├── .gitignore ├── .travis.yml ├── Makefile ├── README.md ├── bin └── .README ├── doc ├── reference │ ├── 01-grammar.md │ ├── 02-kinding.md │ └── 03-typing.md └── syntax │ └── Salt.tmLanguage ├── make ├── config.mk └── target │ ├── bin-salt.mk │ ├── bin-war.mk │ ├── bin-waves.mk │ ├── clean.mk │ ├── setup.mk │ ├── test.mk │ ├── war.mk │ └── waves.mk ├── package.yaml ├── src ├── salt │ ├── Main.hs │ └── Salt │ │ ├── Core │ │ ├── Analysis │ │ │ └── Support.hs │ │ ├── Check.hs │ │ ├── Check │ │ │ ├── Context.hs │ │ │ ├── Equiv.hs │ │ │ ├── Error.hs │ │ │ ├── ErrorMsg.hs │ │ │ ├── Kind.hs │ │ │ ├── Module.hs │ │ │ ├── Module │ │ │ │ ├── Base.hs │ │ │ │ ├── DeclEmit.hs │ │ │ │ ├── DeclTerm.hs │ │ │ │ ├── DeclTest.hs │ │ │ │ └── DeclType.hs │ │ │ ├── Reduce.hs │ │ │ ├── Term.hs │ │ │ ├── Term │ │ │ │ ├── App.hs │ │ │ │ ├── Base.hs │ │ │ │ ├── Bind.hs │ │ │ │ ├── Case.hs │ │ │ │ ├── Params.hs │ │ │ │ └── Value.hs │ │ │ ├── Type.hs │ │ │ ├── Type │ │ │ │ ├── App.hs │ │ │ │ ├── Base.hs │ │ │ │ └── Params.hs │ │ │ ├── Where.hs │ │ │ └── WhereMsg.hs │ │ ├── Codec │ │ │ ├── Text.hs │ │ │ └── Text │ │ │ │ ├── Lexer.hs │ │ │ │ ├── Parser.hs │ │ │ │ ├── Parser │ │ │ │ ├── Base.hs │ │ │ │ ├── Decl.hs │ │ │ │ ├── Module.hs │ │ │ │ ├── Params.hs │ │ │ │ ├── Proc.hs │ │ │ │ ├── Term.hs │ │ │ │ └── Type.hs │ │ │ │ ├── Pretty.hs │ │ │ │ ├── Pretty │ │ │ │ ├── Base.hs │ │ │ │ ├── Term.hs │ │ │ │ └── Type.hs │ │ │ │ └── Token.hs │ │ ├── Eval.hs │ │ ├── Eval │ │ │ ├── Base.hs │ │ │ ├── Error.hs │ │ │ ├── Term.hs │ │ │ └── Type.hs │ │ ├── Exp.hs │ │ ├── Exp │ │ │ ├── Module.hs │ │ │ ├── Name.hs │ │ │ ├── Snv.hs │ │ │ ├── Term.hs │ │ │ ├── Term │ │ │ │ ├── Base.hs │ │ │ │ ├── Compounds.hs │ │ │ │ ├── Patterns.hs │ │ │ │ └── Predicates.hs │ │ │ ├── TermEnv.hs │ │ │ ├── Type.hs │ │ │ ├── Type │ │ │ │ ├── Base.hs │ │ │ │ ├── Compounds.hs │ │ │ │ ├── Patterns.hs │ │ │ │ └── Predicates.hs │ │ │ ├── TypeEnv.hs │ │ │ ├── Universe.hs │ │ │ └── Ups.hs │ │ ├── Prim.hs │ │ ├── Prim │ │ │ ├── Ctor.hs │ │ │ ├── Ops.hs │ │ │ ├── Ops │ │ │ │ ├── Base.hs │ │ │ │ ├── Bool.hs │ │ │ │ ├── Bundle.hs │ │ │ │ ├── Console.hs │ │ │ │ ├── Debug.hs │ │ │ │ ├── Int.hs │ │ │ │ ├── Int16.hs │ │ │ │ ├── Int32.hs │ │ │ │ ├── Int64.hs │ │ │ │ ├── Int8.hs │ │ │ │ ├── List.hs │ │ │ │ ├── Map.hs │ │ │ │ ├── Memory.hs │ │ │ │ ├── Nat.hs │ │ │ │ ├── Reify.hs │ │ │ │ ├── Set.hs │ │ │ │ ├── Symbol.hs │ │ │ │ ├── Word.hs │ │ │ │ ├── Word16.hs │ │ │ │ ├── Word32.hs │ │ │ │ ├── Word64.hs │ │ │ │ └── Word8.hs │ │ │ └── Values.hs │ │ └── Transform │ │ │ ├── MapAnnot.hs │ │ │ ├── Snv.hs │ │ │ ├── StripAnnot.hs │ │ │ └── Ups.hs │ │ ├── Data │ │ ├── List.hs │ │ ├── Location.hs │ │ ├── Pretty.hs │ │ ├── PrettyPrint.hs │ │ ├── Textual.hs │ │ └── Write.hs │ │ ├── LSP │ │ ├── Driver.hs │ │ ├── Interface.hs │ │ ├── Protocol.hs │ │ ├── Protocol │ │ │ ├── Base.hs │ │ │ ├── Initialize.hs │ │ │ ├── Request.hs │ │ │ └── Response.hs │ │ ├── State.hs │ │ └── Task │ │ │ ├── Diagnostics.hs │ │ │ └── Diagnostics │ │ │ ├── Base.hs │ │ │ ├── Checker.hs │ │ │ ├── Lexer.hs │ │ │ ├── Parser.hs │ │ │ └── Tester.hs │ │ ├── Llvm │ │ ├── Syntax.hs │ │ ├── Syntax │ │ │ ├── Attr.hs │ │ │ ├── Exp.hs │ │ │ ├── Function.hs │ │ │ ├── Instr.hs │ │ │ ├── Metadata.hs │ │ │ ├── Module.hs │ │ │ ├── Prim.hs │ │ │ └── Type.hs │ │ ├── Write.hs │ │ └── Write │ │ │ ├── Attr.hs │ │ │ ├── Base.hs │ │ │ ├── Exp.hs │ │ │ ├── Function.hs │ │ │ ├── Instr.hs │ │ │ ├── Metadata.hs │ │ │ ├── Module.hs │ │ │ ├── Prim.hs │ │ │ └── Type.hs │ │ └── Main │ │ ├── Config.hs │ │ └── Mode │ │ ├── Check.hs │ │ ├── Emit.hs │ │ ├── Lex.hs │ │ ├── Make.hs │ │ ├── Parse.hs │ │ └── Test.hs ├── war │ ├── Main.hs │ └── War │ │ ├── Driver │ │ ├── Base.hs │ │ ├── Chain.hs │ │ └── Gang.hs │ │ ├── Interface │ │ ├── Controller.hs │ │ └── VT100.hs │ │ ├── Main │ │ ├── Config.hs │ │ └── Option.hs │ │ └── Task │ │ ├── Create.hs │ │ ├── Create │ │ ├── CreateMainHS.hs │ │ ├── CreateMainSH.hs │ │ ├── CreateSalt.hs │ │ └── Way.hs │ │ ├── Job.hs │ │ ├── Job │ │ ├── CompileHS.hs │ │ ├── Diff.hs │ │ ├── RunExe.hs │ │ ├── RunSalt.hs │ │ └── Shell.hs │ │ └── Test.hs └── waves │ ├── Main.hs │ └── Waves │ ├── Gen │ ├── Core │ │ └── Exp.hs │ └── Corpus.hs │ └── Prop │ └── Core │ ├── Codec.hs │ └── Exp │ └── Codec.hs ├── stack.yaml └── test ├── 00-smoke └── 00-poweron │ ├── Test.salt │ └── Test.salt.stdout.check ├── 01-demo ├── 10-Nat │ ├── Test.salt │ └── Test.salt.stdout.check ├── 20-List │ ├── Test.salt │ └── Test.salt.stdout.check ├── 30-Console │ ├── Test.salt │ └── Test.salt.stdout.check ├── 35-Memory │ ├── Test.salt │ └── Test.salt.stdout.check ├── 40-Proc │ ├── Test.salt │ └── Test.salt.stdout.check └── 50-Loops │ ├── Test.salt │ └── Test.salt.stdout.check ├── 10-syntax ├── 00-layout │ ├── Test.salt │ └── Test.salt.stdout.check ├── 01-decls │ ├── Test.salt │ └── Test.salt.stdout.check ├── 02-types │ ├── Test.salt │ └── Test.salt.stdout.check ├── 03-terms │ ├── Test.salt │ └── Test.salt.stdout.check └── 04-procs │ ├── Test.salt │ └── Test.salt.stdout.check ├── 11-pretty ├── 01-types │ ├── Test.salt │ └── Test.salt.stdout.check └── 02-terms │ ├── Test.salt │ └── Test.salt.stdout.check ├── 20-check ├── 10-kind │ ├── Test.salt │ └── Test.salt.stdout.check ├── 11-type │ ├── Test.salt │ └── Test.salt.stdout.check ├── 20-reduce │ ├── Test.salt │ └── Test.salt.stdout.check ├── 30-equiv │ ├── Test.salt │ └── Test.salt.stdout.check └── 40-capture │ ├── Test.salt │ └── Test.salt.stdout.check ├── 30-error ├── 10-check-type │ ├── Test.salt │ └── Test.salt.error.check ├── 11-check-term │ ├── Test.salt │ └── Test.salt.error.check ├── 12-check-proc │ ├── Test.salt │ └── Test.salt.error.check ├── 20-check-type-sigs │ ├── Test.salt │ └── Test.salt.error.check ├── 21-check-type-decls │ ├── Test.salt │ └── Test.salt.error.check ├── 30-check-term-sigs │ ├── Test.salt │ └── Test.salt.error.check ├── 31-check-term-decls │ ├── Test.salt │ └── Test.salt.error.check ├── 40-check-test-sigs │ ├── Test.salt │ └── Test.salt.error.check └── 41-check-test-decls │ ├── Test.salt │ └── Test.salt.error.check ├── 40-eval ├── 01-bumps │ ├── Test.salt │ └── Test.salt.stdout.check ├── 10-type │ ├── Test.salt │ └── Test.salt.stdout.check ├── 20-term │ ├── Test.salt │ └── Test.salt.stdout.check ├── 30-prims │ ├── 01-bool │ │ ├── Test.salt │ │ └── Test.salt.stdout.check │ ├── 02-nat │ │ ├── Test.salt │ │ └── Test.salt.stdout.check │ ├── 03-int │ │ ├── Test.salt │ │ └── Test.salt.stdout.check │ ├── 04-word │ │ ├── Test.salt │ │ └── Test.salt.stdout.check │ ├── 10-symbol │ │ ├── Test.salt │ │ └── Test.salt.stdout.check │ ├── 20-list │ │ ├── Test.salt │ │ └── Test.salt.stdout.check │ ├── 21-set │ │ ├── Test.salt │ │ └── Test.salt.stdout.check │ ├── 22-map │ │ ├── Test.salt │ │ └── Test.salt.stdout.check │ └── 40-memory │ │ ├── Test.salt │ │ └── Test.salt.stdout.check └── 40-proc │ ├── 20-call │ ├── Test.salt │ └── Test.salt.stdout.check │ ├── 30-return │ ├── Test.salt │ └── Test.salt.stdout.check │ ├── 40-cell │ ├── Test.salt │ └── Test.salt.stdout.check │ └── 50-loop │ ├── Test.salt │ └── Test.salt.stdout.check ├── 50-reify ├── Test.salt └── Test.salt.stdout.check └── 80-docs └── 01-grammar └── Test.salt /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.hi 3 | *.dyn_o 4 | *.dyn_hi 5 | 6 | war-* 7 | make/config-override.mk 8 | 9 | .cabal-sandbox/ 10 | .stack-work/ 11 | dist/ 12 | bin/ 13 | 14 | ghcid.txt 15 | cabal.sandbox.config 16 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # language `ghc` drags in old ghc versions 2 | # language `generic` drags in too many others deps 3 | # language `c` is lighter weight, and is fine since we declare most of our own deps 4 | language: c 5 | 6 | # https://docs.travis-ci.com/user/reference/overview/#Virtualisation-Environment-vs-Operating-System 7 | sudo: required 8 | dist: trusty 9 | 10 | # this will attempt to cache the contents of the specified directories between 11 | # runs to speed up install times 12 | cache: 13 | directories: 14 | - $HOME/.cabal 15 | - $HOME/.ghc 16 | 17 | # clean up anything we don't want to cache 18 | # log and index files aren't worth caching 19 | # Note: this should be safe as cabal should still do an install 20 | # if a newer version of a dependency is available 21 | before_cache: 22 | - rm -f $HOME/.cabal/logs/*.log 23 | - rm -f $HOME/.cabal/packages/00-index* 24 | - rm -f $HOME/.cabal/packages/01-index* 25 | - rm -f $HOME/.cabal/packages/build-reports.log 26 | 27 | # using ghc and cabal-install from 28 | # https://launchpad.net/~hvr/+archive/ubuntu/ghc 29 | # llvm from 30 | # http://apt.llvm.org 31 | addons: 32 | apt: 33 | sources: &apt_sources 34 | - hvr-ghc 35 | - ubuntu-toolchain-r-test 36 | - llvm-toolchain-trusty 37 | - llvm-toolchain-trusty-5.0 38 | - llvm-toolchain-trusty-6.0 39 | 40 | packages: &apt_packages 41 | - cabal-install-2.4 42 | 43 | compiler: 44 | - GHC-8.6.3 45 | - GHC-8.4.4 46 | 47 | env: 48 | global: 49 | - CABAL=2.4 50 | matrix: 51 | - LLVM=6.0.0 52 | - LLVM=5.0.1 53 | 54 | # Install GHC and LLVM. We could do this via the build matrix configuration 55 | # without requiring sudo, but this method is easier to set up a cartesean 56 | # product of 'compiler x matrix' build configurations. 57 | before_install: 58 | - export GHC=${CC:4} 59 | - unset CC 60 | - sudo -E apt-get -yq --no-install-suggests --no-install-recommends --force-yes install ghc-${GHC} llvm-${LLVM:0:3}-dev 61 | 62 | # put ghc and cabal on the path 63 | - export PATH=/opt/ghc/${GHC}/bin:/opt/cabal/${CABAL}/bin:$PATH 64 | - cabal v1-update 65 | 66 | # sanity check 67 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 68 | - cabal --version 69 | - llc-${LLVM:0:3} --version; true 70 | - opt-${LLVM:0:3} --version; true 71 | 72 | # install necessary library dependencies 73 | install: 74 | - make setup 75 | 76 | script: 77 | - make clean 78 | - make 79 | - make war 80 | - make waves 81 | 82 | # vim: nospell sw=4 83 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | # Build the system, but don't automatically run tests. 3 | .PHONY : all 4 | all : 5 | @make allWithConfig 6 | 7 | 8 | # Include configuration. 9 | # These need to come before all the rules after this point in the Makefile. 10 | include make/config.mk 11 | 12 | 13 | # Build everything in scope of the make config. 14 | .PHONY : allWithConfig 15 | allWithConfig : 16 | @make bin/salt 17 | @make bin/war 18 | @make bin/waves 19 | 20 | 21 | include make/target/clean.mk 22 | include make/target/setup.mk 23 | include make/target/bin-salt.mk 24 | include make/target/bin-war.mk 25 | include make/target/bin-waves.mk 26 | include make/target/war.mk 27 | include make/target/test.mk 28 | include make/target/waves.mk 29 | 30 | 31 | # Override default config with local config. 32 | -include make/config-override.mk 33 | -------------------------------------------------------------------------------- /bin/.README: -------------------------------------------------------------------------------- 1 | The build system creates executable files in this directory. 2 | -------------------------------------------------------------------------------- /doc/reference/02-kinding.md: -------------------------------------------------------------------------------- 1 | 2 | # Kinding 3 | 4 | ## Judgment Forms 5 | 6 | ``` 7 | 1) Γ ⊢ T :: K 8 | 2) Γ ⊢ Ts :* Ks 9 | 3) Γ ⊢ Ts :< K 10 | ``` 11 | 12 | 1. In environment `Γ` type `T` has kind `K`. 13 | 2. In environment `Γ` types `Ts` have kinds `Ks`. 14 | 3. In environment `Γ` types `Ts` all have the same kind `K`. 15 | 16 | ## Rules 17 | 18 | ``` 19 | { Γ ⊢ Tsᵢ :: Ksᵢ } ^ (i ← [1 .. n]) 20 | (k-many) --------------------------------------- 21 | Γ ⊢ Tsⁿ :* Ksⁿ 22 | 23 | 24 | { Γ ⊢ Tsᵢ :: K } ^ (i ← [1.. n]) 25 | (k-gets) --------------------------------------- 26 | Γ ⊢ Tsⁿ :< K 27 | 28 | ``` 29 | 30 | ``` 31 | a:K ∈ Γ 32 | (k-var) ------------------- 33 | Γ ⊢ tvar a :: K 34 | 35 | 36 | c has kind K 37 | (k-con) ------------------- 38 | Γ ⊢ tcon c :: K 39 | 40 | 41 | p has kind K 42 | (k-prm) ------------------- 43 | Γ ⊢ tprm p :: K 44 | 45 | 46 | Γ ⊢ T₁ :: tarr Ks₂ K₂ Γ ⊢ Ts₂ :* Ks₂ 47 | (k-app) ----------------------------------------- 48 | Γ ⊢ tapp T₁ Ts₂ :: K₂ 49 | 50 | 51 | Γ ⊢ Ts₁ :< tdat Γ ⊢ Ts₂ :< tdat 52 | (k-fun) --------------------------------------- 53 | Γ ⊢ tfun Ts₁ Ts₂ :: tdat 54 | 55 | 56 | { Γ ⊢ Tsᵢ :< tdat } ^ (i ← [1 .. n]) Ns unique 57 | (k-rec) ------------------------------------------------------ 58 | Γ ⊢ trec Ns Tsⁿ :: tdat 59 | 60 | 61 | { Γ ⊢ Tsᵢ :< tdat } ^ (i ← [1 .. n]) Ns unique 62 | (k-vnt) ------------------------------------------------------ 63 | Γ ⊢ tvnt Ns Ts :: tdat 64 | 65 | 66 | Γ ⊢ Ts₁ :* Ks₁ Γ, As₁:Ks₁ ⊢ T₂ :: tdat 67 | (k-all) --------------------------------------------- 68 | Γ ⊢ tall As₁ Ts₂ T₂ :: tdat 69 | 70 | 71 | Γ ⊢ Ts₁ :* Ks₁ Γ, As₁:Ks₁ ⊢ T₂ :: tdat 72 | (k-ext) --------------------------------------------- 73 | Γ ⊢ text As₁ Ts₂ T₂ :: tdat 74 | 75 | 76 | Γ ⊢ Ts₁ :* Ks₁ Γ, As₁:Ks₁ ⊢ T₂ :: K₂ 77 | (k-abs) --------------------------------------------- 78 | Γ ⊢ tabs As₁ Ts₂ T₂ :: tarr Ks₁ K₂ 79 | 80 | ``` 81 | 82 | -------------------------------------------------------------------------------- /make/target/bin-salt.mk: -------------------------------------------------------------------------------- 1 | 2 | # Find all the source files in the project. 3 | salt_src_hs = $(shell find src/salt -name "*.hs" -follow) 4 | 5 | # Build the executable. 6 | bin/salt : $(salt_src_hs) 7 | @$(GHC) $(GHC_LANGUAGE) $(GHC_WARNINGS) $(GHC_FLAGS) \ 8 | $(SALT_PACKAGES) -j$(THREAD) \ 9 | -o bin/salt \ 10 | -isrc/salt --make src/salt/Main.hs 11 | -------------------------------------------------------------------------------- /make/target/bin-war.mk: -------------------------------------------------------------------------------- 1 | 2 | # Find all the source files in the project. 3 | war_src_hs = $(shell find src/war -name "*.hs" -follow) 4 | 5 | 6 | # Build the executable. 7 | bin/war : $(war_src_hs) 8 | @$(GHC) $(GHC_LANGUAGE) $(GHC_WARNINGS) $(GHC_FLAGS) \ 9 | $(WAR_PACKAGES) \ 10 | -threaded \ 11 | -o bin/war \ 12 | -isrc/war --make src/war/Main.hs 13 | 14 | -------------------------------------------------------------------------------- /make/target/bin-waves.mk: -------------------------------------------------------------------------------- 1 | 2 | # Find all the source files in the project. 3 | waves_src_hs = $(shell find src/waves -name "*.hs" -follow) 4 | 5 | 6 | # Build the executable. 7 | # Note: for some reason this target is producing dyn_* files, but the bin/salt and bin/war targets do not. I suspect that the dependency on hedgehog is somehow forcing dynamic linking. 8 | bin/waves : $(salt_src_hs) $(waves_src_hs) 9 | @$(GHC) $(GHC_LANGUAGE) $(GHC_WARNINGS) $(GHC_FLAGS) \ 10 | $(WAVES_PACKAGES) -j$(THREAD) \ 11 | -threaded \ 12 | -o bin/waves \ 13 | -isrc/salt \ 14 | -isrc/waves --make src/waves/Main.hs 15 | 16 | -------------------------------------------------------------------------------- /make/target/clean.mk: -------------------------------------------------------------------------------- 1 | 2 | # Cleanup everything. 3 | .PHONY : clean 4 | clean : 5 | @echo "* Cleaning up" 6 | @find . \( -name "*.o" -o -name "*.hi" -o -name "war-std" \) -follow -not -path "./.stack-work/*" \ 7 | | xargs -n 1 rm -rf 8 | @rm -f make/deps/* 9 | @rm -f bin/* 10 | 11 | 12 | # Cleanup just the test directory. 13 | .PHONY : clean-test 14 | clean-test : 15 | @echo "* Cleaning up test" 16 | @find test -name "*.o" -o -name "*.hi" -o -name "war-std" -follow \ 17 | | xargs -n 1 rm -rf 18 | 19 | -------------------------------------------------------------------------------- /make/target/setup.mk: -------------------------------------------------------------------------------- 1 | # Print the packages needed to build DDC. 2 | .PHONY : show-pkgs 3 | show-pkgs : 4 | @echo $(DDC_PACKAGES) \ 5 | | sed 's/-hide-all-packages //;s/-package //g;s/base //g;s/directory //;s/array //;s/containers //' 6 | 7 | 8 | # Install prerequisite cabal packages. 9 | .PHONY : setup 10 | setup : 11 | @echo "* Installing prerequisite cabal packages..." 12 | @$(DEPS_INSTALLER) v1-update 13 | @$(DEPS_INSTALLER) v1-install \ 14 | text mtl stm json \ 15 | happy-1.19.9 16 | @$(DEPS_INSTALLER) v1-install \ 17 | parsec-3.1.14.0 \ 18 | inchworm-1.1.1.2 \ 19 | buildbox-2.2.1.2 \ 20 | hedgehog-0.6.1 21 | -------------------------------------------------------------------------------- /make/target/test.mk: -------------------------------------------------------------------------------- 1 | 2 | .PHONY : test 3 | test : bin/war bin/salt bin/waves 4 | @echo "* Running expect tests" 5 | @bin/war test 6 | @echo "* Running property tests" 7 | @bin/waves 8 | -------------------------------------------------------------------------------- /make/target/war.mk: -------------------------------------------------------------------------------- 1 | 2 | .PHONY : war 3 | war : bin/war bin/salt 4 | @echo "* Running expect tests" 5 | @bin/war test 6 | -------------------------------------------------------------------------------- /make/target/waves.mk: -------------------------------------------------------------------------------- 1 | 2 | .PHONY : waves 3 | waves : bin/waves 4 | @echo "* Running property tests" 5 | @bin/waves 6 | 7 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: salt 2 | version: 0.0.0.0 3 | 4 | executables: 5 | salt: 6 | main: Main.hs 7 | 8 | ghc-options: 9 | - -fwarn-identities 10 | - -fwarn-deprecations 11 | - -fwarn-unused-binds 12 | - -fwarn-unused-imports 13 | - -fwarn-unused-matches 14 | - -fwarn-wrong-do-bind 15 | - -fwarn-hi-shadowing 16 | - -fwarn-type-defaults 17 | - -fwarn-name-shadowing 18 | - -fwarn-duplicate-exports 19 | - -fwarn-missing-fields 20 | - -fwarn-overlapping-patterns 21 | - -fwarn-incomplete-patterns 22 | - -fwarn-name-shadowing 23 | - -fwarn-unrecognised-pragmas 24 | - -fwarn-monomorphism-restriction 25 | - -fno-warn-missing-methods 26 | - -fno-warn-missing-signatures 27 | - -fno-warn-missing-local-signatures 28 | - -fno-warn-orphans 29 | - -fno-warn-simplifiable-class-constraints 30 | 31 | default-extensions: 32 | - Strict 33 | - LambdaCase 34 | - RankNTypes 35 | - BangPatterns 36 | - PatternGuards 37 | - NamedFieldPuns 38 | - ConstraintKinds 39 | - PatternSynonyms 40 | - ParallelListComp 41 | - FlexibleContexts 42 | - FlexibleInstances 43 | - OverloadedStrings 44 | - StandaloneDeriving 45 | - ScopedTypeVariables 46 | - TypeSynonymInstances 47 | - DuplicateRecordFields 48 | - MultiParamTypeClasses 49 | - NoMonomorphismRestriction 50 | 51 | source-dirs: 52 | - src/salt 53 | 54 | dependencies: 55 | - base 56 | - text 57 | - unix 58 | - json 59 | - parsec 60 | - inchworm 61 | - containers 62 | - bytestring 63 | - pretty-show 64 | 65 | -------------------------------------------------------------------------------- /src/salt/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | import Salt.Llvm.Syntax () 4 | import Salt.Llvm.Write () 5 | import Salt.Main.Mode.Make 6 | import Salt.Main.Mode.Emit 7 | import Salt.Main.Mode.Test 8 | import Salt.Main.Mode.Check 9 | import Salt.Main.Mode.Parse 10 | import Salt.Main.Mode.Lex 11 | import Salt.Main.Config 12 | import qualified Salt.LSP.Driver as LSP 13 | 14 | import qualified System.Environment as System 15 | import qualified System.Exit as System 16 | 17 | -- NOTE: StripAnnot is currently only used by the testing framework, 18 | -- but we include it here so it always gets built along with the bin/salt, 19 | -- and we can see when it needs updating. 20 | import Salt.Core.Transform.StripAnnot () 21 | 22 | main 23 | = do args <- System.getArgs 24 | config <- parseArgs args configDefault 25 | case configMode config of 26 | Just (ModeLSP mFileLog) -> LSP.runLSP mFileLog 27 | Just (ModeMake filePath) -> mainMake filePath 28 | Just (ModeEmit filePath) -> mainEmits filePath 29 | Just (ModeTest filePath) -> mainTests filePath 30 | Just (ModeTest1 filePath name) -> mainTest filePath name 31 | Just (ModeCheck filePath) -> mainCheck filePath 32 | Just (ModeParse filePath) -> mainParse filePath 33 | Just (ModeLex filePath) -> mainLex filePath 34 | 35 | -- Unhandled mode. 36 | _ -> do putStr usage 37 | System.exitFailure 38 | 39 | 40 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Check.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Check 3 | ( module Salt.Core.Check.Type 4 | , module Salt.Core.Check.Type.Base 5 | , module Salt.Core.Check.Term 6 | , module Salt.Core.Check.Term.Base 7 | , module Salt.Core.Check.Module 8 | , module Salt.Core.Check.Error 9 | , module Salt.Core.Check.Context 10 | , module Salt.Core.Exp 11 | , contextEmpty) 12 | where 13 | import Salt.Core.Check.Type 14 | import Salt.Core.Check.Type.Base 15 | import Salt.Core.Check.Term 16 | import Salt.Core.Check.Term.Base 17 | import Salt.Core.Check.Module 18 | import Salt.Core.Check.Error 19 | import Salt.Core.Check.ErrorMsg () 20 | import Salt.Core.Check.WhereMsg () 21 | import Salt.Core.Check.Context 22 | import Salt.Core.Exp 23 | import qualified Data.Map.Strict as Map 24 | 25 | 26 | -- | Construct an empty context. 27 | contextEmpty :: Context a 28 | contextEmpty 29 | = Context 30 | { contextOptions = optionsDefault 31 | , contextCheckType = checkTypeWith 32 | , contextSynthTerm = synthTermWith 33 | , contextCheckTerm = checkTermWith 34 | , contextModuleType = Map.empty 35 | , contextModuleTerm = Map.empty 36 | , contextLocal = [] 37 | , contextInside = [] } 38 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Check/Kind.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Check.Kind where 3 | import Salt.Core.Check.Context 4 | import Salt.Core.Check.Where 5 | import Salt.Core.Check.Error 6 | import Salt.Core.Exp 7 | import qualified Salt.Core.Prim.Ctor as Prim 8 | import qualified Data.Map as Map 9 | import Control.Exception 10 | 11 | 12 | -- | Check and elaborate a kind. 13 | -- Type errors are thrown as exceptions in the IO monad. 14 | checkKind :: Annot a => a -> [Where a] 15 | -> Context a -> Kind a -> IO (Kind a) 16 | 17 | -- (s-ann) ------------------------------------------------ 18 | checkKind _a wh ctx (TAnn a' t) 19 | = checkKind a' wh ctx t 20 | 21 | 22 | -- (s-prm) ------------------------------------------------ 23 | checkKind a wh _ctx k@(TRef (TRPrm n)) 24 | = case Map.lookup n Prim.primKindCtors of 25 | Just () -> return k 26 | Nothing -> throw $ ErrorUnknownPrim UKind a wh n 27 | 28 | 29 | -- (s-arr) ------------------------------------------------ 30 | checkKind a wh ctx (TArr ks1 k2) 31 | = do ks1' <- mapM (checkKind a wh ctx) ks1 32 | k2' <- checkKind a wh ctx k2 33 | return $ TArr ks1' k2' 34 | 35 | 36 | -- The kind expression is malformed, 37 | -- so we don't have any rule that could match it. 38 | checkKind a wh _ k 39 | = throw $ ErrorTypeMalformed UKind a wh k 40 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Check/Module/Base.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Check.Module.Base 3 | ( module Salt.Core.Check.Where 4 | , module Salt.Core.Check.Error 5 | , CheckDecl 6 | , checkDecls) 7 | where 8 | import Salt.Core.Check.Where 9 | import Salt.Core.Check.Error 10 | import Salt.Core.Check.Term.Base 11 | import qualified Control.Exception as Control 12 | 13 | 14 | type CheckDecl a 15 | = Annot a => a -> Context a -> Decl a -> IO (Decl a) 16 | 17 | checkDecls 18 | :: forall a. Annot a 19 | => (Decl a -> IO (Decl a)) 20 | -> [Decl a] -> IO ([Decl a], [Error a]) 21 | 22 | checkDecls _check [] 23 | = return ([], []) 24 | 25 | checkDecls check (d1 : ds2) 26 | = do (d1', errs1) 27 | <- Control.try (check d1) 28 | >>= \case 29 | Right d1' -> return (d1', []) 30 | Left (err :: Error a) -> return (d1, [err]) 31 | 32 | (ds2', errs2) <- checkDecls check ds2 33 | return (d1' : ds2', errs1 ++ errs2) 34 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Check/Module/DeclEmit.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Check.Module.DeclEmit where 3 | import Salt.Core.Check.Module.Base 4 | import Salt.Core.Check.Term.Base 5 | 6 | 7 | -- | Check emit declarations. 8 | checkDeclEmit :: CheckDecl a 9 | 10 | -- (t-decl-emit) ------------------------------------------ 11 | checkDeclEmit _a ctx (DEmit (DeclEmit a' mn m)) 12 | = do let wh = [WhereEmitDecl a' mn] 13 | 14 | -- TODO: check type is valid 15 | -- TOOD: check names don't conflict. 16 | (m', _t, _effs) 17 | <- synthTerm a' wh ctx m 18 | 19 | return $ DEmit $ DeclEmit a' mn m' 20 | 21 | checkDeclEmit _ _ decl 22 | = return decl -------------------------------------------------------------------------------- /src/salt/Salt/Core/Check/Term/Bind.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Check.Term.Bind where 3 | import Salt.Core.Check.Type.Base 4 | import Salt.Core.Check.Term.Base 5 | import Salt.Core.Check.Term.Params 6 | 7 | 8 | -- | Check a `TermBind`. 9 | checkTermBind 10 | :: Annot a => a -> [Where a] 11 | -> Context a -> TermBind a -> IO (TermBind a) 12 | 13 | checkTermBind a wh ctx (MBind b mpss tsResult mBody) 14 | = do -- Check the parameters. 15 | (ctx', mpss') 16 | <- checkTermParamss a wh ctx mpss 17 | 18 | -- There must be at least one vector of term parameters, 19 | -- as we do not support value recursion in the evaluator. 20 | when (not $ any isJust $ map takeMPTerms mpss) 21 | $ throw $ ErrorRecValueRecursion a wh b 22 | 23 | -- Check the result type annotation. 24 | tsResult' 25 | <- checkTypesAreAll UKind a wh ctx' TData tsResult 26 | 27 | -- The body must have type as specified by the result annotation. 28 | (mBody', _rr, esBody) 29 | <- checkTerm a wh ctx' tsResult mBody 30 | 31 | -- The body must be pure. 32 | let aBody = fromMaybe a $ takeAnnotOfTerm mBody 33 | eBody_red <- simplType aBody ctx' (TSum esBody) 34 | when (not $ isTPure eBody_red) 35 | $ throw $ ErrorAbsImpure UTerm aBody wh eBody_red 36 | 37 | return $ MBind b mpss' tsResult' mBody' 38 | 39 | 40 | 41 | -- | Make the type of a `TermBind`. 42 | -- TODO: handle errors as with makeTypeOfDeclTerm 43 | makeTypeOfTermBind :: TermBind a -> Type a 44 | makeTypeOfTermBind (MBind _b mpss0 tsResult _mBody) 45 | | [] <- mpss0 46 | , [tResult] <- tsResult 47 | = tResult 48 | 49 | | [tResult] <- loop mpss0 50 | = tResult 51 | 52 | | otherwise 53 | = error "TODO: cannot build type of term binding" 54 | 55 | where 56 | loop [] = tsResult 57 | 58 | loop (MPAnn _ mps' : pss') 59 | = loop (mps' : pss') 60 | 61 | loop (MPTerms bts : pss') 62 | = [TFun (map snd bts) (loop pss')] 63 | 64 | loop (MPTypes bts : pss') 65 | = case loop pss' of 66 | [t] -> [TForall (TPTypes bts) t] 67 | _ -> [] 68 | 69 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Check/Term/Params.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Check.Term.Params where 3 | import Salt.Core.Check.Kind 4 | import Salt.Core.Check.Term.Base 5 | import Salt.Core.Check.Type.Base 6 | import qualified Salt.Data.List as List 7 | 8 | 9 | -- | Check some term function parameters. 10 | checkTermParams 11 | :: Annot a => a -> [Where a] 12 | -> Context a -> TermParams a -> IO (TermParams a) 13 | 14 | checkTermParams _a wh ctx (MPAnn a' mps) 15 | = checkTermParams a' wh ctx mps 16 | 17 | checkTermParams a wh ctx (MPTypes bks) 18 | = do let (bs, ks) = unzip bks 19 | 20 | -- Check for duplicate binder names. 21 | let ns = [ n | BindName n <- bs] 22 | let nsDup = List.duplicates ns 23 | when (not $ null nsDup) 24 | $ throw $ ErrorAbsConflict UType a wh nsDup 25 | 26 | -- Check the parameter kinds. 27 | ks' <- mapM (checkKind a wh ctx) ks 28 | return $ MPTypes $ zip bs ks' 29 | 30 | checkTermParams a wh ctx (MPTerms bts) 31 | = do let (bs, ts) = unzip bts 32 | 33 | -- Check for duplicate binder names. 34 | let ns = [n | BindName n <- bs] 35 | let nsDup = List.duplicates ns 36 | when (not $ null nsDup) 37 | $ throw $ ErrorAbsConflict UTerm a wh nsDup 38 | 39 | -- Check the parameter types. 40 | ts' <- checkTypesAre UType a wh ctx (replicate (length ts) TData) ts 41 | return $ MPTerms $ zip bs ts' 42 | 43 | 44 | -- | Check a list of term function parameters, 45 | -- where type variables bound earlier in the list are in scope 46 | -- when checking types annotating term variables later in the list. 47 | checkTermParamss 48 | :: Annot a => a -> [Where a] 49 | -> Context a -> [TermParams a] -> IO (Context a, [TermParams a]) 50 | 51 | checkTermParamss _a _wh ctx [] 52 | = return (ctx, []) 53 | 54 | checkTermParamss a wh ctx (tps : tpss) 55 | = do tps' <- checkTermParams a wh ctx tps 56 | let ctx' = contextBindTermParams tps' ctx 57 | (ctx'', tpss') <- checkTermParamss a wh ctx' tpss 58 | return (ctx'', tps' : tpss') 59 | 60 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Check/Type/App.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Check.Type.App where 3 | import Salt.Core.Check.Type.Base 4 | 5 | 6 | -- | Check the application of a type to some types. 7 | checkTypeAppTypes 8 | :: Annot a => a -> [Where a] 9 | -> Context a -> a -> Kind a -> TypeArgs a 10 | -> IO (TypeArgs a, Kind a) 11 | 12 | checkTypeAppTypes _a wh ctx aFun kFun (TGAnn a tgs') 13 | = checkTypeAppTypes a wh ctx aFun kFun tgs' 14 | 15 | checkTypeAppTypes a wh ctx aFun kFun (TGTypes tsArg) 16 | = case kFun of 17 | TArr ksParam kResult 18 | -> goCheckArgs ksParam kResult 19 | _ -> throw $ ErrorAppTypeTypeCannot aFun wh kFun 20 | where 21 | goCheckArgs ksParam kResult 22 | = if length ksParam /= length tsArg 23 | then throw $ ErrorAppTypeTypeWrongArityNum a wh ksParam (length tsArg) 24 | else do 25 | (tsArg', ksArg) <- checkTypes a wh ctx tsArg 26 | goCheckParams ksParam kResult (TGTypes tsArg') ksArg 27 | 28 | goCheckParams ksParam kResult tsArg' ksArg 29 | = checkTypeEquivs ctx a [] ksParam a [] ksArg 30 | >>= \case 31 | Nothing -> return (tsArg', kResult) 32 | Just ((_aErrParam, kErrParam), (aErrArg', kErrArg)) 33 | -> throw $ ErrorMismatch UKind aErrArg' wh kErrArg kErrParam 34 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Check/Type/Params.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Check.Type.Params where 3 | import Salt.Core.Check.Context 4 | import Salt.Core.Check.Kind 5 | import Salt.Core.Check.Where 6 | import Salt.Core.Check.Error 7 | import Salt.Core.Exp 8 | import qualified Salt.Data.List as List 9 | 10 | import Control.Monad 11 | import Control.Exception 12 | 13 | 14 | -- | Check some type parameters. 15 | checkTypeParams 16 | :: Annot a => a -> [Where a] 17 | -> Context a -> TypeParams a -> IO (TypeParams a) 18 | 19 | checkTypeParams _a wh ctx (TPAnn a' tps') 20 | = checkTypeParams a' wh ctx tps' 21 | 22 | checkTypeParams a wh ctx (TPTypes bks) 23 | = do let (bs, ks) = unzip bks 24 | 25 | -- Check for duplicate binder names. 26 | let ns = [ n | BindName n <- bs ] 27 | let nsDup = List.duplicates ns 28 | when (not $ null nsDup) 29 | $ throw $ ErrorAbsConflict UType a wh nsDup 30 | 31 | -- Check the parameter kinds. 32 | ks' <- mapM (checkKind a wh ctx) ks 33 | return $ TPTypes $ zip bs ks' 34 | 35 | 36 | -- | Check a list of type function parameters, 37 | -- where type variables bound earlier in the list are in scope 38 | -- when checking types annotating term variables later in the list. 39 | checkTypeParamss 40 | :: Annot a => a -> [Where a] 41 | -> Context a -> [TypeParams a] -> IO [TypeParams a] 42 | 43 | checkTypeParamss _a _wh _ctx [] 44 | = return [] 45 | 46 | checkTypeParamss a wh ctx (tps : tpss) 47 | = do tps' <- checkTypeParams a wh ctx tps 48 | let ctx' = contextBindTypeParams tps' ctx 49 | tpss' <- checkTypeParamss a wh ctx' tpss 50 | return $ tps' : tpss' 51 | 52 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Check/Where.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Check.Where where 3 | import Salt.Core.Exp 4 | 5 | 6 | -- | Tracks where we are a source program during type checking, 7 | -- to help error reporting. 8 | data Where a 9 | -- decls ----------------------------------------- 10 | = WhereTypeDecl 11 | { whereAnnot :: a 12 | , whereDeclName :: Name } 13 | 14 | | WhereTermDecl 15 | { whereAnnot :: a 16 | , whereDeclName :: Name } 17 | 18 | | WhereTestDecl 19 | { whereAnnot :: a 20 | , whereTestName :: Maybe Name } 21 | 22 | | WhereEmitDecl 23 | { whereAnnot :: a 24 | , whereEmitName :: Maybe Name } 25 | 26 | 27 | -- terms ------------------------------------------ 28 | | WhereAppPrim 29 | { whereAnnot :: a 30 | , wherePrimName :: Name 31 | , wherePrimType :: Type a } 32 | 33 | | WhereRecordField 34 | { whereAnnot :: a 35 | , whereLabel :: Name 36 | , whereTypeExpected :: Maybe [Type a] } 37 | deriving Show 38 | 39 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Check/WhereMsg.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Check.WhereMsg where 3 | import Salt.Core.Codec.Text.Pretty 4 | import Salt.Core.Codec.Text () 5 | import Salt.Core.Check.Where 6 | 7 | 8 | instance Show a => Pretty c (Where a) where 9 | ppr c wh = pprw c wh 10 | 11 | -- decls -------------------------------------------------- 12 | pprw _c (WhereTypeDecl _a n) 13 | = vcat [ text "In type declaration" %% pprNameQuoted n ] 14 | 15 | pprw _c (WhereTermDecl _a n) 16 | = vcat [ text "In term declaration" %% pprNameQuoted n ] 17 | 18 | pprw _c (WhereTestDecl _a Nothing) 19 | = vcat [ text "In test" ] 20 | 21 | pprw _c (WhereTestDecl _a (Just n)) 22 | = vcat [ text "In test" %% pprNameQuoted n ] 23 | 24 | pprw _c (WhereEmitDecl _a Nothing) 25 | = vcat [ text "In emit declaration" ] 26 | 27 | pprw _c (WhereEmitDecl _a (Just n)) 28 | = vcat [ text "In emit declaration" %% pprNameQuoted n] 29 | 30 | 31 | -- terms -------------------------------------------------- 32 | pprw c (WhereAppPrim _a n t) 33 | = vcat [ text "With " % squotes (pprPrm n) %% text "of type" %% ppr c t ] 34 | 35 | pprw _c (WhereRecordField _a l Nothing) 36 | = vcat [ text "In field" %% pprNameQuoted l ] 37 | 38 | pprw c (WhereRecordField _a l (Just t)) 39 | = vcat [ text "In field" %% pprNameQuoted l %% text "of type" %% ppr c t ] 40 | 41 | 42 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Codec/Text.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Codec.Text 3 | ( module Salt.Core.Codec.Text.Token 4 | , module Salt.Core.Codec.Text.Lexer 5 | , module Salt.Core.Codec.Text.Parser) 6 | where 7 | import Salt.Core.Codec.Text.Token 8 | import Salt.Core.Codec.Text.Lexer 9 | import Salt.Core.Codec.Text.Parser 10 | import Salt.Core.Codec.Text.Pretty () 11 | 12 | 13 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Codec/Text/Parser/Module.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Codec.Text.Parser.Module where 3 | import Salt.Core.Codec.Text.Parser.Decl 4 | import Salt.Core.Codec.Text.Parser.Base 5 | import Salt.Core.Codec.Text.Token 6 | import Salt.Core.Exp 7 | import qualified Text.Parsec as P 8 | 9 | 10 | -- | Parser for a module. 11 | pModule :: Context -> Parser (Module RL) 12 | pModule ctx 13 | = do decls <- P.many (pDecl ctx) 14 | pTok KMetaEnd 15 | return $ Module decls 16 | 17 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Codec/Text/Parser/Params.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Codec.Text.Parser.Params where 3 | import Salt.Core.Codec.Text.Parser.Type 4 | import Salt.Core.Codec.Text.Parser.Base 5 | import Salt.Core.Codec.Text.Token 6 | import Salt.Core.Exp 7 | 8 | import Text.Parsec (()) 9 | import qualified Text.Parsec as P 10 | 11 | 12 | -- | Parser for some term parameters. 13 | pTermParams :: Parser (TermParams RL) 14 | pTermParams 15 | = pMPAnn $ P.choice 16 | [ do -- '@' '[' (Var ':' Type)+ ']' 17 | pTok KAt 18 | bts <- pSquared $ flip P.sepEndBy1 (pTok KComma) 19 | $ do b <- pBind "a binder for the parameter" 20 | pTok KColon "a ':' to give the kind of the parameter" 21 | t <- pType "the kind of the parameter" 22 | return (b, t) 23 | return $ MPTypes bts 24 | 25 | , do -- '[' (Var ':' Type)* ']' 26 | bts <- pSquared $ flip P.sepEndBy (pTok KComma) 27 | $ do b <- pBind "a binder for the parameter" 28 | pTok KColon "a ':' to give the type of the parameter" 29 | t <- pType "the type of the parameter" 30 | return (b, t) 31 | return $ MPTerms bts 32 | ] 33 | 34 | 35 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Codec/Text/Pretty.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Codec.Text.Pretty 3 | ( module Salt.Core.Codec.Text.Pretty.Base 4 | , module Salt.Core.Codec.Text.Pretty.Term 5 | , module Salt.Core.Codec.Text.Pretty.Type 6 | , module Salt.Data.Pretty) 7 | where 8 | import Salt.Core.Codec.Text.Pretty.Base 9 | import Salt.Core.Codec.Text.Pretty.Term 10 | import Salt.Core.Codec.Text.Pretty.Type 11 | import Salt.Data.Pretty 12 | 13 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Codec/Text/Pretty/Base.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Codec.Text.Pretty.Base where 3 | import Salt.Core.Exp 4 | import Salt.Data.Pretty 5 | import qualified Salt.Core.Codec.Text.Lexer as Lexer 6 | import qualified Data.Text as Text 7 | 8 | 9 | instance Pretty c Bind where 10 | ppr _ bb 11 | = case bb of 12 | BindName n -> pprVar n 13 | BindNone -> text "_" 14 | 15 | 16 | instance Pretty c Bound where 17 | ppr _ uu 18 | = case uu of 19 | BoundWith n 0 -> pprVar n 20 | BoundWith n d -> pprVar n % text "^" % integer d 21 | 22 | 23 | instance Pretty c Universe where 24 | ppr _ vv 25 | = case vv of 26 | UKind -> text "kind" 27 | UType -> text "type" 28 | UTerm -> text "term" 29 | 30 | 31 | instance Pretty c Ups where 32 | ppr _ (Ups bs) 33 | = braced (map pprBump bs) 34 | 35 | 36 | instance Pretty c Fragment where 37 | ppr _ mm 38 | = case mm of 39 | FragTerm -> text "term" 40 | FragProcBody -> text "proc body" 41 | FragProcExp -> text "proc exp" 42 | 43 | 44 | braced ds 45 | = braces $ hcat $ punctuate (text "; ") ds 46 | 47 | bracketed ds 48 | = brackets $ hcat $ punctuate (text ", ") ds 49 | 50 | bracketed' name ds 51 | = brackets $ hcat (text name : text "|" : punctuate (text ", ") ds) 52 | 53 | squared ds 54 | = text "[" % (hcat $ punctuate (text ", ") ds) % text "]" 55 | 56 | squoted ds 57 | = squotes (hsep $ punctuate (text ",") ds) 58 | 59 | pprBump ((n, d), b) 60 | = pprVar n % text "^" % integer d % text ":" % integer b 61 | 62 | 63 | pprNameAsIdentifier :: (Int -> Char -> Bool) -> Text -> Text -> Name -> Doc 64 | pprNameAsIdentifier match ident_class prefix (Name name) 65 | | Text.length name > 0 && Lexer.checkMatch match (prefix <> name) 66 | = text (prefix <> name) 67 | | otherwise 68 | = text ("##" <> ident_class) <> string (show name) 69 | 70 | 71 | pprVar :: Name -> Doc 72 | pprVar = pprNameAsIdentifier Lexer.matchVar "Var" "" 73 | 74 | 75 | -- | Labels are currently treated the same as variables in the lexer 76 | pprLbl :: Name -> Doc 77 | pprLbl = pprVar 78 | 79 | 80 | pprCon :: Name -> Doc 81 | pprCon = pprNameAsIdentifier Lexer.matchCon "Con" "" 82 | 83 | 84 | pprSym :: Name -> Doc 85 | pprSym = pprNameAsIdentifier Lexer.matchSym "Sym" "'" 86 | 87 | 88 | pprPrm :: Name -> Doc 89 | pprPrm = pprNameAsIdentifier Lexer.matchPrm "Prm" "#" 90 | 91 | 92 | pprNameQuoted :: Name -> Doc 93 | pprNameQuoted (Name name) 94 | = string (show name) 95 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Eval.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Eval 3 | ( module Salt.Core.Eval.Type 4 | , module Salt.Core.Eval.Term 5 | , module Salt.Core.Eval.Error 6 | , module Salt.Core.Eval.Base 7 | , module Salt.Core.Exp) 8 | where 9 | import Salt.Core.Eval.Type 10 | import Salt.Core.Eval.Term 11 | import Salt.Core.Eval.Error 12 | import Salt.Core.Eval.Base 13 | import Salt.Core.Exp 14 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Exp.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Exp 3 | ( module Salt.Core.Exp.Name 4 | , module Salt.Core.Exp.Ups 5 | , module Salt.Core.Exp.Snv 6 | , module Salt.Core.Exp.Type 7 | , module Salt.Core.Exp.TypeEnv 8 | , module Salt.Core.Exp.Term 9 | , module Salt.Core.Exp.TermEnv 10 | , module Salt.Core.Exp.Term.Predicates 11 | , module Salt.Core.Exp.Term.Compounds 12 | , module Salt.Core.Exp.Module 13 | , module Salt.Core.Exp.Universe) 14 | where 15 | import Salt.Core.Exp.Name 16 | import Salt.Core.Exp.Ups 17 | import Salt.Core.Exp.Snv 18 | import Salt.Core.Exp.Type 19 | import Salt.Core.Exp.TypeEnv 20 | import Salt.Core.Exp.Term 21 | import Salt.Core.Exp.TermEnv 22 | import Salt.Core.Exp.Term.Predicates 23 | import Salt.Core.Exp.Term.Compounds 24 | import Salt.Core.Exp.Module 25 | import Salt.Core.Exp.Universe 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Exp/Name.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Exp.Name 3 | ( Annot 4 | , Name (..), Text, IsString(..) 5 | , Bind (..) 6 | , Bound (..), pattern Bound) 7 | where 8 | import Data.Text (Text) 9 | import Data.String 10 | import Data.Typeable 11 | import qualified Data.Text as T 12 | 13 | 14 | --------------------------------------------------------------------------------------------------- 15 | -- | The usual constraints on expression annotations. 16 | -- Typeable allows us to throw exceptions that mention them. 17 | type Annot a = (Show a, Typeable a) 18 | 19 | 20 | --------------------------------------------------------------------------------------------------- 21 | -- | Names of things. 22 | data Name 23 | = Name Text 24 | deriving (Show, Eq, Ord) 25 | 26 | instance IsString Name where 27 | fromString str = Name $ T.pack str 28 | 29 | 30 | --------------------------------------------------------------------------------------------------- 31 | -- | Binding occurence of variable. 32 | data Bind 33 | -- | Named binder. 34 | = BindName Name 35 | 36 | -- | Non-binding binder. 37 | -- This behaves like a binder where the name is not mentioned 38 | -- anywhere else in the program. 39 | | BindNone 40 | deriving (Show, Eq, Ord) 41 | 42 | instance IsString Bind where 43 | fromString str = BindName $ Name $ T.pack str 44 | 45 | 46 | --------------------------------------------------------------------------------------------------- 47 | -- | Bound occurrence of variable. 48 | data Bound 49 | = BoundWith Name Integer 50 | deriving (Show, Eq, Ord) 51 | 52 | pattern Bound n = BoundWith n 0 53 | 54 | 55 | instance IsString Bound where 56 | fromString str = Bound $ Name $ T.pack str 57 | 58 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Exp/Snv.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Exp.Snv where 3 | import Salt.Core.Exp.Name 4 | import Salt.Core.Exp.Ups 5 | 6 | 7 | -- | A substitution of things for names. 8 | data Snv x 9 | = Snv [((Name, Depth), x)] 10 | deriving (Show, Eq, Ord) 11 | 12 | 13 | -- | An empty substitution. 14 | snvEmpty :: Snv x 15 | snvEmpty = Snv [] 16 | 17 | 18 | -- | Construct a substitution where all the bindings are at depth 0. 19 | snvOfBinds :: [(Name, x)] -> Snv x 20 | snvOfBinds nxs 21 | = Snv [ ((n, 0), x) | (n, x) <- nxs ] 22 | 23 | 24 | -- | Check if the given subsitution is empty. 25 | snvIsEmpty :: Snv x -> Bool 26 | snvIsEmpty (Snv bs) = null bs 27 | 28 | 29 | -- | Bump a subsitution due to pushing it under some binders. 30 | -- 31 | -- This adjusts the depth fields in the substitution, but does not apply 32 | -- ups to the bindings. This needs to be done separately. 33 | -- 34 | snvBump :: [Name] -> Snv x -> Snv x 35 | snvBump ns (Snv bs) 36 | = Snv $ map snvBump1 bs 37 | where 38 | snvBump1 ((n, d), x) 39 | = ( (n, d + if elem n ns then 1 else 0) 40 | , x) 41 | 42 | 43 | -- | Apply a substitution to a bound occurrence of a variable. 44 | -- 45 | -- Given a bound and a subsitution, if the substitution has a binder of the 46 | -- same name as the bound, and the depth of substitution is more than the depth 47 | -- of the bound then also decrement the depth in the bound. This is done to handle 48 | -- substitutions arising from beta contraction in a context with shadowed binders. 49 | -- 50 | snvApplyBound :: Snv x -> Bound -> Either Bound x 51 | snvApplyBound (Snv bs) u@(BoundWith name depth) 52 | = case bs of 53 | [] -> Left u 54 | 55 | ((name', depth'), x) : bs' 56 | -- Substitution matches the bound variable. 57 | | name == name', depth == depth' 58 | -> Right $ x 59 | 60 | -- Decrement the depth to handle subsitutions arising from beta-contraction 61 | -- in a context with shadowed binders. 62 | | name == name', depth > depth' 63 | -> Left $ BoundWith name (depth - 1) 64 | 65 | -- Subsitution does not match this variable, 66 | -- so check the others. 67 | | otherwise 68 | -> snvApplyBound (Snv bs') u 69 | 70 | 71 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Exp/Term.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Exp.Term 3 | ( module Salt.Core.Exp.Term.Base 4 | , module Salt.Core.Exp.Term.Compounds 5 | , module Salt.Core.Exp.Term.Patterns 6 | , module Salt.Core.Exp.Term.Predicates 7 | , Fragment(..)) 8 | where 9 | import Salt.Core.Exp.Term.Base 10 | import Salt.Core.Exp.Term.Compounds 11 | import Salt.Core.Exp.Term.Patterns 12 | import Salt.Core.Exp.Term.Predicates 13 | 14 | 15 | -- | Language fragment that a subexpression is being restricted to. 16 | data Fragment 17 | -- | A functional term that computes a value. 18 | -- 19 | -- Functional terms can create and apply arbitrary function abstractions, 20 | -- and define locally recursive computations. 21 | = FragTerm 22 | 23 | -- | The body of a procedure that can use procedural 24 | -- control flow constructs. 25 | | FragProcBody 26 | 27 | -- | A simple expression within a procedure. 28 | -- 29 | -- Procedural expressions can only apply primops and call existing functions. 30 | -- They cannot define new function abstractions or use local recursion. 31 | | FragProcExp 32 | deriving (Show, Eq) 33 | 34 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Exp/Term/Predicates.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Exp.Term.Predicates where 3 | import Salt.Core.Exp.Term.Patterns 4 | import Salt.Core.Exp.Term.Base 5 | 6 | 7 | -- | Check if this the boolean true value. 8 | isVTrue :: Value a -> Bool 9 | isVTrue (VBool True) = True 10 | isVTrue _ = False 11 | 12 | 13 | -- | Check if this is a procedure, or one wrapped by a 'the' 14 | isSomeMProc :: Term a -> Bool 15 | isSomeMProc mm 16 | = case mm of 17 | MAnn _ m -> isSomeMProc m 18 | MThe _ m -> isSomeMProc m 19 | MSeq{} -> True 20 | MLaunch{} -> True 21 | MReturn{} -> True 22 | MCell{} -> True 23 | MUpdate{} -> True 24 | MWhens{} -> True 25 | MMatch{} -> True 26 | MLoop{} -> True 27 | MBreak{} -> True 28 | MContinue{} -> True 29 | MWhile{} -> True 30 | MEnter{} -> True 31 | MLeave{} -> True 32 | _ -> False 33 | 34 | 35 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Exp/TermEnv.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Exp.TermEnv where 3 | import Salt.Core.Exp.Name 4 | import Salt.Core.Exp.Term 5 | import Salt.Core.Exp.Type 6 | import qualified Data.Map.Strict as Map 7 | 8 | 9 | -- | Construct an empty term environment. 10 | menvEmpty :: TermEnv a 11 | menvEmpty = TermEnv [] 12 | 13 | 14 | -- | Extend a term environment with a new type. 15 | menvExtendType :: Bind -> Type a -> TermEnv a -> TermEnv a 16 | menvExtendType bb t env@(TermEnv evs) 17 | = case bb of 18 | BindName n -> TermEnv (TermEnvTypes (Map.singleton n t) : evs) 19 | BindNone -> env 20 | 21 | 22 | -- | Extend an environment with some new types, 23 | -- binding them all at the same level. 24 | menvExtendTypes :: [(Bind, Type a)] -> TermEnv a -> TermEnv a 25 | menvExtendTypes bts1 (TermEnv bs2) 26 | = let nts = Map.fromList [ (n, t) | (BindName n, t) <- bts1] 27 | in TermEnv (TermEnvTypes nts : bs2) 28 | 29 | 30 | -- | Extend an environment with a new value. 31 | menvExtendValue :: Bind -> Value a -> TermEnv a -> TermEnv a 32 | menvExtendValue bb v env@(TermEnv evs) 33 | = case bb of 34 | BindName n -> TermEnv (TermEnvValues (Map.singleton n v) : evs) 35 | BindNone -> env 36 | 37 | 38 | -- | Extend an environment with some new values. 39 | menvExtendValues :: [(Bind, Value a)] -> TermEnv a -> TermEnv a 40 | menvExtendValues bvs1 (TermEnv bs2) 41 | = let nvs = Map.fromList [ (n, v) | (BindName n, v) <- bvs1] 42 | in TermEnv (TermEnvValues nvs : bs2) 43 | 44 | 45 | -- | Extend an environemnt with some new values that recursively reference the new environment. 46 | menvExtendValuesRec :: [(Bind, TermClosure a)] -> TermEnv a -> TermEnv a 47 | menvExtendValuesRec bvs1 (TermEnv bs2) 48 | = let ncs = Map.fromList [ (n, clo) | (BindName n, clo) <- bvs1 ] 49 | in TermEnv (TermEnvValuesRec ncs : bs2) 50 | 51 | 52 | -- | Slice out the type portion of a `TermEnv` to produce a `TypeEnv` 53 | menvSliceTypeEnv :: TermEnv a -> TypeEnv a 54 | menvSliceTypeEnv (TermEnv evs) 55 | = TypeEnv $ goSlice evs 56 | where 57 | goSlice (TermEnvTypes nts : rest) 58 | = TypeEnvTypes nts : goSlice rest 59 | 60 | goSlice (TermEnvValues{} : rest) = goSlice rest 61 | goSlice (TermEnvValuesRec{} : rest) = goSlice rest 62 | 63 | goSlice [] = [] 64 | 65 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Exp/Type.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Exp.Type 3 | ( module Salt.Core.Exp.Type.Base 4 | , module Salt.Core.Exp.Type.Compounds 5 | , module Salt.Core.Exp.Type.Patterns 6 | , module Salt.Core.Exp.Type.Predicates) 7 | where 8 | import Salt.Core.Exp.Type.Base 9 | import Salt.Core.Exp.Type.Compounds 10 | import Salt.Core.Exp.Type.Patterns 11 | import Salt.Core.Exp.Type.Predicates 12 | 13 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Exp/Type/Predicates.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Exp.Type.Predicates where 3 | import Salt.Core.Exp.Type.Patterns 4 | import Salt.Core.Exp.Type.Base 5 | 6 | 7 | -- | Check if this is the data kind, 8 | isTData :: Type a -> Bool 9 | isTData tt 10 | = case tt of 11 | TAnn _ t -> isTData t 12 | TData -> True 13 | _ -> False 14 | 15 | 16 | -- | Check if this type is the pure effect. 17 | isTPure :: Type a -> Bool 18 | isTPure tt 19 | = case tt of 20 | TAnn _ t -> isTPure t 21 | TPure -> True 22 | TSum [] -> True 23 | _ -> False 24 | 25 | 26 | -- | Check if this type is a suspension. 27 | isTSusp :: Type a -> Bool 28 | isTSusp tt 29 | = case tt of 30 | TAnn _ t -> isTSusp t 31 | TSusp _ _ -> True 32 | _ -> False 33 | 34 | 35 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Exp/TypeEnv.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Exp.TypeEnv where 3 | import Salt.Core.Exp.Name 4 | import Salt.Core.Exp.Type 5 | import qualified Data.Map.Strict as Map 6 | 7 | 8 | -- | Construct an empty term environment. 9 | tenvEmpty :: TypeEnv a 10 | tenvEmpty = TypeEnv [] 11 | 12 | 13 | -- | Extend a term environment with a new type. 14 | tenvExtendType :: Bind -> Type a -> TypeEnv a -> TypeEnv a 15 | tenvExtendType bb t env@(TypeEnv evs) 16 | = case bb of 17 | BindName n -> TypeEnv (TypeEnvTypes (Map.singleton n t) : evs) 18 | BindNone -> env 19 | 20 | 21 | -- | Extend an environment with some new types, 22 | -- binding them all at the same level. 23 | tenvExtendTypes :: [(Bind, Type a)] -> TypeEnv a -> TypeEnv a 24 | tenvExtendTypes bts1 (TypeEnv bs2) 25 | = let nts = Map.fromList [ (n, t) | (BindName n, t) <- bts1] 26 | in TypeEnv (TypeEnvTypes nts : bs2) 27 | 28 | 29 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Exp/Universe.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Exp.Universe where 3 | 4 | 5 | -- | What level of the hierarchy we might be talking about. 6 | data Universe 7 | = UKind -- level 2 8 | | UType -- level 1 9 | | UTerm -- level 0 10 | deriving (Eq, Show) 11 | 12 | 13 | -- | Get the next universe up. 14 | universeUp :: Universe -> Maybe Universe 15 | universeUp uni 16 | = case uni of 17 | UKind -> Nothing 18 | UType -> Just UKind 19 | UTerm -> Just UTerm 20 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim 3 | ( module Salt.Core.Prim.Ops 4 | , module Salt.Core.Prim.Ctor 5 | , module Salt.Core.Prim.Values) 6 | where 7 | import Salt.Core.Prim.Ops 8 | import Salt.Core.Prim.Ctor 9 | import Salt.Core.Prim.Values 10 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ctor.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ctor where 3 | import Salt.Core.Exp 4 | import Data.Map (Map) 5 | import qualified Data.Map.Strict as Map 6 | 7 | 8 | -- | Sorts of primitive kind constructors. 9 | primKindCtors :: Map Name () 10 | primKindCtors 11 | = Map.fromList 12 | [ ("Repr", ()) 13 | , ("Data", ()) 14 | , ("Comp", ()) 15 | , ("Prop", ()) 16 | , ("Region", ()) 17 | , ("Effect", ()) ] 18 | 19 | 20 | -- | Kinds of primitive type constructors. 21 | primTypeCtors :: Map Name (Type ()) 22 | primTypeCtors 23 | = Map.fromList 24 | [ ("Unit", TData) 25 | , ("Bool", TData) 26 | , ("Nat", TData) 27 | , ("Int", TData) 28 | , ("Int8", TData) 29 | , ("Int16", TData) 30 | , ("Int32", TData) 31 | , ("Int64", TData) 32 | , ("Word", TData) 33 | , ("Word8", TData) 34 | , ("Word16", TData) 35 | , ("Word32", TData) 36 | , ("Word64", TData) 37 | , ("Text", TData) 38 | , ("Symbol", TData) 39 | , ("Alloc", [TRegion] :=> TProp) 40 | , ("Read", [TRegion] :=> TProp) 41 | , ("Write", [TRegion] :=> TProp) 42 | , ("Addr", TData) 43 | , ("Ptr", [TRegion, TData] :=> TData) 44 | , ("Option", [TData] :=> TData) 45 | , ("List", [TData] :=> TData) 46 | , ("Set", [TData] :=> TData) 47 | , ("Map", [TData, TData] :=> TData) 48 | , ("Console", TEffect) 49 | , ("Memory", TEffect) 50 | , ("Sleep", TEffect) ] 51 | 52 | 53 | -- | Types of primitive data constructors. 54 | primDataCtors :: Map Name (Type ()) 55 | primDataCtors 56 | = Map.fromList 57 | [ ("None", [("a", TData)] :*> ([] :-> [TOption "a"])) 58 | , ("Some", [("a", TData)] :*> (["a"] :-> [TOption "a"]))] 59 | 60 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops 3 | ( Prim(..) 4 | , typeOfPrim 5 | , primOps) 6 | where 7 | import Data.Map (Map) 8 | import qualified Data.Map.Strict as Map 9 | 10 | import Salt.Core.Prim.Ops.Base 11 | import Salt.Core.Prim.Ops.Bool 12 | import Salt.Core.Prim.Ops.Console 13 | import Salt.Core.Prim.Ops.Debug 14 | import Salt.Core.Prim.Ops.Int 15 | import Salt.Core.Prim.Ops.Int8 16 | import Salt.Core.Prim.Ops.Int16 17 | import Salt.Core.Prim.Ops.Int32 18 | import Salt.Core.Prim.Ops.Int64 19 | import Salt.Core.Prim.Ops.List 20 | import Salt.Core.Prim.Ops.Map 21 | import Salt.Core.Prim.Ops.Memory 22 | import Salt.Core.Prim.Ops.Nat 23 | import Salt.Core.Prim.Ops.Set 24 | import Salt.Core.Prim.Ops.Symbol 25 | import Salt.Core.Prim.Ops.Word 26 | import Salt.Core.Prim.Ops.Word8 27 | import Salt.Core.Prim.Ops.Word16 28 | import Salt.Core.Prim.Ops.Word32 29 | import Salt.Core.Prim.Ops.Word64 30 | import Salt.Core.Prim.Ops.Reify 31 | import Salt.Core.Prim.Ops.Bundle 32 | 33 | 34 | primOps :: Map Name Prim 35 | primOps 36 | = Map.fromList $ map (\p -> (name p, p)) $ concat 37 | [ primOpsBool, primOpsNat 38 | , primOpsInt, primOpsInt8, primOpsInt16, primOpsInt32, primOpsInt64 39 | , primOpsWord, primOpsWord8, primOpsWord16, primOpsWord32, primOpsWord64 40 | , primOpsSymbol 41 | , primOpsList, primOpsSet, primOpsMap 42 | , primOpsMemory 43 | , primOpsDebug 44 | , primOpsConsole 45 | , primOpsReify 46 | , primOpsBundle ] 47 | 48 | 49 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Base.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Base 3 | ( module Salt.Core.Transform.StripAnnot 4 | , module Salt.Core.Exp 5 | , Prim(..) 6 | , typeOfPrim) 7 | where 8 | import Salt.Core.Transform.StripAnnot 9 | import Salt.Core.Exp 10 | 11 | 12 | -- | Holds information about a primitive operator. 13 | -- We keep all the info about an operator in once place, 14 | -- instead of spread out all over the compiler and external documentation. 15 | data Prim 16 | -- Define a pure primitive operator. 17 | -- Provided the values match the expected types, 18 | -- these operators always succeed, and perform no actions. 19 | = PP 20 | { name :: Name 21 | , tsig :: Type () 22 | , step :: forall a. Show a => [TermNormals a] -> [Value a] 23 | , docs :: Text } 24 | 25 | -- Define an operator that performs an action in the local process. 26 | | PO 27 | { name :: Name 28 | , tsig :: Type () 29 | , exec :: forall a. Show a => [TermNormals a] -> IO [Value a] 30 | , docs :: Text } 31 | 32 | 33 | -- | Get the value type of a primitive. 34 | typeOfPrim :: Prim -> Type () 35 | typeOfPrim pp 36 | = case pp of 37 | PP {tsig} -> tsig 38 | PO {tsig} -> tsig 39 | 40 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Bool.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Bool where 3 | import Salt.Core.Prim.Ops.Base 4 | 5 | 6 | primOpsBool 7 | = [ PP { name = "bool'not" 8 | , tsig = [TBool] :-> [TBool] 9 | , step = \[NVs [VBool b]] -> [VBool (not b)] 10 | , docs = "Boolean negation." } 11 | 12 | , PP { name = "bool'and" 13 | , tsig = [TBool, TBool] :-> [TBool] 14 | , step = \[NVs [VBool b1, VBool b2]] -> [VBool $ b1 && b2] 15 | , docs = "Boolean and." } 16 | 17 | , PP { name = "bool'or" 18 | , tsig = [TBool, TBool] :-> [TBool] 19 | , step = \[NVs [VBool b1, VBool b2]] -> [VBool $ b1 || b2] 20 | , docs = "Boolean or." } 21 | 22 | , PP { name = "bool'eq" 23 | , tsig = [TBool, TBool] :-> [TBool] 24 | , step = \[NVs [VBool b1, VBool b2]] -> [VBool $ b1 == b2] 25 | , docs = "Boolean or." } 26 | ] 27 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Bundle.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Bundle where 3 | import Salt.Core.Prim.Ops.Base 4 | 5 | 6 | primOpsBundle 7 | = [ PP { name = "bundle'new" 8 | , tsig = [TSet TSymbol, TSet TSymbol] :-> [TBundle] 9 | , step = \_ -> error "primOpsBundle: #bundle'new handled in evaluator" 10 | , docs = "Construct a new code bundle." } 11 | ] 12 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Console.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Console where 3 | import Salt.Core.Prim.Ops.Base 4 | import qualified Data.Text.IO as Text 5 | 6 | 7 | primOpsConsole 8 | = [ PO { name = "console'print" 9 | , tsig = [TText] :-> [TSusp [] TConsole] 10 | , exec = \[NVs [VText tx]] -> do Text.putStr tx; return [] 11 | , docs = "Print a text string to the console." } 12 | 13 | , PO { name = "console'println" 14 | , tsig = [TText] :-> [TSusp [] TConsole] 15 | , exec = \[NVs [VText tx]] -> do Text.putStrLn tx; return [] 16 | , docs = "Print a text string to the console, with a newline on the end." } 17 | ] 18 | 19 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Debug.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Debug where 3 | import Salt.Core.Prim.Ops.Base 4 | 5 | 6 | primOpsDebug 7 | = [ PO { name = "debug'print'raw" 8 | , tsig = [("a", TData)] :*> ["a"] :-> [TUnit] 9 | , exec = \[NTs [_ta], NVs [v]] -> do putStrLn $ "TRACE " ++ show v; return [VUnit] 10 | , docs = "DEBUG: Print the internal representaiton of a value to the local console." } 11 | ] 12 | 13 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Int.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Int where 3 | import Salt.Core.Prim.Ops.Base 4 | 5 | 6 | primOpsInt 7 | = [ PP { name = "int'add" 8 | , tsig = [TInt, TInt] :-> [TInt] 9 | , step = \[NVs [VInt n1, VInt n2]] -> [VInt $ n1 + n2] 10 | , docs = "Integer addition." } 11 | 12 | , PP { name = "int'sub" 13 | , tsig = [TInt, TInt] :-> [TInt] 14 | , step = \[NVs [VInt n1, VInt n2]] -> [VInt $ n1 - n2] 15 | , docs = "Integer subtraction." } 16 | 17 | , PP { name = "int'mul" 18 | , tsig = [TInt, TInt] :-> [TInt] 19 | , step = \[NVs [VInt n1, VInt n2]] -> [VInt $ n1 * n2] 20 | , docs = "Integer multiplication." } 21 | 22 | , PP { name = "int'div" 23 | , tsig = [TInt, TInt] :-> [TInt] 24 | , step = \[NVs [VInt n1, VInt n2]] -> [VInt $ n1 `div` n2] 25 | , docs = "Integer division." } 26 | 27 | , PP { name = "int'rem" 28 | , tsig = [TInt, TInt] :-> [TInt] 29 | , step = \[NVs [VInt n1, VInt n2]] -> [VInt $ n1 `rem` n2] 30 | , docs = "Integer remainder." } 31 | 32 | , PP { name = "int'eq" 33 | , tsig = [TInt, TInt] :-> [TBool] 34 | , step = \[NVs [VInt n1, VInt n2]] -> [VBool $ n1 == n2] 35 | , docs = "Integer equality." } 36 | 37 | , PP { name = "int'neq" 38 | , tsig = [TInt, TInt] :-> [TBool] 39 | , step = \[NVs [VInt n1, VInt n2]] -> [VBool $ n1 /= n2] 40 | , docs = "Integer negated equality." } 41 | 42 | , PP { name = "int'lt" 43 | , tsig = [TInt, TInt] :-> [TBool] 44 | , step = \[NVs [VInt n1, VInt n2]] -> [VBool $ n1 < n2] 45 | , docs = "Integer less-than." } 46 | 47 | , PP { name = "int'le" 48 | , tsig = [TInt, TInt] :-> [TBool] 49 | , step = \[NVs [VInt n1, VInt n2]] -> [VBool $ n1 <= n2] 50 | , docs = "Integer less-than or equal." } 51 | 52 | , PP { name = "int'gt" 53 | , tsig = [TInt, TInt] :-> [TBool] 54 | , step = \[NVs [VInt n1, VInt n2]] -> [VBool $ n1 > n2] 55 | , docs = "Integer greater-than." } 56 | 57 | , PP { name = "int'ge" 58 | , tsig = [TInt, TInt] :-> [TBool] 59 | , step = \[NVs [VInt n1, VInt n2]] -> [VBool $ n1 >= n2] 60 | , docs = "Integer greater-than or equal." } 61 | ] 62 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Int16.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Int16 where 3 | import Salt.Core.Prim.Ops.Base 4 | 5 | 6 | primOpsInt16 7 | = [ PP { name = "int16'add" 8 | , tsig = [TInt16, TInt16] :-> [TInt16] 9 | , step = \[NVs [VInt16 n1, VInt16 n2]] -> [VInt16 $ n1 + n2] 10 | , docs = "Integer addition." } 11 | 12 | , PP { name = "int16'sub" 13 | , tsig = [TInt16, TInt16] :-> [TInt16] 14 | , step = \[NVs [VInt16 n1, VInt16 n2]] -> [VInt16 $ n1 - n2] 15 | , docs = "Integer subtraction." } 16 | 17 | , PP { name = "int16'mul" 18 | , tsig = [TInt16, TInt16] :-> [TInt16] 19 | , step = \[NVs [VInt16 n1, VInt16 n2]] -> [VInt16 $ n1 * n2] 20 | , docs = "Integer multiplication." } 21 | 22 | , PP { name = "int16'div" 23 | , tsig = [TInt16, TInt16] :-> [TInt16] 24 | , step = \[NVs [VInt16 n1, VInt16 n2]] -> [VInt16 $ n1 `div` n2] 25 | , docs = "Integer division." } 26 | 27 | , PP { name = "int16'rem" 28 | , tsig = [TInt16, TInt16] :-> [TInt16] 29 | , step = \[NVs [VInt16 n1, VInt16 n2]] -> [VInt16 $ n1 `rem` n2] 30 | , docs = "Integer remainder." } 31 | 32 | , PP { name = "int16'eq" 33 | , tsig = [TInt16, TInt16] :-> [TBool] 34 | , step = \[NVs [VInt16 n1, VInt16 n2]] -> [VBool $ n1 == n2] 35 | , docs = "Integer equality." } 36 | 37 | , PP { name = "int16'neq" 38 | , tsig = [TInt16, TInt16] :-> [TBool] 39 | , step = \[NVs [VInt16 n1, VInt16 n2]] -> [VBool $ n1 /= n2] 40 | , docs = "Integer negated equality." } 41 | 42 | , PP { name = "int16'lt" 43 | , tsig = [TInt16, TInt16] :-> [TBool] 44 | , step = \[NVs [VInt16 n1, VInt16 n2]] -> [VBool $ n1 < n2] 45 | , docs = "Integer less-than." } 46 | 47 | , PP { name = "int16'le" 48 | , tsig = [TInt16, TInt16] :-> [TBool] 49 | , step = \[NVs [VInt16 n1, VInt16 n2]] -> [VBool $ n1 <= n2] 50 | , docs = "Integer less-than or equal." } 51 | 52 | , PP { name = "int16'gt" 53 | , tsig = [TInt16, TInt16] :-> [TBool] 54 | , step = \[NVs [VInt16 n1, VInt16 n2]] -> [VBool $ n1 > n2] 55 | , docs = "Integer greater-than." } 56 | 57 | , PP { name = "int16'ge" 58 | , tsig = [TInt16, TInt16] :-> [TBool] 59 | , step = \[NVs [VInt16 n1, VInt16 n2]] -> [VBool $ n1 >= n2] 60 | , docs = "Integer greater-than or equal." } 61 | ] 62 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Int32.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Int32 where 3 | import Salt.Core.Prim.Ops.Base 4 | 5 | 6 | primOpsInt32 7 | = [ PP { name = "int32'add" 8 | , tsig = [TInt32, TInt32] :-> [TInt32] 9 | , step = \[NVs [VInt32 n1, VInt32 n2]] -> [VInt32 $ n1 + n2] 10 | , docs = "Integer addition." } 11 | 12 | , PP { name = "int32'sub" 13 | , tsig = [TInt32, TInt32] :-> [TInt32] 14 | , step = \[NVs [VInt32 n1, VInt32 n2]] -> [VInt32 $ n1 - n2] 15 | , docs = "Integer subtraction." } 16 | 17 | , PP { name = "int32'mul" 18 | , tsig = [TInt32, TInt32] :-> [TInt32] 19 | , step = \[NVs [VInt32 n1, VInt32 n2]] -> [VInt32 $ n1 * n2] 20 | , docs = "Integer multiplication." } 21 | 22 | , PP { name = "int32'div" 23 | , tsig = [TInt32, TInt32] :-> [TInt32] 24 | , step = \[NVs [VInt32 n1, VInt32 n2]] -> [VInt32 $ n1 `div` n2] 25 | , docs = "Integer division." } 26 | 27 | , PP { name = "int32'rem" 28 | , tsig = [TInt32, TInt32] :-> [TInt32] 29 | , step = \[NVs [VInt32 n1, VInt32 n2]] -> [VInt32 $ n1 `rem` n2] 30 | , docs = "Integer remainder." } 31 | 32 | , PP { name = "int32'eq" 33 | , tsig = [TInt32, TInt32] :-> [TBool] 34 | , step = \[NVs [VInt32 n1, VInt32 n2]] -> [VBool $ n1 == n2] 35 | , docs = "Integer equality." } 36 | 37 | , PP { name = "int32'neq" 38 | , tsig = [TInt32, TInt32] :-> [TBool] 39 | , step = \[NVs [VInt32 n1, VInt32 n2]] -> [VBool $ n1 /= n2] 40 | , docs = "Integer negated equality." } 41 | 42 | , PP { name = "int32'lt" 43 | , tsig = [TInt32, TInt32] :-> [TBool] 44 | , step = \[NVs [VInt32 n1, VInt32 n2]] -> [VBool $ n1 < n2] 45 | , docs = "Integer less-than." } 46 | 47 | , PP { name = "int32'le" 48 | , tsig = [TInt32, TInt32] :-> [TBool] 49 | , step = \[NVs [VInt32 n1, VInt32 n2]] -> [VBool $ n1 <= n2] 50 | , docs = "Integer less-than or equal." } 51 | 52 | , PP { name = "int32'gt" 53 | , tsig = [TInt32, TInt32] :-> [TBool] 54 | , step = \[NVs [VInt32 n1, VInt32 n2]] -> [VBool $ n1 > n2] 55 | , docs = "Integer greater-than." } 56 | 57 | , PP { name = "int32'ge" 58 | , tsig = [TInt32, TInt32] :-> [TBool] 59 | , step = \[NVs [VInt32 n1, VInt32 n2]] -> [VBool $ n1 >= n2] 60 | , docs = "Integer greater-than or equal." } 61 | ] 62 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Int64.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Int64 where 3 | import Salt.Core.Prim.Ops.Base 4 | 5 | 6 | primOpsInt64 7 | = [ PP { name = "int64'add" 8 | , tsig = [TInt64, TInt64] :-> [TInt64] 9 | , step = \[NVs [VInt64 n1, VInt64 n2]] -> [VInt64 $ n1 + n2] 10 | , docs = "Integer addition." } 11 | 12 | , PP { name = "int64'sub" 13 | , tsig = [TInt64, TInt64] :-> [TInt64] 14 | , step = \[NVs [VInt64 n1, VInt64 n2]] -> [VInt64 $ n1 - n2] 15 | , docs = "Integer subtraction." } 16 | 17 | , PP { name = "int64'mul" 18 | , tsig = [TInt64, TInt64] :-> [TInt64] 19 | , step = \[NVs [VInt64 n1, VInt64 n2]] -> [VInt64 $ n1 * n2] 20 | , docs = "Integer multiplication." } 21 | 22 | , PP { name = "int64'div" 23 | , tsig = [TInt64, TInt64] :-> [TInt64] 24 | , step = \[NVs [VInt64 n1, VInt64 n2]] -> [VInt64 $ n1 `div` n2] 25 | , docs = "Integer division." } 26 | 27 | , PP { name = "int64'rem" 28 | , tsig = [TInt64, TInt64] :-> [TInt64] 29 | , step = \[NVs [VInt64 n1, VInt64 n2]] -> [VInt64 $ n1 `rem` n2] 30 | , docs = "Integer remainder." } 31 | 32 | , PP { name = "int64'eq" 33 | , tsig = [TInt64, TInt64] :-> [TBool] 34 | , step = \[NVs [VInt64 n1, VInt64 n2]] -> [VBool $ n1 == n2] 35 | , docs = "Integer equality." } 36 | 37 | , PP { name = "int64'neq" 38 | , tsig = [TInt64, TInt64] :-> [TBool] 39 | , step = \[NVs [VInt64 n1, VInt64 n2]] -> [VBool $ n1 /= n2] 40 | , docs = "Integer negated equality." } 41 | 42 | , PP { name = "int64'lt" 43 | , tsig = [TInt64, TInt64] :-> [TBool] 44 | , step = \[NVs [VInt64 n1, VInt64 n2]] -> [VBool $ n1 < n2] 45 | , docs = "Integer less-than." } 46 | 47 | , PP { name = "int64'le" 48 | , tsig = [TInt64, TInt64] :-> [TBool] 49 | , step = \[NVs [VInt64 n1, VInt64 n2]] -> [VBool $ n1 <= n2] 50 | , docs = "Integer less-than or equal." } 51 | 52 | , PP { name = "int64'gt" 53 | , tsig = [TInt64, TInt64] :-> [TBool] 54 | , step = \[NVs [VInt64 n1, VInt64 n2]] -> [VBool $ n1 > n2] 55 | , docs = "Integer greater-than." } 56 | 57 | , PP { name = "int64'ge" 58 | , tsig = [TInt64, TInt64] :-> [TBool] 59 | , step = \[NVs [VInt64 n1, VInt64 n2]] -> [VBool $ n1 >= n2] 60 | , docs = "Integer greater-than or equal." } 61 | ] 62 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Int8.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Int8 where 3 | import Salt.Core.Prim.Ops.Base 4 | import Data.Text (pack) 5 | 6 | 7 | primOpsInt8 8 | = [ PP { name = "int8'show" 9 | , tsig = [TInt8] :-> [TText] 10 | , step = \[NVs [VInt8 n]] -> [VText $ pack $ show n] 11 | , docs = "Convert int to text." } 12 | 13 | , PP { name = "int8'add" 14 | , tsig = [TInt8, TInt8] :-> [TInt8] 15 | , step = \[NVs [VInt8 n1, VInt8 n2]] -> [VInt8 $ n1 + n2] 16 | , docs = "Integer addition." } 17 | 18 | , PP { name = "int8'sub" 19 | , tsig = [TInt8, TInt8] :-> [TInt8] 20 | , step = \[NVs [VInt8 n1, VInt8 n2]] -> [VInt8 $ n1 - n2] 21 | , docs = "Integer subtraction." } 22 | 23 | , PP { name = "int8'mul" 24 | , tsig = [TInt8, TInt8] :-> [TInt8] 25 | , step = \[NVs [VInt8 n1, VInt8 n2]] -> [VInt8 $ n1 * n2] 26 | , docs = "Integer multiplication." } 27 | 28 | , PP { name = "int8'div" 29 | , tsig = [TInt8, TInt8] :-> [TInt8] 30 | , step = \[NVs [VInt8 n1, VInt8 n2]] -> [VInt8 $ n1 `div` n2] 31 | , docs = "Integer division." } 32 | 33 | , PP { name = "int8'rem" 34 | , tsig = [TInt8, TInt8] :-> [TInt8] 35 | , step = \[NVs [VInt8 n1, VInt8 n2]] -> [VInt8 $ n1 `rem` n2] 36 | , docs = "Integer remainder." } 37 | 38 | , PP { name = "int8'eq" 39 | , tsig = [TInt8, TInt8] :-> [TBool] 40 | , step = \[NVs [VInt8 n1, VInt8 n2]] -> [VBool $ n1 == n2] 41 | , docs = "Integer equality." } 42 | 43 | , PP { name = "int8'neq" 44 | , tsig = [TInt8, TInt8] :-> [TBool] 45 | , step = \[NVs [VInt8 n1, VInt8 n2]] -> [VBool $ n1 /= n2] 46 | , docs = "Integer negated equality." } 47 | 48 | , PP { name = "int8'lt" 49 | , tsig = [TInt8, TInt8] :-> [TBool] 50 | , step = \[NVs [VInt8 n1, VInt8 n2]] -> [VBool $ n1 < n2] 51 | , docs = "Integer less-than." } 52 | 53 | , PP { name = "int8'le" 54 | , tsig = [TInt8, TInt8] :-> [TBool] 55 | , step = \[NVs [VInt8 n1, VInt8 n2]] -> [VBool $ n1 <= n2] 56 | , docs = "Integer less-than or equal." } 57 | 58 | , PP { name = "int8'gt" 59 | , tsig = [TInt8, TInt8] :-> [TBool] 60 | , step = \[NVs [VInt8 n1, VInt8 n2]] -> [VBool $ n1 > n2] 61 | , docs = "Integer greater-than." } 62 | 63 | , PP { name = "int8'ge" 64 | , tsig = [TInt8, TInt8] :-> [TBool] 65 | , step = \[NVs [VInt8 n1, VInt8 n2]] -> [VBool $ n1 >= n2] 66 | , docs = "Integer greater-than or equal." } 67 | ] 68 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Map.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Map where 3 | import Salt.Core.Prim.Ops.Base 4 | import qualified Data.Map.Strict as Map 5 | 6 | 7 | primOpsMap 8 | = [ PP { name = "map'empty" 9 | , tsig = [("k", TData), ("v", TData)] 10 | :*> TMap "k" "v" 11 | , step = \[NTs [tk, tv]] 12 | -> [VMap tk tv $ Map.empty] 13 | , docs = "Construct an empty map." } 14 | 15 | , PP { name = "map'isEmpty" 16 | , tsig = [("k", TData), ("v", TData)] 17 | :*> [TMap "k" "v"] :-> [TBool] 18 | , step = \[NTs [_, _], NVs [VMap _ _ vks]] 19 | -> [VBool $ Map.null vks] 20 | , docs = "Check if the given map is empty." } 21 | 22 | , PP { name = "map'size" 23 | , tsig = [("k", TData), ("v", TData)] 24 | :*> [TMap "k" "v"] :-> [TNat] 25 | , step = \[NTs [_, _], NVs [VMap _ _ vks]] 26 | -> [VNat $ fromIntegral $ Map.size vks] 27 | , docs = "Produce the size of the given map." } 28 | 29 | , PP { name = "map'insert" 30 | , tsig = [("k", TData), ("v", TData)] 31 | :*> ["k", "v", TMap "k" "v"] :-> [TMap "k" "v"] 32 | , step = \[NTs [tk, tv], NVs [vk, vv, VMap _ _ vks]] 33 | -> [VMap tk tv $ Map.insert (stripAnnot vk) vv vks] 34 | , docs = "Insert an element into a map." } 35 | 36 | , PP { name = "map'delete" 37 | , tsig = [("k", TData), ("v", TData)] 38 | :*> ["k", TMap "k" "v"] :-> [TMap "k" "v"] 39 | , step = \[NTs [tk, tv], NVs [vk, VMap _ _ vks]] 40 | -> [VMap tk tv $ Map.delete (stripAnnot vk) vks] 41 | , docs = "Delete an element from a map." } 42 | 43 | , PP { name = "map'lookup" 44 | , tsig = [("k", TData), ("v", TData)] 45 | :*> ["k", TMap "k" "v"] :-> [TOption "v"] 46 | , step = \[NTs [_, tv], NVs [vk, VMap _ _ vks]] 47 | -> case Map.lookup (stripAnnot vk) vks of 48 | Nothing -> [VNone tv] 49 | Just vv -> [VSome tv vv] 50 | , docs = "Lookup an element from a map." } 51 | ] 52 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Nat.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Nat where 3 | import Salt.Core.Prim.Ops.Base 4 | import qualified Data.Text as T 5 | 6 | primOpsNat 7 | = [ PP { name = "nat'show" 8 | , tsig = [TNat] :-> [TText] 9 | , step = \[NVs [VNat n]] -> [VText $ T.pack $ show n] 10 | , docs = "Convert nat to text." } 11 | 12 | , PP { name = "nat'add" 13 | , tsig = [TNat, TNat] :-> [TNat] 14 | , step = \[NVs [VNat n1, VNat n2]] -> [VNat $ n1 + n2] 15 | , docs = "Natural number addition." } 16 | 17 | , PP { name = "nat'sub" 18 | , tsig = [TNat, TNat] :-> [TNat] 19 | , step = \[NVs [VNat n1, VNat n2]] -> [VNat $ n1 - n2] 20 | , docs = "Natural number subtraction." } 21 | 22 | , PP { name = "nat'mul" 23 | , tsig = [TNat, TNat] :-> [TNat] 24 | , step = \[NVs [VNat n1, VNat n2]] -> [VNat $ n1 * n2] 25 | , docs = "Natural number multiplication." } 26 | 27 | , PP { name = "nat'div" 28 | , tsig = [TNat, TNat] :-> [TNat] 29 | , step = \[NVs [VNat n1, VNat n2]] -> [VNat $ n1 `div` n2] 30 | , docs = "Natural number division." } 31 | 32 | , PP { name = "nat'rem" 33 | , tsig = [TNat, TNat] :-> [TNat] 34 | , step = \[NVs [VNat n1, VNat n2]] -> [VNat $ n1 `rem` n2] 35 | , docs = "Natural number remainder." } 36 | 37 | , PP { name = "nat'eq" 38 | , tsig = [TNat, TNat] :-> [TBool] 39 | , step = \[NVs [VNat n1, VNat n2]] -> [VBool $ n1 == n2] 40 | , docs = "Natural number equality." } 41 | 42 | , PP { name = "nat'neq" 43 | , tsig = [TNat, TNat] :-> [TBool] 44 | , step = \[NVs [VNat n1, VNat n2]] -> [VBool $ n1 /= n2] 45 | , docs = "Natural number negated equality." } 46 | 47 | , PP { name = "nat'lt" 48 | , tsig = [TNat, TNat] :-> [TBool] 49 | , step = \[NVs [VNat n1, VNat n2]] -> [VBool $ n1 < n2] 50 | , docs = "Natural number less-than." } 51 | 52 | , PP { name = "nat'le" 53 | , tsig = [TNat, TNat] :-> [TBool] 54 | , step = \[NVs [VNat n1, VNat n2]] -> [VBool $ n1 <= n2] 55 | , docs = "Natural number less-than or equal." } 56 | 57 | , PP { name = "nat'gt" 58 | , tsig = [TNat, TNat] :-> [TBool] 59 | , step = \[NVs [VNat n1, VNat n2]] -> [VBool $ n1 > n2] 60 | , docs = "Natural number greater-than." } 61 | 62 | , PP { name = "nat'ge" 63 | , tsig = [TNat, TNat] :-> [TBool] 64 | , step = \[NVs [VNat n1, VNat n2]] -> [VBool $ n1 >= n2] 65 | , docs = "Natural number greater-than or equal." } 66 | ] 67 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Reify.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Reify where 3 | import Salt.Core.Prim.Ops.Base 4 | import Salt.Core.Codec.Text.Pretty () 5 | import qualified Salt.Data.Pretty as P 6 | import qualified Data.Text as T 7 | 8 | 9 | primOpsReify 10 | = [ PP { name = "reify'pretty" 11 | , tsig = [("a", TData)] :*> ["a"] :-> [TText] 12 | , step = \[NTs [_t], NVs [v]] 13 | -> [VText $ T.pack $ P.render $ P.ppr () $ stripAnnot v] 14 | , docs = "Reify a term into a pretty printed string." } 15 | ] 16 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Set.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Set where 3 | import Salt.Core.Prim.Ops.Base 4 | import qualified Data.Set as Set 5 | 6 | 7 | primOpsSet 8 | = [ PP { name = "set'empty" 9 | , tsig = [("a", TData)] :*> TSet "a" 10 | , step = \[NTs [t]] 11 | -> [VSet t $ Set.empty] 12 | , docs = "Construct an empty set." } 13 | 14 | , PP { name = "set'fromList" 15 | , tsig = [("a", TData)] :*> [TList "a"] :-> [TSet "a"] 16 | , step = \[NTs [t], NVs [VList _ vs]] 17 | -> [VSet t $ Set.fromList $ map stripAnnot vs] 18 | , docs = "Construct a set from a list of values." } 19 | 20 | , PP { name = "set'isEmpty" 21 | , tsig = [("a", TData)] :*> [TSet "a"] :-> [TBool] 22 | , step = \[NTs [_], NVs [VSet _ vs]] 23 | -> [VBool $ Set.null vs] 24 | , docs = "Check if the given set is empty." } 25 | 26 | , PP { name = "set'size" 27 | , tsig = [("a", TData)] :*> [TSet "a"] :-> [TNat] 28 | , step = \[NTs [_], NVs [VSet _ vs]] 29 | -> [VNat $ fromIntegral $ Set.size vs] 30 | , docs = "Produce the size of the given set." } 31 | 32 | , PP { name = "set'hasElem" 33 | , tsig = [("a", TData)] :*> ["a", TSet "a"] :-> [TBool] 34 | , step = \[NTs [_], NVs [v, VSet _ vs]] 35 | -> [VBool $ Set.member (stripAnnot v) vs] 36 | , docs = "Check if an element is in the given set." } 37 | 38 | , PP { name = "set'insert" 39 | , tsig = [("a", TData)] :*> ["a", TSet "a"] :-> [TSet "a"] 40 | , step = \[NTs [t], NVs [v, VSet _ vs]] 41 | -> [VSet t $ Set.insert (stripAnnot v) vs] 42 | , docs = "Insert an element into a set." } 43 | 44 | , PP { name = "set'delete" 45 | , tsig = [("a", TData)] :*> ["a", TSet "a"] :-> [TSet "a"] 46 | , step = \[NTs [t], NVs [v, VSet _ vs]] 47 | -> [VSet t $ Set.delete (stripAnnot v) vs] 48 | , docs = "Delete an element from a set." } 49 | ] 50 | 51 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Symbol.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Symbol where 3 | import Salt.Core.Prim.Ops.Base 4 | 5 | 6 | primOpsSymbol 7 | = [ PP { name = "symbol'eq" 8 | , tsig = [TSymbol, TSymbol] :-> [TBool] 9 | , step = \[NVs [VSymbol s1, VSymbol s2]] -> [VBool $ s1 == s2] 10 | , docs = "Symbol equality comparison." } 11 | ] 12 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Word.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Word where 3 | import Salt.Core.Prim.Ops.Base 4 | 5 | 6 | primOpsWord 7 | = [ PP { name = "word'add" 8 | , tsig = [TWord, TWord] :-> [TWord] 9 | , step = \[NVs [VWord n1, VWord n2]] -> [VWord $ n1 + n2] 10 | , docs = "Word addition." } 11 | 12 | , PP { name = "word'sub" 13 | , tsig = [TWord, TWord] :-> [TWord] 14 | , step = \[NVs [VWord n1, VWord n2]] -> [VWord $ n1 - n2] 15 | , docs = "Word subtraction." } 16 | 17 | , PP { name = "word'mul" 18 | , tsig = [TWord, TWord] :-> [TWord] 19 | , step = \[NVs [VWord n1, VWord n2]] -> [VWord $ n1 * n2] 20 | , docs = "Word multiplication." } 21 | 22 | , PP { name = "word'div" 23 | , tsig = [TWord, TWord] :-> [TWord] 24 | , step = \[NVs [VWord n1, VWord n2]] -> [VWord $ n1 `div` n2] 25 | , docs = "Word division." } 26 | 27 | , PP { name = "word'rem" 28 | , tsig = [TWord, TWord] :-> [TWord] 29 | , step = \[NVs [VWord n1, VWord n2]] -> [VWord $ n1 `rem` n2] 30 | , docs = "Word remainder." } 31 | 32 | , PP { name = "word'eq" 33 | , tsig = [TWord, TWord] :-> [TBool] 34 | , step = \[NVs [VWord n1, VWord n2]] -> [VBool $ n1 == n2] 35 | , docs = "Word equality." } 36 | 37 | , PP { name = "word'neq" 38 | , tsig = [TWord, TWord] :-> [TBool] 39 | , step = \[NVs [VWord n1, VWord n2]] -> [VBool $ n1 /= n2] 40 | , docs = "Word negated equality." } 41 | 42 | , PP { name = "word'lt" 43 | , tsig = [TWord, TWord] :-> [TBool] 44 | , step = \[NVs [VWord n1, VWord n2]] -> [VBool $ n1 < n2] 45 | , docs = "Word less-than." } 46 | 47 | , PP { name = "word'le" 48 | , tsig = [TWord, TWord] :-> [TBool] 49 | , step = \[NVs [VWord n1, VWord n2]] -> [VBool $ n1 <= n2] 50 | , docs = "Word less-than or equal." } 51 | 52 | , PP { name = "word'gt" 53 | , tsig = [TWord, TWord] :-> [TBool] 54 | , step = \[NVs [VWord n1, VWord n2]] -> [VBool $ n1 > n2] 55 | , docs = "Word greater-than." } 56 | 57 | , PP { name = "word'ge" 58 | , tsig = [TWord, TWord] :-> [TBool] 59 | , step = \[NVs [VWord n1, VWord n2]] -> [VBool $ n1 >= n2] 60 | , docs = "Word greater-than or equal." } 61 | ] 62 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Word16.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Word16 where 3 | import Salt.Core.Prim.Ops.Base 4 | 5 | 6 | primOpsWord16 7 | = [ PP { name = "word16'add" 8 | , tsig = [TWord16, TWord16] :-> [TWord16] 9 | , step = \[NVs [VWord16 n1, VWord16 n2]] -> [VWord16 $ n1 + n2] 10 | , docs = "Word addition." } 11 | 12 | , PP { name = "word16'sub" 13 | , tsig = [TWord16, TWord16] :-> [TWord16] 14 | , step = \[NVs [VWord16 n1, VWord16 n2]] -> [VWord16 $ n1 - n2] 15 | , docs = "Word subtraction." } 16 | 17 | , PP { name = "word16'mul" 18 | , tsig = [TWord16, TWord16] :-> [TWord16] 19 | , step = \[NVs [VWord16 n1, VWord16 n2]] -> [VWord16 $ n1 * n2] 20 | , docs = "Word multiplication." } 21 | 22 | , PP { name = "word16'div" 23 | , tsig = [TWord16, TWord16] :-> [TWord16] 24 | , step = \[NVs [VWord16 n1, VWord16 n2]] -> [VWord16 $ n1 `div` n2] 25 | , docs = "Word division." } 26 | 27 | , PP { name = "word16'rem" 28 | , tsig = [TWord16, TWord16] :-> [TWord16] 29 | , step = \[NVs [VWord16 n1, VWord16 n2]] -> [VWord16 $ n1 `rem` n2] 30 | , docs = "Word remainder." } 31 | 32 | , PP { name = "word16'eq" 33 | , tsig = [TWord16, TWord16] :-> [TBool] 34 | , step = \[NVs [VWord16 n1, VWord16 n2]] -> [VBool $ n1 == n2] 35 | , docs = "Word equality." } 36 | 37 | , PP { name = "word16'neq" 38 | , tsig = [TWord16, TWord16] :-> [TBool] 39 | , step = \[NVs [VWord16 n1, VWord16 n2]] -> [VBool $ n1 /= n2] 40 | , docs = "Word negated equality." } 41 | 42 | , PP { name = "word16'lt" 43 | , tsig = [TWord16, TWord16] :-> [TBool] 44 | , step = \[NVs [VWord16 n1, VWord16 n2]] -> [VBool $ n1 < n2] 45 | , docs = "Word less-than." } 46 | 47 | , PP { name = "word16'le" 48 | , tsig = [TWord16, TWord16] :-> [TBool] 49 | , step = \[NVs [VWord16 n1, VWord16 n2]] -> [VBool $ n1 <= n2] 50 | , docs = "Word less-than or equal." } 51 | 52 | , PP { name = "word16'gt" 53 | , tsig = [TWord16, TWord16] :-> [TBool] 54 | , step = \[NVs [VWord16 n1, VWord16 n2]] -> [VBool $ n1 > n2] 55 | , docs = "Word greater-than." } 56 | 57 | , PP { name = "word16'ge" 58 | , tsig = [TWord16, TWord16] :-> [TBool] 59 | , step = \[NVs [VWord16 n1, VWord16 n2]] -> [VBool $ n1 >= n2] 60 | , docs = "Word greater-than or equal." } 61 | ] 62 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Word32.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Word32 where 3 | import Salt.Core.Prim.Ops.Base 4 | 5 | 6 | primOpsWord32 7 | = [ PP { name = "word32'add" 8 | , tsig = [TWord32, TWord32] :-> [TWord32] 9 | , step = \[NVs [VWord32 n1, VWord32 n2]] -> [VWord32 $ n1 + n2] 10 | , docs = "Word addition." } 11 | 12 | , PP { name = "word32'sub" 13 | , tsig = [TWord32, TWord32] :-> [TWord32] 14 | , step = \[NVs [VWord32 n1, VWord32 n2]] -> [VWord32 $ n1 - n2] 15 | , docs = "Word subtraction." } 16 | 17 | , PP { name = "word32'mul" 18 | , tsig = [TWord32, TWord32] :-> [TWord32] 19 | , step = \[NVs [VWord32 n1, VWord32 n2]] -> [VWord32 $ n1 * n2] 20 | , docs = "Word multiplication." } 21 | 22 | , PP { name = "word32'div" 23 | , tsig = [TWord32, TWord32] :-> [TWord32] 24 | , step = \[NVs [VWord32 n1, VWord32 n2]] -> [VWord32 $ n1 `div` n2] 25 | , docs = "Word division." } 26 | 27 | , PP { name = "word32'rem" 28 | , tsig = [TWord32, TWord32] :-> [TWord32] 29 | , step = \[NVs [VWord32 n1, VWord32 n2]] -> [VWord32 $ n1 `rem` n2] 30 | , docs = "Word remainder." } 31 | 32 | , PP { name = "word32'eq" 33 | , tsig = [TWord32, TWord32] :-> [TBool] 34 | , step = \[NVs [VWord32 n1, VWord32 n2]] -> [VBool $ n1 == n2] 35 | , docs = "Word equality." } 36 | 37 | , PP { name = "word32'neq" 38 | , tsig = [TWord32, TWord32] :-> [TBool] 39 | , step = \[NVs [VWord32 n1, VWord32 n2]] -> [VBool $ n1 /= n2] 40 | , docs = "Word negated equality." } 41 | 42 | , PP { name = "word32'lt" 43 | , tsig = [TWord32, TWord32] :-> [TBool] 44 | , step = \[NVs [VWord32 n1, VWord32 n2]] -> [VBool $ n1 < n2] 45 | , docs = "Word less-than." } 46 | 47 | , PP { name = "word32'le" 48 | , tsig = [TWord32, TWord32] :-> [TBool] 49 | , step = \[NVs [VWord32 n1, VWord32 n2]] -> [VBool $ n1 <= n2] 50 | , docs = "Word less-than or equal." } 51 | 52 | , PP { name = "word32'gt" 53 | , tsig = [TWord32, TWord32] :-> [TBool] 54 | , step = \[NVs [VWord32 n1, VWord32 n2]] -> [VBool $ n1 > n2] 55 | , docs = "Word greater-than." } 56 | 57 | , PP { name = "word32'ge" 58 | , tsig = [TWord32, TWord32] :-> [TBool] 59 | , step = \[NVs [VWord32 n1, VWord32 n2]] -> [VBool $ n1 >= n2] 60 | , docs = "Word greater-than or equal." } 61 | ] 62 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Word64.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Word64 where 3 | import Salt.Core.Prim.Ops.Base 4 | import Data.Text (pack) 5 | 6 | 7 | primOpsWord64 8 | = [ PP { name = "word64'show" 9 | , tsig = [TWord64] :-> [TText] 10 | , step = \[NVs [VWord64 n]] -> [VText $ pack $ show n] 11 | , docs = "Convert word to text." } 12 | 13 | , PP { name = "word64'add" 14 | , tsig = [TWord64, TWord64] :-> [TWord64] 15 | , step = \[NVs [VWord64 n1, VWord64 n2]] -> [VWord64 $ n1 + n2] 16 | , docs = "Word addition." } 17 | 18 | , PP { name = "word64'sub" 19 | , tsig = [TWord64, TWord64] :-> [TWord64] 20 | , step = \[NVs [VWord64 n1, VWord64 n2]] -> [VWord64 $ n1 - n2] 21 | , docs = "Word subtraction." } 22 | 23 | , PP { name = "word64'mul" 24 | , tsig = [TWord64, TWord64] :-> [TWord64] 25 | , step = \[NVs [VWord64 n1, VWord64 n2]] -> [VWord64 $ n1 * n2] 26 | , docs = "Word multiplication." } 27 | 28 | , PP { name = "word64'div" 29 | , tsig = [TWord64, TWord64] :-> [TWord64] 30 | , step = \[NVs [VWord64 n1, VWord64 n2]] -> [VWord64 $ n1 `div` n2] 31 | , docs = "Word division." } 32 | 33 | , PP { name = "word64'rem" 34 | , tsig = [TWord64, TWord64] :-> [TWord64] 35 | , step = \[NVs [VWord64 n1, VWord64 n2]] -> [VWord64 $ n1 `rem` n2] 36 | , docs = "Word remainder." } 37 | 38 | , PP { name = "word64'eq" 39 | , tsig = [TWord64, TWord64] :-> [TBool] 40 | , step = \[NVs [VWord64 n1, VWord64 n2]] -> [VBool $ n1 == n2] 41 | , docs = "Word equality." } 42 | 43 | , PP { name = "word64'neq" 44 | , tsig = [TWord64, TWord64] :-> [TBool] 45 | , step = \[NVs [VWord64 n1, VWord64 n2]] -> [VBool $ n1 /= n2] 46 | , docs = "Word negated equality." } 47 | 48 | , PP { name = "word64'lt" 49 | , tsig = [TWord64, TWord64] :-> [TBool] 50 | , step = \[NVs [VWord64 n1, VWord64 n2]] -> [VBool $ n1 < n2] 51 | , docs = "Word less-than." } 52 | 53 | , PP { name = "word64'le" 54 | , tsig = [TWord64, TWord64] :-> [TBool] 55 | , step = \[NVs [VWord64 n1, VWord64 n2]] -> [VBool $ n1 <= n2] 56 | , docs = "Word less-than or equal." } 57 | 58 | , PP { name = "word64'gt" 59 | , tsig = [TWord64, TWord64] :-> [TBool] 60 | , step = \[NVs [VWord64 n1, VWord64 n2]] -> [VBool $ n1 > n2] 61 | , docs = "Word greater-than." } 62 | 63 | , PP { name = "word64'ge" 64 | , tsig = [TWord64, TWord64] :-> [TBool] 65 | , step = \[NVs [VWord64 n1, VWord64 n2]] -> [VBool $ n1 >= n2] 66 | , docs = "Word greater-than or equal." } 67 | ] 68 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Ops/Word8.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Ops.Word8 where 3 | import Salt.Core.Prim.Ops.Base 4 | 5 | 6 | primOpsWord8 7 | = [ PP { name = "word8'add" 8 | , tsig = [TWord8, TWord8] :-> [TWord8] 9 | , step = \[NVs [VWord8 n1, VWord8 n2]] -> [VWord8 $ n1 + n2] 10 | , docs = "Word addition." } 11 | 12 | , PP { name = "word8'sub" 13 | , tsig = [TWord8, TWord8] :-> [TWord8] 14 | , step = \[NVs [VWord8 n1, VWord8 n2]] -> [VWord8 $ n1 - n2] 15 | , docs = "Word subtraction." } 16 | 17 | , PP { name = "word8'mul" 18 | , tsig = [TWord8, TWord8] :-> [TWord8] 19 | , step = \[NVs [VWord8 n1, VWord8 n2]] -> [VWord8 $ n1 * n2] 20 | , docs = "Word multiplication." } 21 | 22 | , PP { name = "word8'div" 23 | , tsig = [TWord8, TWord8] :-> [TWord8] 24 | , step = \[NVs [VWord8 n1, VWord8 n2]] -> [VWord8 $ n1 `div` n2] 25 | , docs = "Word division." } 26 | 27 | , PP { name = "word8'rem" 28 | , tsig = [TWord8, TWord8] :-> [TWord8] 29 | , step = \[NVs [VWord8 n1, VWord8 n2]] -> [VWord8 $ n1 `rem` n2] 30 | , docs = "Word remainder." } 31 | 32 | , PP { name = "word8'eq" 33 | , tsig = [TWord8, TWord8] :-> [TBool] 34 | , step = \[NVs [VWord8 n1, VWord8 n2]] -> [VBool $ n1 == n2] 35 | , docs = "Word equality." } 36 | 37 | , PP { name = "word8'neq" 38 | , tsig = [TWord8, TWord8] :-> [TBool] 39 | , step = \[NVs [VWord8 n1, VWord8 n2]] -> [VBool $ n1 /= n2] 40 | , docs = "Word negated equality." } 41 | 42 | , PP { name = "word8'lt" 43 | , tsig = [TWord8, TWord8] :-> [TBool] 44 | , step = \[NVs [VWord8 n1, VWord8 n2]] -> [VBool $ n1 < n2] 45 | , docs = "Word less-than." } 46 | 47 | , PP { name = "word8'le" 48 | , tsig = [TWord8, TWord8] :-> [TBool] 49 | , step = \[NVs [VWord8 n1, VWord8 n2]] -> [VBool $ n1 <= n2] 50 | , docs = "Word less-than or equal." } 51 | 52 | , PP { name = "word8'gt" 53 | , tsig = [TWord8, TWord8] :-> [TBool] 54 | , step = \[NVs [VWord8 n1, VWord8 n2]] -> [VBool $ n1 > n2] 55 | , docs = "Word greater-than." } 56 | 57 | , PP { name = "word8'ge" 58 | , tsig = [TWord8, TWord8] :-> [TBool] 59 | , step = \[NVs [VWord8 n1, VWord8 n2]] -> [VBool $ n1 >= n2] 60 | , docs = "Word greater-than or equal." } 61 | ] 62 | 63 | 64 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Prim/Values.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Prim.Values where 3 | import Salt.Core.Exp 4 | 5 | 6 | -- | Take a primitive value from a name. 7 | -- This is used by the parser to decide if a primitive is an operator 8 | -- that should be applied, or is a value 9 | takePrimValueOfName :: Name -> Maybe (Value a) 10 | takePrimValueOfName (Name tx) 11 | = case tx of 12 | "unit" -> Just $ VUnit 13 | "true" -> Just $ VBool True 14 | "false" -> Just $ VBool False 15 | 16 | "bool'true" -> Just $ VBool True 17 | "bool'false" -> Just $ VBool False 18 | 19 | _ -> Nothing 20 | 21 | -------------------------------------------------------------------------------- /src/salt/Salt/Core/Transform/Snv.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Core.Transform.Snv where 3 | import Salt.Core.Transform.Ups 4 | import Salt.Core.Exp.Snv 5 | import Salt.Core.Exp 6 | import qualified Data.Map as Map 7 | 8 | 9 | -- | Apply a type substitution to a type. 10 | -- As we carry the subtitution into the tree 11 | snvApplyType :: Ups -> Snv (Type a) -> Type a -> Type a 12 | snvApplyType ups snv tt 13 | = case tt of 14 | -- Decend into annotations. 15 | TAnn a t -> TAnn a (snvApplyType ups snv t) 16 | 17 | -- Plain references don't have any variables. 18 | TRef{} -> tt 19 | 20 | -- Apply substitution to the variable. 21 | TVar u 22 | -> case snvApplyBound snv u of 23 | Left u' -> TVar u' 24 | Right t' -> upsApplyType ups t' 25 | 26 | -- Carry subsitution under binders. 27 | -- We update the ups to account for any binders that shadow 28 | -- elements of our subsitution. 29 | TAbs tps tBody 30 | -> let nsBind = [ n | (BindName n, _) <- takeTPTypes tps ] 31 | upsBind = upsOfNames nsBind 32 | ups' = upsCombine upsBind ups 33 | snv' = snvBump nsBind snv 34 | in TAbs tps $ snvApplyType ups' snv' tBody 35 | 36 | -- Apply substitution to other types generically. 37 | TKey k tgss 38 | -> TKey k $ map (snvApplyTypeArgs ups snv) tgss 39 | 40 | 41 | -- | Apply a type substitution to some type arguments. 42 | snvApplyTypeArgs :: Ups -> Snv (Type a) -> TypeArgs a -> TypeArgs a 43 | snvApplyTypeArgs ups snv tgs 44 | = case tgs of 45 | TGAnn a tgs' -> TGAnn a (snvApplyTypeArgs ups snv tgs') 46 | TGTypes ts -> TGTypes $ map (snvApplyType ups snv) ts 47 | 48 | 49 | snvOfTermEnvTypes :: TermEnv a -> Snv (Type a) 50 | snvOfTermEnvTypes (TermEnv bs) 51 | = Snv $ concatMap takeBinds bs 52 | where 53 | takeBinds (TermEnvTypes mp) 54 | = [ ((n, 0), t) | (n, t) <- Map.toList mp ] 55 | 56 | takeBinds TermEnvValues{} = [] 57 | takeBinds TermEnvValuesRec{} = [] 58 | 59 | -------------------------------------------------------------------------------- /src/salt/Salt/Data/List.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Data.List where 3 | import Data.Set as Set 4 | 5 | 6 | -- | Get the list of duplicate values in a list. 7 | duplicates :: Ord a => [a] -> [a] 8 | duplicates xx 9 | = go Set.empty Set.empty xx 10 | where 11 | go _ dups [] = Set.toList dups 12 | go acc dups (x : xs) 13 | | Set.member x acc = go acc (Set.insert x dups) xs 14 | | otherwise = go (Set.insert x acc) dups xs 15 | 16 | -------------------------------------------------------------------------------- /src/salt/Salt/Data/Location.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Data.Location 3 | ( Range (..) 4 | , Location (..) 5 | , RL, rlNone) 6 | where 7 | import Text.Lexer.Inchworm.Source 8 | 9 | type RL = Range Location 10 | rlNone = Range (Location 0 0) (Location 0 0) 11 | -------------------------------------------------------------------------------- /src/salt/Salt/LSP/Protocol.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.LSP.Protocol 3 | ( module Salt.LSP.Protocol.Base 4 | , module Salt.LSP.Protocol.Request 5 | , module Salt.LSP.Protocol.Response 6 | , module Salt.LSP.Protocol.Initialize) 7 | where 8 | import Salt.LSP.Protocol.Base 9 | import Salt.LSP.Protocol.Request 10 | import Salt.LSP.Protocol.Response 11 | import Salt.LSP.Protocol.Initialize 12 | 13 | -------------------------------------------------------------------------------- /src/salt/Salt/LSP/Protocol/Initialize.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.LSP.Protocol.Initialize where 3 | import Salt.LSP.Protocol.Base 4 | import qualified Data.List as List 5 | 6 | 7 | -- | Request from the client to initialize the server. 8 | data InitializeParams 9 | = InitializeParams 10 | { ipProcessId :: Maybe Integer 11 | , ipRootUri :: Maybe String 12 | , ipInitializationOptions :: Maybe JSValue 13 | , ipCapabilities :: [(String, JSValue)] 14 | , ipTrace :: Maybe String 15 | , ipWorkspaceFolders :: Maybe JSValue 16 | } 17 | deriving Show 18 | 19 | 20 | instance Unpack InitializeParams where 21 | unpack js 22 | = do mProcessId <- getIntegerNull =<< getField js "processId" 23 | mRootUri <- getStringNull =<< getField js "rootUri" 24 | let mInitOptions = getField js "initializationOptions" 25 | jCapabilities <- getField js "capabilities" 26 | mTrace <- maybe (Just Nothing) (fmap Just getString) $ getField js "trace" 27 | let mjWorkspaceFolders = getField js "workspaceFolders" 28 | 29 | return $ InitializeParams 30 | mProcessId mRootUri 31 | mInitOptions 32 | [ (List.intercalate "." fs, v) 33 | | (fs, v) <- flattenJSValue jCapabilities] 34 | mTrace 35 | mjWorkspaceFolders 36 | 37 | -------------------------------------------------------------------------------- /src/salt/Salt/LSP/Protocol/Request.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.LSP.Protocol.Request where 3 | import Salt.LSP.Protocol.Base 4 | 5 | 6 | -- | Client request. 7 | data Request a 8 | = Request 9 | { reqId :: JsonRpcId 10 | , reqMethod :: String 11 | , reqParams :: Maybe a } 12 | 13 | | Notification 14 | { reqMethod :: String 15 | , reqParams :: Maybe a } 16 | deriving Show 17 | 18 | 19 | instance Pack a => Pack (Request a) where 20 | pack (Request iid sMethod mxParams) 21 | = jobj [ "id" := V $ pack iid 22 | , "method" := S sMethod 23 | , "params" ?= fmap (V . pack) mxParams ] 24 | 25 | pack (Notification sMethod mxParams) 26 | = jobj [ "method" := S sMethod 27 | , "params" ?= fmap (V . pack) mxParams ] 28 | 29 | 30 | instance Unpack a => Unpack (Request a) where 31 | unpack js 32 | | Just iId <- unpack =<< getField js "id" 33 | , Just sMethod <- getString =<< getField js "method" 34 | , Just mxParams <- maybe Nothing (fmap Just unpack) $ getField js "params" 35 | = return $ Request iId sMethod mxParams 36 | 37 | | Just sMethod <- getString =<< getField js "method" 38 | , Just mxParams <- maybe Nothing (fmap Just unpack) $ getField js "params" 39 | = return $ Notification sMethod mxParams 40 | 41 | | otherwise 42 | = Nothing 43 | 44 | 45 | 46 | -------------------------------------------------------------------------------- /src/salt/Salt/LSP/Protocol/Response.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.LSP.Protocol.Response where 3 | import Salt.LSP.Protocol.Base 4 | 5 | 6 | --------------------------------------------------------------------------------------------------- 7 | data Response a 8 | = ResponseResult 9 | { rspId :: JsonRpcId 10 | , rspResult :: a } 11 | 12 | | ResponseError 13 | { rspId :: JsonRpcId 14 | , rspErrorCode :: ResponseErrorCode 15 | , rspErrorMessage :: String 16 | , rspErrorData :: Maybe JSValue } 17 | deriving Show 18 | 19 | 20 | instance Pack a => Pack (Response a) where 21 | pack (ResponseResult jid xResult) 22 | = jobj [ "id" := V $ pack jid 23 | , "result" := V $ pack xResult ] 24 | 25 | pack (ResponseError jid errCode sMsg mValue) 26 | = jobj [ "id" := V $ pack jid 27 | , "error" 28 | := O [ "code" := V $ pack errCode 29 | , "message" := V $ pack sMsg 30 | , "data" ?= fmap V mValue ]] 31 | 32 | 33 | --------------------------------------------------------------------------------------------------- 34 | data ResponseErrorCode 35 | = RecParseError -- -32700 36 | | RecInvalidRequest -- -32600 37 | | RecMethodNotFound -- -32601 38 | | RecInvalidParams -- -32602 39 | | RecInternalError -- -32606 40 | | RecServerErrorStart -- -32099 41 | | RecServerErrorEnd -- -32000 42 | | RecServerNotInitialized -- -32002 43 | | RecUnknownErrorCode -- -32001 44 | | RecRequestCancelled -- -32800 45 | deriving Show 46 | 47 | instance Pack ResponseErrorCode where 48 | pack = \case 49 | RecParseError -> pack (-32700 :: Int) 50 | RecInvalidRequest -> pack (-32600 :: Int) 51 | RecMethodNotFound -> pack (-32601 :: Int) 52 | RecInvalidParams -> pack (-32602 :: Int) 53 | RecInternalError -> pack (-32603 :: Int) 54 | RecServerErrorStart -> pack (-32099 :: Int) 55 | RecServerErrorEnd -> pack (-32000 :: Int) 56 | RecServerNotInitialized -> pack (-32002 :: Int) 57 | RecUnknownErrorCode -> pack (-32001 :: Int) 58 | RecRequestCancelled -> pack (-32800 :: Int) 59 | -------------------------------------------------------------------------------- /src/salt/Salt/LSP/State.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.LSP.State where 3 | import Salt.Core.Exp 4 | import Salt.Data.Location 5 | 6 | import Data.Map (Map) 7 | import Data.IORef 8 | import qualified System.Exit as System 9 | import qualified System.IO as System 10 | 11 | 12 | -- | Language server plugin state. 13 | data State 14 | = State 15 | { statePhase :: Phase 16 | , stateLogDebug :: Maybe (FilePath, System.Handle) 17 | 18 | -- | Checked core files. 19 | , stateCoreChecked :: IORef (Map String (Maybe (Module (Range Location)))) } 20 | 21 | 22 | -- | Phase of the LSP server protocol. 23 | data Phase 24 | -- | We have just started up and have not yet initialized with the client. 25 | = PhaseStartup 26 | 27 | -- | Initialization with the client failed. 28 | | PhaseInitFailed 29 | 30 | -- | We have initialized with the client and are now handling requests. 31 | | PhaseInitialized 32 | deriving (Eq, Show) 33 | 34 | 35 | -- | Append a messgage to the server side log file, if we have one. 36 | lspLog :: State -> String -> IO () 37 | lspLog state str 38 | | Just (_, h) <- stateLogDebug state 39 | = do System.hPutStr h (str ++ "\n") 40 | System.hFlush h 41 | 42 | | otherwise = return () 43 | 44 | 45 | -- | Append a message to the server side log file and exit the process. 46 | lspFail :: State -> String -> IO a 47 | lspFail state str 48 | = do lspLog state str 49 | System.die str 50 | -------------------------------------------------------------------------------- /src/salt/Salt/LSP/Task/Diagnostics.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.LSP.Task.Diagnostics where 3 | import Salt.LSP.Task.Diagnostics.Lexer 4 | import Salt.LSP.Task.Diagnostics.Parser 5 | import Salt.LSP.Task.Diagnostics.Checker 6 | import Salt.LSP.Task.Diagnostics.Tester 7 | import Salt.LSP.State 8 | import Salt.LSP.Protocol 9 | import Salt.LSP.Interface 10 | import qualified Salt.Core.Codec.Text.Parser as Parser 11 | import qualified Salt.Core.Codec.Text.Lexer as Lexer 12 | import qualified Salt.Core.Codec.Text.Token as Token 13 | import qualified Salt.Core.Check as Checker 14 | 15 | import Data.IORef 16 | import qualified Data.Map.Strict as Map 17 | 18 | 19 | -- | Compute diagnostics for a source file, and push them to the client. 20 | updateDiagnostics :: State -> String -> String -> IO () 21 | updateDiagnostics state sUri sSource 22 | = goLex 23 | where 24 | goLex 25 | = case Lexer.lexSource sSource of 26 | Left errs -> sendLexerErrors state sUri errs 27 | Right toks -> goParse toks 28 | 29 | goParse toks 30 | = case Parser.parseModule toks of 31 | Left errs 32 | -> sendParserDiagnostics state sUri 33 | $ map (diagnosticOfParseError toks) errs 34 | 35 | Right mm 36 | -> goCheck toks mm 37 | 38 | goCheck toks mm 39 | = Checker.checkModule (Token.rangeOfTokenList toks) mm 40 | >>= \case 41 | Left errs 42 | -> do modifyIORef' (stateCoreChecked state) 43 | $ \mp -> Map.delete sUri mp 44 | sendCheckerDiagnostics state sUri 45 | $ map diagnosticOfCheckerError errs 46 | 47 | Right (mm', ctx) 48 | -> do modifyIORef' (stateCoreChecked state) 49 | $ \mp -> Map.insert sUri (Just mm') mp 50 | goTest ctx mm' 51 | 52 | goTest ctx mm' 53 | = do diags <- buildTesterDiagnostics state ctx mm' 54 | if (not $ null diags) 55 | then sendTesterDiagnostics state sUri diags 56 | else sendClearDiagnostics state sUri 57 | 58 | 59 | 60 | -- | Clear diagnostics for the given file. 61 | -- We do this when we haven't found any problems with it. 62 | sendClearDiagnostics :: State -> String -> IO () 63 | sendClearDiagnostics state sUri 64 | = do lspLog state "* Clearing Diagnostics" 65 | lspSend state $ jobj 66 | [ "method" := S "textDocument/publishDiagnostics" 67 | , "params" := O [ "uri" := S sUri 68 | , "diagnostics" := A [] ]] 69 | -------------------------------------------------------------------------------- /src/salt/Salt/LSP/Task/Diagnostics/Base.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.LSP.Task.Diagnostics.Base where 3 | import Salt.Data.Location 4 | 5 | -- | Severity of a diagnostic. 6 | data Severity 7 | = SeverityError 8 | | SeverityWarning 9 | | SeverityInformation 10 | | SeverityHint 11 | deriving (Eq, Show) 12 | 13 | 14 | -- | Get the numeric code of a severity level. 15 | codeOfSeverity :: Severity -> Int 16 | codeOfSeverity sv 17 | = case sv of 18 | SeverityError -> 1 19 | SeverityWarning -> 2 20 | SeverityInformation -> 3 21 | SeverityHint -> 4 22 | 23 | 24 | -- | Munge a range to work with VSCode 25 | -- The ranges that Inchworm attaches to tokens are from the first character 26 | -- to the last character in the token. VSCode wants from first character 27 | -- to just after where to put the red wiggle. 28 | mungeRangeForVSCode :: Range Location -> Range Location 29 | mungeRangeForVSCode range'@(Range locStart locEnd) 30 | | Location lStart cStart <- locStart 31 | , Location lEnd cEnd <- locEnd 32 | , lStart == lEnd, cEnd - cStart > 1 33 | = Range locStart (Location lEnd (cEnd + 1)) 34 | 35 | | otherwise = range' 36 | 37 | 38 | -------------------------------------------------------------------------------- /src/salt/Salt/LSP/Task/Diagnostics/Checker.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.LSP.Task.Diagnostics.Checker where 3 | import Salt.LSP.Task.Diagnostics.Lexer 4 | import Salt.LSP.Task.Diagnostics.Base 5 | import Salt.LSP.State 6 | import Salt.LSP.Protocol 7 | import Salt.LSP.Interface 8 | import Salt.Data.Location 9 | import qualified Salt.Core.Check as Check 10 | import qualified Salt.Core.Codec.Text.Lexer as Lexer 11 | import qualified Salt.Data.Pretty as P 12 | 13 | 14 | ------------------------------------------------------------------------------------------ Types -- 15 | -- | A type checker diagnostic to send to the client. 16 | data CheckerDiagnostic 17 | = CheckerDiagnostic 18 | { checkerDiagnosticRange :: Lexer.Range Lexer.Location 19 | , checkerDiagnosticMessage :: String } 20 | deriving Show 21 | 22 | 23 | ------------------------------------------------------------------------------------------- Send -- 24 | -- | Send type checker errors to the client. 25 | sendCheckerDiagnostics :: State -> String -> [CheckerDiagnostic] -> IO () 26 | sendCheckerDiagnostics state sUri diags 27 | = do lspLog state "* Sending Checker Diagnostics" 28 | lspSend state $ jobj 29 | [ "method" := S "textDocument/publishDiagnostics" 30 | , "params" := O [ "uri" := S sUri 31 | , "diagnostics" := A (map (V . packCheckerDiagnostic) diags) ]] 32 | 33 | 34 | -- | Pack a `CheckerDiagnostic` into JSON. 35 | packCheckerDiagnostic :: CheckerDiagnostic -> JSValue 36 | packCheckerDiagnostic (CheckerDiagnostic range sMsg) 37 | = jobj [ "range" := V $ packRange range 38 | , "severity" := I 1 39 | , "source" := S "checker" 40 | , "message" := S sMsg ] 41 | 42 | 43 | ------------------------------------------------------------------------------------------ Build -- 44 | -- | Build a diagnostic from a type checker error. 45 | diagnosticOfCheckerError 46 | :: Check.Error (Range Location) -> CheckerDiagnostic 47 | diagnosticOfCheckerError err 48 | = CheckerDiagnostic range' msg 49 | where 50 | range = Check.errorAnnot err 51 | range' = mungeRangeForVSCode range 52 | msg = P.render $ P.ppr () err 53 | -------------------------------------------------------------------------------- /src/salt/Salt/LSP/Task/Diagnostics/Lexer.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.LSP.Task.Diagnostics.Lexer where 3 | import Salt.LSP.State 4 | import Salt.LSP.Protocol 5 | import Salt.LSP.Interface 6 | import Salt.Core.Codec.Text.Lexer 7 | import Data.Char 8 | 9 | 10 | -- | Send lexer errors to the client. 11 | sendLexerErrors :: State -> String -> [LexerError] -> IO () 12 | sendLexerErrors state sUri errs 13 | = do lspLog state "* Sending Lexer Errors" 14 | lspSend state $ jobj 15 | [ "method" := S "textDocument/publishDiagnostics" 16 | , "params" := O [ "uri" := S sUri 17 | , "diagnostics" := A $ map (V . packLexerError) errs ]] 18 | 19 | 20 | -- | Expand and pack a lexer error into JSON. 21 | -- 22 | -- The errors we get from a lexer will only indicate the first character 23 | -- that was not part of a valid token. In the editor window we prefer to 24 | -- report the error location from that point until the next space character 25 | -- or end of line, so they're easier to read. 26 | -- 27 | packLexerError :: LexerError -> JSValue 28 | packLexerError (LexerError nLine nColStart csRest) 29 | = jobj [ "range" := V $ packRange (Range locStart locEnd) 30 | , "severity" := I 1 31 | , "source" := S "lexer" 32 | , "message" := S "Lexical error." ] 33 | 34 | where nColEnd 35 | = expand nColStart csRest 36 | 37 | locStart = Location nLine nColStart 38 | locEnd = Location nLine nColEnd 39 | 40 | expand n [] = n 41 | expand n (c : cs) 42 | | isSpace c = n 43 | | c == '\n' = n 44 | | otherwise = expand (n + 1) cs 45 | 46 | 47 | packRange :: Range Location -> JSValue 48 | packRange (Range locFirst locFinal) 49 | = jobj [ "start" := V $ packLocation locFirst 50 | , "end" := V $ packLocation locFinal] 51 | 52 | 53 | packLocation :: Location -> JSValue 54 | packLocation (Location nLine nCol) 55 | = jobj [ "line" := J nLine 56 | , "character" := J nCol ] 57 | -------------------------------------------------------------------------------- /src/salt/Salt/Llvm/Syntax.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Llvm.Syntax 3 | ( -- * Modules 4 | Module (..) 5 | , lookupCallConv 6 | 7 | -- * Global variables 8 | , Global (..) 9 | , typeOfGlobal 10 | , varOfGlobal 11 | 12 | -- * Static data 13 | , Static (..) 14 | , typeOfStatic 15 | 16 | -- * Function declarations 17 | , FunctionDecl (..) 18 | , ParamListType (..) 19 | , Param (..) 20 | , Align (..) 21 | 22 | -- * Functions 23 | , Function (..) 24 | , Section (..) 25 | 26 | -- * Blocks 27 | , Block (..) 28 | , defVarsOfBlock 29 | 30 | -- * Block labels 31 | , Label (..) 32 | 33 | -- * Instructions 34 | , Instr (..) 35 | , branchTargetsOfInstr 36 | , defVarOfInstr 37 | 38 | -- * Metadata 39 | , Metadata (..) 40 | , MDecl (..) 41 | , MRef (..) 42 | , rval 43 | , tbaaNode 44 | 45 | -- * Expression types 46 | , Type (..) 47 | , TypeAlias (..) 48 | , isInt 49 | , isFloat 50 | , isPointer 51 | , takeBytesOfType 52 | 53 | -- * Expressions 54 | , Exp (..) 55 | , typeOfExp 56 | , isXVar, isXLit, isXUndef 57 | , isClosedExp 58 | 59 | -- * Variables 60 | , Var (..) 61 | , nameOfVar 62 | , typeOfVar 63 | 64 | -- * Names 65 | , Name (..) 66 | , textOfName 67 | 68 | -- * Literals 69 | , Lit (..) 70 | , typeOfLit 71 | , makeLitString 72 | 73 | -- * Primitive operators 74 | , Op (..) 75 | , Cond (..) 76 | , ICond (..) 77 | , FCond (..) 78 | , Conv (..) 79 | 80 | -- * Attributes 81 | , FuncAttr (..) 82 | , ParamAttr (..) 83 | , CallConv (..) 84 | , CallType (..) 85 | , Linkage (..)) 86 | where 87 | import Salt.Llvm.Syntax.Attr 88 | import Salt.Llvm.Syntax.Exp 89 | import Salt.Llvm.Syntax.Function 90 | import Salt.Llvm.Syntax.Instr 91 | import Salt.Llvm.Syntax.Metadata 92 | import Salt.Llvm.Syntax.Module 93 | import Salt.Llvm.Syntax.Prim 94 | import Salt.Llvm.Syntax.Type 95 | -------------------------------------------------------------------------------- /src/salt/Salt/Llvm/Syntax/Function.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Llvm.Syntax.Function 3 | ( Section (..) 4 | , Function (..)) 5 | where 6 | import Salt.Llvm.Syntax.Instr 7 | import Salt.Llvm.Syntax.Type 8 | import Salt.Llvm.Syntax.Attr 9 | import Data.Text (Text) 10 | 11 | 12 | -- | A LLVM Function 13 | data Function 14 | = Function 15 | { -- | The signature of this declared function. 16 | funDecl :: FunctionDecl 17 | 18 | -- | The function parameter names. 19 | , funParams :: [String] 20 | 21 | -- | The function attributes. 22 | , funAttrs :: [FuncAttr] 23 | 24 | -- | The section to put the function into, 25 | , funSection :: Section 26 | 27 | -- | The body of the functions. 28 | , funBlocks :: [Block] 29 | } 30 | 31 | 32 | -- | The section name to put the function in. 33 | data Section 34 | -- | Let the LLVM decide what section to put this in. 35 | = SectionAuto 36 | 37 | -- | Put it in this specific section. 38 | | SectionSpecific Text 39 | deriving (Eq, Show) 40 | 41 | -------------------------------------------------------------------------------- /src/salt/Salt/Llvm/Syntax/Metadata.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Llvm.Syntax.Metadata 3 | ( Metadata (..) 4 | , tbaaNode 5 | , tbaaRoot 6 | , MDecl (..) 7 | , MRef (..) 8 | , MDString (..) 9 | , MDNode (..) 10 | , MDNodeOp (..) 11 | , rval ) 12 | where 13 | import Salt.Llvm.Syntax.Type 14 | import Data.Text (Text) 15 | 16 | 17 | -- Metadata types ------------------------------------------------------------- 18 | -- | Different types of metadata used in LLVM IR 19 | -- e.g. 'debug', 'tbaa', 'range', etc. 20 | data Metadata 21 | -- Metadata used for type-based alias analysis. 22 | = Tbaa MDNode 23 | 24 | -- Metadata for debugging, here as an example only. 25 | | Debug 26 | deriving (Eq, Show) 27 | 28 | 29 | -- | Maps matadata references to metadata nodes 30 | -- e.g. !2 = !{ metadata "id", !0, !i11} 31 | data MDecl 32 | = MDecl MRef Metadata 33 | deriving (Eq, Show) 34 | 35 | 36 | -- | Reference to a metadata node. 37 | data MRef 38 | = MRef Int 39 | deriving (Eq, Show) 40 | 41 | 42 | rval :: MDecl -> Metadata 43 | rval (MDecl _ m) = m 44 | 45 | 46 | -- Metadata internal----------------------------------------------------------- 47 | -- | Primitive types of LLVM metadata 48 | data MDString 49 | = MDString Text 50 | deriving (Eq, Show) 51 | 52 | 53 | data MDNode 54 | = MDNode [MDNodeOp] 55 | deriving (Eq, Show) 56 | 57 | 58 | -- Operands to metadata nodes 59 | data MDNodeOp 60 | = OpNull 61 | | OpMDString MDString 62 | | OpMDNode MDNode 63 | | OpMDRef MRef 64 | | OpBool Bool 65 | | OpType Type 66 | deriving (Eq, Show) 67 | 68 | 69 | -- TBAA metadata -------------------------------------------------------------- 70 | -- | Construct a single tbaa node 71 | tbaaNode 72 | :: Text -- ^ A unique identifier for the node 73 | -> MRef -- ^ The parent node 74 | -> Bool -- ^ Whether this node represents a const region 75 | -> Metadata 76 | 77 | tbaaNode n pr c 78 | = Tbaa $ MDNode 79 | [ OpMDString (MDString n) 80 | , OpMDRef pr 81 | , OpBool c ] 82 | 83 | 84 | -- | Construct the tbaa root node. 85 | tbaaRoot :: Text -> Metadata 86 | tbaaRoot n 87 | = Tbaa $ MDNode 88 | [ OpMDString (MDString n) ] 89 | 90 | -------------------------------------------------------------------------------- /src/salt/Salt/Llvm/Write.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Llvm.Write 3 | ( Config (..), Version 4 | , configOfVersion 5 | , configOfHandle 6 | , module Salt.Data.Write) 7 | where 8 | import Salt.Llvm.Write.Base 9 | import Salt.Llvm.Write.Attr () 10 | import Salt.Llvm.Write.Exp () 11 | import Salt.Llvm.Write.Function () 12 | import Salt.Llvm.Write.Instr () 13 | import Salt.Llvm.Write.Metadata () 14 | import Salt.Llvm.Write.Module () 15 | import Salt.Llvm.Write.Prim () 16 | import Salt.Llvm.Write.Type () 17 | import Salt.Data.Write 18 | 19 | 20 | -------------------------------------------------------------------------------- /src/salt/Salt/Llvm/Write/Attr.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Llvm.Write.Attr where 3 | import Salt.Llvm.Syntax.Attr 4 | import Salt.Llvm.Write.Base 5 | 6 | 7 | instance Write Config FuncAttr where 8 | write o attr 9 | = case attr of 10 | AlwaysInline -> text o "alwaysinline" 11 | InlineHint -> text o "inlinehint" 12 | NoInline -> text o "noinline" 13 | OptSize -> text o "optsize" 14 | NoReturn -> text o "noreturn" 15 | NoUnwind -> text o "nounwind" 16 | ReadNone -> text o "readnon" 17 | ReadOnly -> text o "readonly" 18 | Ssp -> text o "ssp" 19 | SspReq -> text o "ssqreq" 20 | NoRedZone -> text o "noredzone" 21 | NoImplicitFloat -> text o "noimplicitfloat" 22 | Naked -> text o "naked" 23 | 24 | 25 | instance Write Config ParamAttr where 26 | write o attr 27 | = case attr of 28 | ZeroExt -> text o "zeroext" 29 | SignExt -> text o "signext" 30 | InReg -> text o "inreg" 31 | ByVal -> text o "byval" 32 | SRet -> text o "sret" 33 | NoAlias -> text o "noalias" 34 | NoCapture -> text o "nocapture" 35 | Nest -> text o "nest" 36 | 37 | 38 | instance Write Config CallConv where 39 | write o cc 40 | = case cc of 41 | Ccc -> text o "ccc" 42 | Fastcc -> text o "fastcc" 43 | Coldcc -> text o "coldcc" 44 | Ncc i -> do text o "cc "; write o i 45 | 46 | 47 | instance Write Config Linkage where 48 | write o lt 49 | = case lt of 50 | Internal -> text o "internal" 51 | LinkOnce -> text o "linkonce" 52 | Weak -> text o "weak" 53 | Appending -> text o "appending" 54 | ExternWeak -> text o "extern_weak" 55 | 56 | -- ExternallyVisible does not have a textual representation, it is 57 | -- the linkage type a function resolves to if no other is specified 58 | -- in Llvm. 59 | ExternallyVisible -> return () 60 | 61 | External -> text o "external" 62 | 63 | 64 | instance Write Config CallType where 65 | write o ct 66 | = case ct of 67 | CallTypeStd -> return () 68 | CallTypeTail -> text o "tail" 69 | 70 | -------------------------------------------------------------------------------- /src/salt/Salt/Llvm/Write/Exp.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Llvm.Write.Exp where 3 | import Salt.Llvm.Write.Type () 4 | import Salt.Llvm.Write.Prim () 5 | import Salt.Llvm.Syntax.Exp 6 | import Salt.Llvm.Write.Base 7 | 8 | 9 | instance Write Config Name where 10 | write o nn 11 | = case nn of 12 | NameGlobal str -> do text o "@"; text o str 13 | NameLocal str -> do text o "%"; text o str 14 | 15 | 16 | instance Write Config Var where 17 | write o (Var n t) 18 | = do write o t; space o; write o n 19 | 20 | 21 | instance Write Config Lit where 22 | write o ll 23 | = case ll of 24 | LitInt _ i -> write o i 25 | LitFloat _ f -> write o f 26 | LitNull _ -> text o "null" 27 | LitUndef _ -> text o "undef" 28 | 29 | LitString _ txEnc _ 30 | -> do text o "c"; dquotes o (text o txEnc) 31 | 32 | 33 | instance Write Config Exp where 34 | write o xx 35 | = case xx of 36 | XVar v -> write o (nameOfVar v) 37 | XLit l -> write o l 38 | XUndef _ -> text o "undef" 39 | -------------------------------------------------------------------------------- /src/salt/Salt/Llvm/Write/Function.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Llvm.Write.Function where 3 | import Salt.Llvm.Syntax.Function 4 | import Salt.Llvm.Syntax.Type 5 | import Salt.Llvm.Write.Type () 6 | import Salt.Llvm.Write.Attr () 7 | import Salt.Llvm.Write.Instr () 8 | import Salt.Llvm.Write.Base 9 | import Data.Text (Text) 10 | import qualified Data.Text as T 11 | 12 | 13 | instance Write Config Function where 14 | write o (Function decl nsParam attrs sec blocks) 15 | = do 16 | text o "define " 17 | writeFunctionDeclWithNames o decl (Just $ map T.pack nsParam) 18 | 19 | space o 20 | punc o " " attrs 21 | 22 | space o 23 | (case sec of 24 | SectionAuto -> return () 25 | SectionSpecific s 26 | -> do text o "section "; dquotes o (text o s)) 27 | 28 | space o; text o "{"; line o 29 | vwrite o blocks 30 | line o; text o "}"; line o 31 | 32 | 33 | writeFunctionDeclWithNames :: Config -> FunctionDecl -> Maybe [Text] -> IO () 34 | writeFunctionDeclWithNames o 35 | (FunctionDecl name linkage callConv tReturn varg params align mGcStrat) 36 | mnsParams 37 | = do 38 | write o linkage; space o 39 | write o callConv; space o 40 | write o tReturn 41 | text o " @"; text o name 42 | 43 | parens o $ do 44 | (case mnsParams of 45 | Nothing 46 | -> punc' o ", " 47 | [ do write o t 48 | (case attrs of 49 | [] -> return () 50 | as -> do space o; punc o " " as) 51 | | Param t attrs <- params ] 52 | 53 | Just nsParams 54 | -> punc' o ", " 55 | [ do write o t 56 | (case attrs of 57 | [] -> return () 58 | as -> do space o; punc o " " as) 59 | text o " %"; text o nParam 60 | | Param t attrs <- params 61 | | nParam <- nsParams ]) 62 | 63 | (case varg of 64 | VarArgs | null params -> text o "..." 65 | | otherwise -> text o ", ..." 66 | _ -> return ()) 67 | 68 | (case align of 69 | AlignNone -> return () 70 | AlignBytes b -> do text o " align "; write o b) 71 | 72 | (case mGcStrat of 73 | Nothing -> return () 74 | Just sStrat -> do text o " gc "; dquotes o (text o sStrat)) 75 | 76 | -------------------------------------------------------------------------------- /src/salt/Salt/Llvm/Write/Metadata.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Llvm.Write.Metadata where 3 | import Salt.Llvm.Syntax.Metadata 4 | import Salt.Llvm.Write.Type () 5 | import Salt.Llvm.Write.Base 6 | 7 | 8 | instance Write Config Metadata where 9 | write o mt 10 | = case mt of 11 | Debug 12 | -> text o "DEBUGMD" 13 | 14 | Tbaa (MDNode ops) 15 | -> do text o "!"; braces o (punc' o "," (map (write o) ops)) 16 | 17 | 18 | instance Write Config MDecl where 19 | write o (MDecl ref m) 20 | | configWantsMetadataAsValue o 21 | = do write o ref; text o " = metadata "; write o m 22 | 23 | | otherwise 24 | = do write o ref; text o " = "; write o m 25 | 26 | 27 | instance Write Config MDNodeOp where 28 | write o op 29 | | configWantsMetadataAsValue o 30 | = case op of 31 | OpNull -> text o "null" 32 | OpMDString ms -> do text o "metadata"; space o; write o ms 33 | OpMDNode ns -> do text o "metadata"; space o; write o ns 34 | OpMDRef r -> do text o "metadata"; space o; write o r 35 | OpBool b -> do text o "i64"; space o; text o (if b then "1" else "0") 36 | OpType t -> write o t 37 | 38 | | otherwise 39 | = case op of 40 | OpNull -> text o "null" 41 | OpMDString ms -> write o ms 42 | OpMDNode ns -> write o ns 43 | OpMDRef r -> do space o; write o r 44 | OpBool b -> do text o "i64"; space o; text o (if b then "1" else "0") 45 | OpType t -> write o t 46 | 47 | 48 | instance Write Config MDNode where 49 | write o (MDNode ns) 50 | = do text o "!"; braces o (punc' o "," (map (write o) ns)) 51 | 52 | 53 | instance Write Config MDString where 54 | write o (MDString s) 55 | = do text o "!"; dquotes o (text o s) 56 | 57 | 58 | instance Write Config MRef where 59 | write o (MRef i) 60 | = do text o "!"; write o i 61 | 62 | 63 | -------------------------------------------------------------------------------- /src/salt/Salt/Llvm/Write/Type.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Llvm.Write.Type where 3 | import Salt.Llvm.Syntax.Type 4 | import Salt.Llvm.Write.Attr () 5 | import Salt.Llvm.Write.Base 6 | 7 | 8 | instance Write Config Param where 9 | write o (Param t _attrs) 10 | = write o t 11 | 12 | 13 | instance Write Config FunctionDecl where 14 | write o (FunctionDecl n l c r vargs params a strategy) 15 | = do 16 | write o l; space o 17 | write o c; space o 18 | write o r; space o 19 | text o " @" 20 | text o n 21 | 22 | brackets o $ do 23 | punc o "," params 24 | (case vargs of 25 | VarArgs | null params -> text o "..." 26 | | otherwise -> text o ", ..." 27 | _ -> return ()) 28 | 29 | (case a of 30 | AlignNone -> return () 31 | AlignBytes a' -> text o " align " >> write o a') 32 | 33 | (case strategy of 34 | Nothing -> return () 35 | Just strat' -> text o " gc " >> dquotes o (text o strat')) 36 | 37 | 38 | instance Write Config TypeAlias where 39 | write o (TypeAlias n t) 40 | = do text o "%"; text o n; text o " = type "; write o t 41 | 42 | 43 | instance Write Config Type where 44 | write o tt 45 | = case tt of 46 | TVoid -> text o "void" 47 | TInt size -> text o "i" >> write o size 48 | TFloat -> text o "float" 49 | TDouble -> text o "double" 50 | TFloat80 -> text o "x86_fp80" 51 | TFloat128 -> text o "fp128" 52 | TLabel -> text o "label" 53 | TPointer x -> write o x >> text o "*" 54 | 55 | TStruct tys 56 | -> do text o "<{"; punc o "," tys; text o "}>" 57 | 58 | TArray nr tp 59 | -> brackets o $ do write o nr; text o " x "; write o tp 60 | 61 | TAlias (TypeAlias s _) 62 | -> do text o "%"; text o s 63 | 64 | TFunction (FunctionDecl _ _ _ r varg params _ _) 65 | -> do write o r 66 | parens o $ do 67 | punc o "," params 68 | 69 | (case varg of 70 | VarArgs | null params -> text o "..." 71 | | otherwise -> text o ", ..." 72 | _ -> return ()) 73 | 74 | -------------------------------------------------------------------------------- /src/salt/Salt/Main/Mode/Check.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Main.Mode.Check where 3 | import Salt.Main.Mode.Parse 4 | import Salt.Core.Exp 5 | import Salt.Data.Location 6 | import Salt.Data.Pretty 7 | import qualified Salt.Core.Check as Check 8 | import qualified Salt.Core.Check.Error as Error 9 | import qualified Salt.Core.Check.Where as Where 10 | import qualified Salt.Data.Pretty as P 11 | 12 | import qualified System.Exit as System 13 | 14 | 15 | -- | Check a source module and print any errors to stdout. 16 | mainCheck :: FilePath -> IO () 17 | mainCheck filePath 18 | = do mm <- runParse filePath 19 | runCheck filePath mm 20 | return () 21 | 22 | 23 | -- | Check a source module and return the resulting top-level context. 24 | runCheck :: FilePath -> Module RL -> IO (Module RL, Check.Context RL) 25 | runCheck filePath mm 26 | = do Check.checkModule rlNone mm 27 | >>= \case 28 | Right (mm', ctx) 29 | -> return (mm', ctx) 30 | Left errs 31 | -> do mapM_ (printError filePath) errs 32 | System.exitFailure 33 | 34 | printError filePath err 35 | = do let (Range (Location nLine nCol) _) 36 | = Error.errorAnnot err 37 | putStrLn 38 | $ P.render $ P.vcat 39 | $ [ P.padL 6 $ P.string filePath 40 | % P.text ":" % P.string (show (nLine + 1)) 41 | % P.text ":" % P.string (show (nCol + 1)) 42 | , P.indent 2 $ ppr () err ] 43 | 44 | ++ [ P.empty ] 45 | ++ [ let (Range (Location nLine' nCol') _) 46 | = Where.whereAnnot wh 47 | in P.indent 2 48 | $ P.padL 6 49 | ( P.string (show (nLine' + 1)) 50 | % P.text ":" % (P.string (show (nCol' + 1)))) 51 | %% P.ppr () wh 52 | | wh <- Error.errorWhere err ] 53 | 54 | ++ [P.empty] 55 | 56 | -------------------------------------------------------------------------------- /src/salt/Salt/Main/Mode/Emit.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Main.Mode.Emit where 3 | import Salt.Main.Mode.Check 4 | import Salt.Main.Mode.Parse 5 | import Salt.Core.Exp 6 | import Salt.Data.Location 7 | import qualified Salt.Core.Eval as Eval 8 | import qualified Salt.Core.Check as Check 9 | import qualified Salt.Core.Codec.Text.Pretty as P 10 | 11 | 12 | -- | Run all the emit declarations in the given source file. 13 | -- Emit declarations are the main hook when using salt as a compiler. 14 | -- We evaluate the provided term to a compiled bundle and print the result. 15 | mainEmits :: FilePath -> IO () 16 | mainEmits filePath 17 | = do mm <- runParse filePath 18 | (mm', ctx) <- runCheck filePath mm 19 | 20 | let emits = [ d | DEmit d <- moduleDecls mm' ] 21 | mapM_ (runEmit ctx mm') emits 22 | 23 | 24 | -- | Evalaute a code bundle and emit the result 25 | mainEmit :: FilePath -> Text -> IO () 26 | mainEmit filePath name 27 | = do mm <- runParse filePath 28 | (mm', ctx) <- runCheck filePath mm 29 | 30 | let emits = [ d | DEmit d <- moduleDecls mm' 31 | , declEmitName d == Just (Name name) ] 32 | 33 | case emits of 34 | [] -> error $ "mainEmit: no emit named: " ++ show name 35 | _ -> mapM_ (runEmit ctx mm') emits 36 | 37 | 38 | -- | Run a single emit declareation. 39 | runEmit :: Check.Context RL -> Module RL -> DeclEmit RL -> IO () 40 | runEmit _ctx mm (DeclEmit _ _ mEmit) 41 | = do 42 | -- Initialize the machine state. 43 | state <- Eval.newState Eval.configDefault mm 44 | 45 | -- Evaluate the term in an empty environment and print the result. 46 | vsResult <- Eval.evalTerm state rlNone (TermEnv []) mEmit 47 | case vsResult of 48 | [VBundle bundle] 49 | -> putStrLn $ P.render $ P.ppBundleGuts bundle 50 | 51 | [] -> return () 52 | _ -> putStrLn $ P.render $ P.ppr () vsResult 53 | -------------------------------------------------------------------------------- /src/salt/Salt/Main/Mode/Lex.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Main.Mode.Lex where 3 | import qualified Salt.Core.Codec.Text.Lexer as Lexer 4 | import qualified Salt.Core.Codec.Text.Token as Token 5 | 6 | import Data.Function 7 | import qualified Text.Lexer.Inchworm.Char as IW 8 | import qualified System.Exit as System 9 | 10 | 11 | -- | Lex a source module and print the result to stdout. 12 | mainLex :: FilePath -> IO () 13 | mainLex filePath 14 | = do toks <- runLex filePath 15 | putStr $ unlines $ map show toks 16 | 17 | 18 | -- | Lex a source file into tokens. 19 | runLex :: FilePath -> IO [Token.At Token.Token] 20 | runLex filePath 21 | = do source <- readFile filePath 22 | 23 | (toks, loc, strRest) 24 | <- IW.scanStringIO source Lexer.scanner 25 | 26 | let toks' = [ Token.At l k 27 | | Token.At l k <- toks 28 | , k & \case Token.KMetaComment _ -> False 29 | _ -> True] 30 | 31 | case strRest of 32 | [] -> return toks' 33 | _ -> System.die 34 | $ "lexical error at " 35 | ++ show loc 36 | ++ " " ++ show (take 10 strRest) ++ "..." 37 | -------------------------------------------------------------------------------- /src/salt/Salt/Main/Mode/Make.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Main.Mode.Make where 3 | import Salt.Main.Mode.Emit 4 | import Salt.Main.Mode.Test 5 | import Salt.Main.Mode.Check 6 | import Salt.Main.Mode.Parse 7 | import Salt.Core.Exp 8 | 9 | 10 | -- | If there is an 'emit' declaration defined then run that, 11 | -- otherwise run any contained tests. 12 | mainMake :: FilePath -> IO () 13 | mainMake filePath 14 | = do mm <- runParse filePath 15 | (mm', ctx) <- runCheck filePath mm 16 | 17 | let emits = [ d | DEmit d <- moduleDecls mm' ] 18 | let tests = [ d | DTest d <- moduleDecls mm' ] 19 | if not (null emits) 20 | then mapM_ (runEmit ctx mm') emits 21 | else mapM_ (runTest ctx mm') tests 22 | 23 | -------------------------------------------------------------------------------- /src/salt/Salt/Main/Mode/Parse.hs: -------------------------------------------------------------------------------- 1 | 2 | module Salt.Main.Mode.Parse where 3 | import Salt.Main.Mode.Lex 4 | import Salt.Core.Exp 5 | import Salt.Data.Location 6 | 7 | import qualified Salt.Core.Codec.Text.Parser as Parser 8 | import qualified Salt.Data.Pretty as P 9 | 10 | import qualified System.Exit as System 11 | import qualified Text.Show.Pretty as Show 12 | 13 | 14 | -- | Parse a source file and print the result to stdout. 15 | mainParse :: FilePath -> IO () 16 | mainParse filePath 17 | = do mm <- runParse filePath 18 | putStrLn $ Show.ppShow mm 19 | 20 | 21 | -- | Load and parse a source module. 22 | runParse :: FilePath -> IO (Module RL) 23 | runParse filePath 24 | = do toks <- runLex filePath 25 | let result = Parser.parseModule toks 26 | 27 | case result of 28 | Left errs 29 | -> do putStrLn $ P.render $ P.vcat 30 | $ map (Parser.ppParseError filePath) errs 31 | System.exitFailure 32 | 33 | Right mm -> return mm 34 | 35 | -------------------------------------------------------------------------------- /src/war/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | import War.Main.Config 3 | import War.Main.Option 4 | import BuildBox 5 | import System.Environment 6 | import System.Directory 7 | import qualified War.Task.Test as T 8 | 9 | 10 | main :: IO () 11 | main 12 | = do -- Parse command line options, and exit if they're no good. 13 | args <- getArgs 14 | config <- parseOptions args defaultConfig 15 | let Just spec = configTest config 16 | mainTest spec 17 | 18 | 19 | -- | Run tests from the provided directories 20 | mainTest :: T.Spec -> IO () 21 | mainTest spec 22 | = do tmp <- getTemporaryDirectory 23 | result <- runBuild tmp $ T.build spec 24 | case result of 25 | Left err -> error $ show err 26 | Right _ -> return () 27 | 28 | -------------------------------------------------------------------------------- /src/war/War/Driver/Chain.hs: -------------------------------------------------------------------------------- 1 | 2 | module War.Driver.Chain 3 | ( runChainWithTChan 4 | , runJobWithTChan 5 | , runChain 6 | , runJob) 7 | where 8 | import War.Driver.Base 9 | import Control.Concurrent.STM.TChan 10 | import Control.Monad.STM 11 | 12 | 13 | -- Run a chain of jobs, optionally writing the results to this channel 14 | -- after each job finishes. 15 | runChainWithTChan 16 | :: Maybe (TChan Result) 17 | -> Int 18 | -> Chain 19 | -> Build [Result] 20 | 21 | runChainWithTChan mChannel ixChain (Chain jobs) 22 | = zipWithM (runJobWithTChan mChannel ixChain) [0..] jobs 23 | 24 | 25 | -- | Run a job, optionally writing the result to this channel. 26 | runJobWithTChan 27 | :: Maybe (TChan Result) 28 | -> Int 29 | -> Int 30 | -> Job 31 | -> Build Result 32 | 33 | runJobWithTChan mChannel ixChain ixJob job 34 | = case mChannel of 35 | Nothing 36 | -> runJob ixChain ixJob job 37 | 38 | Just channel 39 | -> do result <- runJob ixChain ixJob job 40 | io $ atomically $ writeTChan channel result 41 | return result 42 | 43 | 44 | -- | Run a job chain, returning the results. 45 | runChain :: Int -- ^ Index of this chain. 46 | -> Chain -- ^ Chain of jobs to run 47 | -> Build [Result] -- ^ Job results. 48 | 49 | runChain ixChain (Chain jobs) 50 | = zipWithM (runJob ixChain) [0..] jobs 51 | 52 | 53 | -- | Run a single job, returning its result. 54 | runJob :: Int -- ^ Index of this chain. 55 | -> Int -- ^ Index of this job of the chain. 56 | -> Job -- ^ The job to run. 57 | -> Build Result 58 | 59 | runJob ixChain ixJob (Job jobId actionName spec builder) 60 | = do 61 | -- Run the job. 62 | result <- builder 63 | 64 | -- Convert the result into the product the controller wants. 65 | let product' = productOfResult spec result 66 | let jobResult = Result ixChain ixJob jobId actionName product' 67 | 68 | return jobResult 69 | 70 | -------------------------------------------------------------------------------- /src/war/War/Driver/Gang.hs: -------------------------------------------------------------------------------- 1 | 2 | module War.Driver.Gang 3 | ( forkChainsIO 4 | , runChainIO) 5 | where 6 | import War.Driver.Base 7 | import War.Driver.Chain 8 | import BuildBox.Build.BuildState 9 | import BuildBox.Control.Gang 10 | import Control.Concurrent.STM.TChan 11 | 12 | 13 | -- | Run some job chains. 14 | forkChainsIO 15 | :: Int -- ^ Number of threads to use. 16 | -> FilePath -- ^ Scratch directory. 17 | -> Maybe (TChan Result) -- ^ Channel to write job results into. 18 | -> [Chain] -- ^ Chains of jobs to sun. 19 | -> IO Gang -- ^ The gang now running the jobs. 20 | 21 | forkChainsIO numThreads dirScratch mChanResult chains 22 | = do 23 | -- Fork a gang to run all the job chains. 24 | gang <- forkGangActions numThreads 25 | $ zipWith (runChainIO dirScratch mChanResult) 26 | [1..] 27 | chains 28 | return gang 29 | 30 | 31 | -- | Run a chain of jobs in the IO monad, 32 | -- writing job results to the given channel when they finish. 33 | runChainIO 34 | :: FilePath 35 | -> Maybe (TChan Result) 36 | -> Int -> Chain -> IO () 37 | 38 | runChainIO tmpDir mChanResult ixChain chain 39 | = do let state = buildStateDefault tmpDir 40 | 41 | runBuildWithState state 42 | $ runChainWithTChan mChanResult ixChain chain 43 | 44 | return () 45 | -------------------------------------------------------------------------------- /src/war/War/Main/Config.hs: -------------------------------------------------------------------------------- 1 | 2 | module War.Main.Config where 3 | import qualified War.Task.Test as T 4 | 5 | 6 | -- | Configuration information read from command line arguments. 7 | data Config 8 | = Config 9 | { -- | Whether to emit debugging info for war. 10 | configDebug :: Bool 11 | 12 | -- | Config for test mode. 13 | , configTest :: Maybe T.Spec } 14 | deriving Show 15 | 16 | 17 | -- | Default configuration. 18 | defaultConfig :: Config 19 | defaultConfig 20 | = Config 21 | { configDebug = False 22 | , configTest = Just defaultTestSpec } 23 | 24 | 25 | -- | Default tester configuration. 26 | defaultTestSpec :: T.Spec 27 | defaultTestSpec 28 | = T.Spec 29 | { T.specTestDirs = [] 30 | , T.specWays = [] 31 | , T.specThreads = 1 32 | , T.specFormatPathWidth = 80 33 | , T.specInteractive = True 34 | , T.specResultsFileAll = Nothing 35 | , T.specResultsFileFailed = Nothing } 36 | 37 | 38 | -------------------------------------------------------------------------------- /src/war/War/Task/Create.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | Creation of test jobs. 3 | -- We decide what to do based on what files are in a directory. 4 | module War.Task.Create 5 | ( Way (..) 6 | , create) 7 | where 8 | import War.Task.Create.Way 9 | import War.Driver.Base 10 | import qualified War.Task.Create.CreateMainSH as CreateMainSH 11 | import qualified War.Task.Create.CreateMainHS as CreateMainHS 12 | import qualified War.Task.Create.CreateSalt as CreateSalt 13 | 14 | 15 | -- | Create job chains based on this file. 16 | create :: Way -- ^ Create tests for this way. 17 | -> Set FilePath -- ^ All files in the test directory. 18 | -> FilePath -- ^ Create test chains based on this file. 19 | -> [Chain] 20 | 21 | create way allFiles filePath 22 | = let creations 23 | = [ CreateMainSH.create 24 | , CreateMainHS.create 25 | , CreateSalt.create ] 26 | 27 | in catMaybes [ creat way allFiles filePath 28 | | creat <- creations] 29 | 30 | -------------------------------------------------------------------------------- /src/war/War/Task/Create/CreateMainHS.hs: -------------------------------------------------------------------------------- 1 | 2 | module War.Task.Create.CreateMainHS where 3 | import War.Task.Create.Way 4 | import War.Task.Job () 5 | import War.Driver.Base 6 | import qualified War.Task.Job.CompileHS as CompileHS 7 | import qualified War.Task.Job.RunExe as RunExe 8 | 9 | 10 | -- | Compile and run Main.hs files. 11 | -- When we run the exectuable, pass it out build dir as the first argument. 12 | create :: Way -> Set FilePath -> FilePath -> Maybe Chain 13 | create way _allFiles filePath 14 | | takeFileName filePath == "Main.hs" 15 | = let 16 | sourceDir = takeDirectory filePath 17 | buildDir = sourceDir "war-" ++ wayName way 18 | testName = filePath 19 | 20 | mainBin = buildDir "Main.bin" 21 | mainCompStdout = buildDir "Main.compile.stdout" 22 | mainCompStderr = buildDir "Main.compile.stderr" 23 | mainRunStdout = buildDir "Main.run.stdout" 24 | mainRunStderr = buildDir "Main.run.stderr" 25 | 26 | compile = jobOfSpec (JobId testName (wayName way)) 27 | $ CompileHS.Spec 28 | filePath [] 29 | buildDir mainCompStdout mainCompStderr 30 | mainBin 31 | 32 | run = jobOfSpec (JobId testName (wayName way)) 33 | $ RunExe.Spec 34 | filePath 35 | mainBin [buildDir] 36 | mainRunStdout mainRunStderr 37 | True 38 | 39 | in Just $ Chain [compile, run] 40 | 41 | | otherwise = Nothing 42 | -------------------------------------------------------------------------------- /src/war/War/Task/Create/CreateMainSH.hs: -------------------------------------------------------------------------------- 1 | 2 | module War.Task.Create.CreateMainSH where 3 | import War.Task.Create.Way 4 | import War.Task.Job () 5 | import War.Driver.Base 6 | import qualified War.Task.Job.Shell as Shell 7 | import qualified War.Task.Job.Diff as Diff 8 | import qualified Data.Set as Set 9 | 10 | 11 | -- | Run Main.sh files. 12 | create :: Way -> Set FilePath -> FilePath -> Maybe Chain 13 | create way allFiles filePath 14 | | takeFileName filePath == "Main.sh" 15 | = let 16 | sourceDir = takeDirectory filePath 17 | buildDir = sourceDir "war-" ++ wayName way 18 | testName = filePath 19 | 20 | 21 | mainShellStdout = buildDir "Main.shell.stdout" 22 | mainShellStderr = buildDir "Main.shell.stderr" 23 | mainShellStderrDiff = buildDir "Main.compile.stderr.diff" 24 | mainErrorCheck = sourceDir "Main.error.check" 25 | shouldSucceed = not $ Set.member mainErrorCheck allFiles 26 | 27 | shell = jobOfSpec (JobId testName (wayName way)) 28 | $ Shell.Spec 29 | filePath sourceDir buildDir 30 | mainShellStdout mainShellStderr 31 | shouldSucceed 32 | 33 | diffError = jobOfSpec (JobId testName (wayName way)) 34 | $ Diff.Spec 35 | mainErrorCheck 36 | mainShellStderr mainShellStderrDiff 37 | 38 | in Just $ Chain 39 | $ [shell] 40 | ++ (if shouldSucceed then [] else [diffError]) 41 | 42 | | otherwise = Nothing 43 | -------------------------------------------------------------------------------- /src/war/War/Task/Create/CreateSalt.hs: -------------------------------------------------------------------------------- 1 | 2 | module War.Task.Create.CreateSalt where 3 | import War.Task.Create.Way 4 | import War.Task.Job () 5 | import War.Driver.Base 6 | import qualified War.Task.Job.RunSalt as RunSalt 7 | import qualified War.Task.Job.Diff as Diff 8 | import qualified Data.Set as Set 9 | 10 | 11 | -- | Run .salt files with the salt interpreter. 12 | create :: Way -> Set FilePath -> FilePath -> Maybe Chain 13 | create way allFiles filePath 14 | | takeFileName filePath == "Test.salt" 15 | = let 16 | fileName = takeFileName filePath 17 | sourceDir = takeDirectory filePath 18 | buildDir = sourceDir "war-" ++ wayName way 19 | testName = filePath 20 | 21 | saltStdout = buildDir replaceExtension fileName ".salt.stdout" 22 | saltStderr = buildDir replaceExtension fileName ".salt.stderr" 23 | stdoutCheck = sourceDir "Test.salt.stdout.check" 24 | stdoutDiff = buildDir "Test.salt.stdout.diff" 25 | errorCheck = sourceDir "Test.salt.error.check" 26 | shouldSucceed = not $ Set.member errorCheck allFiles 27 | 28 | jobRun = jobOfSpec (JobId testName (wayName way)) 29 | $ RunSalt.Spec filePath buildDir 30 | saltStdout saltStderr 31 | shouldSucceed 32 | 33 | jobDiffOut = jobOfSpec (JobId testName (wayName way)) 34 | $ Diff.Spec stdoutCheck saltStdout stdoutDiff 35 | 36 | jobDiffErr = jobOfSpec (JobId testName (wayName way)) 37 | $ Diff.Spec errorCheck saltStdout stdoutDiff 38 | 39 | in Just $ Chain 40 | $ [jobRun] 41 | ++ (if Set.member stdoutCheck allFiles then [jobDiffOut] else []) 42 | ++ (if Set.member errorCheck allFiles then [jobDiffErr] else []) 43 | 44 | | otherwise = Nothing 45 | 46 | -------------------------------------------------------------------------------- /src/war/War/Task/Create/Way.hs: -------------------------------------------------------------------------------- 1 | 2 | module War.Task.Create.Way where 3 | 4 | 5 | -- | A way to build the test. 6 | -- This holds extra options to pass to the program. 7 | data Way 8 | = Way 9 | { wayName :: String 10 | , wayOptsComp :: [String] 11 | , wayOptsRun :: [String] } 12 | deriving (Eq, Ord, Show) 13 | 14 | -------------------------------------------------------------------------------- /src/war/War/Task/Job.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# OPTIONS -fno-warn-orphans #-} 3 | module War.Task.Job where 4 | import War.Driver.Base 5 | import qualified War.Task.Job.Diff as Diff 6 | import qualified War.Task.Job.CompileHS as CompileHS 7 | import qualified War.Task.Job.RunSalt as RunSalt 8 | import qualified War.Task.Job.RunExe as RunExe 9 | import qualified War.Task.Job.Shell as Shell 10 | 11 | 12 | instance Spec Diff.Spec Diff.Result where 13 | specActionName _ = "diff" 14 | buildFromSpec = Diff.build 15 | productOfResult _ result 16 | = case result of 17 | Diff.ResultSame 18 | -> ProductStatus (ppr result) True 19 | 20 | Diff.ResultDiff ref out' diff 21 | -> ProductDiff ref out' diff 22 | 23 | 24 | instance Spec CompileHS.Spec CompileHS.Result where 25 | specActionName _ = "compile" 26 | buildFromSpec = CompileHS.build 27 | productOfResult _ result 28 | = ProductStatus (ppr result) (CompileHS.resultSuccess result) 29 | 30 | 31 | instance Spec RunSalt.Spec RunSalt.Result where 32 | specActionName _ = "run" 33 | buildFromSpec = RunSalt.build 34 | productOfResult _ result 35 | = ProductStatus (ppr result) (RunSalt.resultSuccess result) 36 | 37 | 38 | instance Spec RunExe.Spec RunExe.Result where 39 | specActionName _ = "run" 40 | buildFromSpec = RunExe.build 41 | productOfResult _ result 42 | = ProductStatus (ppr result) (RunExe.resultSuccess result) 43 | 44 | 45 | instance Spec Shell.Spec Shell.Result where 46 | specActionName _ = "shell" 47 | buildFromSpec = Shell.build 48 | productOfResult _ result 49 | = ProductStatus (ppr result) (Shell.resultSuccess result) 50 | 51 | -------------------------------------------------------------------------------- /src/war/War/Task/Job/Diff.hs: -------------------------------------------------------------------------------- 1 | 2 | module War.Task.Job.Diff 3 | ( Spec (..) 4 | , Result (..) 5 | , resultSuccess 6 | , build) 7 | where 8 | import BuildBox.Command.File 9 | import BuildBox.Command.System 10 | import BuildBox.Pretty 11 | import BuildBox 12 | 13 | 14 | -- | Diff two files. 15 | data Spec 16 | = Spec 17 | { -- | The baseline file. 18 | specFile :: FilePath 19 | 20 | -- | File produced that we want to compare with the baseline. 21 | , specFileOut :: FilePath 22 | 23 | -- | Put the result of the diff here. 24 | , specFileDiff :: FilePath } 25 | deriving Show 26 | 27 | 28 | -- | Result of a diff process. 29 | data Result 30 | = ResultSame 31 | 32 | | ResultDiff 33 | { resultFileRef :: FilePath 34 | , resultFileOut :: FilePath 35 | , resultFileDiff :: FilePath } 36 | 37 | 38 | -- | Check if this is a successful diff result. 39 | resultSuccess :: Result -> Bool 40 | resultSuccess result 41 | = case result of 42 | ResultSame{} -> True 43 | _ -> False 44 | 45 | 46 | instance Pretty Result where 47 | ppr result 48 | = case result of 49 | ResultSame -> string "ok" 50 | ResultDiff{} -> string "diff" 51 | 52 | 53 | -- | Compare two files for differences. 54 | build :: Spec -> Build Result 55 | build (Spec fileRef fileOut fileDiff) 56 | = do needs fileRef 57 | needs fileOut 58 | 59 | let diffExe = "diff" 60 | 61 | -- Run the binary. 62 | (_code, strOut, _strErr) 63 | <- systemTee False 64 | (diffExe ++ " --ignore-space-change " ++ fileRef ++ " " ++ fileOut) 65 | "" 66 | 67 | -- Write its output to file. 68 | atomicWriteFile fileDiff strOut 69 | 70 | if strOut == "" 71 | then return $ ResultSame 72 | else return $ ResultDiff fileRef fileOut fileDiff 73 | 74 | -------------------------------------------------------------------------------- /src/war/War/Task/Job/RunExe.hs: -------------------------------------------------------------------------------- 1 | 2 | module War.Task.Job.RunExe 3 | ( Spec (..) 4 | , Result (..) 5 | , resultSuccess 6 | , build) 7 | where 8 | import BuildBox.Build.Benchmark 9 | import BuildBox.Command.File 10 | import BuildBox.Command.System 11 | import BuildBox.Data.Physical 12 | import BuildBox 13 | import BuildBox.Pretty 14 | import Data.List 15 | 16 | 17 | -- | Run an executable. 18 | data Spec 19 | = Spec 20 | { -- | The main source file this binary was built from. 21 | specFileSrc :: FilePath 22 | 23 | -- | Binary to run. 24 | , specFileBin :: FilePath 25 | 26 | -- | Command line arguments to pass. 27 | , specCmdArgs :: [String] 28 | 29 | -- | Put what binary said on stdout here. 30 | , specRunStdout :: FilePath 31 | 32 | -- | Put what binary said on stderr here. 33 | , specRunStderr :: FilePath 34 | 35 | -- | True if we expect the executable to succeed. 36 | , specShouldSucceed :: Bool } 37 | deriving Show 38 | 39 | 40 | data Result 41 | = ResultSuccess Seconds 42 | | ResultUnexpectedFailure 43 | | ResultUnexpectedSuccess 44 | 45 | 46 | resultSuccess :: Result -> Bool 47 | resultSuccess result 48 | = case result of 49 | ResultSuccess{} -> True 50 | _ -> False 51 | 52 | 53 | instance Pretty Result where 54 | ppr result 55 | = case result of 56 | ResultSuccess seconds 57 | -> string "success" %% parens (ppr seconds) 58 | 59 | ResultUnexpectedFailure 60 | -> string "failed" 61 | 62 | ResultUnexpectedSuccess 63 | -> string "unexpected" 64 | 65 | 66 | -- | Run a binary 67 | build :: Spec -> Build Result 68 | build (Spec _fileName 69 | mainBin args 70 | mainRunOut mainRunErr 71 | shouldSucceed) 72 | = do 73 | needs mainBin 74 | 75 | -- Run the binary. 76 | (time, (code, strOut, strErr)) 77 | <- timeBuild 78 | $ systemTee False (mainBin ++ " " ++ intercalate " " args) "" 79 | 80 | -- Write its output to files. 81 | atomicWriteFile mainRunOut strOut 82 | atomicWriteFile mainRunErr strErr 83 | 84 | case code of 85 | ExitFailure _ 86 | | shouldSucceed -> return ResultUnexpectedFailure 87 | 88 | ExitSuccess 89 | | not shouldSucceed -> return ResultUnexpectedSuccess 90 | 91 | _ -> return $ ResultSuccess time 92 | -------------------------------------------------------------------------------- /src/waves/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | import qualified Waves.Prop.Core.Exp.Codec 3 | 4 | import Control.Monad (unless) 5 | import System.IO (BufferMode(..), hSetBuffering, stdout, stderr) 6 | import System.Exit (exitFailure) 7 | 8 | all_tests :: [IO Bool] 9 | all_tests 10 | = [ Waves.Prop.Core.Exp.Codec.tests 11 | ] 12 | 13 | main :: IO () 14 | main = do 15 | hSetBuffering stdout LineBuffering 16 | hSetBuffering stderr LineBuffering 17 | 18 | results <- sequence all_tests 19 | 20 | unless (and results) $ exitFailure 21 | -------------------------------------------------------------------------------- /src/waves/Waves/Gen/Corpus.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | Strings used for generating moderately readable names and things. 3 | module Waves.Gen.Corpus where 4 | import Data.String 5 | 6 | letters :: IsString a => [a] 7 | letters = map (fromString . (:[])) ['a' .. 'z'] 8 | 9 | colours :: IsString a => [a] 10 | colours = 11 | [ "amber" 12 | , "beige" 13 | , "black" 14 | , "blue" 15 | , "brown" 16 | , "green" 17 | , "grey" 18 | , "indigo" 19 | , "navy" 20 | , "ochre" 21 | , "pink" 22 | , "purple" 23 | , "red" 24 | , "silver" 25 | , "teal" 26 | , "violet" 27 | , "white" 28 | , "yellow" 29 | ] 30 | 31 | fruits :: IsString a => [a] 32 | fruits = 33 | [ "apple" 34 | , "apricot" 35 | , "avocado" 36 | , "banana" 37 | , "cherry" 38 | , "coconut" 39 | , "fig" 40 | , "grapefruit" 41 | , "guava" 42 | , "jujube" 43 | , "kiwifruit" 44 | , "lime" 45 | , "lychee" 46 | , "mango" 47 | , "orange" 48 | , "peach" 49 | , "plum" 50 | , "quince" 51 | , "strawberry" 52 | , "watermelon" 53 | ] 54 | 55 | -------------------------------------------------------------------------------- /src/waves/Waves/Prop/Core/Codec.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | Convenience functions for testing round-trip between pretty and parse 3 | module Waves.Prop.Core.Codec where 4 | 5 | import qualified Salt.Core.Codec.Text.Lexer as Lexer 6 | -- import qualified Salt.Core.Codec.Text.Parser as Parser 7 | import qualified Salt.Core.Codec.Text.Parser.Base as PB 8 | import Salt.Core.Codec.Text.Pretty () 9 | import qualified Salt.Core.Codec.Text.Token as K 10 | import qualified Salt.Core.Transform.StripAnnot as StripAnnot 11 | import qualified Text.Parsec as Parser 12 | 13 | import qualified Salt.Data.Pretty as Pretty 14 | 15 | import qualified Text.Lexer.Inchworm.Char as IW 16 | 17 | import System.IO.Unsafe (unsafePerformIO) 18 | 19 | -- | We hope this holds: 20 | -- > dataOfText pTerm . textOfDataPlain = Right 21 | -- > dataOfText pTerm . textOfDataIndent = Right 22 | dataOfText :: StripAnnot.StripAnnot c 23 | => PB.Parser (c a) -> String -> Either (RoundtripError (c ())) (c ()) 24 | dataOfText p text = do 25 | toks <- scanner text 26 | parser (StripAnnot.stripAnnot <$> p) toks 27 | 28 | textOfData :: Pretty.Pretty () a => a -> String 29 | textOfData a = Pretty.render $ Pretty.ppr () a 30 | 31 | 32 | -- | The kinds of errors that can occur when we try to lex & parse the result of pretty-printing: 33 | data RoundtripError v 34 | = ErrorNoParse String 35 | | ErrorLexLeftover TokensNoEq String 36 | | ErrorParseLeftover v String 37 | deriving (Eq, Show) 38 | 39 | newtype TokensNoEq = Tokens [K.At K.Token] 40 | deriving Show 41 | 42 | -- Eq instance for (Either (RoundTripError _) term) is required for 43 | -- round-tripping test on (term), but the (term) is the only important bit 44 | instance Eq TokensNoEq where 45 | _ == _ = True 46 | 47 | scanner :: String -> Either (RoundtripError a) [K.At K.Token] 48 | scanner text = 49 | let -- Is there a pure lexer? 50 | (toks,_,strRest) = unsafePerformIO $ IW.scanStringIO text Lexer.scanner 51 | in case strRest of 52 | [] -> return toks 53 | _ -> Left $ ErrorLexLeftover (Tokens toks) strRest 54 | 55 | parser :: PB.Parser a -> [K.At K.Token] -> Either (RoundtripError a) a 56 | parser p toks 57 | = case Parser.runParser p 58 | (PB.State 59 | { PB.statePrev 60 | = K.At (IW.Range (IW.Location 0 0) (IW.Location 0 0)) K.KMetaStart 61 | , PB.stateOffside = [] 62 | , PB.stateInjected = []}) 63 | "" toks 64 | of 65 | Right v -> return v 66 | Left err -> Left $ ErrorNoParse (show err) 67 | -------------------------------------------------------------------------------- /src/waves/Waves/Prop/Core/Exp/Codec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Waves.Prop.Core.Exp.Codec where 4 | 5 | import qualified Waves.Gen.Core.Exp as GenX 6 | import qualified Waves.Prop.Core.Codec as Codec 7 | 8 | import qualified Salt.Core.Codec.Text.Parser.Term as Parser 9 | import qualified Salt.Core.Codec.Text.Parser.Type as Parser 10 | 11 | import Hedgehog 12 | import qualified Hedgehog.Range as Range 13 | 14 | 15 | prop_type_roundtrip_parse :: Property 16 | prop_type_roundtrip_parse = property $ do 17 | x <- forAll GenX.type_ 18 | tripping x Codec.textOfData (Codec.dataOfText Parser.pType) 19 | 20 | prop_value_roundtrip_parse :: Property 21 | prop_value_roundtrip_parse = property $ do 22 | x <- forAll GenX.valuePrimitive 23 | tripping x Codec.textOfData (Codec.dataOfText Parser.pValue) 24 | 25 | prop_string_roundtrip :: Property 26 | prop_string_roundtrip = property $ do 27 | x <- forAll $ GenX.valueText $ Range.linear 0 1000 28 | -- NOTE: This needs the latest version of inchworm on github. 29 | -- NOTE: You may need to upgrade if this fails. 30 | tripping x Codec.textOfData (Codec.dataOfText Parser.pValue) 31 | 32 | tests :: IO Bool 33 | tests = checkParallel $$(discover) 34 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.1 2 | packages: 3 | - . 4 | extra-deps: 5 | - inchworm-1.1.1.2 6 | -------------------------------------------------------------------------------- /test/00-smoke/00-poweron/Test.salt: -------------------------------------------------------------------------------- 1 | -- Power-on tests ensure the most basic things work. 2 | -- At least the lights go on.. 3 | test eval #true 4 | test eval #bool'or [#false, #true] 5 | test eval (λ[x: #Bool] → x) [#true] 6 | -------------------------------------------------------------------------------- /test/00-smoke/00-poweron/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * [#true] 2 | * [#true] 3 | * [#true] 4 | -------------------------------------------------------------------------------- /test/01-demo/10-Nat/Test.salt: -------------------------------------------------------------------------------- 1 | -- Recursive functions over natural numbers. 2 | 3 | -- Factorial 4 | term fac [x: #Nat]: #Nat 5 | = if #nat'eq x 0 6 | then 1 7 | else #nat'mul x (fac (#nat'sub x 1)) 8 | 9 | test eval fac05 = fac 5 10 | test eval fac10 = fac 10 11 | test eval fac15 = fac 15 12 | 13 | 14 | -- Fibonacci 15 | term fib [x: #Nat]: #Nat 16 | = ifs #nat'eq x 0 → 0 17 | #nat'eq x 1 → 1 18 | else #nat'add (fib (#nat'sub x 1)) (fib (#nat'sub x 2)) 19 | 20 | test eval fib'1 = fib 1 21 | test eval fib'2 = fib 2 22 | test eval fib'3 = fib 3 23 | test eval fib'15 = fib 15 24 | 25 | 26 | -- Ackermann's function. 27 | term ack [m: #Nat, n: #Nat]: #Nat 28 | = ifs #nat'eq m 0 → #nat'add n 1 29 | #nat'eq n 0 → ack (#nat'sub m 1) 1 30 | else ack (#nat'sub m 1) (ack m (#nat'sub n 1)) 31 | 32 | test eval ack'3'4 = ack 3 4 33 | 34 | 35 | -- Greatest common divisor. 36 | term gcd [x: #Nat, y: #Nat]: #Nat 37 | = ifs #nat'eq x 0 → y 38 | #nat'eq y 0 → x 39 | #nat'gt x y → gcd y (#nat'rem x y) 40 | else gcd x (#nat'rem y x) 41 | 42 | test eval gcd'100'28 = gcd 100 28 43 | 44 | 45 | -- Tak (after Ikuo Takeuchi) 46 | term tak [x: #Nat, y: #Nat, z: #Nat]: #Nat 47 | = if #nat'lt y x 48 | then tak (tak (#nat'sub x 1) y z) 49 | (tak (#nat'sub y 1) z x) 50 | (tak (#nat'sub z 1) x y) 51 | else z 52 | 53 | test eval tak'12'8'4 = tak 12 8 4 54 | -------------------------------------------------------------------------------- /test/01-demo/10-Nat/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * fac05: [120] 2 | * fac10: [3628800] 3 | * fac15: [1307674368000] 4 | * fib'1: [1] 5 | * fib'2: [1] 6 | * fib'3: [2] 7 | * fib'15: [610] 8 | * ack'3'4: [125] 9 | * gcd'100'28: [4] 10 | * tak'12'8'4: [5] 11 | -------------------------------------------------------------------------------- /test/01-demo/20-List/Test.salt: -------------------------------------------------------------------------------- 1 | -- Recursive functions over built-in lists. 2 | 3 | -- Length 4 | term length @[a: #Data] [xx: #List a]: #Nat 5 | = case #list'case @a xx of 6 | nil [] → 0 7 | cons [head: a, tail: #List a] 8 | → #nat'add 1 (length @a tail) 9 | 10 | test eval length5 11 | = length @#Nat [list #Nat| 10, 11, 12, 13, 14] 12 | 13 | 14 | -- Append 15 | term append @[a: #Data] [xx: #List a, yy: #List a]: #List a 16 | = case #list'case @a xx of 17 | nil [] → yy 18 | cons [x: a, xs: #List a] 19 | → #list'cons @a x (append @a xs yy) 20 | 21 | test eval append 22 | = append @#Nat [list #Nat| 10, 11, 12] [list #Nat| 13, 14, 15] 23 | 24 | 25 | -- Reverse 26 | term reverse @[a: #Data] [xx: #List a]: #List a 27 | = case #list'case @a xx of 28 | nil [] → [list a|] 29 | cons [x: a, xs: #List a] 30 | → append @a (reverse @a xs) (#list'one @a x) 31 | 32 | test eval reverse 33 | = reverse @#Nat [list #Nat| 10, 12, 13, 14] 34 | 35 | -------------------------------------------------------------------------------- /test/01-demo/20-List/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * length5: [5] 2 | * append: [[list #Nat| 10, 11, 12, 13, 14, 15]] 3 | * reverse: [[list #Nat| 14, 13, 12, 10]] 4 | -------------------------------------------------------------------------------- /test/01-demo/30-Console/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | -- Effectful term using let-expressions. 3 | term hello : []! #Console 4 | = box let [] = #console'print "hello " 5 | in #console'println "world" 6 | 7 | test exec hello 8 | 9 | 10 | -- Sugared version of above. 11 | term hello2 : []! #Console 12 | = box do 13 | #console'print "hello " 14 | #console'println "world" 15 | 16 | test exec hello2 17 | 18 | 19 | -------------------------------------------------------------------------------- /test/01-demo/30-Console/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | hello world 2 | hello world 3 | -------------------------------------------------------------------------------- /test/01-demo/35-Memory/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | 0 2 | 143 3 | 0 4 | 143 5 | 4 6 | 1 7 | 2 8 | 4 9 | 8 10 | 1 11 | 2 12 | 4 13 | 8 14 | 8 15 | 8 16 | 1 17 | 100 18 | 10 19 | 25 20 | 42 21 | 67 22 | -------------------------------------------------------------------------------- /test/01-demo/40-Proc/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | term derp [n: #Nat]: #Nat ! #Console 3 | = box launch #Nat of 4 | let x = 5; 5 | let y = the of `foo 4; 6 | let [] = #console'print "derp"; 7 | when (#nat'eq x 0) return 3; 8 | cell n: #Nat ← 0; 9 | loop #console'print "derp"; 10 | [3] 11 | 12 | 13 | term derps [n: #Nat]: #Nat ! #Console 14 | = box launch #Nat of do 15 | let x = 5 16 | let y = the of `foo 4 17 | seq #console'print "derp" 18 | when (#nat'eq x 0) return 3 19 | cell n: #Nat ← 0 20 | loop #console'print "derp" 21 | [n] 22 | 23 | -------------------------------------------------------------------------------- /test/01-demo/40-Proc/Test.salt.stdout.check: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/discus-lang/salt/33c14414ac7e238fdbd8161971b8b8ac67fff569/test/01-demo/40-Proc/Test.salt.stdout.check -------------------------------------------------------------------------------- /test/01-demo/50-Loops/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | 3 | -- Factorial using tail recursion. 4 | term fac1 [x: #Nat]: #Nat 5 | = if #nat'eq x 0 6 | then 1 7 | else #nat'mul x (fac1 (#nat'sub x 1)) 8 | 9 | test eval fac1 10 10 | 11 | 12 | -- Factorial using procedural loop. 13 | term fac2 [x: #Nat]: #Nat 14 | = launch #Nat of 15 | do cell n: #Nat ← x 16 | cell a: #Nat ← 1 17 | loop do 18 | when (#nat'eq n 0) break 19 | a ← #nat'mul a n 20 | n ← #nat'sub n 1 21 | end 22 | return a 23 | 24 | test eval fac2 10 25 | 26 | 27 | -- Factorial using enter/leave. 28 | -- We use a local recursive function and tail-calls to perform the loop. 29 | proc fac3 [x: #Nat]: #Nat 30 | = do cell n: #Nat ← x 31 | cell a: #Nat ← 1 32 | enter fac [] 33 | with fac []: [] = do 34 | when (#nat'eq n 0) leave 35 | a ← #nat'mul a n 36 | n ← #nat'sub n 1 37 | fac [] 38 | return a 39 | 40 | test eval fac3 10 41 | -------------------------------------------------------------------------------- /test/01-demo/50-Loops/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * [3628800] 2 | * [3628800] 3 | * [3628800] 4 | -------------------------------------------------------------------------------- /test/10-syntax/00-layout/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | -- Test offside rule handling in the parser framework. 3 | 4 | proc do'explicit []: [] ! #Console 5 | = do { #console'print "hello" 6 | ; return [] } 7 | 8 | 9 | proc do'same []: [] ! #Console 10 | = do #console'print "hello" 11 | [] 12 | 13 | 14 | proc do'next []: [] ! #Console 15 | = do 16 | #console'print "hello" 17 | [] 18 | 19 | 20 | proc do'head []: [] ! #Console = do 21 | #console'print "hello" 22 | [] 23 | 24 | 25 | proc do'nest []: []! #Console 26 | = do #console'print "good morning" 27 | do #console'print "hello" 28 | #console'print "world" 29 | 30 | 31 | proc do'nest'head []: []! #Console = do 32 | #console'print "good morning" 33 | do #console'print "hello" 34 | #console'print "world" 35 | 36 | 37 | proc when3ss [n: #Nat, m: #Nat]: #Text 38 | = do when (#nat'eq [n, 1]) do 39 | when (#nat'eq [n, 2]) do 40 | return "derp" 41 | "whatever" 42 | 43 | 44 | proc when4sss [n: #Nat, m: #Nat]: #Text 45 | = do when (#nat'eq [n, 1]) do 46 | when (#nat'eq [m, 1]) do 47 | return "one, one" 48 | when (#nat'eq [m, 2]) do 49 | return "one, two" 50 | "whatever" 51 | 52 | 53 | proc match1 [v: ]: #Nat 54 | = do match v with 55 | foo [x: #Nat] → return x 56 | bar [x: #Nat] → return x 57 | [5] 58 | -------------------------------------------------------------------------------- /test/10-syntax/00-layout/Test.salt.stdout.check: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/discus-lang/salt/33c14414ac7e238fdbd8161971b8b8ac67fff569/test/10-syntax/00-layout/Test.salt.stdout.check -------------------------------------------------------------------------------- /test/10-syntax/01-decls/Test.salt: -------------------------------------------------------------------------------- 1 | -- Test syntax of top-level declarations. 2 | 3 | -- Type decls ----------------------------------------------------------------- 4 | -- Simple type decls with no parameters. 5 | type nat1: #Data = #Nat 6 | 7 | -- Higher kinded type decls with no parameters. 8 | type some: #Data ⇒ #Data = λ[a: #Data] ⇒ [x: a, y: a] 9 | 10 | -- Higher kinded type decls with parameters, same as above. 11 | type some2 [a: #Data]: #Data = [x: a, y: a] 12 | 13 | 14 | -- Term decls ----------------------------------------------------------------- 15 | term fac [x: #Nat]: #Nat 16 | = if #nat'eq [x, 0] 17 | then 1 18 | else #nat'mul x (fac (#nat'sub x 1)) 19 | 20 | 21 | -- Test decls ----------------------------------------------------------------- 22 | -- Test kind decls. 23 | test kind #Nat 24 | test kind nat2 = #Nat 25 | 26 | 27 | -- Test type decls. 28 | test type 5 29 | test type nat3 = 5 30 | 31 | 32 | -- Test eval decls. 33 | test eval fac 6 34 | test eval fac05 = fac 5 35 | 36 | 37 | -- Test exec decls. 38 | test exec print = box #console'println "hello" 39 | test exec box #console'println "world" 40 | 41 | 42 | -- Test assert decls. 43 | test assert #true 44 | test assert #bool'and [#true, #true] 45 | 46 | -------------------------------------------------------------------------------- /test/10-syntax/01-decls/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * #Data 2 | * nat2: #Data 3 | * #Nat 4 | * nat3: #Nat 5 | * [720] 6 | * fac05: [120] 7 | print: hello 8 | world 9 | * ok 10 | * ok 11 | -------------------------------------------------------------------------------- /test/10-syntax/02-types/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * unit: #Data 2 | * bool: #Data 3 | * nat: #Data 4 | * int: #Data 5 | * text: #Data 6 | * symbol: #Data 7 | * option: [#Data] ⇒ #Data 8 | * list: [#Data] ⇒ #Data 9 | * set: [#Data] ⇒ #Data 10 | * map: [#Data, #Data] ⇒ #Data 11 | * app'option: #Data 12 | * app'list: #Data 13 | * app'set: #Data 14 | * map'nat: #Data 15 | * app'set'set: #Data 16 | * op1: [#Data, #Data] ⇒ #Data 17 | * op2: [[#Data] ⇒ #Data] ⇒ [#Data] ⇒ #Data 18 | * op3: #Data 19 | * op1'sugar: [#Data, #Data] ⇒ #Data 20 | * op2'sugar: [[#Data] ⇒ #Data] ⇒ [#Data] ⇒ #Data 21 | * op3'sugar: #Data 22 | * all1: #Data 23 | * all1'sugar: #Data 24 | * all1'region: #Data 25 | * some1: #Data 26 | * some1'sugar: #Data 27 | * some1'region: #Data 28 | * rec0: #Data 29 | * rec1: #Data 30 | * rec2: #Data 31 | * rec0'sugar1: #Data 32 | * rec1'sugar1: #Data 33 | * rec2'sugar1: #Data 34 | * rec1'sugar2: #Data 35 | * rec2'sugar2: #Data 36 | * vnt0: #Data 37 | * vnt1: #Data 38 | * vnt2: #Data 39 | * vnt0'sugar1: #Data 40 | * vnt1'sugar1: #Data 41 | * vnt2'sugar1: #Data 42 | * vnt1'sugar2: #Data 43 | * vnt2'sugar2: #Data 44 | * fun1: #Data 45 | * fun2: #Data 46 | * fun3: #Data 47 | * fun4: #Data 48 | * fun1'sugar: #Data 49 | * fun2'sugar: #Data 50 | * fun3'sugar: #Data 51 | * fun4'sugar: #Data 52 | * effect1: #Effect 53 | * effect2: #Effect 54 | * effect3: #Effect 55 | * effect4: #Effect 56 | * effect5: #Effect 57 | * effect6: #Effect 58 | * effect7: #Effect 59 | * susp1: #Comp 60 | * susp2: #Comp 61 | * susp3: #Data 62 | * susp4: #Comp 63 | * susp5: #Comp 64 | * susp6: #Comp 65 | * quoted1: [#Data] ⇒ #Data 66 | * quoted2: [#Data] ⇒ #Data 67 | * quoted3: [[#Data] ⇒ #Data] ⇒ [#Data] ⇒ #Data 68 | -------------------------------------------------------------------------------- /test/10-syntax/04-procs/Test.salt.stdout.check: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/discus-lang/salt/33c14414ac7e238fdbd8161971b8b8ac67fff569/test/10-syntax/04-procs/Test.salt.stdout.check -------------------------------------------------------------------------------- /test/11-pretty/01-types/Test.salt: -------------------------------------------------------------------------------- 1 | -- Test pretty printing of types. 2 | -- Evaluating normal form types will just print them back. 3 | 4 | test eval'type #Nat 5 | test eval'type λ[a: #Data] ⇒ a 6 | test eval'type [#Data] ⇒ [#Data] 7 | test eval'type #Map [#Nat, #Symbol] 8 | test eval'type [#Nat, #Nat] → [#Symbol] 9 | test eval'type ∀[a: #Data, b: #Data]. [a] → [b, b] 10 | test eval'type ∃[a: #Data, b: #Data]. [a] → [b, b] 11 | test eval'type [x: [#Nat, #Nat], y: [#Symbol]] 12 | test eval'type 13 | test eval'type [#Nat] ! #Console + #Sleep 14 | test eval'type sync 15 | test eval'type pure 16 | test eval'type #Console + #Sleep + pure 17 | 18 | -------------------------------------------------------------------------------- /test/11-pretty/01-types/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * #Nat 2 | * [tclo_|λ[a: #Data] → a] 3 | * [#Data] ⇒ #Data 4 | * #Map [#Nat, #Symbol] 5 | * [#Nat, #Nat] → [#Symbol] 6 | * ∀[a: #Data, b: #Data]. [#Data] → [#Data, #Data] 7 | * ∃[a: #Data, b: #Data]. [#Data] → [#Data, #Data] 8 | * ∏[x: [#Nat, #Nat], y: #Symbol] 9 | * ∑[x: [#Nat, #Nat], y: #Symbol] 10 | * [#Nat]!(#Console + #Sleep) 11 | * sync 12 | * pure 13 | * #Console + #Sleep + pure 14 | -------------------------------------------------------------------------------- /test/11-pretty/02-terms/Test.salt: -------------------------------------------------------------------------------- 1 | -- Test pretty printing of terms. 2 | -- We can display terms with redexes by boxing them. 3 | 4 | test eval box λ[x: #Nat] → x 5 | 6 | test eval box the #Nat of 3 7 | test eval box the [#Nat, #Symbol] of [3, 'foo] 8 | 9 | test eval box (λ@[a: #Data] → λ[x: a] → x) @#Nat 5 10 | 11 | test eval box let x = 2 in let y = 3 in #nat'add [2, 3] 12 | 13 | test eval box ∏[] 14 | test eval box ∏[x = 1, y = 'foo] 15 | 16 | test eval box ∏[x = 1, y = 'foo].y 17 | 18 | test eval box the of `foo [5, 'derp] 19 | 20 | test eval 21 | box λ[x: ] → 22 | case x of 23 | foo [y: #Nat, z: #Symbol] → z 24 | bar [z: #Symbol] → z 25 | 26 | test eval box λ[x: [] → [#Nat]!pure] → x [] 27 | test eval box box #nat'add [2, 3] 28 | 29 | test eval box [list #Nat| #nat'add [2, 3], #nat'add [3, 4]] 30 | test eval box [set #Nat| #nat'add [2, 3], #nat'add [3, 4]] 31 | test eval box [map #Symbol #Nat| 'five := #nat'add [2, 3], 'seven := #nat'add [3, 4]] 32 | 33 | -------------------------------------------------------------------------------- /test/11-pretty/02-terms/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * [[mclo_|λ[] → λ[x: #Nat] → x]] 2 | * [[mclo_|λ[] → the #Nat of 3 | 3]] 4 | * [[mclo_|λ[] → the [#Nat, #Symbol] of 5 | [3, 'foo]]] 6 | * [[mclo_|λ[] → (λ@[a: #Data] → λ[x: a] → x) @#Nat 5]] 7 | * [[mclo_|λ[] → let x = 2; let y = 3; #nat'add [2, 3]]] 8 | * [[mclo_|λ[] → ∏[]]] 9 | * [[mclo_|λ[] → ∏[x = 1, y = 'foo]]] 10 | * [[mclo_|λ[] → ∏[x = 1, y = 'foo].y]] 11 | * [[mclo_|λ[] → the ∑[foo: [#Nat, #Symbol]] of `foo [5, 'derp]]] 12 | * [[mclo_|λ[] → λ[x: ∑[foo: [#Nat, #Symbol], bar: #Symbol]] → case x of {foo [y: #Nat, z: #Symbol] → z; bar [z: #Symbol] → z}]] 13 | * [[mclo_|λ[] → λ[x: [] → [[#Nat]!pure]] → x []]] 14 | * [[mclo_|λ[] → box #nat'add [2, 3]]] 15 | * [[mclo_|λ[] → [list #Nat| #nat'add [2, 3], #nat'add [3, 4]]]] 16 | * [[mclo_|λ[] → [set #Nat| #nat'add [2, 3], #nat'add [3, 4]]]] 17 | * [[mclo_|λ[] → [map #Symbol #Nat| 'five := #nat'add [2, 3], 'seven := #nat'add [3, 4]]]] 18 | -------------------------------------------------------------------------------- /test/20-check/10-kind/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | -- Check type synonym lookup in kind checker. 3 | type nat: #Data = #Nat 4 | test kind nat 5 | 6 | -- (t-prm) lookup kind of primitive type. 7 | test kind #Nat 8 | 9 | -- (t-var) lookup kind of type var. 10 | test kind forall [a: #Data]. a 11 | 12 | -- (t-abs) check kind of type abstraction. 13 | test kind λ[a: #Data] ⇒ a 14 | 15 | -- (t-arr) check kind of function arrow 16 | test kind #Data ⇒ #Data 17 | 18 | -- (t-app) check kind of type application. 19 | test kind #Option #Nat 20 | 21 | -- (t-all) check kind of forall quantified type. 22 | test kind forall [a: #Data]. a → a 23 | 24 | -- (t-ext) check kind of exists quantified type. 25 | test kind exists [a: #Data]. a 26 | 27 | -- (t-fun) check kind of function type. 28 | test kind #Nat → #Nat 29 | 30 | -- (t-rec) check kind of record type. 31 | test kind ∏[x: #Nat, y: #Nat] 32 | 33 | -- (t-vnt) check kind of variant type. 34 | test kind ∑[x: #Nat, y: #Nat] 35 | 36 | -- (t-susp) check kind of suspension type. 37 | test kind #Nat ! #Console 38 | 39 | -- (t-sync) check kind of primitive 'sync' type. 40 | test kind sync 41 | 42 | -- (t-sync) check kind of primitive 'pure' type. 43 | test kind pure 44 | 45 | -- (t-sum) check kind of type sum. 46 | test kind #Console + #Memory 47 | 48 | -------------------------------------------------------------------------------- /test/20-check/10-kind/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * #Data 2 | * #Data 3 | * #Data 4 | * [#Data] ⇒ #Data 5 | * #Type 6 | * #Data 7 | * #Data 8 | * #Data 9 | * #Data 10 | * #Data 11 | * #Data 12 | * #Comp 13 | * #Effect 14 | * #Effect 15 | * #Effect 16 | -------------------------------------------------------------------------------- /test/20-check/11-type/Test.salt: -------------------------------------------------------------------------------- 1 | -- Check operation of each of the typing rules. 2 | 3 | -- (t-the) look through synonyms when checking ascribed types. 4 | type nat: #Data = #Nat 5 | test type the nat of 5 6 | 7 | 8 | -- (t-run) look through synonyms when running suspensions. 9 | type foo: #Comp = [#Nat] ! #Console + #Sleep 10 | test type λ[x: [] → foo] → box x [] 11 | 12 | 13 | -- (t-apt) look through synonyms in term/type application. 14 | type thing2thing: #Data = ∀[a: #Data]. a → a 15 | test type λ[f: thing2thing] → f @#Nat 3 16 | 17 | 18 | -- (t-apm) look through synonyms in term/terms application. 19 | type nat2nats: #Data = [#Nat, #Nat] → #Nat 20 | test type λ[f: nat2nats] → f [2, 3] 21 | 22 | -- (t-apm) check that suspensions in the result of applications 23 | -- are being automatically run. If they were not then the type 24 | -- of the result would be a double suspension. 25 | term print [x: #Text]: [] ! #Console 26 | = box #console'print x 27 | 28 | test type box print "hello" 29 | 30 | 31 | -- (t-apv) look through synonyms in term/term application. 32 | type nat2nat: #Data = #Nat → #Nat 33 | test type λ[f: nat2nat] → f 3 34 | 35 | 36 | -- (t-prj) look through synonyms when projecting fields from records. 37 | type recy: #Data = [x: #Nat, y: #Nat, z: #Nat] 38 | test type λ[r: recy] → r.x 39 | 40 | 41 | -- (t-vnt) look through synonym to see expected type of body. 42 | type vntx: #Data = 43 | test type the vntx of `foo 3 44 | 45 | 46 | -- (t-cse) look through synonym to see type of scrutinee. 47 | type vnty: #Data = 48 | test type λ[x: vnty] → case x of foo [x: #Nat] → x; bar [y: #Nat] → y 49 | 50 | -------------------------------------------------------------------------------- /test/20-check/11-type/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * nat 2 | * [[] → [foo]] → [[#Nat]!(#Console + #Sleep)] 3 | * [thing2thing] → [#Nat] 4 | * [nat2nats] → [#Nat] 5 | * []!(#Console) 6 | * [nat2nat] → [#Nat] 7 | * [recy] → [#Nat] 8 | * vntx 9 | * [vnty] → [#Nat] 10 | -------------------------------------------------------------------------------- /test/20-check/20-reduce/Test.salt: -------------------------------------------------------------------------------- 1 | -- Check type reduction. 2 | 3 | -- Check type operator reduction. 4 | type some: #Data ⇒ #Data = λ[a: #Data] ⇒ [x: a, y: a] 5 | test type λ[r: some #Nat] → r.x 6 | 7 | 8 | -- As above, but use the form with explicit parameters. 9 | -- This makes sure the parameters are attached to the decl properly. 10 | type some2 [a: #Data]: #Data = [x: a, y: a] 11 | test type λ[r: some2 #Nat] → r.x 12 | 13 | 14 | -- Multi parameter type operator. 15 | type some3 [a: #Data, b: #Data]: #Data = [x: a, y: b] 16 | test type λ[r: some3 [#Nat, #Bool]] → r.y 17 | -------------------------------------------------------------------------------- /test/20-check/20-reduce/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * [some [#Nat]] → [#Nat] 2 | * [some2 [#Nat]] → [#Nat] 3 | * [some3 [#Nat, #Bool]] → [#Bool] 4 | -------------------------------------------------------------------------------- /test/20-check/30-equiv/Test.salt: -------------------------------------------------------------------------------- 1 | -- Check type equivalence decider. 2 | 3 | -- Type equivalence checking under alpha conversion. 4 | -- The types themselves are closed, so when deciding equivalence the 5 | -- context starts out empty. 6 | test type equiv'alpha 7 | = λ[ f: ∀[a: #Data]. [a] → [a] 8 | , g: ∀[b: #Data]. [b] → [b] 9 | , b: #Bool ] 10 | → if b then f else g 11 | 12 | 13 | -- Type mentions a variable bound by a term level abstraction. 14 | -- The context for type equivalence checking must extend the context of the 15 | -- term it appears in. 16 | test type equiv'alpha'local 17 | = λ@[ a: #Data] → 18 | λ[ f: ∀[b: #Data]. [a, b] → [a, b, a] 19 | , g: ∀[c: #Data]. [a, c] → [a, c, a] 20 | , b: #Bool ] 21 | → if b then f else g 22 | 23 | 24 | -- Type equivalence where variables being compared are bumped. 25 | test type equiv'bump 26 | = λ@[a: #Data] → λ@[a: #Data] → λ[f: [a^1] → [a^1], x: a^1] → f x 27 | 28 | 29 | -- Type equivalence where the variables being compared have different bumps. 30 | -- Type mentions a variable bound by a term level abstraction. 31 | -- The context for type equivalence checking must extend the context of the 32 | -- term it appears in. 33 | test type equiv'alpha'bump 34 | = λ@[ a: #Data] → 35 | λ[ f: ∀[b: #Data]. ∀[b: #Data]. [a, b^1] → [a, b^1, b] 36 | , g: ∀[c: #Data]. ∀[d: #Data]. [a, c] → [a, c, d] 37 | , b: #Bool ] 38 | → if b then f else g 39 | 40 | 41 | -- Type equivalence where a binding shadows a synonym. 42 | type nat: #Data = #Nat 43 | test type equiv'syn'shadow 44 | = λ[ f: ∀[a: #Data]. ∀[nat: #Data]. [a] → [nat, a, nat^1] 45 | , g: ∀[b: #Data]. ∀[c: #Data]. [b] → [c, b, nat] 46 | , b: #Bool ] 47 | → if b then f else g 48 | 49 | 50 | -- Type equivalence when the type bound by a synonym is shadowed by a 51 | -- local binding. When resolving synonyms we need to lift the right hand 52 | -- sides across names used as local parameters. 53 | type bar: #Data = #Nat 54 | type foo: #Data = bar 55 | test type equiv'syn'shadow'pull 56 | = λ[ f: ∀[a: #Data]. ∀[nat: #Data]. [a] → [nat, a, nat^1] 57 | , g: ∀[b: #Data]. ∀[bar: #Data]. [b] → [bar, b, foo] 58 | , b: #Bool ] 59 | → if b then f else g 60 | 61 | 62 | -- Type equivalence where we need to reduce a type operator application. 63 | type ids [a: #Data]: #Data = [a] → [a] 64 | test type equiv'red 65 | = λ [f: ids #Nat, b: #Bool] 66 | → if b then f else λ[x: #Nat] → x 67 | 68 | 69 | 70 | -------------------------------------------------------------------------------- /test/20-check/30-equiv/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * equiv'alpha: [∀[a: #Data]. [a] → [a], ∀[b: #Data]. [b] → [b], #Bool] → [∀[a: #Data]. [a] → [a]] 2 | * equiv'alpha'local: ∀[a: #Data]. [∀[b: #Data]. [a, b] → [a, b, a], ∀[c: #Data]. [a, c] → [a, c, a], #Bool] → [∀[b: #Data]. [a, b] → [a, b, a]] 3 | * equiv'bump: ∀[a: #Data]. ∀[a: #Data]. [[a^1] → [a^1], a^1] → [a^1] 4 | * equiv'alpha'bump: ∀[a: #Data]. [∀[b: #Data]. ∀[b: #Data]. [a, b^1] → [a, b^1, b], ∀[c: #Data]. ∀[d: #Data]. [a, c] → [a, c, d], #Bool] → [∀[b: #Data]. ∀[b: #Data]. [a, b^1] → [a, b^1, b]] 5 | * equiv'syn'shadow: [∀[a: #Data]. ∀[nat: #Data]. [a] → [nat, a, nat^1], ∀[b: #Data]. ∀[c: #Data]. [b] → [c, b, nat], #Bool] → [∀[a: #Data]. ∀[nat: #Data]. [a] → [nat, a, nat^1]] 6 | * equiv'syn'shadow'pull: [∀[a: #Data]. ∀[nat: #Data]. [a] → [nat, a, nat^1], ∀[b: #Data]. ∀[bar: #Data]. [b] → [bar, b, foo], #Bool] → [∀[a: #Data]. ∀[nat: #Data]. [a] → [nat, a, nat^1]] 7 | * equiv'red: [ids [#Nat], #Bool] → [ids [#Nat]] 8 | -------------------------------------------------------------------------------- /test/20-check/40-capture/Test.salt: -------------------------------------------------------------------------------- 1 | -- Check that name capture is avoided correctly. 2 | 3 | -- Check that variable capture is avoided. 4 | -- When determining the type of 'x' in the result we need to account 5 | -- for the fact that the binder for its type variable is shadowed. 6 | test type shadow 7 | = λ@[a: #Data] → λ[x: a] → 8 | λ@[a: #Data] → λ[y: a] → 9 | [x, y] 10 | 11 | 12 | -- The type of the term variable also has a conflicting quantifier, 13 | -- which prevents the variable in the type of 'x' from being bumped. 14 | test type shadow'quant 15 | = λ@[a: #Data] → λ[x: ∀[a: #Data]. a] → 16 | λ@[a: #Data] → λ[y: a] → 17 | [x, y] 18 | 19 | 20 | -- Combination of the above two cases, 21 | -- using the explicit bump syntax to refer to an outer type variable. 22 | test type shadow'both 23 | = λ@[a: #Data] → λ[x: ∀[a: #Data]. [a] → a^1] → 24 | λ@[a: #Data] → λ[y: a] → 25 | [x, y] 26 | 27 | 28 | -- Apply the outer-most type abstraction to test we can substitute for the 29 | -- correct type variable. 30 | test type shadow'both'app 31 | = (λ@[a: #Data] → λ[x: ∀[a: #Data]. [a] → a^1] → 32 | λ@[a: #Data] → λ[y: a] → 33 | [x, y]) @#Nat 34 | 35 | -------------------------------------------------------------------------------- /test/20-check/40-capture/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * shadow: ∀[a: #Data]. [a] → [∀[a: #Data]. [a] → [a^1, a]] 2 | * shadow'quant: ∀[a: #Data]. [∀[a: #Data]. a] → [∀[a: #Data]. [a] → [∀[a: #Data]. a, a]] 3 | * shadow'both: ∀[a: #Data]. [∀[a: #Data]. [a] → [a^1]] → [∀[a: #Data]. [a] → [∀[a: #Data]. [a] → [a^2], a]] 4 | * shadow'both'app: [∀[a: #Data]. [a] → [#Nat]] → [∀[a: #Data]. [a] → [∀[a: #Data]. [a] → [#Nat], a]] 5 | -------------------------------------------------------------------------------- /test/30-error/12-check-proc/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | 3 | -- launch / return ----------------------------------------------------------- 4 | test type launch #Nat of return 5 5 | 6 | -- Error: value produced by 'return' does not match type of launch. 7 | test type launch #Nat of return #true 8 | 9 | 10 | -- cell / update ------------------------------------------------------------- 11 | test type cell a: #Nat ← 5; a ← 6; a 12 | 13 | -- Error: type of cell does not match the type it is being updated at. 14 | test type cell a: #Nat ← 5; a ← #true; a 15 | 16 | 17 | -- when ----------------------------------------------------------------------- 18 | test type launch [] of 19 | when #true return [] 20 | 21 | -- Error: scrutinee is not a boolean. 22 | test type launch [] of 23 | when 5 return [] 24 | 25 | -- Error: body yields a value. 26 | test type 27 | when #true do 5 28 | 29 | 30 | -- match ---------------------------------------------------------------------- 31 | test type launch [] of 32 | match the of `foo [5] with 33 | { foo [x: #Nat] → return []} 34 | 35 | -- Error: scrutinee type does not match alt type. 36 | test type launch [] of 37 | match the of `bar [5] with 38 | { foo [x: #Nat] → return []} 39 | 40 | -- Error: body yields a value 41 | test type 42 | match the of `foo [5] with 43 | { foo [x: #Nat] → [x]} 44 | 45 | 46 | -- loop ----------------------------------------------------------------------- 47 | test type loop #console'print "meep" 48 | 49 | -- Error: body yields a value. 50 | test type loop [5] 51 | 52 | test type loop break 53 | 54 | -- Error: break appears outside the scope of a loop 55 | test type break 56 | 57 | test type loop continue 58 | 59 | -- Error: continue appears outside the scope of a loop 60 | test type continue -------------------------------------------------------------------------------- /test/30-error/12-check-proc/Test.salt.error.check: -------------------------------------------------------------------------------- 1 | test/30-error/12-check-proc/Test.salt:7:26 2 | Actual type '#Bool' 3 | does not match 4 | expected type '#Nat' 5 | 6 | 7:11 In test 7 | 8 | test/30-error/12-check-proc/Test.salt:14:29 9 | Actual type '#Bool' 10 | does not match 11 | expected type '#Nat' 12 | 13 | 14:11 In test 14 | 15 | test/30-error/12-check-proc/Test.salt:23:2 16 | Actual type '#Nat' 17 | does not match 18 | expected type '#Bool' 19 | 20 | 22:11 In test 21 | 22 | test/30-error/12-check-proc/Test.salt:27:2 23 | Too many terms. 24 | Actual type '#Nat' 25 | Expected types [] 26 | 27 | 27:2 In test 28 | 29 | test/30-error/12-check-proc/Test.salt:37:2 30 | Alternative 'foo' is not in scrutinee type. 31 | '∑[bar: #Nat]' 32 | 33 | 36:11 In test 34 | 35 | test/30-error/12-check-proc/Test.salt:43:21 36 | Too many terms. 37 | Actual type '#Nat' 38 | Expected types [] 39 | 40 | 42:2 In test 41 | 42 | test/30-error/12-check-proc/Test.salt:50:11 43 | Too many terms. 44 | Actual type '#Nat' 45 | Expected types [] 46 | 47 | 50:11 In test 48 | 49 | test/30-error/12-check-proc/Test.salt:55:11 50 | break statement does not have an enclosing loop 51 | 52 | 55:11 In test 53 | 54 | test/30-error/12-check-proc/Test.salt:60:11 55 | continue statement does not have an enclosing loop 56 | 57 | 60:11 In test 58 | 59 | -------------------------------------------------------------------------------- /test/30-error/20-check-type-sigs/Test.salt: -------------------------------------------------------------------------------- 1 | -- Trigger all the errors that can be produced by 2 | -- 'goTypeSigs' when checking the top-level module structure. 3 | 4 | -- Error: Malformed kind annotation on type synonym parameter. 5 | type decl1 [a: #Derp]: #Data = #Nat 6 | 7 | -- Error: Malformed kind annotation on type synonym result. 8 | type decl2 [a: #Data]: #Derp = #Nat 9 | 10 | -- Error: Type synonym has duplicate parameters. 11 | type decl3 [a: #Data, a: #Data]: #Data = #Nat 12 | 13 | -- Error: Synonym is rebound. 14 | type decl4: #Data = #Nat 15 | type decl4: #Data = #Nat 16 | 17 | -- Error: Synonym is directly recursive. 18 | type decl5: #Data = decl5 19 | 20 | -- Error: Synonym is indirectly recursive. 21 | type decl6: #Data = decl7 22 | type decl7: #Data = [x: decl6, y: #Nat] 23 | 24 | -- Error: Synonym is indirectly recursive. 25 | type decl8: #Data = decl9 26 | type decl9: #Data = [x: decl10, y: #Nat] 27 | type decl10: #Data = [x: decl8, y: #Nat] 28 | -------------------------------------------------------------------------------- /test/30-error/20-check-type-sigs/Test.salt.error.check: -------------------------------------------------------------------------------- 1 | test/30-error/20-check-type-sigs/Test.salt:5:16 2 | Unknown kind primitive '#Derp' 3 | 4 | 5:6 In type declaration "decl1" 5 | 6 | test/30-error/20-check-type-sigs/Test.salt:8:24 7 | Unknown kind primitive '#Derp' 8 | 9 | 8:6 In type declaration "decl2" 10 | 11 | test/30-error/20-check-type-sigs/Test.salt:11:12 12 | Conflicting type binders for 'a' 13 | 14 | 11:6 In type declaration "decl3" 15 | 16 | test/30-error/20-check-type-sigs/Test.salt:14:6 17 | Rebound type name 'decl4' 18 | 19 | 14:6 In type declaration "decl4" 20 | 21 | test/30-error/20-check-type-sigs/Test.salt:15:6 22 | Rebound type name 'decl4' 23 | 24 | 15:6 In type declaration "decl4" 25 | 26 | test/30-error/20-check-type-sigs/Test.salt:18:6 27 | Recursive type declaration 'decl5' 28 | Involving 'decl5' 29 | 30 | 18:6 In type declaration "decl5" 31 | 32 | test/30-error/20-check-type-sigs/Test.salt:21:6 33 | Recursive type declaration 'decl6' 34 | Involving 'decl7' 35 | 36 | 21:6 In type declaration "decl6" 37 | 38 | test/30-error/20-check-type-sigs/Test.salt:22:6 39 | Recursive type declaration 'decl7' 40 | Involving 'decl6' 41 | 42 | 22:6 In type declaration "decl7" 43 | 44 | test/30-error/20-check-type-sigs/Test.salt:25:6 45 | Recursive type declaration 'decl8' 46 | Involving 'decl9' 47 | 48 | 25:6 In type declaration "decl8" 49 | 50 | test/30-error/20-check-type-sigs/Test.salt:26:6 51 | Recursive type declaration 'decl9' 52 | Involving 'decl10' 53 | 54 | 26:6 In type declaration "decl9" 55 | 56 | test/30-error/20-check-type-sigs/Test.salt:27:6 57 | Recursive type declaration 'decl10' 58 | Involving 'decl8' 59 | 60 | 27:6 In type declaration "decl10" 61 | 62 | -------------------------------------------------------------------------------- /test/30-error/21-check-type-decls/Test.salt: -------------------------------------------------------------------------------- 1 | -- Error: Out of scope variable in type synonym. 2 | type syn4: #Data = a 3 | 4 | -------------------------------------------------------------------------------- /test/30-error/21-check-type-decls/Test.salt.error.check: -------------------------------------------------------------------------------- 1 | test/30-error/21-check-type-decls/Test.salt:2:20 2 | Unknown type name 'a' 3 | 4 | 2:6 In type declaration "syn4" 5 | 6 | -------------------------------------------------------------------------------- /test/30-error/30-check-term-sigs/Test.salt: -------------------------------------------------------------------------------- 1 | -- Trigger all the errors that can be produced by 2 | -- 'goTermSigs' when checking the top-level module structure. 3 | 4 | -- Error: Malformed type annotations on term declaration. 5 | term term1 [x: #Derp]: #Nat = 5 6 | 7 | -- Error: Malformed result type. 8 | term term2 [x: #Nat]: #Derp = 5 9 | 10 | -- Error: Term declaration has duplicate parameters. 11 | term term3 [x: #Nat, x: #Nat]: #Nat = x 12 | 13 | -- Error: Term declaration is rebound 14 | term term4: #Nat = 1 15 | term term4: #Nat = 2 16 | 17 | -- Error: Term declaration does not produce a value. 18 | term term5 @[a: #Data]: [] = [] 19 | test type term5 = term5 20 | 21 | -- Error: Term declaration does not bind a value. 22 | term term6: [] = [] 23 | 24 | -- Error: Malformed type annotations on proc declaration. 25 | proc proc1 [x: #Derp]: #Nat = 5 26 | 27 | -- Error: Malformed result type. 28 | proc proc2 [x: #Nat]: #Derp = 5 29 | 30 | -- Error: Proc declaration has duplicate parameters. 31 | proc proc3 [x: #Nat, x: #Nat]: #Nat = x 32 | 33 | -- Error: Proc declaration is rebound 34 | proc proc4 []: #Nat = 1 35 | proc proc4 []: #Nat = 2 36 | 37 | -- Error: Proc declaration does not produce a value. 38 | proc proc5 @[a: #Data]: [] = [] 39 | test type term5 = term5 40 | 41 | -- Error: Proc declaration does not have parameters. 42 | proc proc6: #Nat = 5 43 | -------------------------------------------------------------------------------- /test/30-error/30-check-term-sigs/Test.salt.error.check: -------------------------------------------------------------------------------- 1 | test/30-error/30-check-term-sigs/Test.salt:5:16 2 | Unknown type primitive '#Derp' 3 | 4 | 5:6 In term declaration "term1" 5 | 6 | test/30-error/30-check-term-sigs/Test.salt:8:23 7 | Unknown type primitive '#Derp' 8 | 9 | 8:6 In term declaration "term2" 10 | 11 | test/30-error/30-check-term-sigs/Test.salt:11:12 12 | Conflicting term binders for 'x' 13 | 14 | 11:6 In term declaration "term3" 15 | 16 | test/30-error/30-check-term-sigs/Test.salt:25:16 17 | Unknown type primitive '#Derp' 18 | 19 | 25:6 In term declaration "proc1" 20 | 21 | test/30-error/30-check-term-sigs/Test.salt:28:23 22 | Unknown type primitive '#Derp' 23 | 24 | 28:6 In term declaration "proc2" 25 | 26 | test/30-error/30-check-term-sigs/Test.salt:31:12 27 | Conflicting term binders for 'x' 28 | 29 | 31:6 In term declaration "proc3" 30 | 31 | test/30-error/30-check-term-sigs/Test.salt:14:6 32 | Rebound term name 'term4' 33 | 34 | 14:6 In term declaration "term4" 35 | 36 | test/30-error/30-check-term-sigs/Test.salt:15:6 37 | Rebound term name 'term4' 38 | 39 | 15:6 In term declaration "term4" 40 | 41 | test/30-error/30-check-term-sigs/Test.salt:34:6 42 | Rebound term name 'proc4' 43 | 44 | 34:6 In term declaration "proc4" 45 | 46 | test/30-error/30-check-term-sigs/Test.salt:35:6 47 | Rebound term name 'proc4' 48 | 49 | 35:6 In term declaration "proc4" 50 | 51 | test/30-error/30-check-term-sigs/Test.salt:18:6 52 | Polymorphic term abstraction does not produce a value. 53 | Parameters [@[a: #Data]] 54 | 55 | 18:6 In term declaration "term5" 56 | 57 | test/30-error/30-check-term-sigs/Test.salt:22:6 58 | Empty term declaration 'term6' 59 | 60 | 22:6 In term declaration "term6" 61 | 62 | test/30-error/30-check-term-sigs/Test.salt:38:6 63 | Polymorphic term abstraction does not produce a value. 64 | Parameters [@[a: #Data]] 65 | 66 | 38:6 In term declaration "proc5" 67 | 68 | test/30-error/30-check-term-sigs/Test.salt:42:6 69 | Proc declaration 'proc6' has no parameters 70 | 71 | 42:6 In term declaration "proc6" 72 | 73 | -------------------------------------------------------------------------------- /test/30-error/31-check-term-decls/Test.salt: -------------------------------------------------------------------------------- 1 | -- Trigger all the errors that can be produced by 2 | -- 'goTermDecls' when checking the top-level module structure. 3 | 4 | -- Error: Term declaration body does not have same type as result annotation. 5 | term term1: #Nat = #true 6 | 7 | -- Error: Term declaration causes an unboxed effect. 8 | term term2: #Nat 9 | = do { #console'print "hello" 10 | ; 5 } 11 | 12 | -------------------------------------------------------------------------------- /test/30-error/31-check-term-decls/Test.salt.error.check: -------------------------------------------------------------------------------- 1 | test/30-error/31-check-term-decls/Test.salt:5:6 2 | Actual type '#Bool' 3 | does not match 4 | expected type '#Nat' 5 | 6 | 5:6 In term declaration "term1" 7 | 8 | test/30-error/31-check-term-decls/Test.salt:8:6 9 | Impure term declaration 'term2' 10 | has effect '#Console' 11 | 12 | 8:6 In term declaration "term2" 13 | 14 | -------------------------------------------------------------------------------- /test/30-error/40-check-test-sigs/Test.salt: -------------------------------------------------------------------------------- 1 | -- Trigger all the errors that can be produced by 2 | -- 'goTestSigs' when checking the top-level module structure. 3 | 4 | -- Error: Test declaration is rebound 5 | test type test1 = 1 6 | test type test1 = 2 7 | -------------------------------------------------------------------------------- /test/30-error/40-check-test-sigs/Test.salt.error.check: -------------------------------------------------------------------------------- 1 | test/30-error/40-check-test-sigs/Test.salt:5:11 2 | Rebound test 'test1' 3 | 4 | 5:11 In test "test1" 5 | 6 | test/30-error/40-check-test-sigs/Test.salt:6:11 7 | Rebound test 'test1' 8 | 9 | 6:11 In test "test1" 10 | 11 | -------------------------------------------------------------------------------- /test/30-error/41-check-test-decls/Test.salt: -------------------------------------------------------------------------------- 1 | -- Trigger all the errors that can be produced by 2 | -- 'goTestDecls' when checking the top-level module structure. 3 | 4 | -- Error: term to evaluate is not pure. 5 | test eval test1 = #console'print "hello" 6 | 7 | -- Error: term to assert is not pure 8 | test assert test4 9 | = do { #console'print "hello" 10 | ; #true } 11 | 12 | -------------------------------------------------------------------------------- /test/30-error/41-check-test-decls/Test.salt.error.check: -------------------------------------------------------------------------------- 1 | test/30-error/41-check-test-decls/Test.salt:5:11 2 | Impure test declaration 'test1' 3 | has effect '#Console' 4 | 5 | 5:11 In test "test1" 6 | 7 | test/30-error/41-check-test-decls/Test.salt:8:13 8 | Impure test declaration 'test4' 9 | has effect '#Console' 10 | 11 | 8:13 In test "test4" 12 | 13 | -------------------------------------------------------------------------------- /test/40-eval/01-bumps/Test.salt: -------------------------------------------------------------------------------- 1 | -- Check evaluator handles variable bumps correctly. 2 | 3 | -- Use bumps to refer to vars in the environment. 4 | term add [x: #Nat] [x: #Nat]: #Nat 5 | = #nat'add [x^0, x^1] 6 | test eval add = add 2 3 7 | 8 | 9 | -- Use bumps to refer to vars at top level, recursively. 10 | term derp [derp: #Nat]: #Nat 11 | = if #nat'eq [derp, 0] 12 | then 0 13 | else derp^1 (#nat'sub [derp, 1]) 14 | 15 | test eval derp = derp 4 16 | 17 | 18 | -- Ack function with even more ack. 19 | -- There's an ack at every level.. 20 | term ack [ack: #Nat] [ack: #Nat]: #Nat 21 | = ifs #nat'eq [ack^1, 0] → #nat'add [ack^0, 1] 22 | #nat'eq [ack^0, 0] → ack^2 (#nat'sub [ack^1, 1]) 1 23 | else → ack^2 (#nat'sub [ack^1, 1]) 24 | (ack^2 ack^1 (#nat'sub [ack^0, 1])) 25 | 26 | test eval ack'2'3 = ack 2 3 27 | -------------------------------------------------------------------------------- /test/40-eval/01-bumps/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * add: [5] 2 | * derp: [0] 3 | * ack'2'3: [9] 4 | -------------------------------------------------------------------------------- /test/40-eval/10-type/Test.salt: -------------------------------------------------------------------------------- 1 | -- Exercise all the cases in the type evaluator. 2 | 3 | -- (evt-var-decl) ----------------------------------------- 4 | type nat: #Data = #Nat 5 | test eval'type evt'decl = nat 6 | 7 | -- (evt-abs) ---------------------------------------------- 8 | test eval'type evt'abs 9 | = λ[a: #Data] ⇒ a 10 | 11 | -- (evt-arr) ---------------------------------------------- 12 | test eval'type evt'arr 13 | = #Data ⇒ #Data 14 | 15 | -- (evt-app) ---------------------------------------------- 16 | type op [a: #Data]: #Data = #List a 17 | test eval'type evt'app 18 | = op [#Nat] 19 | 20 | -- (evt-fun) ---------------------------------------------- 21 | test eval'type evt'fun 22 | = [nat, nat] → nat 23 | 24 | -- (evt-all) ---------------------------------------------- 25 | test eval'type evt'all 26 | = ∀[a: #Data]. [a] → nat 27 | 28 | -- (evt-ext) ---------------------------------------------- 29 | test eval'type evt'ext 30 | = ∃[a: #Data]. [a] → nat 31 | 32 | -- (evt-rec) ---------------------------------------------- 33 | test eval'type evt'rec 34 | = [x: nat, y: [nat, nat]] 35 | 36 | -- (evt-vnt) ---------------------------------------------- 37 | test eval'type evt'vnt 38 | = 39 | 40 | -- (evt-susp) --------------------------------------------- 41 | test eval'type evt'susp 42 | = [nat] ! #Console 43 | 44 | -- (evt-pure) --------------------------------------------- 45 | test eval'type evt'pure 46 | = pure 47 | 48 | -- (evt-sync) --------------------------------------------- 49 | test eval'type evt'sync 50 | = sync 51 | 52 | -- (evt-sum) ---------------------------------------------- 53 | type eff: #Effect = #Console 54 | test eval'type evt'sym 55 | = eff + pure 56 | 57 | 58 | -------------------------------------------------------------------------------- /test/40-eval/10-type/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * evt'decl: #Nat 2 | * evt'abs: [tclo_|λ[a: #Data] → a] 3 | * evt'arr: [#Data] ⇒ #Data 4 | * evt'app: #List [#Nat] 5 | * evt'fun: [#Nat, #Nat] → [#Nat] 6 | * evt'all: ∀[a: #Data]. [#Data] → [#Nat] 7 | * evt'ext: ∃[a: #Data]. [#Data] → [#Nat] 8 | * evt'rec: ∏[x: #Nat, y: [#Nat, #Nat]] 9 | * evt'vnt: ∑[x: #Nat, y: [#Nat, #Nat]] 10 | * evt'susp: [#Nat]!#Console 11 | * evt'pure: pure 12 | * evt'sync: sync 13 | * evt'sym: #Console + pure 14 | -------------------------------------------------------------------------------- /test/40-eval/20-term/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * evm'mmm'multi: [5,5] 2 | * evm'var'clo: [[mclo|[menv|@[a = #Nat]], λ[x: a] → the a of 3 | x]] 4 | * evm'abs'type: [[mclo|[menv|@[a = #Nat]], λ[y: a] → y]] 5 | * evm'abs'term: [[mclo|[menv|[x = 5]], λ[y: #Nat] → x]] 6 | * evm'aps'prim: [5] 7 | * evm'aps'prim2: [[list #Nat| ]] 8 | * evm'aps'term'term: [10] 9 | * evm'aps'term'terms: [5] 10 | * evm'aps'term'type: [[mclo|[menv|@[a = #Nat]], λ[x: a] → x]] 11 | * evm'aps'bump1: [2] 12 | * evm'let: [5] 13 | * evm'rec: [16] 14 | * evm'rcd: [[x = [5,5], y = [9,9]]] 15 | * evm'prj: [5,5] 16 | * evm'vnt: [the ∑[foo: [#Nat, #Bool]] of `foo [2, #true]] 17 | * evm'case: [5] 18 | * evm'box: [[mclo_|λ[] → #console'print "hello"]] 19 | * evm'run: [5] 20 | * evm'list: [[list #Nat| 5, 5]] 21 | * evm'set: [[set #Nat| 5, 6]] 22 | * evm'map: [[map #Nat #Symbol| 5 := 'Derp]] 23 | * region'private'nat: [1] 24 | * region'private'effect: [18] 25 | * region'extend'nat: [1] 26 | * region'extend'effect: [17] 27 | * pack'useful: [[pack [x = [5], f = [[mclo_|λ[n: #Nat] → n]]] with [#Nat] as ∃[a: #Data]. ∏[x: #Data, f: [#Data] → [#Nat]]]] 28 | * pack'multiple: [[pack [x = [6], f = [[mclo_|λ[n: #Nat] → n]], y = ["hello world"], g = [[mclo_|λ[n: #Text] → n]]] with [#Nat, #Text] as ∃[a: #Data, b: #Data]. ∏[x: #Data, f: [#Data] → [#Nat], y: #Data, g: [#Data] → [#Text]]]] 29 | * unpack'pack: [5] 30 | * unpack'multiple: [6] 31 | -------------------------------------------------------------------------------- /test/40-eval/30-prims/01-bool/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | test assert bool'not1 = #bool'not [#false] 3 | test assert bool'not2 = #bool'not [#bool'not [#true]] 4 | test assert bool'and1 = #bool'and [#true, #true] 5 | test assert bool'and2 = #bool'and [#bool'not [#false], #true] 6 | test assert bool'or1 = #bool'or [#false, #true] 7 | test assert bool'or2 = #bool'or [#true, #false] 8 | test assert bool'eq1 = #bool'eq [#true, #true] 9 | test assert bool'eq2 = #bool'eq [#false, #false] 10 | -------------------------------------------------------------------------------- /test/40-eval/30-prims/01-bool/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * bool'not1: ok 2 | * bool'not2: ok 3 | * bool'and1: ok 4 | * bool'and2: ok 5 | * bool'or1: ok 6 | * bool'or2: ok 7 | * bool'eq1: ok 8 | * bool'eq2: ok 9 | -------------------------------------------------------------------------------- /test/40-eval/30-prims/02-nat/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | test assert nat'eq1 = #nat'eq [1, 1] 3 | test assert nat'eq2 = #nat'eq [#nat'1, #nat'1] 4 | test assert nat'eq3 = #bool'not [#nat'eq [1, 2]] 5 | test assert nat'neq = #nat'neq [1, 2] 6 | test assert nat'add = #nat'eq [3, #nat'add [1, 2]] 7 | test assert nat'sub = #nat'eq [3, #nat'sub [7, 4]] 8 | test assert nat'mul = #nat'eq [8, #nat'mul [2, 4]] 9 | test assert nat'lt1 = #nat'lt [4, 5] 10 | test assert nat'lt2 = #bool'not [#nat'lt [4, 4]] 11 | test assert nat'le = #nat'le [4, 4] 12 | test assert nat'gt1 = #nat'gt [10, 8] 13 | test assert nat'gt2 = #bool'not [#nat'gt [4, 4]] 14 | test assert nat'ge = #nat'ge [4, 4] 15 | 16 | -------------------------------------------------------------------------------- /test/40-eval/30-prims/02-nat/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * nat'eq1: ok 2 | * nat'eq2: ok 3 | * nat'eq3: ok 4 | * nat'neq: ok 5 | * nat'add: ok 6 | * nat'sub: ok 7 | * nat'mul: ok 8 | * nat'lt1: ok 9 | * nat'lt2: ok 10 | * nat'le: ok 11 | * nat'gt1: ok 12 | * nat'gt2: ok 13 | * nat'ge: ok 14 | -------------------------------------------------------------------------------- /test/40-eval/30-prims/03-int/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * int'eq1: ok 2 | * int'eq2: ok 3 | * int'neq: ok 4 | * int'add: ok 5 | * int'sub: ok 6 | * int'mul: ok 7 | * int'lt1: ok 8 | * int'lt2: ok 9 | * int'le: ok 10 | * int'gt1: ok 11 | * int'gt2: ok 12 | * int'ge: ok 13 | * int8'eq1: ok 14 | * int8'eq2: ok 15 | * int8'neq: ok 16 | * int8'add: ok 17 | * int8'sub: ok 18 | * int8'mul: ok 19 | * int8'lt1: ok 20 | * int8'lt2: ok 21 | * int8'le: ok 22 | * int8'gt1: ok 23 | * int8'gt2: ok 24 | * int8'ge: ok 25 | * int16'eq1: ok 26 | * int16'eq2: ok 27 | * int16'neq: ok 28 | * int16'add: ok 29 | * int16'sub: ok 30 | * int16'mul: ok 31 | * int16'lt1: ok 32 | * int16'lt2: ok 33 | * int16'le: ok 34 | * int16'gt1: ok 35 | * int16'gt2: ok 36 | * int16'ge: ok 37 | * int32'eq1: ok 38 | * int32'eq2: ok 39 | * int32'neq: ok 40 | * int32'add: ok 41 | * int32'sub: ok 42 | * int32'mul: ok 43 | * int32'lt1: ok 44 | * int32'lt2: ok 45 | * int32'le: ok 46 | * int32'gt1: ok 47 | * int32'gt2: ok 48 | * int32'ge: ok 49 | * int64'eq1: ok 50 | * int64'eq2: ok 51 | * int64'neq: ok 52 | * int64'add: ok 53 | * int64'sub: ok 54 | * int64'mul: ok 55 | * int64'lt1: ok 56 | * int64'lt2: ok 57 | * int64'le: ok 58 | * int64'gt1: ok 59 | * int64'gt2: ok 60 | * int64'ge: ok 61 | -------------------------------------------------------------------------------- /test/40-eval/30-prims/04-word/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * word'eq1: ok 2 | * word'eq2: ok 3 | * word'neq: ok 4 | * word'add: ok 5 | * word'sub: ok 6 | * word'mul: ok 7 | * word'lt1: ok 8 | * word'lt2: ok 9 | * word'le: ok 10 | * word'gt1: ok 11 | * word'gt2: ok 12 | * word'ge: ok 13 | * word8'eq1: ok 14 | * word8'eq2: ok 15 | * word8'neq: ok 16 | * word8'add: ok 17 | * word8'sub: ok 18 | * word8'mul: ok 19 | * word8'lt1: ok 20 | * word8'lt2: ok 21 | * word8'le: ok 22 | * word8'gt1: ok 23 | * word8'gt2: ok 24 | * word8'ge: ok 25 | * word16'eq1: ok 26 | * word16'eq2: ok 27 | * word16'neq: ok 28 | * word16'add: ok 29 | * word16'sub: ok 30 | * word16'mul: ok 31 | * word16'lt1: ok 32 | * word16'lt2: ok 33 | * word16'le: ok 34 | * word16'gt1: ok 35 | * word16'gt2: ok 36 | * word16'ge: ok 37 | * word32'eq1: ok 38 | * word32'eq2: ok 39 | * word32'neq: ok 40 | * word32'add: ok 41 | * word32'sub: ok 42 | * word32'mul: ok 43 | * word32'lt1: ok 44 | * word32'lt2: ok 45 | * word32'le: ok 46 | * word32'gt1: ok 47 | * word32'gt2: ok 48 | * word32'ge: ok 49 | * word64'eq1: ok 50 | * word64'eq2: ok 51 | * word64'neq: ok 52 | * word64'add: ok 53 | * word64'sub: ok 54 | * word64'mul: ok 55 | * word64'lt1: ok 56 | * word64'lt2: ok 57 | * word64'le: ok 58 | * word64'gt1: ok 59 | * word64'gt2: ok 60 | * word64'ge: ok 61 | -------------------------------------------------------------------------------- /test/40-eval/30-prims/10-symbol/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | -- Symbol primitives 3 | test assert symbol'eq1 = #symbol'eq ['foo, 'foo] 4 | test assert symbol'eq2 = #bool'not [#symbol'eq ['foo, 'bar]] 5 | -------------------------------------------------------------------------------- /test/40-eval/30-prims/10-symbol/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * symbol'eq1: ok 2 | * symbol'eq2: ok 3 | -------------------------------------------------------------------------------- /test/40-eval/30-prims/20-list/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | test eval list'empty = #list'empty @#Nat 3 | test eval list'nil = #list'nil @#Nat 4 | test eval list'one = #list'one @#Nat 5 5 | test eval list'cons = #list'cons @#Nat [2, #list'one @#Nat 3] 6 | test eval list'isEmpty = #list'isEmpty @#Nat (#list'empty @#Nat) 7 | test eval list'size = #list'size @#Nat [list #Nat| 2, 3, 4] 8 | test eval list'head = #list'head @#Nat [list #Nat| 2, 3, 4] 9 | test eval list'tail = #list'tail @#Nat [list #Nat| 2, 3, 4] 10 | test eval list'case = #list'case @#Nat [list #Nat| 2, 3, 4] 11 | 12 | -------------------------------------------------------------------------------- /test/40-eval/30-prims/20-list/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * list'empty: [[list #Nat| ]] 2 | * list'nil: [[list #Nat| ]] 3 | * list'one: [[list #Nat| 5]] 4 | * list'cons: [[list #Nat| 2, 3]] 5 | * list'isEmpty: [#true] 6 | * list'size: [3] 7 | * list'head: [Some #Nat 2] 8 | * list'tail: [Some #Nat [list #Nat| 3, 4]] 9 | * list'case: [the ∑[nil: [], cons: [#Nat, #List [#Nat]]] of `cons [2, [list #Nat| 3, 4]]] 10 | -------------------------------------------------------------------------------- /test/40-eval/30-prims/21-set/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | test eval set'empty = #set'empty @#Nat 3 | test eval set'fromList = #set'fromList @#Nat [list #Nat| 3, 4, 4, 5, 5, 5] 4 | test eval set'isEmpty = #set'isEmpty @#Nat [set #Nat|] 5 | test eval set'size = #set'size @#Nat [set #Nat| 3, 4, 4, 5, 6] 6 | test eval set'hasElem = #set'hasElem @#Nat [5, [set #Nat| 3, 4, 5, 6]] 7 | test eval set'insert = #set'insert @#Nat [4, [set #Nat| 2, 5]] 8 | test eval set'delete = #set'delete @#Nat [4, [set #Nat| 3, 4, 5]] 9 | -------------------------------------------------------------------------------- /test/40-eval/30-prims/21-set/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * set'empty: [[set #Nat| ]] 2 | * set'fromList: [[set #Nat| 3, 4, 5]] 3 | * set'isEmpty: [#true] 4 | * set'size: [4] 5 | * set'hasElem: [#true] 6 | * set'insert: [[set #Nat| 2, 4, 5]] 7 | * set'delete: [[set #Nat| 3, 5]] 8 | -------------------------------------------------------------------------------- /test/40-eval/30-prims/22-map/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | test eval map'empty = #map'empty @[#Nat, #Symbol] 3 | test eval map'isEmpty = #map'isEmpty @[#Nat, #Symbol] [map #Nat #Symbol|] 4 | 5 | test eval map'size 6 | = #map'size @[#Nat, #Symbol] 7 | [map #Nat #Symbol| 4 := 'four, 3 := 'five] 8 | 9 | test eval map'insert 10 | = #map'insert @[#Nat, #Symbol] 11 | [ 3 12 | , 'three 13 | , [map #Nat #Symbol| 2 := 'two, 4 := 'four]] 14 | 15 | test eval map'delete 16 | = #map'delete @[#Nat, #Symbol] 17 | [ 3 18 | , [map #Nat #Symbol| 2 := 'two, 3 := 'three, 4 := 'four]] 19 | 20 | test eval map'lookup 21 | = #map'lookup @[#Nat, #Symbol] 22 | [ 3 23 | , [map #Nat #Symbol| 2 := 'two, 3 := 'three, 4 := 'four] ] 24 | -------------------------------------------------------------------------------- /test/40-eval/30-prims/22-map/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * map'empty: [[map #Nat #Symbol| ]] 2 | * map'isEmpty: [#true] 3 | * map'size: [2] 4 | * map'insert: [[map #Nat #Symbol| 2 := 'two, 3 := 'three, 4 := 'four]] 5 | * map'delete: [[map #Nat #Symbol| 2 := 'two, 4 := 'four]] 6 | * map'lookup: [Some #Symbol 'three] 7 | -------------------------------------------------------------------------------- /test/40-eval/30-prims/40-memory/Test.salt: -------------------------------------------------------------------------------- 1 | test eval sizeOf'bool = #sizeOf @[#Bool] 2 | 3 | test eval sizeOf'int8 = #sizeOf @[#Int8] 4 | test eval sizeOf'int16 = #sizeOf @[#Int16] 5 | test eval sizeOf'int32 = #sizeOf @[#Int32] 6 | test eval sizeOf'int64 = #sizeOf @[#Int64] 7 | 8 | test eval sizeOf'word8 = #sizeOf @[#Word8] 9 | test eval sizeOf'word16 = #sizeOf @[#Word16] 10 | test eval sizeOf'word32 = #sizeOf @[#Word32] 11 | test eval sizeOf'word64 = #sizeOf @[#Word64] 12 | 13 | test eval sizeOf'addr = #sizeOf @[#Addr] 14 | 15 | test eval sizeOf'ptr 16 | = private r with {} in #sizeOf @[#Ptr [r, #Word8]] 17 | 18 | test type castPtr 19 | = private r with {} in do 20 | p1 = #allocPtr @[r, #Word8] 21 | p2 = #castPtr @[r, #Word8, #Bool] p1 22 | #freePtr @[r, #Bool] p2 23 | 24 | test type castPtrRegion 25 | = private r1 with {} in 26 | private r2 with {} in do 27 | p1 = #allocPtr @[r1, #Word8] 28 | p2 = #castPtrRegion @[r1, r2, #Word8] p1 29 | #writePtr @[r2, #Word8] [p2, #word8'16] 30 | #freePtr @[r2, #Word8] p2 31 | -------------------------------------------------------------------------------- /test/40-eval/30-prims/40-memory/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * sizeOf'bool: [4] 2 | * sizeOf'int8: [1] 3 | * sizeOf'int16: [2] 4 | * sizeOf'int32: [4] 5 | * sizeOf'int64: [8] 6 | * sizeOf'word8: [1] 7 | * sizeOf'word16: [2] 8 | * sizeOf'word32: [4] 9 | * sizeOf'word64: [8] 10 | * sizeOf'addr: [8] 11 | * sizeOf'ptr: [8] 12 | * castPtr: [] 13 | * castPtrRegion: [] 14 | -------------------------------------------------------------------------------- /test/40-eval/40-proc/20-call/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | proc add [x:#Nat, y: #Nat]: #Nat 3 | = #nat'add [x, y] 4 | 5 | test eval add 2 3 6 | 7 | 8 | -------------------------------------------------------------------------------- /test/40-eval/40-proc/20-call/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * [5] 2 | -------------------------------------------------------------------------------- /test/40-eval/40-proc/30-return/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | -- Launch and direct return. 3 | test eval launch #Nat of 4 | return 5 5 | 6 | 7 | -- Return from deeper within a procedure. 8 | test eval launch #Nat of 9 | do when #false return 2 10 | when #true return 3 11 | return 5 12 | 13 | 14 | -- Local use of launch/return in a functional expression. 15 | test eval #nat'add (launch #Nat of return 2) 3 16 | 17 | -------------------------------------------------------------------------------- /test/40-eval/40-proc/30-return/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * [5] 2 | * [3] 3 | * [5] 4 | -------------------------------------------------------------------------------- /test/40-eval/40-proc/40-cell/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | 3 | -- Simple cell init and read. 4 | test eval do 5 | cell x: #Nat ← 2 6 | x 7 | 8 | 9 | -- Cell update. 10 | test eval do 11 | cell x: #Nat ← 2 12 | x ← 3 13 | x 14 | 15 | 16 | -- Shadowed cell names. 17 | test eval do 18 | cell x: #Nat ← 5 19 | cell x: #Nat ← 6 20 | x 21 | 22 | 23 | -- Update of cell that shadows another. 24 | test eval do 25 | cell x: #Nat ← 5 26 | cell x: #Nat ← 6 27 | x ← 7 28 | x 29 | -------------------------------------------------------------------------------- /test/40-eval/40-proc/40-cell/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * [2] 2 | * [3] 3 | * [6] 4 | * [7] 5 | -------------------------------------------------------------------------------- /test/40-eval/40-proc/50-loop/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | 3 | -- Factorial using procedural loop. 4 | test eval launch #Nat of 5 | do cell n: #Nat ← 10 6 | cell x: #Nat ← 1 7 | loop do 8 | when (#nat'eq n 0) break 9 | x ← #nat'mul x n 10 | n ← #nat'sub n 1 11 | return x 12 | 13 | 14 | -- Draw a square, using loop syntax. 15 | proc square []: []! #Console 16 | = do cell x: #Nat ← 9 17 | loop do 18 | when (#nat'eq x 0) break 19 | x ← #nat'sub x 1 20 | cell y: #Nat ← 9 21 | loop do 22 | when (#nat'eq y 0) break 23 | y ← #nat'sub y 1 24 | #console'print "o" 25 | #console'print "\n" 26 | #console'print "\n" 27 | 28 | test exec square [] 29 | 30 | 31 | -- Draw a square, using while syntax. 32 | proc square2 []: []! #Console 33 | = do cell x: #Nat ← 9 34 | while (#nat'gt x 0) do 35 | x ← #nat'sub x 1 36 | cell y: #Nat ← 9 37 | while (#nat'gt y 0) do 38 | y ← #nat'sub y 1 39 | #console'print "x" 40 | #console'print "\n" 41 | #console'print "\n" 42 | 43 | test exec square2 [] 44 | 45 | 46 | -- Draw a square, using enter-leave syntax. 47 | proc square3 []: []! #Console 48 | = do cell x: #Nat ← 9 49 | cell y: #Nat ← 9 50 | enter go [] with 51 | go []: [] 52 | = do when (#nat'eq y 0) leave 53 | 54 | when (#nat'eq x 0) do 55 | y ← #nat'sub y 1 56 | x ← 9 57 | #console'print "\n" 58 | go [] 59 | 60 | #console'print "o" 61 | x ← #nat'sub x 1 62 | go [] 63 | #console'print "\n" 64 | 65 | test exec square3 [] -------------------------------------------------------------------------------- /test/40-eval/40-proc/50-loop/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | * [3628800] 2 | ooooooooo 3 | ooooooooo 4 | ooooooooo 5 | ooooooooo 6 | ooooooooo 7 | ooooooooo 8 | ooooooooo 9 | ooooooooo 10 | ooooooooo 11 | 12 | xxxxxxxxx 13 | xxxxxxxxx 14 | xxxxxxxxx 15 | xxxxxxxxx 16 | xxxxxxxxx 17 | xxxxxxxxx 18 | xxxxxxxxx 19 | xxxxxxxxx 20 | xxxxxxxxx 21 | 22 | ooooooooo 23 | ooooooooo 24 | ooooooooo 25 | ooooooooo 26 | ooooooooo 27 | ooooooooo 28 | ooooooooo 29 | ooooooooo 30 | ooooooooo 31 | 32 | -------------------------------------------------------------------------------- /test/50-reify/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | 3 | -- term print @[a: #Data] [x: a]: [] !#Console 4 | -- = box #console'println (#reify'pretty @a x) 5 | 6 | term derp [x: #Nat]: #Bool 7 | = #nat'eq x 0 8 | 9 | term fac [x: #Nat]: #Nat 10 | = launch #Nat of 11 | do cell n: #Nat ← x 12 | cell a: #Nat ← 1 13 | loop do 14 | when (#nat'eq n 0) break 15 | a ← #nat'mul a n 16 | n ← #nat'sub n 1 17 | end 18 | return a 19 | 20 | 21 | emit #bundle'new 22 | [set #Symbol|] 23 | [set #Symbol| 'fac] 24 | 25 | -------------------------------------------------------------------------------- /test/50-reify/Test.salt.stdout.check: -------------------------------------------------------------------------------- 1 | term fac [x: #Nat]: [#Nat] 2 | = launch [#Nat] of 3 | cell n: #Nat ← x; 4 | cell a: #Nat ← 1; 5 | loop (when (#nat'eq [n, 0]) break; 6 | update a ← #nat'mul [a, n]; 7 | update n ← #nat'sub [n, 1]; 8 | []); 9 | return a 10 | -------------------------------------------------------------------------------- /test/80-docs/01-grammar/Test.salt: -------------------------------------------------------------------------------- 1 | 2 | -- Examples from docs/01-grammar.md 3 | 4 | -- Draw a square. 5 | proc square1 []: []! #Console 6 | = cell x: #Nat ← 9 7 | ; while (#nat'gt [x, 0]) 8 | ( cell y: #Nat ← 9 9 | ; while (#nat'gt [y, 0]) 10 | ( seq #console'print "*" 11 | ; update y ← #nat'sub [y, 1] 12 | ; end) 13 | ; seq #console'print "\n" 14 | ; update x ← #nat'sub [x, 1] 15 | ; end) 16 | ; #console'println "done" 17 | 18 | test exec square1 [] 19 | 20 | 21 | proc square2 []: []! #Console 22 | = do { cell x: #Nat ← 9 23 | ; while (#nat'gt [x, 0]) 24 | do { cell y: #Nat ← 9 25 | ; while (#nat'gt [y, 0]) 26 | do { #console'print "*" 27 | ; y ← #nat'sub [y, 1] } 28 | ; #console'print "\n" 29 | ; x ← #nat'sub [x, 1] } 30 | ; #console'println "done" } 31 | 32 | test exec square2 [] 33 | 34 | 35 | proc square3 []: []! #Console 36 | = do cell x: #Nat ← 9 37 | while (#nat'gt [x, 0]) do 38 | cell y: #Nat ← 9 39 | while (#nat'gt [y, 0]) do 40 | #console'print "*" 41 | y ← #nat'sub [y, 1] 42 | #console'print "\n" 43 | x ← #nat'sub [x, 1] 44 | #console'println "done" 45 | 46 | 47 | test exec square3 [] --------------------------------------------------------------------------------