├── .github └── workflows │ ├── ci-macos.yml │ └── ci-ubuntu.yml ├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── config.mk ├── idris2-lua.ipkg ├── src ├── LuaAst.idr ├── LuaCommon.idr ├── LuaGen.idr └── OrderDefs.idr ├── support └── lua │ ├── idris2-lua-scm-0.rockspec │ ├── idris2-lua.lua │ └── lib.c └── tests ├── Main.idr ├── Makefile ├── chez ├── chez001 │ ├── Total.idr │ ├── expected │ ├── input │ └── run ├── chez002 │ ├── Pythag.idr │ ├── expected │ ├── input │ └── run ├── chez003 │ ├── IORef.idr │ ├── expected │ ├── input │ └── run ├── chez004 │ ├── Buffer.idr │ ├── expected │ ├── input │ └── run ├── chez005 │ ├── Filter.idr │ ├── expected │ ├── input │ └── run ├── chez006 │ ├── TypeCase.idr │ ├── TypeCase2.idr │ ├── expected │ ├── input │ └── run ├── chez007 │ ├── TypeCase.idr │ ├── expected │ ├── input │ └── run ├── chez008 │ ├── Nat.idr │ ├── expected │ ├── input │ └── run ├── chez009 │ ├── expected │ ├── input │ ├── run │ └── uni.idr ├── chez010 │ ├── .gitignore │ ├── CB.idr │ ├── Makefile │ ├── cblib.c │ ├── expected │ ├── input │ └── run ├── chez011 │ ├── bangs.idr │ ├── expected │ ├── input │ └── run ├── chez012 │ ├── array.idr │ ├── expected │ ├── input │ └── run ├── chez013 │ ├── .gitignore │ ├── Makefile │ ├── Struct.idr │ ├── expected │ ├── input │ ├── run │ ├── struct.c │ └── struct.h ├── chez014 │ ├── Echo.idr │ ├── expected │ ├── input │ └── run ├── chez015 │ ├── Numbers.idr │ ├── expected │ ├── input │ └── run ├── chez016 │ ├── expected │ ├── folder with spaces │ │ └── Main.idr │ ├── input │ └── run ├── chez017 │ ├── .gitignore │ ├── dir.idr │ ├── expected.in │ ├── gen_expected.sh │ ├── input │ └── run ├── chez018 │ ├── File.idr │ ├── expected │ ├── input │ ├── run │ └── test.txt ├── chez019 │ ├── expected │ ├── input │ ├── partial.idr │ └── run ├── chez020 │ ├── Popen.idr │ ├── expected │ ├── input │ └── run ├── chez021 │ ├── Bits.idr │ ├── expected │ ├── input │ └── run ├── chez022 │ ├── Makefile │ ├── expected │ ├── input │ ├── mkalloc.c │ ├── mkalloc.d │ ├── run │ └── usealloc.idr ├── chez023 │ ├── File.idr │ ├── expected │ ├── input │ └── run ├── chez024 │ ├── Envy.idr │ ├── expected │ ├── input │ └── run ├── chez025 │ ├── expected │ ├── input │ ├── run │ └── runst.idr ├── chez026 │ ├── Dummy.idr │ ├── dummy.ipkg │ ├── expected │ └── run ├── chez027 │ ├── StringParser.idr │ ├── expected │ ├── input │ └── run ├── chez028 │ ├── ExpressionParser.idr │ ├── expected │ ├── input │ └── run ├── chez029 │ ├── BitCasts.idr │ ├── expected │ ├── input │ └── run └── reg001 │ ├── expected │ ├── numbers.idr │ └── run ├── lua ├── lua001 │ ├── Foreign.idr │ ├── expected │ ├── extra.lua │ ├── input │ └── run ├── lua002 │ ├── Foreign.idr │ ├── expected │ ├── input │ └── run ├── lua003 │ ├── Test.idr │ ├── expected │ ├── input │ └── run ├── lua004 │ ├── Test.idr │ ├── data.txt │ ├── data4.txt │ ├── expected │ ├── input │ └── run └── lua005 │ ├── Test.idr │ ├── expected │ ├── input │ └── run └── tests.ipkg /.github/workflows/ci-macos.yml: -------------------------------------------------------------------------------- 1 | name: macOS 2 | on: 3 | push: 4 | branches: 5 | - '*' 6 | tags: 7 | - '*' 8 | pull_request: 9 | branches: 10 | - master 11 | env: 12 | SCHEME: chez 13 | IDRIS2_TESTS_CG: chez 14 | IDRIS2_COMMIT: "96c44abb64ce1ccf5daa6b2eb5ad3d2e86d80001" 15 | 16 | jobs: 17 | build: 18 | runs-on: macos-latest 19 | steps: 20 | - name: Checkout 21 | uses: actions/checkout@v2 22 | - name: Install build dependencies 23 | run: | 24 | brew install chezscheme 25 | brew install coreutils 26 | brew install luarocks 27 | brew install lua@5.1 28 | luarocks install luautf8 --lua-version=5.1 --local 29 | luarocks install bigint --lua-version=5.1 --local 30 | luarocks install luafilesystem --lua-version=5.1 --local 31 | luarocks install vstruct --lua-version=5.1 --local 32 | luarocks install bit32 --lua-version=5.1 --local 33 | luarocks install inspect --lua-version=5.1 --local 34 | echo "$HOME/.idris2/bin" >> $GITHUB_PATH 35 | - name: Install Idris 2 36 | run: | 37 | git clone https://github.com/idris-lang/Idris2 38 | cd Idris2 39 | git reset --hard ${{ env.IDRIS2_COMMIT }} 40 | make bootstrap && make install 41 | make clean && make all && make install && make install-api 42 | cd .. 43 | - name: Build and test the backend 44 | run: eval $(luarocks path --lua-version=5.1) && LuaVersion=5.1 LuaExe=lua5.1 make all INTERACTIVE='' 45 | shell: bash 46 | -------------------------------------------------------------------------------- /.github/workflows/ci-ubuntu.yml: -------------------------------------------------------------------------------- 1 | name: Ubuntu 2 | on: 3 | push: 4 | branches: 5 | - '*' 6 | tags: 7 | - '*' 8 | pull_request: 9 | branches: 10 | - master 11 | 12 | env: 13 | SCHEME: scheme 14 | IDRIS2_TESTS_CG: chez 15 | IDRIS2_COMMIT: "96c44abb64ce1ccf5daa6b2eb5ad3d2e86d80001" 16 | 17 | jobs: 18 | build: 19 | runs-on: ubuntu-latest 20 | steps: 21 | - name: Checkout 22 | uses: actions/checkout@v2 23 | - name: Install build dependencies 24 | run: | 25 | sudo apt-get install -y chezscheme 26 | sudo apt-get install -y lua5.1 27 | sudo apt-get install -y liblua5.1-dev 28 | sudo apt-get install -y luarocks 29 | luarocks install luautf8 --lua-version=5.1 --local 30 | luarocks install bigint --lua-version=5.1 --local LD='clang -lstdc++' 31 | luarocks install luafilesystem --lua-version=5.1 --local 32 | luarocks install vstruct --lua-version=5.1 --local 33 | luarocks install bit32 --lua-version=5.1 --local 34 | luarocks install inspect --lua-version=5.1 --local 35 | echo "$HOME/.idris2/bin" >> $GITHUB_PATH 36 | - name: Install Idris 2 37 | run: | 38 | git clone https://github.com/idris-lang/Idris2 39 | cd Idris2 40 | git reset --hard ${{ env.IDRIS2_COMMIT }} 41 | make bootstrap && make install 42 | make clean && make all && make install && make install-api 43 | cd .. 44 | - name: Build and test the backend 45 | run: eval $(luarocks path --lua-version=5.1) && LuaVersion=5.1 LuaExe=lua5.1 make all INTERACTIVE='' 46 | shell: bash 47 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | idris2docs_venv 2 | *~ 3 | *.ibc 4 | *.ttc 5 | *.ttm 6 | *.o 7 | *.d 8 | *.a 9 | *.dll 10 | 11 | # Editor/IDE Related 12 | .\#* # Emacs swap file 13 | *~ # Vim swap file 14 | # VS Code 15 | .vscode/* 16 | 17 | /build 18 | 19 | /libs/**/build 20 | 21 | /tests/**/build 22 | /tests/**/output 23 | /tests/**/*.so 24 | /tests/**/*.dylib 25 | /tests/**/*.dll 26 | /tests/build/exec 27 | 28 | /support/lua/*.so 29 | 30 | .DS_Store 31 | 32 | /custom.mk 33 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Ruslan Feizerahmanov 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WIH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE.T 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | include config.mk 2 | 3 | # Idris 2 executable we're building 4 | NAME = idris2-lua 5 | TARGETDIR = build/exec 6 | TARGET = ${TARGETDIR}/${NAME} 7 | IDRIS2 = idris2 8 | IPKG = idris2-lua.ipkg 9 | 10 | MAJOR=0 11 | MINOR=5 12 | PATCH=1 13 | 14 | 15 | export IDRIS2_VERSION := ${MAJOR}.${MINOR}.${PATCH} 16 | 17 | ifeq ($(OS), windows) 18 | # This produces D:/../.. style paths 19 | IDRIS2_PREFIX := $(shell cygpath -m ${PREFIX}) 20 | IDRIS2_CURDIR := $(shell cygpath -m ${CURDIR}) 21 | SEP := ; 22 | else 23 | IDRIS2_PREFIX := ${PREFIX} 24 | IDRIS2_CURDIR := ${CURDIR} 25 | SEP := : 26 | endif 27 | 28 | 29 | .PHONY: all idris2-lua-exec ${TARGET} clean-tests clean check-env test 30 | 31 | all: ${TARGET} test 32 | 33 | idris2-lua-exec: ${TARGET} 34 | 35 | ${TARGET}: 36 | ${IDRIS2} --build ${IPKG} 37 | 38 | clean-tests: 39 | $(RM) -r tests/build 40 | 41 | clean: clean-tests 42 | $(RM) -r build 43 | $(RM) support/lua/*.so 44 | $(RM) support/lua/*.o 45 | 46 | install: install-idris2-lua install-support 47 | 48 | install-idris2-lua: 49 | mkdir -p ${PREFIX}/bin/ 50 | install ${TARGET} ${PREFIX}/bin 51 | ifeq ($(OS), windows) 52 | -install ${TARGET}.cmd ${PREFIX}/bin 53 | endif 54 | mkdir -p ${PREFIX}/bin/${NAME}_app 55 | install ${TARGETDIR}/${NAME}_app/* ${PREFIX}/bin/${NAME}_app 56 | 57 | install-support: check-env 58 | mkdir -p ${PREFIX}/idris2-${IDRIS2_VERSION}/support/lua 59 | cd support/lua; \ 60 | luarocks make --lua-version=$(LuaVersion) --local 61 | install support/lua/idris2-lua.lua ${PREFIX}/idris2-${IDRIS2_VERSION}/support/lua 62 | 63 | test: clean-tests install-support 64 | make -C tests IDRIS2_LUA=../${TARGET} 65 | 66 | 67 | check-env: 68 | ifndef LuaVersion 69 | $(error LuaVersion is undefined) 70 | endif 71 | 72 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Lua backend for Idris 2 2 | [![](https://github.com/Russoul/Idris2-Lua/workflows/Ubuntu/badge.svg)](https://github.com/Russoul/Idris2-Lua/actions?query=workflow%3A"Ubuntu") 3 | [![](https://github.com/Russoul/Idris2-Lua/workflows/macOS/badge.svg)](https://github.com/Russoul/Idris2-Lua/actions?query=workflow%3A"macOS") 4 |
Tested against [Idris 2, version 0.5.1-96c44abb6](https://github.com/idris-lang/Idris2/tree/96c44abb64ce1ccf5daa6b2eb5ad3d2e86d80001) 5 | 6 | ## Requirements & Installation 7 | - Install `Idris 2` and `Idris 2 API`, see https://github.com/idris-lang/Idris2/blob/master/INSTALL.md for instructions 8 | - Target Lua versions: 5.1, 5.2, 5.3, recent LuaJIT 9 | - Depends on [lua-utf8](https://github.com/starwing/luautf8.git), [lua-bigint](https://github.com/JorjBauer/lua-bigint.git), 10 | [lfs](https://keplerproject.github.io/luafilesystem/manual.html), [vstruct](https://github.com/ToxicFrog/vstruct) and 11 | [inspect](https://github.com/kikito/inspect.lua) (tests only) 12 | 13 | 14 | 15 | #### All libraries can be installed via [*luarocks*](https://luarocks.org): 16 | 17 | ``` 18 | luarocks install luautf8 --lua-version=V --local 19 | luarocks install bigint --lua-version=V --local LD='clang -lstdc++' 20 | luarocks install luafilesystem --lua-version=V --local 21 | luarocks install vstruct --lua-version=V --local 22 | luarocks install inspect --lua-version=V --local 23 | ``` 24 | #### Lua 5.1 only: 25 | 26 | ``` 27 | luarocks install bit32 --lua-version=5.1 --local 28 | ``` 29 | 30 | where `V` is your lua version (5.1, 5.2, 5.3). 31 | 32 | --- 33 | 34 | Before you proceed, fill in the `LuaVersion` and `LuaExe` environment variables with a desired Lua version and a name of the executable file for that version. 35 | 36 | #### Build, test and install: 37 | 38 | `make all && make install` 39 | 40 | Idris 2 REPL preconfigured with `lua` codegen will be available under the name `idris2-lua` located in the same folder as your `idris2` executable. 41 | 42 | ## Status 43 | - The project aims to keep performance reasonable, Lua has many limitations, concerning 44 | local variables and nested structures like if-then-else statements, 45 | leading to design choices that may decrease performance and limit what the Lua runtime can do to optimize execution. 46 | Suggestions are welcome ! 47 | 48 | - Major `chez` tests taken from the official repository under `tests/chez` run successfully, those which don't are primary FFI or BitXX tests. 49 | 50 | ### Structure and How-Tos 51 | - Backend needs to know what version of Lua you target as there are incompatibilities: 52 | 53 | Define a global varible `LuaVersion` with a value: `5.1`, `5.2`, `5.3` 54 | - If you want to run generated code within the REPL, define `LuaExe` with the name of the Lua executable (which should be in `PATH`) of the target version. 55 | If the variable is undefined, the backend will default to `lua`. 56 | 57 | 58 | ### Good to know 59 | - Lua 5.1 and Lua 5.2 do not support 64 bit integers ! 60 | Best precision you can get is 52 bits. 61 | Also, if you use Buffers maximum precision is 48 bits, disregarding the Lua version ! 62 | This is planned to be fixed moving to native buffers. 63 | - Bits8, Bits16, Bits32, Bits64 are not yet implemented 64 | -------------------------------------------------------------------------------- /config.mk: -------------------------------------------------------------------------------- 1 | ##### Options which a user might set before building go here ##### 2 | 3 | PREFIX ?= $(HOME)/.idris2 4 | 5 | # For Windows targets. Set to 1 to support Windows 7. 6 | OLD_WIN ?= 0 7 | 8 | ################################################################## 9 | 10 | RANLIB ?= ranlib 11 | AR ?= ar 12 | 13 | CFLAGS := -Wall $(CFLAGS) 14 | LDFLAGS := $(LDFLAGS) 15 | 16 | MACHINE := $(shell $(CC) -dumpmachine) 17 | ifneq (,$(findstring cygwin, $(MACHINE))) 18 | OS := windows 19 | SHLIB_SUFFIX := .dll 20 | else ifneq (,$(findstring mingw, $(MACHINE))) 21 | OS := windows 22 | SHLIB_SUFFIX := .dll 23 | else ifneq (,$(findstring windows, $(MACHINE))) 24 | OS := windows 25 | SHLIB_SUFFIX := .dll 26 | else ifneq (,$(findstring darwin, $(MACHINE))) 27 | OS := darwin 28 | SHLIB_SUFFIX := .dylib 29 | CFLAGS += -fPIC 30 | else ifneq (, $(findstring bsd, $(MACHINE))) 31 | OS := bsd 32 | SHLIB_SUFFIX := .so 33 | CFLAGS += -fPIC 34 | else 35 | OS := linux 36 | SHLIB_SUFFIX := .so 37 | CFLAGS += -fPIC 38 | endif 39 | export OS 40 | 41 | ifeq ($(OS),bsd) 42 | MAKE := gmake 43 | else 44 | MAKE := make 45 | endif 46 | export MAKE 47 | 48 | # Add a custom.mk file to override any of the configurations 49 | -include custom.mk 50 | -------------------------------------------------------------------------------- /idris2-lua.ipkg: -------------------------------------------------------------------------------- 1 | package idris2lua 2 | 3 | depends = idris2, contrib, network 4 | 5 | modules = 6 | LuaCommon, 7 | OrderDefs, 8 | LuaAst, 9 | LuaGen 10 | 11 | sourcedir = "src" 12 | main = LuaGen 13 | executable = idris2-lua 14 | -------------------------------------------------------------------------------- /src/LuaAst.idr: -------------------------------------------------------------------------------- 1 | module LuaAst 2 | 3 | import Core.Name 4 | import Core.TT 5 | 6 | import Data.Vect 7 | 8 | %hide Core.TT.Visibility 9 | 10 | public export 11 | data Visibility = Local 12 | | Global 13 | 14 | 15 | export 16 | Eq Visibility where 17 | (==) Local Local = True 18 | (==) Global Global = True 19 | (==) _ _ = False 20 | 21 | 22 | public export 23 | data LuaExpr = LLVar Name -- references some local variable 24 | | LGVar Name -- references some global variable defined inside `idris` table 25 | | LLambda (List Name) LuaExpr 26 | | LApp LuaExpr (List LuaExpr) 27 | | LPrimFn (PrimFn arity) (Vect arity LuaExpr) 28 | | LTrue --literal 'true' 29 | | LFalse --literal 'false' 30 | | LNil --literal 'nil' 31 | | LNumber String --literal number 32 | | LBigInt String --literal bigint 33 | | LString String --literal string 34 | | LTable (List (LuaExpr, LuaExpr)) 35 | | LIndex LuaExpr LuaExpr 36 | | LSeq LuaExpr LuaExpr 37 | | LReturn LuaExpr 38 | | LAssign (Maybe Visibility) LuaExpr LuaExpr --decl with initial val and reassignment 39 | | LDeclVar Visibility Name 40 | | LIfThenElse LuaExpr LuaExpr LuaExpr 41 | | LBreak 42 | | LWhile LuaExpr LuaExpr 43 | | LDoNothing 44 | | LComment String 45 | 46 | public export 47 | Semigroup LuaExpr where 48 | LDoNothing <+> y = y 49 | x <+> LDoNothing = x 50 | x <+> y = LSeq x y 51 | 52 | public export 53 | Monoid LuaExpr where 54 | neutral = LDoNothing 55 | 56 | public export 57 | primFnNames : List String 58 | primFnNames = 59 | ["prim__cast_IntChar" 60 | ,"prim__cast_IntegerDouble" 61 | ,"prim__cast_IntDouble" 62 | ,"prim__cast_StringDouble" 63 | ,"prim__cast_DoubleInt" 64 | ,"prim__cast_CharInt" 65 | ,"prim__cast_IntegerInt" 66 | ,"prim__cast_StringInt" 67 | ,"prim__cast_DoubleInteger" 68 | ,"prim__cast_CharInteger" 69 | ,"prim__cast_IntInteger" 70 | ,"prim__cast_StringInteger" 71 | ,"prim__cast_DoubleString" 72 | ,"prim__cast_CharString" 73 | ,"prim__cast_IntegerString" 74 | ,"prim__cast_IntString" 75 | ,"prim__doubleCeiling" 76 | ,"prim__doubleFloor" 77 | ,"prim__doubleSqrt" 78 | ,"prim__doubleATan" 79 | ,"prim__doubleACos" 80 | ,"prim__doubleASin" 81 | ,"prim__doubleTan" 82 | ,"prim__doubleCos" 83 | ,"prim__doubleSin" 84 | ,"prim__doubleLog" 85 | ,"prim__doubleExp" 86 | ,"prim__crash" 87 | ,"prim__believe_me" 88 | ,"prim__strSubstr" 89 | ,"prim__strReverse" 90 | ,"prim__strAppend" 91 | ,"prim__strCons" 92 | ,"prim__strIndex" 93 | ,"prim__strTail" 94 | ,"prim__strHead" 95 | ,"prim__strLength" 96 | ,"prim__gt_String" 97 | ,"prim__gt_Double" 98 | ,"prim__gt_Char" 99 | ,"prim__gt_Integer" 100 | ,"prim__gt_Int" 101 | ,"prim__gte_String" 102 | ,"prim__gte_Double" 103 | ,"prim__gte_Char" 104 | ,"prim__gte_Integer" 105 | ,"prim__gte_Int" 106 | ,"prim__eq_String" 107 | ,"prim__eq_Double" 108 | ,"prim__eq_Char" 109 | ,"prim__eq_Integer" 110 | ,"prim__eq_Int" 111 | ,"prim__lte_String" 112 | ,"prim__lte_Double" 113 | ,"prim__lte_Char" 114 | ,"prim__lte_Integer" 115 | ,"prim__lte_Int" 116 | ,"prim__lt_String" 117 | ,"prim__lt_Double" 118 | ,"prim__lt_Char" 119 | ,"prim__lt_Integer" 120 | ,"prim__lt_Int" 121 | ,"prim__xor_Int" 122 | ,"prim__or_Integer" 123 | ,"prim__or_Int" 124 | ,"prim__and_Integer" 125 | ,"prim__and_Int" 126 | ,"prim__shr_Integer" 127 | ,"prim__shr_Int" 128 | ,"prim__shl_Integer" 129 | ,"prim__shl_Int" 130 | ,"prim__negate_Double" 131 | ,"prim__mod_Integer" 132 | ,"prim__mod_Int" 133 | ,"prim__div_Double" 134 | ,"prim__div_Integer" 135 | ,"prim__div_Int" 136 | ,"prim__mul_Double" 137 | ,"prim__mul_Integer" 138 | ,"prim__mul_Int" 139 | ,"prim__sub_Double" 140 | ,"prim__sub_Integer" 141 | ,"prim__sub_Int" 142 | ,"prim__add_Double" 143 | ,"prim__add_Integer" 144 | ,"prim__add_Int" 145 | ] 146 | 147 | 148 | -------------------------------------------------------------------------------- /src/LuaCommon.idr: -------------------------------------------------------------------------------- 1 | module LuaCommon 2 | 3 | 4 | import Core.Core 5 | import Core.Context.Context 6 | import Core.Name 7 | import Data.Buffer 8 | import Data.Buffer 9 | import Data.List 10 | import Data.List 11 | import Data.List1 12 | import Data.String.Extra 13 | import Data.String 14 | import Data.Vect 15 | import Data.Zippable 16 | 17 | import Libraries.Utils.Hex 18 | 19 | infixl 100 |> 20 | 21 | ||| Flipped tightly bound function application 22 | public export %inline 23 | (|>) : a -> (a -> b) -> b 24 | x |> f = f x 25 | 26 | namespace Strings 27 | FromString (List Char) where 28 | fromString = fastUnpack 29 | 30 | public export 31 | record String1 where 32 | constructor MkString1 33 | head : Char 34 | tail : String 35 | 36 | public export 37 | data NonEmptyString : String -> Type where 38 | ItIsNonEmptyString : (0 prf : IsJust (strUncons str)) -> NonEmptyString str 39 | 40 | public export 41 | toString1 : (str : String) -> {auto 0 prf : NonEmptyString str} -> String1 42 | toString1 str @{ItIsNonEmptyString itIs} with (strUncons str) 43 | toString1 str @{ItIsNonEmptyString ItIsJust} | Just (x, xs) = MkString1 x xs 44 | 45 | public export 46 | toList1 : (str : String) -> {auto 0 prf : NonEmptyString str} -> List1 Char 47 | toList1 str @{ItIsNonEmptyString itIs} with (strUncons str) 48 | toList1 str @{ItIsNonEmptyString ItIsJust} | Just (x, xs) = x ::: fastUnpack xs 49 | 50 | public export 51 | ||| Removes all occurances of the literal @lit 52 | ||| in the string @str 53 | removeAll : 54 | (lit : String) 55 | -> (str : String) 56 | -> String 57 | removeAll lit str with (str == "") 58 | removeAll lit str | False = 59 | if isPrefixOf lit str 60 | then removeAll lit (substr (length lit) (length str `minus` length lit) str) 61 | else case strUncons str of 62 | Just (head, rest) => strCons head (removeAll lit rest) 63 | Nothing => "" 64 | removeAll lit str | True = "" 65 | 66 | -- TODO Useful function to add to `base` ? 67 | ||| Splits the subject string into parts by the delimiter. 68 | public export 69 | split : (delim : List1 Char) -> (subject : List Char) -> List1 (List Char) 70 | split delim subject = 71 | reverse $ splitHelper delim subject [] [] 72 | where 73 | splitHelper : List1 Char -> List Char -> List Char -> List (List Char) -> List1 (List Char) 74 | splitHelper delim [] acc store = (reverse acc) ::: store 75 | splitHelper delim str@(x :: xs) acc store = 76 | case isPrefixOf (forget delim) str of 77 | -- Dropping a non-zero sequence of characters from `str` ensures that `str` is structurally smaller with each successive call 78 | True => splitHelper delim (assert_smaller str $ drop (length $ forget delim) str) [] (reverse acc :: store) 79 | False => splitHelper delim xs (x :: acc) store 80 | 81 | public export %inline 82 | indent : Nat -> String 83 | indent n = replicate (2 * n) ' ' 84 | 85 | public export 86 | trimLeft : List Char -> List Char 87 | trimLeft (' ' :: xs) = trimLeft xs 88 | trimLeft xs = xs 89 | 90 | public export %inline 91 | trim : List Char -> List Char 92 | trim = reverse . trimLeft . reverse . trimLeft 93 | 94 | 95 | public export 96 | data LuaVersion = Lua51 | Lua52 | Lua53 | Lua54 97 | 98 | 99 | namespace LuaVersion 100 | 101 | export 102 | index : LuaVersion -> Int 103 | index Lua51 = 51 104 | index Lua52 = 52 105 | index Lua53 = 53 106 | index Lua54 = 54 107 | 108 | export 109 | fromIndex : Int -> Maybe LuaVersion 110 | fromIndex 51 = Just Lua51 111 | fromIndex 52 = Just Lua52 112 | fromIndex 53 = Just Lua53 113 | fromIndex 54 = Just Lua54 114 | fromIndex _ = Nothing 115 | 116 | export 117 | Eq LuaVersion where 118 | Lua51 == Lua51 = True 119 | Lua52 == Lua52 = True 120 | Lua53 == Lua53 = True 121 | Lua54 == Lua54 = True 122 | _ == _ = False 123 | 124 | export 125 | Show LuaVersion where 126 | show ver = 127 | let index = index ver 128 | major = index `div` 10 129 | minor = index `mod` 10 130 | in 131 | "Lua" ++ show major ++ "." ++ show minor 132 | 133 | export 134 | Ord LuaVersion where 135 | compare v v' = compare (index v) (index v') 136 | 137 | export 138 | parseLuaVersion : String -> Maybe LuaVersion 139 | parseLuaVersion str = helper ((trim . toLower) str) 140 | where 141 | helper : String -> Maybe LuaVersion 142 | helper x = 143 | let noprefix = 144 | if isPrefixOf "lua" x 145 | then drop 3 x 146 | else x 147 | nodots = removeAll "." noprefix 148 | nodashes = removeAll "-" nodots 149 | firstTwo = take 2 nodashes 150 | in 151 | do int <- parseInteger {a = Int} firstTwo 152 | fromIndex int 153 | 154 | 155 | namespace Data.List 156 | public export 157 | contains : Eq a => List a -> a -> Bool 158 | contains [] _ = False 159 | contains (x :: xs) x' = x == x' || contains xs x 160 | 161 | public export 162 | group : {n : _} -> List a -> Vect n (a -> Bool) -> Vect n (List a) 163 | group [] _ = replicate _ [] 164 | group (x :: xs) fs 165 | = zipWith List.(++) (map (\f => fromMaybe [] (toMaybe (f x) [x])) fs) (group xs fs) 166 | 167 | 168 | namespace Data.Maybe 169 | public export %inline 170 | orElse : (maybe : Maybe a) -> (def : Lazy a) -> a 171 | orElse = flip fromMaybe 172 | 173 | public export 174 | luaKeywords : List String 175 | luaKeywords = ["and", "break", "do", "else", "elseif", "end", 176 | "false", "for", "function", "goto", "if", "in", 177 | "local", "nil", "not", "or", "repeat", "return", 178 | "then", "true", "until", "while"] 179 | 180 | --lua's set of chars that form a valid identifier is restricted to alphanumeric characters and underscore 181 | --in order to resemble at least some level of readability of generated names below 'pseudotranslation' is utilized 182 | --this is not failproof, i.e. you can find 2 different identifiers such that after running both of them though this function 183 | --you will get same output. But that is highly unlikely and would be a result of using bad naming conventions 184 | public export 185 | validateIdentifier : String -> String 186 | validateIdentifier str = fastConcat $ validate <$> unpack (validateKeyword str) 187 | where 188 | validate : Char -> String 189 | validate ':' = "_col_" 190 | validate ';' = "_semicol_" 191 | validate ',' = "_comma_" 192 | validate '+' = "_plus_" 193 | validate '-' = "_minus_" 194 | validate '*' = "_mult_" 195 | validate '\\' = "_bslash_" 196 | validate '/' = "_fslash_" 197 | validate '=' = "_eq_" 198 | validate '.' = "_dot_" 199 | validate '?' = "_what_" 200 | validate '|' = "_pipe_" 201 | validate '&' = "_and_" 202 | validate '>' = "_gt_" 203 | validate '<' = "_lt_" 204 | validate '!' = "_exclam_" 205 | validate '@' = "_at_" 206 | validate '$' = "_dollar_" 207 | validate '%' = "_percent_" 208 | validate '^' = "_arrow_" 209 | validate '~' = "_tilde_" 210 | validate '#' = "_hash_" 211 | validate ' ' = "_space_" 212 | validate '(' = "_lpar_" 213 | validate ')' = "_rpar_" 214 | validate '[' = "_lbrack_" 215 | validate ']' = "_rbrack_" 216 | validate '{' = "_lbrace_" 217 | validate '}' = "_rbrace_" 218 | validate '\'' = "_prime_" 219 | validate '"' = "_quote_" 220 | validate s with (ord s > 160) --unicode codepoints are above 160 221 | validate s | False = cast s 222 | validate s | True = "_uni_" ++ cast (ord s) ++ "_" 223 | 224 | validateKeyword : String -> String 225 | validateKeyword mbkw = 226 | case find (== mbkw) luaKeywords of 227 | Just kw => "_kw_" ++ kw ++ "_" 228 | Nothing => mbkw 229 | 230 | public export 231 | parseEnvBool : String -> Maybe Bool 232 | parseEnvBool str = 233 | case toLower str of 234 | "true" => Just True 235 | "1" => Just True 236 | "on" => Just True 237 | "false" => Just False 238 | "0" => Just False 239 | "off" => Just False 240 | _ => Nothing 241 | 242 | ||| Escape some of the ascii codes, fail on unicode, as 243 | ||| not all supported lua versions have unicode escape sequences 244 | public export 245 | escapeStringLua : String -> Maybe String 246 | escapeStringLua s = concat <$> traverse okchar (fastUnpack s) 247 | where 248 | okchar : Char -> Maybe String 249 | okchar c = if (c >= ' ') && (c /= '\\') && (c /= '"') && (c <= '~') 250 | then Just (cast c) 251 | else case c of 252 | '\0' => Just "\\0" 253 | '"' => Just "\\\"" 254 | '\\' => Just "\\\\" 255 | '\r' => Just "\\r" 256 | '\n' => Just "\\n" 257 | _ => Nothing 258 | 259 | ||| Transforms `x, y, ... w => body` into `function(x) return function(y) ... return function(w) return body end ... end end 260 | public export 261 | curryTransform : (vars : List (List Char)) -> (body : List Char) -> List Char 262 | curryTransform [] body = body 263 | curryTransform (x :: xs) body = "function(" ++ x ++ ") return " ++ curryTransform xs body ++ " end" 264 | 265 | export %inline 266 | sequenceMaybe : Maybe (Core a) -> Core (Maybe a) 267 | sequenceMaybe Nothing = pure Nothing 268 | sequenceMaybe (Just x) = x >>= pure . Just 269 | 270 | public export 271 | record StrBuffer where 272 | constructor MkStrBuffer 273 | get : Buffer 274 | offset : Int 275 | 276 | 277 | namespace StrBuffer 278 | 279 | export 280 | allocStrBuffer : Int -> Core StrBuffer 281 | allocStrBuffer initialSize = 282 | do 283 | (Just buf) <- coreLift $ newBuffer initialSize 284 | | _ => throw (UserError "Could not allocate buffer") 285 | pure (MkStrBuffer buf 0) 286 | 287 | export 288 | writeStr : 289 | (marker : Type) 290 | -> {auto buf : Ref marker StrBuffer} 291 | -> String 292 | -> Core () 293 | writeStr marker str = 294 | do 295 | let strlen = stringByteLength str 296 | strbuf <- get marker 297 | raw <- ensureSize strbuf.get strbuf.offset strlen 298 | coreLift $ setString raw strbuf.offset str 299 | put marker (MkStrBuffer raw (strbuf.offset + strlen)) 300 | pure () 301 | 302 | where 303 | ensureSize : Buffer -> Int -> Int -> Core Buffer 304 | ensureSize buf offset strlen = 305 | let bufLen = !(coreLift $ rawSize buf) in 306 | if offset + strlen > bufLen 307 | then do 308 | (Just buf) <- coreLift $ resizeBuffer buf (max (2 * bufLen) (offset + strlen)) 309 | | _ => throw (UserError "Could not allocate buffer") 310 | pure buf 311 | else 312 | pure buf 313 | 314 | 315 | public export 316 | data DeferredStr : Type where 317 | Nil : DeferredStr 318 | (::) : Lazy a 319 | -> {auto prf : Either (a = String) (a = DeferredStr)} 320 | -> Lazy DeferredStr 321 | -> DeferredStr 322 | 323 | 324 | namespace DeferredStr 325 | 326 | export 327 | pure : String -> DeferredStr 328 | pure x = [delay x] 329 | 330 | export 331 | traverse_ : (String -> Core b) -> DeferredStr -> Core () 332 | traverse_ f ((::) x xs {prf = Left Refl}) = do ignore (f x); traverse_ f xs 333 | traverse_ f ((::) x xs {prf = Right Refl}) = do traverse_ f x; traverse_ f xs 334 | traverse_ _ [] = pure () 335 | 336 | export 337 | sepBy : Lazy (List (DeferredStr)) -> String -> DeferredStr 338 | sepBy (x :: xs@(_ :: _)) sep = x :: sep :: sepBy xs sep 339 | sepBy (x :: []) _ = [x] 340 | sepBy [] _ = [] 341 | 342 | export 343 | (++) : Lazy DeferredStr -> Lazy DeferredStr -> DeferredStr 344 | [] ++ rhs = rhs 345 | (x :: xs) ++ rhs = x :: xs ++ rhs 346 | 347 | --it is actually more general than that, but whatever 348 | export 349 | trimQuotes : String -> String 350 | trimQuotes x = substr 1 (length x `minus` 2) x 351 | 352 | public export %inline 353 | forAll : (a -> Bool) -> List a -> Bool 354 | forAll f xs = foldl (\ac, x => ac && f x) True xs 355 | -------------------------------------------------------------------------------- /src/OrderDefs.idr: -------------------------------------------------------------------------------- 1 | module OrderDefs 2 | 3 | import Data.List 4 | import Data.So 5 | import Data.SortedMap 6 | import Data.SortedSet 7 | import Data.Vect 8 | 9 | import Core.CompileExpr 10 | import Core.FC 11 | import Core.Name 12 | 13 | import LuaCommon 14 | 15 | -- Borrowed from the Node backend 16 | mutual 17 | ||| Returns all names referenced within the given expression. 18 | ||| Names are not chased down transitivily. 19 | export 20 | usedNames : NamedCExp -> SortedSet Name 21 | usedNames (NmLocal fc n) = empty 22 | usedNames (NmRef fc n) = insert n empty 23 | usedNames (NmLam fc n e) = usedNames e 24 | usedNames (NmApp fc x args) = usedNames x `union` concat (usedNames <$> args) 25 | usedNames (NmPrimVal fc c) = empty 26 | usedNames (NmOp fc op args) = concat $ usedNames <$> args 27 | usedNames (NmConCase fc sc alts def) = (usedNames sc `union` concat (usedNamesConAlt <$> alts)) `union` maybe empty usedNames def 28 | usedNames (NmConstCase fc sc alts def) = (usedNames sc `union` concat (usedNamesConstAlt <$> alts)) `union` maybe empty usedNames def 29 | usedNames (NmExtPrim fc p args) = concat $ usedNames <$> args 30 | usedNames (NmCon fc x _ t args) = concat $ usedNames <$> args 31 | usedNames (NmDelay fc _ t) = usedNames t 32 | usedNames (NmForce fc _ t) = usedNames t 33 | usedNames (NmLet fc x val sc) = usedNames val `union` usedNames sc 34 | usedNames (NmErased fc) = empty 35 | usedNames (NmCrash fc msg) = empty 36 | 37 | usedNamesConAlt : NamedConAlt -> SortedSet Name 38 | usedNamesConAlt (MkNConAlt n _ t args exp) = usedNames exp 39 | 40 | usedNamesConstAlt : NamedConstAlt -> SortedSet Name 41 | usedNamesConstAlt (MkNConstAlt c exp) = usedNames exp 42 | 43 | ||| Returns all names referenced within the given definition. 44 | ||| Names are not chased down transitivily. 45 | usedNamesDef : NamedDef -> SortedSet Name 46 | usedNamesDef (MkNmFun args exp) = usedNames exp 47 | usedNamesDef (MkNmError exp) = usedNames exp 48 | usedNamesDef (MkNmForeign cs args ret) = empty 49 | usedNamesDef (MkNmCon _ _ _) = empty 50 | 51 | ||| For each definition finds names referenced within it. 52 | export 53 | defsToUsedMap : List (Name, NamedDef) -> SortedMap Name (NamedDef, SortedSet Name) 54 | defsToUsedMap defs = 55 | fromList $ (\(n, d) => (n, (d, usedNamesDef d))) <$> defs 56 | 57 | ||| The first argument is for local storage. Initialized with the empty set. 58 | ||| The second argument is a map from names to their dependencies. 59 | ||| The third argument is a set of names 60 | ||| Returns a set of names that the given names depend on. 61 | calcUsed : SortedSet Name -> SortedMap Name (NamedDef, SortedSet Name) -> List Name -> SortedSet Name 62 | calcUsed done d [] = done 63 | calcUsed done d xs = 64 | let used_in_xs = foldl (\x, y => union x (fromMaybe empty (snd <$> y))) empty $ (\z => lookup z d) <$> xs 65 | new_done = union done (fromList xs) 66 | in calcUsed (new_done) d (SortedSet.toList $ difference used_in_xs new_done) 67 | 68 | calcUsedDefs : List Name -> SortedMap Name (NamedDef, SortedSet Name) -> List (Name, (NamedDef, SortedSet Name)) 69 | calcUsedDefs names usedMap = 70 | let usedNames = calcUsed empty usedMap names 71 | in List.filter (\(n, _) => contains n usedNames) (toList usedMap) 72 | 73 | export 74 | defsUsedByNamedCExp : NamedCExp -> SortedMap Name (NamedDef, SortedSet Name) -> List (Name, NamedDef) 75 | defsUsedByNamedCExp exp usedMap = map (mapSnd fst) $ calcUsedDefs (SortedSet.toList $ usedNames exp) usedMap 76 | 77 | export 78 | used : (Name, NamedDef) -> SortedMap Name (NamedDef, SortedSet Name) -> SortedSet Name 79 | used (n, _) usedMap = fromList $ map fst $ calcUsedDefs [n] usedMap 80 | 81 | public export 82 | interface MaybeRelated t r where 83 | mbRelated : (a : t) -> (b : t) -> Maybe (a `r` b) 84 | 85 | contains : SortedSet a -> a -> Bool 86 | contains = flip SortedSet.contains 87 | 88 | %hide SortedSet.contains 89 | 90 | -- `x` <= `y`: ?reflexive, transitive, antisymmetric relation. Forms a total order 91 | public export 92 | data Lte : (defs : SortedMap Name (NamedDef, SortedSet Name)) -> (x : (Name, NamedDef)) -> (y : (Name, NamedDef)) -> Type where 93 | MkLte : {x, y, defs : _} -> 94 | let a = contains (used y defs) (fst x) 95 | b = contains (used x defs) (fst y) 96 | in (0 prf : Either (So a, So $ not b) $ Either (So a, So b) (So $ not a, So $ not b)) 97 | -> Lte defs x y 98 | 99 | public export 100 | {defs : _} -> MaybeRelated _ (Lte defs) where 101 | mbRelated x y 102 | = let 103 | a : Bool 104 | a = contains (used y defs) (fst x) 105 | b : Bool 106 | b = contains (used x defs) (fst y) 107 | in 108 | case (choose a, choose b) of 109 | (Left isA, Right notB) => Just $ MkLte (Left (isA, notB)) 110 | (Left isA, Left isB) => Just $ MkLte (Right $ Left (isA, isB)) 111 | (Right notA, Right notB) => Just $ MkLte (Right $ Right (notA, notB)) 112 | _ => Nothing 113 | 114 | public export 115 | quicksort : {defs : SortedMap Name (NamedDef, SortedSet Name)} -> List (Name, NamedDef) -> List (Name, NamedDef) 116 | quicksort (y :: xs) 117 | = let (lte, gt) = partition (\x => isJust $ mbRelated {r = Lte defs} x y) xs in 118 | quicksort {defs} lte ++ (y :: quicksort {defs} gt) 119 | quicksort [] = [] 120 | -------------------------------------------------------------------------------- /support/lua/idris2-lua-scm-0.rockspec: -------------------------------------------------------------------------------- 1 | package = "idris2-lua" 2 | version = "scm-0" 3 | 4 | source = { 5 | url = "git://github.com/russoul/idris2-lua" 6 | } 7 | 8 | description = { 9 | summary = "Support module for Lua backend of Idris 2", 10 | detailed = [[ 11 | Defines functions that serve as a library for Lua backend of Idris 2 12 | ]], 13 | homepage = "http://github.com/russoul/idris2-lua", 14 | license = "MIT", 15 | } 16 | 17 | dependencies = { 18 | "lua >= 5.1" 19 | } 20 | 21 | build = { 22 | type = "builtin", 23 | modules = { 24 | ["idris2-lua"] = "idris2-lua.lua", 25 | ["idris2-lua_native"] = "lib.c" 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /support/lua/idris2-lua.lua: -------------------------------------------------------------------------------- 1 | --idris = {} 2 | --idris.null = {} 3 | --local null = idris.null 4 | --idris.luaVersion {51,52,53,54} --set automatically by the compiler 5 | --idris.noRequire {true,false} 6 | 7 | if not idris.noRequire then 8 | idrisn = require("idris2-lua_native") 9 | utf8 = require("lua-utf8") 10 | bigint = require("bigint") 11 | lfs = require("lfs") 12 | vstruct = require("vstruct") 13 | end 14 | 15 | idris.error = error 16 | idris.print = print 17 | idris["os.exit"] = os.exit 18 | idris.W = {} 19 | 20 | setmetatable(idris.W, {__tostring=function(_) return "%MkWorld" end}) 21 | 22 | ------------------------------------- 23 | ---- Cross-Version Compatibility ---- --possible Lua version range is [5.1; 5.4] 24 | ------------------------------------- --supported features may very between versions 25 | --as well as the level of optimisations applied 26 | --5.4 is probably out of reach yet, as not all required libraries are updated 27 | --if ever will be 28 | 29 | function idris.addenv(key) 30 | return function(val) 31 | if idris.luaVersion < 52 then 32 | local env = getfenv(1) 33 | env[key] = val 34 | setfenv(1, env) 35 | else 36 | _ENV[key] = val 37 | end 38 | end 39 | end 40 | 41 | function idris.getenv(key) 42 | if idris.luaVersion < 52 then 43 | return getfenv()[key] 44 | else 45 | return _ENV[key] 46 | end 47 | end 48 | 49 | local abs = math.abs 50 | local modf = math.modf 51 | function idris.getBit32() 52 | if idris.luaVersion == 51 then --idris.luaVersion is autodefined by the compiler 53 | return require('bit32') --bit32 lib is required on lua 5.1 54 | elseif idris.luaVersion == 52 then 55 | return bit32 --builtin on lua 5.2 56 | else 57 | return null --lua 5.3 adds native bitwise ops 58 | end --in this case bit32 won't be used by Idris 2 59 | end 60 | 61 | function idris.getToInteger() --behaviour of math.tointeger of lua 5.3 (returns nil on float) 62 | if idris.luaVersion < 53 then 63 | return function (x) 64 | local int, frac = modf(x) 65 | if frac ~= 0.0 then 66 | return nil 67 | else 68 | return int 69 | end 70 | end 71 | else 72 | return math.tointeger 73 | end 74 | end 75 | 76 | function idris.getReadLineString() 77 | if idris.luaVersion <= 52 then 78 | return "*l" 79 | else 80 | return "l" 81 | end 82 | end 83 | 84 | function idris.getUnpack() 85 | if idris.luaVersion == 51 then 86 | return unpack 87 | else 88 | return table.unpack 89 | end 90 | end 91 | 92 | function idris.getOnCollectAny() 93 | if idris.luaVersion == 51 then 94 | return function(ptr) 95 | return function(f) 96 | return function(w) 97 | error("prim__onCollectAny not implemented for Lua 5.1") 98 | end 99 | end 100 | end 101 | else 102 | return function(ptr) 103 | return function(f) 104 | return function(w) 105 | local t = getmetatable(ptr) 106 | if not t then t = {} end 107 | t.__gc = f 108 | setmetatable(ptr, t) 109 | return ptr 110 | end 111 | end 112 | end 113 | end 114 | end 115 | function idris.getOnCollect() 116 | if idris.luaVersion == 51 then 117 | return function(ty) 118 | return function(ptr) 119 | return function(f) 120 | return function(w) 121 | error("prim__onCollect not implemented for Lua 5.1") 122 | end 123 | end 124 | end 125 | end 126 | else 127 | return function (ty) 128 | return function(ptr) 129 | return function(f) 130 | return function(w) 131 | local t = getmetatable(ptr) 132 | if not t then t = {} end 133 | t.__gc = f 134 | setmetatable(ptr, t) 135 | return ptr 136 | end 137 | end 138 | end 139 | end 140 | end 141 | end 142 | 143 | bit32 = idris.getBit32() 144 | idris.tointeger = idris.getToInteger() 145 | idris.strtointeger = function (str) return math.floor(tonumber(str)) end 146 | idris.readl = idris.getReadLineString() 147 | idris.unpack = idris.getUnpack() 148 | idris.onCollectAny = idris.getOnCollectAny() 149 | 150 | function idris.signum(x) 151 | if x > 0 then 152 | return 1 153 | elseif x < 0 then 154 | return -1 155 | else 156 | return 0 157 | end 158 | end 159 | local signum = idris.signum 160 | 161 | function idris.div(x, m) 162 | local sx = signum(x) 163 | return (x - sx * (x * sx % abs(m))) / m 164 | end 165 | local div = idris.div 166 | local min = math.min 167 | local max = math.max 168 | 169 | -- function idris.powbi(base, exp) 170 | -- local zero = bigint:new(0) 171 | -- local one = bigint:one(1) 172 | -- local k = one 173 | -- while exp >= one do 174 | -- k = k * base 175 | -- exp = exp - one 176 | -- end 177 | -- return k 178 | -- end 179 | 180 | function bigint.abs(x) 181 | if x >= bigint:new(0) then 182 | return bigint:new(x) 183 | else 184 | return -x 185 | end 186 | end 187 | 188 | function bigint.numd2(x) 189 | local zero = bigint:new(0) 190 | local n = 0 191 | local x = x:abs() 192 | while x > zero do 193 | n = n + 1 194 | x = x:shiftright(1) 195 | end 196 | return n 197 | end 198 | 199 | -- Primitive function, do not curry 200 | function idris.bandbi(a, b) 201 | local a = bigint:new(a) 202 | local b = bigint:new(b) 203 | local zero = bigint:new(0) 204 | local one = bigint:new(1) 205 | local two = bigint:new(2) 206 | local ca = a:numd2() 207 | local cb = b:numd2() 208 | local cmax = max(ca, cb) 209 | local tp = two ^ cmax 210 | local sa = 0 211 | local sb = 0 212 | if a < zero then 213 | a = tp + a 214 | sa = 1 215 | end 216 | if b < zero then 217 | b = tp + b 218 | sb = 1 219 | end 220 | ca = a:numd2() 221 | cb = b:numd2() 222 | cmax = max(ca, cb) 223 | cmin = min(ca, cb) 224 | local r = zero 225 | for i = 1, cmin do 226 | local ma = a % two 227 | local mb = b % two 228 | r = r + one:shiftleft(i - 1) * (ma * mb) 229 | a = a:shiftright(1) 230 | b = b:shiftright(1) 231 | end 232 | if sa * sb == 0 then 233 | return r 234 | else 235 | return -(tp - r) 236 | end 237 | end 238 | 239 | -- Primitive function, do not curry 240 | function idris.borbi(a, b) 241 | local a = bigint:new(a) 242 | local b = bigint:new(b) 243 | local zero = bigint:new(0) 244 | local one = bigint:new(1) 245 | local two = bigint:new(2) 246 | local ca = a:numd2() 247 | local cb = b:numd2() 248 | local cmax = max(ca, cb) 249 | local tp = two ^ cmax 250 | local sa = 0 251 | local sb = 0 252 | if a < zero then 253 | a = tp + a 254 | sa = 1 255 | end 256 | if b < zero then 257 | b = tp + b 258 | sb = 1 259 | end 260 | ca = a:numd2() 261 | cb = b:numd2() 262 | cmax = max(ca, cb) 263 | local r = zero 264 | for i = 1, cmax do 265 | local ma = a % two 266 | local mb = b % two 267 | local mc = zero 268 | if ma > zero or mb > zero then mc = one end 269 | r = r + one:shiftleft(i - 1) * mc 270 | a = a:shiftright(1) 271 | b = b:shiftright(1) 272 | end 273 | if sa == 0 and sb == 0 then 274 | return r 275 | else 276 | return -(tp - r) 277 | end 278 | end 279 | 280 | -- Primitive function, do not curry 281 | function idris.bxorbi(a, b) 282 | local a = bigint:new(a) 283 | local b = bigint:new(b) 284 | local zero = bigint:new(0) 285 | local one = bigint:new(1) 286 | local two = bigint:new(2) 287 | local ca = a:numd2() 288 | local cb = b:numd2() 289 | local cmax = max(ca, cb) 290 | local tp = two ^ cmax 291 | local sa = 0 292 | local sb = 0 293 | if a < zero then 294 | a = tp + a 295 | sa = 1 296 | end 297 | if b < zero then 298 | b = tp + b 299 | sb = 1 300 | end 301 | ca = a:numd2() 302 | cb = b:numd2() 303 | cmax = max(ca, cb) 304 | local r = zero 305 | for i = 1, cmax do 306 | local ma = a % two 307 | local mb = b % two 308 | r = r + one:shiftleft(i - 1) * ((ma + mb) % two) 309 | a = a:shiftright(1) 310 | b = b:shiftright(1) 311 | end 312 | if (sa + sb) % 2 == 0 then 313 | return r 314 | else 315 | return -(tp - r) 316 | end 317 | end 318 | 319 | --------------------------------- 320 | ---------- Basic stuff ---------- 321 | --------------------------------- 322 | 323 | function idris.fastConcatImpl(list, buffer) 324 | local l = list 325 | while l.tag ~= "0" do 326 | buffer[#buffer + 1] = l.arg1 327 | l = l.arg2 328 | end 329 | return table.concat(buffer) 330 | end 331 | 332 | function idris.fastUnpackImpl(str, i, chars) 333 | while i ~= 0 do 334 | chars = {tag="1", arg1=utf8.sub(str, i, i), arg2=chars} 335 | i = i - 1 336 | end 337 | return chars 338 | end 339 | 340 | idris.fastConcat = function(args) return idris.fastConcatImpl(args, {}) end -- impl of fastConcat 341 | idris.fastUnpack = function(str) return idris.fastUnpackImpl(str, utf8.len(str), {tag = "0"}) end -- impl of fastUnpack 342 | idris["Prelude.Types.fastConcat"] = idris.fastConcat 343 | idris["Prelude.Types.fastUnpack"] = idris.fastUnpack 344 | idris["Prelude.Types.fastPack"] = idris.fastConcat 345 | 346 | function idris.iterFromStringImpl(str) 347 | return 1 348 | end 349 | 350 | function idris.unconsImpl(str, i) 351 | if utf8.len(str) < i then 352 | -- EOF 353 | return {tag = "0"} 354 | else 355 | -- Character 356 | return {tag = "1", arg1 = utf8.sub(str, i, i), arg2 = i + 1} 357 | end 358 | end 359 | 360 | idris["Data.String.Iterator.fromString"] = idris.iterFromStringImpl 361 | idris["Data.String.Iterator.uncons"] = function (str) return function (i) return idris.unconsImpl(str, i) end end 362 | 363 | function idris.mkPtr(val) 364 | if val then return {deref=val} else return null end 365 | end 366 | 367 | idris["PrimIO.prim__nullAnyPtr"] = function(ptr) 368 | if ptr == null then 369 | return 1 370 | else 371 | return 0 372 | end 373 | end 374 | 375 | idris["Prelude.IO.prim__onCollectAny"] = idris.onCollectAny 376 | idris["Prelude.IO.prim__onCollect"] = idris.onCollect 377 | 378 | idris["Prelude.IO.prim__getString"] = function(ptr) 379 | return ptr.deref 380 | end 381 | 382 | idris["Prelude.IO.prim__putChar"] = function(char) 383 | return function(w) 384 | io.stdout:write(char) 385 | return {tag="0"} -- Unit 386 | end 387 | end 388 | 389 | --reads 1 byte (no matter the encoding) 390 | idris["Prelude.IO.prim__getChar"] = function(w) 391 | local res = io.stdin:read(1) 392 | if res then 393 | return res 394 | else 395 | return "" 396 | end 397 | end 398 | 399 | idris["Prelude.IO.prim__putStr"] = function(str) 400 | return function(w) 401 | io.stdout:write(str) 402 | return {tag="0"} -- Unit 403 | end 404 | end 405 | 406 | --trims new line 407 | idris["Prelude.IO.prim__getStr"] = function(w) 408 | local res = io.stdin:read(idris.readl) 409 | if res then 410 | return res 411 | else 412 | return "" 413 | end 414 | end 415 | 416 | idris["System.prim__system"] = function(cmd) 417 | return function(w) 418 | local success, typ, code = os.execute(cmd) 419 | return code 420 | end 421 | end 422 | 423 | idris["System.File.Process.prim__popen"] = function(cmd) 424 | return function(mode) 425 | return function(_) 426 | local res = assert(io.popen(cmd, mode)) 427 | if res then 428 | return idris.mkPtr({handle=res, path=""}) 429 | else 430 | return null 431 | end 432 | end 433 | end 434 | end 435 | 436 | idris["System.File.Process.prim__pclose"] = function(ptr) 437 | return function(_) 438 | return ptr.deref.handle:close() 439 | end 440 | end 441 | 442 | -------------------------------------------------------- 443 | ---------------------- LFS ---------------------------- 444 | -------------------------------------------------------- 445 | 446 | idris.last_file_err = -1 447 | 448 | idris["System.Directory.prim__changeDir"] = function(d) 449 | return function(w) 450 | if lfs.chdir(d) then 451 | return 0 452 | else 453 | return 1 454 | end 455 | end 456 | end 457 | 458 | idris["System.Directory.prim__currentDir"] = function(w) 459 | local cwd, errstr = lfs.currentdir() 460 | return idris.mkPtr(cwd) 461 | end 462 | 463 | idris["System.Directory.prim__createDir"] = function(d) 464 | return function(w) 465 | local ok, errmsg = lfs.mkdir(d) 466 | if ok then 467 | return 0 468 | else 469 | if errmsg == "File exists" then 470 | idris.last_file_err = 4 471 | idris.last_file_error_code = 4 472 | end 473 | return 1 474 | end 475 | end 476 | end 477 | 478 | idris["System.Directory.prim__removeDir"] = function(d) 479 | return function(w) 480 | local ok, errmsg, errno = lfs.rmdir(d) 481 | if ok then 482 | return 0 483 | else 484 | if errno then idris.last_file_err = errno end 485 | return 1 486 | end 487 | end 488 | end 489 | 490 | idris["System.Directory.prim__openDir"] = function(d) 491 | return function(w) 492 | local ok, iter, dir = pcall(lfs.dir, d) 493 | if ok then 494 | return idris.mkPtr(dir) 495 | else 496 | return null 497 | end 498 | end 499 | end 500 | 501 | idris["System.Directory.prim__closeDir"] = function(ptr) 502 | return function(w) 503 | local ok, res = pcall(function() return ptr.deref:close() end) 504 | return {tag = "0"} -- Unit 505 | end 506 | end 507 | 508 | idris["System.Directory.prim__dirEntry"] = function(ptr) 509 | return function(w) 510 | local ok, res, err, code = pcall(function() return ptr.deref:next() end) 511 | if ok then 512 | return idris.mkPtr(res) --returns dir name (String) 513 | else 514 | if code then idris.last_file_err = code end 515 | return null 516 | end 517 | end 518 | end 519 | 520 | idris["System.Errno.prim__getErrno"] = function(w) 521 | return idris.last_file_err 522 | end 523 | 524 | -------------------------------------------------------- 525 | ---------------------- FILE IO ------------------------- 526 | -------------------------------------------------------- 527 | 528 | idris.last_file_error_string = "" 529 | idris.last_file_error_code = 0 530 | 531 | -- internal 532 | idris.updateFileError = function(errstr, code) 533 | if code and code ~= 0 then 534 | idris.last_file_error_string = errstr 535 | idris.last_file_error_code = code 536 | end 537 | end 538 | 539 | idris["System.File.Handle.prim__open"] = function(name) 540 | return function(mode) 541 | return function(w) 542 | local f, str, code = io.open(name, mode) 543 | idris.updateFileError(str, code) 544 | if f then 545 | return idris.mkPtr({handle=f, path=name}) 546 | else 547 | return null 548 | end 549 | end 550 | end 551 | end 552 | 553 | idris["System.File.Handle.prim__close"] = function(file) 554 | return function(w) 555 | file.deref.handle:close() 556 | return {tag="0"} -- Unit 557 | end 558 | end 559 | 560 | idris["System.File.Error.prim__error"] = function(file) 561 | return function(w) 562 | if file ~= null then return 0 else return 1 end 563 | end 564 | end 565 | 566 | idris["System.File.Error.prim__fileErrno"] = function (w) 567 | return idris.last_file_error_code 568 | end 569 | 570 | -- internal 571 | function idris.readFile(file, ty) 572 | local line, err, code = file.deref.handle:read(ty) 573 | idris.updateFileError(err, code) 574 | if err then 575 | return null 576 | else 577 | if line then 578 | return idris.mkPtr(line) 579 | else 580 | return idris.mkPtr("") --nothing to read, return empty string 581 | --Idris behaviour 582 | end 583 | end 584 | end 585 | 586 | idris["System.File.ReadWrite.prim__readLine"] = function(file) 587 | return function(w) 588 | local ptr = idris.readFile(file, idris.readl) 589 | if ptr ~= null then 590 | if idris["System.File.ReadWrite.prim__eof"](file)(w) == 0 then -- no EOF 591 | return idris.mkPtr(ptr.deref .. "\n") 592 | else return idris.mkPtr(ptr.deref) --[[ no EOL in case we hit EOF --]] end 593 | else 594 | return null 595 | end 596 | end 597 | end 598 | 599 | idris["System.File.ReadWrite.prim__readChars"] = function(n) 600 | return function(file) 601 | return function(w) 602 | return idris.readFile(file, n) 603 | end 604 | end 605 | end 606 | 607 | idris["System.File.ReadWrite.prim__readChar"] = function(file) 608 | return function(w) 609 | local res = idris.readFile(file, 1) 610 | if res ~= null and res.deref ~= "" then 611 | return utf8.byte(res.deref) 612 | else 613 | return -1 614 | end 615 | end 616 | end 617 | 618 | idris["System.File.ReadWrite.prim__writeLine"] = function(file) 619 | return function(line) 620 | return function(w) 621 | local ok, err, code = file.deref.handle:write(line) 622 | idris.updateFileError(err, code) 623 | if ok then return 1 else return 0 end 624 | end 625 | end 626 | end 627 | 628 | idris["System.File.ReadWrite.prim__eof"] = function(file) 629 | return function(w) 630 | if idrisn.feof(file.deref.handle) == 0 then return 0 --[[ no EOF --]] else return 1 --[[ EOF --]] end 631 | end 632 | end 633 | 634 | idris["System.File.Process.prim__flush"] = function(file) 635 | return function(w) 636 | local ok, err, code = file.deref.handle:flush() --TODO no documentation for file:flush(), does it return error str and code ? 637 | idris.updateFileError(err, code) 638 | if ok then return 0 else return 1 end 639 | end 640 | end 641 | 642 | idris["System.File.ReadWrite.prim__removeFile"] = function(name) 643 | return function(w) 644 | local ok, err, code = os.remove(name) 645 | idris.updateFileError(err, code) 646 | if ok then return 0 else return code end 647 | end 648 | end 649 | 650 | idris["System.File.Meta.prim__fileSize"] = function(file) 651 | return function(w) 652 | local pos = file.deref.handle:seek() 653 | local bytes, err = file.deref.handle:seek("end") 654 | idris.updateFileError(err, 5) --set error to generic IO (code = 5) 655 | if bytes then 656 | file.deref.handle:seek("set", pos) 657 | return bytes 658 | else 659 | error("Failed getting file size for " .. file.deref.path) 660 | end 661 | end 662 | end 663 | 664 | idris["System.File.Meta.prim__fPoll"] = function(file) 665 | return function(w) 666 | return idris["System.File.Meta.prim__fileSize"](file)(w) 667 | end 668 | end 669 | 670 | idris["System.File.Meta.prim__fileModifiedTime"] = function(file) 671 | return function(w) 672 | local ok, err, code = lfs.attributes(file.deref.path, "modification") 673 | idris.updateFileError(err, code) 674 | if ok then 675 | return ok 676 | else 677 | return 0 678 | end 679 | end 680 | end 681 | 682 | idris["System.File.Meta.prim__fileStatusTime"] = function(file) 683 | return function(w) 684 | local ok, err, code = lfs.attributes(file.deref.path, "change") 685 | idris.updateFileError(err, code) 686 | if ok then 687 | return ok 688 | else 689 | return 0 690 | end 691 | end 692 | end 693 | 694 | idris["System.File.Virtual.prim__stdin"] = idris.mkPtr({handle=io.stdin, path="$stdin"}) 695 | 696 | idris["System.File.Virtual.prim__stdout"] = idris.mkPtr({handle=io.stdout, path="$stdout"}) 697 | 698 | idris["System.File.Virtual.prim__stderr"] = idris.mkPtr({handle=io.stderr, path="$stderr"}) 699 | 700 | idris["System.File.Permissions.prim__chmod"] = function(path) 701 | return function(mod) 702 | return function(w) 703 | local exit, code = os.execute("chmod " .. string.format("%o", mod) .. " " .. path) 704 | if exit == "exit" then 705 | return code 706 | else 707 | return -1 708 | end 709 | end 710 | end 711 | end 712 | 713 | -------------------------------------------------------- 714 | -------------------- BUFFER API ------------------------ 715 | -------------------------------------------------------- 716 | 717 | --TODO better write a wrapper for native C buffer 718 | --at least because vstruct does not support lua's 5.3 64-bit integers 719 | --plus it looks like its impossible to implement overwriting copying using vstruct 720 | 721 | idris["Data.Buffer.prim__newBuffer"] = function(size) 722 | return function(w) 723 | return vstruct.cursor("") 724 | end 725 | end 726 | 727 | idris["Data.Buffer.prim__bufferSize"] = function(buf) 728 | local pos = buf.pos 729 | local size = buf:seek("end") 730 | buf:seek("set", pos) 731 | return size 732 | end 733 | 734 | idris["Data.Buffer.prim__setByte"] = function(buf) 735 | return function(offset) 736 | return function(value) 737 | return function(w) 738 | local pos = buf.pos 739 | buf:seek("set", offset) 740 | vstruct.write("i1", buf, {value}) 741 | buf:seek("set", pos) 742 | return {tag="0"} -- Unit 743 | end 744 | end 745 | end 746 | end 747 | 748 | idris["Data.Buffer.prim__getByte"] = function(buf) 749 | return function(offset) 750 | return function(w) 751 | local pos = buf.pos 752 | buf:seek("set", offset) 753 | local byte = vstruct.read("i1", buf)[1] 754 | buf:seek("set", pos) 755 | return byte 756 | end 757 | end 758 | end 759 | 760 | idris["Data.Buffer.prim__setInt32"] = function(buf) 761 | return function(offset) 762 | return function(value) 763 | return function(w) 764 | local pos = buf.pos 765 | buf:seek("set", offset) 766 | vstruct.write("i4", buf, {value}) 767 | buf:seek("set", pos) 768 | return {tag="0"} -- Unit 769 | end 770 | end 771 | end 772 | end 773 | 774 | idris["Data.Buffer.prim__getInt32"] = function(buf) 775 | return function(offset) 776 | return function(w) 777 | local pos = buf.pos 778 | buf:seek("set", offset) 779 | local i32 = idris.tointeger(vstruct.read("i4", buf)[1]) 780 | if not i32 then error("unexpected float when reading Int32") end 781 | buf:seek("set", pos) 782 | return i32 783 | end 784 | end 785 | end 786 | 787 | idris["Data.Buffer.prim__setInt"] = function(buf) 788 | return function(offset) 789 | return function(value) 790 | return function(w) 791 | local pos = buf.pos 792 | buf:seek("set", offset) 793 | vstruct.write("i6x2", buf, {value}) 794 | buf:seek("set", pos) 795 | return {tag="0"} -- Unit 796 | end 797 | end 798 | end 799 | end 800 | 801 | idris["Data.Buffer.prim__getInt"] = function(buf) --64bit integer 802 | return function(offset) 803 | return function(w) 804 | local pos = buf.pos 805 | buf:seek("set", offset) 806 | local i64 = idris.tointeger(vstruct.read("i6x2" --[[ vstruct does not support 5.3 integer type, so write 48bits in any case --]], buf)[1]) 807 | if not i64 then error("unexpected float when reading Int64") end 808 | buf:seek("set", pos) 809 | return i64 810 | end 811 | end 812 | end 813 | 814 | idris["Data.Buffer.prim__setDouble"] = function(buf) --64bit float 815 | return function(offset) 816 | return function(value) 817 | return function(w) 818 | local pos = buf.pos 819 | buf:seek("set", offset) 820 | vstruct.write("f8", buf, {value}) 821 | buf:seek("set", pos) 822 | return {tag="0"} -- Unit 823 | end 824 | end 825 | end 826 | end 827 | 828 | idris["Data.Buffer.prim__getDouble"] = function(buf) 829 | return function(offset) 830 | return function(w) 831 | local pos = buf.pos 832 | buf:seek("set", offset) 833 | local f8 = vstruct.read("f8", buf)[1] 834 | buf:seek("set", pos) 835 | return f8 836 | end 837 | end 838 | end 839 | 840 | idris["Data.Buffer.prim__setString"] = function(buf) --not null-terminated string (in lua strings may contain 841 | return function(offset) --arbitrary binary data, size is always known beforehand) 842 | return function(value) 843 | return function(w) 844 | local pos = buf.pos 845 | buf:seek("set", offset) 846 | vstruct.write("s", buf, {value}) 847 | buf:seek("set", pos) 848 | return {tag="0"} -- Unit 849 | end 850 | end 851 | end 852 | end 853 | 854 | 855 | --len is raw length (in bytes not in symbol count) 856 | idris["Data.Buffer.prim__getString"] = function(buf) 857 | return function(offset) 858 | return function(len) 859 | return function(w) 860 | if len == 0 then return "" end 861 | local pos = buf.pos 862 | buf:seek("set", offset) 863 | local str = vstruct.read("s"..len, buf) 864 | buf:seek("set", pos) 865 | return str[1] 866 | end 867 | end 868 | end 869 | end 870 | 871 | --TODO copy the contents of the first over the second 872 | --that would be faster but seems to be impossible with vstruct 873 | idris["Data.Buffer.prim__copyData"] = function(bufA) 874 | return function(offsetA) 875 | return function(len) 876 | return function(bufB) 877 | return function(offsetB) 878 | return function(w) 879 | local posA = bufA.pos 880 | bufA:seek("set", offsetA) 881 | local data = vstruct.read(len.."*i1", bufA) 882 | bufA:seek("set", posA) 883 | local posB = bufB.pos 884 | bufB:seek("set", offsetB) 885 | vstruct.write(len.."*i1", bufB, data) 886 | bufB:seek("set", posB) 887 | return {tag="0"} -- Unit 888 | end 889 | end 890 | end 891 | end 892 | end 893 | end 894 | 895 | --offset is 'buf' offset 896 | idris["System.File.Buffer.prim__readBufferData"] = function(file) 897 | return function(buf) 898 | return function(offset) 899 | return function(max) 900 | return function(w) 901 | local str, err, code = file.deref.handle:read(max) 902 | local pos = buf.pos 903 | buf:seek("set", offset) 904 | vstruct.write("s", buf, {str}) 905 | buf:seek("set", pos) 906 | return #str 907 | end 908 | end 909 | end 910 | end 911 | end 912 | 913 | idris["System.File.Buffer.prim__writeBufferData"] = function(file) 914 | return function(buf) 915 | return function(offset) 916 | return function(len) 917 | return function(w) 918 | local pos = buf.pos 919 | buf:seek("set", offset) 920 | local data = vstruct.readvals("s"..len, buf) 921 | buf:seek("set", pos) 922 | file.deref.handle:write(data) 923 | return #data 924 | end 925 | end 926 | end 927 | end 928 | end 929 | 930 | idris["Data.Buffer.stringByteLength"] = function(str) 931 | return #str 932 | end 933 | 934 | ----------------------------------------------------- 935 | ------------------- Builtin ------------------------- 936 | ----------------------------------------------------- 937 | 938 | idris["System.prim__getEnv"] = function(n) 939 | return function(w) 940 | return idris.mkPtr(os.getenv(n)) 941 | end 942 | end 943 | 944 | idris["System.prim__exit"] = function(code) 945 | return function(w) 946 | os.exit(code) 947 | end 948 | end 949 | 950 | idris["System.prim__getArgCount"] = function(w) 951 | if arg then 952 | return 1 + #arg 953 | else 954 | return 0 955 | end 956 | end 957 | 958 | idris["System.prim__getArg"] = function(i) 959 | return function(w) 960 | return arg[i] 961 | end 962 | end 963 | 964 | idris["Prelude.Uninhabited.void"] = function(ty) 965 | return function(void) 966 | return "%FromVoid" 967 | end 968 | end 969 | 970 | --TODO uname may not work correctly if ulimit -Sn is not set to higher number ... 971 | function idris.getOS() 972 | local raw_os_name 973 | local env_OS = os.getenv('OS') 974 | if env_OS then 975 | raw_os_name = env_OS 976 | else 977 | -- LuaJIT shortcut 978 | if jit and jit.os then 979 | raw_os_name = jit.os 980 | else 981 | -- is popen supported? 982 | local popen_status, popen_result = pcall(io.popen, "") 983 | if popen_status then 984 | if popen_result then popen_result:close() end 985 | -- Unix-based OS 986 | raw_os_name = io.popen('uname -s'):read(idris.readl) 987 | end 988 | end 989 | end 990 | if not raw_os_name then raw_os_name = "unknown" end 991 | raw_os_name = raw_os_name:lower() 992 | 993 | local os_patterns = { 994 | ['windows'] = 'windows', 995 | ['linux'] = 'linux', 996 | ['mac'] = 'mac', 997 | ['darwin'] = 'darwin', 998 | ['^mingw'] = 'windows', 999 | ['^cygwin'] = 'windows', 1000 | ['bsd$'] = 'bsd', 1001 | ['SunOS'] = 'solaris', 1002 | } 1003 | 1004 | 1005 | local os_name = 'unknown' 1006 | 1007 | for pattern, name in pairs(os_patterns) do 1008 | if raw_os_name:match(pattern) then 1009 | os_name = name 1010 | break 1011 | end 1012 | end 1013 | return os_name 1014 | end 1015 | 1016 | idris["System.Info.prim__os"] = idris.getOS() 1017 | 1018 | idris["System.Info.prim__codegen"] = "lua" 1019 | 1020 | idris["Libraries.Utils.Term.prim__setupTerm"] = function(w) 1021 | return {tag="0"} -- Unit 1022 | end 1023 | 1024 | --TODO add native library code to deal with this 1025 | idris["Libraries.Utils.Term.prim__getTermCols"] = function () return 0 end 1026 | idris["Libraries.Utils.Term.prim__getTermLines"] = function () return 0 end 1027 | -------------------------------------------------------------------------------- /support/lua/lib.c: -------------------------------------------------------------------------------- 1 | #ifdef __cplusplus 2 | #include "lua.hpp" 3 | #else 4 | #include "lua.h" 5 | #include "lualib.h" 6 | #include "lauxlib.h" 7 | #endif 8 | #include 9 | 10 | #ifdef __cplusplus 11 | extern "C"{ 12 | #endif 13 | 14 | #define tofilep(L) ((FILE **)luaL_checkudata(L, 1, LUA_FILEHANDLE)) 15 | static FILE *tofile (lua_State *L) { 16 | FILE **f = tofilep(L); 17 | if (*f == NULL) 18 | luaL_error(L, "attempt to use a closed file"); 19 | return *f; 20 | } 21 | 22 | //non-blocking EOF check 23 | static int c_eof (lua_State *L){ 24 | FILE *file = tofile(L); 25 | int r = feof(file); 26 | lua_pushinteger(L, r); 27 | return 1; 28 | } 29 | 30 | static const struct luaL_Reg lib [] = { 31 | {"feof", c_eof}, 32 | {NULL, NULL} 33 | }; 34 | 35 | int luaopen_lua_native (lua_State *L){ 36 | #if LUA_VERSION_NUM == 501 37 | luaL_register(L, "idris2-lua-native", lib); 38 | #else 39 | luaL_newlib(L, lib); 40 | #endif 41 | return 1; 42 | } 43 | 44 | #ifdef __cplusplus 45 | } 46 | #endif 47 | -------------------------------------------------------------------------------- /tests/Main.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Data.Maybe 4 | import Data.List 5 | import Data.List1 6 | import Data.String 7 | 8 | import System 9 | import System.Directory 10 | import System.File 11 | import System.Info 12 | import System.Path 13 | 14 | %default covering 15 | 16 | ------------------------------------------------------------------------ 17 | -- Test cases 18 | 19 | chezTests : List String 20 | chezTests 21 | = ["chez001", "chez002", "chez003", {-"chez004" (Bits),-} "chez005", "chez006", 22 | "chez007", "chez008", "chez009", {- "chez010" (C callback),-} "chez011", "chez012", 23 | {-"chez013" (FFI Field),-} {-"chez014" (FFI Network),-} {- "chez015" (Int overflow) -} "chez016", "chez017", "chez018", 24 | "chez019", "chez020",{- "chez021", "chez022", "chez023", "chez024", -} 25 | "chez025", "chez026", "chez027", 26 | "reg001"] 27 | 28 | luaTests : List String 29 | luaTests = ["lua001", "lua002", "lua003", "lua004", "lua005"] 30 | 31 | ------------------------------------------------------------------------ 32 | -- Options 33 | 34 | ||| Options for the test driver. 35 | record Options where 36 | constructor MkOptions 37 | ||| Name of the idris2 executable 38 | idris2 : String 39 | ||| Name of the codegenerator to use for `exec` 40 | codegen : Maybe String 41 | ||| Should we only run some specific cases? 42 | onlyNames : List String 43 | ||| Should we run the test suite interactively? 44 | interactive : Bool 45 | 46 | usage : String 47 | usage = "Usage: runtests [--interactive]" 48 | 49 | options : List String -> Maybe Options 50 | options args = case args of 51 | (_ :: idris2 :: rest) => go rest (MkOptions idris2 Nothing [] False) 52 | _ => Nothing 53 | 54 | where 55 | 56 | go : List String -> Options -> Maybe Options 57 | go rest opts = case rest of 58 | [] => pure opts 59 | ("--interactive" :: xs) => go xs (record { interactive = True } opts) 60 | ("--cg" :: cg :: xs) => go xs (record { codegen = Just cg } opts) 61 | ("--only" :: xs) => pure $ record { onlyNames = xs } opts 62 | _ => Nothing 63 | 64 | ------------------------------------------------------------------------ 65 | -- Actual test runner 66 | 67 | fail : String -> IO () 68 | fail err 69 | = do putStrLn err 70 | exitWith (ExitFailure 1) 71 | 72 | -- on Windows, we just ignore backslashes and slashes when comparing, 73 | -- similarity up to that is good enough. Leave errors that depend 74 | -- on the confusion of slashes and backslashes to unix machines. 75 | normalize : String -> String 76 | normalize str = 77 | if isWindows 78 | then pack $ filter (\ch => ch /= '/' && ch /= '\\') (unpack str) 79 | else str 80 | 81 | runTest : Options -> String -> IO Bool 82 | runTest opts testPath 83 | = do ignore $ changeDir testPath 84 | isSuccess <- runTest' 85 | ignore $ changeDir "../.." 86 | pure isSuccess 87 | where 88 | getAnswer : IO Bool 89 | getAnswer = do 90 | str <- getLine 91 | case str of 92 | "y" => pure True 93 | "n" => pure False 94 | _ => do putStrLn "Invalid Answer." 95 | getAnswer 96 | 97 | printExpectedVsOutput : String -> String -> IO () 98 | printExpectedVsOutput exp out = do 99 | putStrLn "Expected:" 100 | printLn exp 101 | putStrLn "Given:" 102 | printLn out 103 | 104 | mayOverwrite : Maybe String -> String -> IO () 105 | mayOverwrite mexp out = do 106 | the (IO ()) $ case mexp of 107 | Nothing => putStr $ unlines 108 | [ "Golden value missing. I computed the following result:" 109 | , out 110 | , "Accept new golden value? [yn]" 111 | ] 112 | Just exp => do 113 | putStrLn "Golden value differs from actual value." 114 | code <- system "git diff --no-index --exit-code --word-diff=color expected output" 115 | when (code < 0) $ printExpectedVsOutput exp out 116 | putStrLn "Accept actual value as new golden value? [yn]" 117 | b <- getAnswer 118 | when b $ do Right _ <- writeFile "expected" out 119 | | Left err => print err 120 | pure () 121 | runTest' : IO Bool 122 | runTest' 123 | = do putStr $ testPath ++ ": " 124 | ignore $ system $ "sh ./run " ++ idris2 opts ++ " | tr -d '\\r' > output" 125 | Right out <- readFile "output" 126 | | Left err => do print err 127 | pure False 128 | Right exp <- readFile "expected" 129 | | Left FileNotFound => do 130 | if interactive opts 131 | then mayOverwrite Nothing out 132 | else print FileNotFound 133 | pure False 134 | | Left err => do print err 135 | pure False 136 | let result = normalize out == normalize exp 137 | -- The issue #116 that made this necessary is fixed, but 138 | -- please resist putting 'result' here until it's also 139 | -- fixed in Idris2-boot! 140 | if normalize out == normalize exp 141 | then putStrLn "success" 142 | else do 143 | putStrLn "FAILURE" 144 | if interactive opts 145 | then mayOverwrite (Just exp) out 146 | else printExpectedVsOutput exp out 147 | 148 | pure result 149 | 150 | exists : String -> IO Bool 151 | exists f 152 | = do Right ok <- openFile f Read 153 | | Left err => pure False 154 | closeFile ok 155 | pure True 156 | 157 | firstExists : List String -> IO (Maybe String) 158 | firstExists [] = pure Nothing 159 | firstExists (x :: xs) = if !(exists x) then pure (Just x) else firstExists xs 160 | 161 | pathLookup : List String -> IO (Maybe String) 162 | pathLookup names = do 163 | path <- getEnv "PATH" 164 | let pathList = List1.forget $ split (== pathSeparator) $ fromMaybe "/usr/bin:/usr/local/bin" path 165 | let candidates = [p ++ "/" ++ x | p <- pathList, 166 | x <- names] 167 | firstExists candidates 168 | 169 | findLua : IO (Maybe String) 170 | findLua 171 | = do Just lua <- getEnv "LuaExe" | Nothing => pathLookup ["lua"] 172 | pure $ Just lua 173 | 174 | runLuaTests : Options -> List String -> IO (List Bool) 175 | runLuaTests opts tests 176 | = do chexec <- findLua 177 | maybe (do putStrLn "Lua not found" 178 | pure []) 179 | (\c => do putStrLn $ "Found Lua at " ++ c 180 | traverse (runTest opts) tests) 181 | chexec 182 | 183 | filterTests : Options -> List String -> List String 184 | filterTests opts = case onlyNames opts of 185 | [] => id 186 | xs => filter (\ name => any (`isInfixOf` name) xs) 187 | 188 | main : IO () 189 | main 190 | = do args <- getArgs 191 | let (Just opts) = options args 192 | | _ => do print args 193 | putStrLn usage 194 | 195 | let filteredNonCGTests = 196 | filterTests opts $ concat $ the (List _) [ 197 | testPaths "chez" chezTests 198 | , testPaths "lua" luaTests 199 | ] 200 | 201 | res <- runLuaTests opts $ filteredNonCGTests 202 | 203 | putStrLn (show (length (filter id res)) ++ "/" ++ show (length res) 204 | ++ " tests successful") 205 | if (any not res) 206 | then exitWith (ExitFailure 1) 207 | else exitWith ExitSuccess 208 | where 209 | testPaths : String -> List String -> List String 210 | testPaths dir tests = map (\test => dir ++ "/" ++ test) tests 211 | -------------------------------------------------------------------------------- /tests/Makefile: -------------------------------------------------------------------------------- 1 | INTERACTIVE ?= --interactive 2 | 3 | IDRIS2 ?= idris2 4 | IDRIS2_LUA ?= ../build/exec/idris2-lua 5 | .PHONY: testbin test 6 | 7 | test: 8 | $(IDRIS2) --build tests.ipkg && ./build/exec/runtests ../../$(IDRIS2_LUA) $(INTERACTIVE) --cg lua --only $(only) 9 | 10 | clean: 11 | $(RM) -r build 12 | @find . -type f -name 'output' -exec rm -rf {} \; 13 | @find . -type f -name '*.ttc' -exec rm -f {} \; 14 | @find . -type f -name '*.ttm' -exec rm -f {} \; 15 | -------------------------------------------------------------------------------- /tests/chez/chez001/Total.idr: -------------------------------------------------------------------------------- 1 | count : Nat -> Stream Nat 2 | count n = n :: count (S n) 3 | 4 | badCount : Nat -> Stream Nat 5 | badCount n = n :: map S (badCount n) 6 | 7 | data SP : Type -> Type -> Type where 8 | Get : (a -> SP a b) -> SP a b 9 | Put : b -> Inf (SP a b) -> SP a b 10 | 11 | copy : SP a a 12 | copy = Get (\x => Put x copy) 13 | 14 | process : SP a b -> Stream a -> Stream b 15 | process (Get f) (x :: xs) = process (f x) xs 16 | process (Put b sp) xs = b :: process sp xs 17 | 18 | badProcess : SP a b -> Stream a -> Stream b 19 | badProcess (Get f) (x :: xs) = badProcess (f x) xs 20 | badProcess (Put b sp) xs = badProcess sp xs 21 | 22 | doubleInt : SP Nat Integer 23 | doubleInt = Get (\x => Put (the Integer (cast x)) 24 | (Put (the Integer (cast x) * 2) doubleInt)) 25 | 26 | countStream : Nat -> Stream Nat 27 | countStream x = x :: countStream (x + 1) 28 | 29 | main : IO () 30 | main = printLn (take 10 (process doubleInt (countStream 1))) 31 | -------------------------------------------------------------------------------- /tests/chez/chez001/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building Total (Total.idr) 2 | Main> [1, 2, 2, 4, 3, 6, 4, 8, 5, 10] 3 | Main> Bye for now! 4 | -------------------------------------------------------------------------------- /tests/chez/chez001/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez001/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner Total.idr < input 2 | 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/chez/chez002/Pythag.idr: -------------------------------------------------------------------------------- 1 | range : Integer -> Integer -> List Integer 2 | range bottom top 3 | = if bottom > top then [] 4 | else bottom :: range (bottom + 1) top 5 | 6 | pythag : Integer -> List (Integer, Integer, Integer) 7 | pythag top 8 | = [(x, y, z) | z <- range 1 top, y <- range 1 z, x <- range 1 y, 9 | x * x + y * y == z * z] 10 | -------------------------------------------------------------------------------- /tests/chez/chez002/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building Pythag (Pythag.idr) 2 | Main> [(3, (4, 5)), (6, (8, 10)), (5, (12, 13)), (9, (12, 15)), (8, (15, 17)), (12, (16, 20)), (15, (20, 25)), (7, (24, 25)), (10, (24, 26)), (20, (21, 29)), (18, (24, 30)), (16, (30, 34)), (21, (28, 35)), (12, (35, 37)), (15, (36, 39)), (24, (32, 40)), (9, (40, 41)), (27, (36, 45)), (30, (40, 50)), (14, (48, 50))] 3 | Main> Bye for now! 4 | -------------------------------------------------------------------------------- /tests/chez/chez002/input: -------------------------------------------------------------------------------- 1 | :exec printLn (pythag 50) 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez002/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner Pythag.idr < input 2 | rm -rf build 3 | -------------------------------------------------------------------------------- /tests/chez/chez003/IORef.idr: -------------------------------------------------------------------------------- 1 | import Data.IORef 2 | 3 | main : IO () 4 | main 5 | = do x <- newIORef 42 6 | let y = x 7 | writeIORef y 94 8 | val <- readIORef x 9 | printLn val 10 | val <- readIORef y 11 | printLn val 12 | modifyIORef x (* 2) 13 | val <- readIORef x 14 | printLn val 15 | val <- readIORef y 16 | printLn val 17 | -------------------------------------------------------------------------------- /tests/chez/chez003/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building IORef (IORef.idr) 2 | Main> 94 3 | 94 4 | 188 5 | 188 6 | Main> Bye for now! 7 | -------------------------------------------------------------------------------- /tests/chez/chez003/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez003/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner IORef.idr < input 2 | rm -rf build 3 | -------------------------------------------------------------------------------- /tests/chez/chez004/Buffer.idr: -------------------------------------------------------------------------------- 1 | import Data.Buffer 2 | import System.File 3 | import Debug.Buffer 4 | 5 | main : IO () 6 | main 7 | = do Just buf <- newBuffer 100 8 | | Nothing => putStrLn "Buffer creation failed" 9 | s <- rawSize buf 10 | printLn s 11 | 12 | setInt32 buf 1 94 13 | setString buf 5 "AAAA" 14 | val <- getInt32 buf 1 15 | printLn val 16 | 17 | setDouble buf 10 94.42 18 | val <- getDouble buf 10 19 | printLn val 20 | 21 | setString buf 20 "Hello there!" 22 | val <- getString buf 20 5 23 | printLn val 24 | 25 | val <- getString buf 26 6 26 | printLn val 27 | 28 | setBits16 buf 32 65535 29 | val <- getBits16 buf 32 30 | printLn val 31 | 32 | ds <- bufferData buf 33 | printLn ds 34 | 35 | Right _ <- writeBufferToFile "test.buf" buf 100 36 | | Left err => putStrLn "Buffer write fail" 37 | Right buf2 <- createBufferFromFile "test.buf" 38 | | Left err => putStrLn "Buffer read fail" 39 | 40 | ds <- bufferData buf2 41 | printLn ds 42 | 43 | setByte buf2 0 1 44 | Just ccBuf <- concatBuffers [buf, buf2] 45 | | Nothing => putStrLn "Buffer concat failed" 46 | printLn !(bufferData ccBuf) 47 | 48 | Just (a, b) <- splitBuffer buf 20 49 | | Nothing => putStrLn "Buffer split failed" 50 | printBuffer a 51 | printBuffer b 52 | freeBuffer buf 53 | freeBuffer buf2 54 | 55 | -- Put back when the File API is moved to C and these can work again 56 | -- Right f <- openBinaryFile "test.buf" Read 57 | -- | Left err => putStrLn "File error on read" 58 | -- Just buf3 <- newBuffer 99 59 | -- | Nothing => putStrLn "Buffer creation failed" 60 | -- Right _ <- readBufferFromFile f buf3 100 61 | -- | Left err => do putStrLn "Buffer read fail" 62 | -- closeFile f 63 | -- closeFile f 64 | 65 | -------------------------------------------------------------------------------- /tests/chez/chez004/expected: -------------------------------------------------------------------------------- 1 | 100 2 | 94 3 | 94.42 4 | "Hello" 5 | "there!" 6 | 65535 7 | [0, 94, 0, 0, 0, 65, 65, 65, 65, 0, 123, 20, 174, 71, 225, 154, 87, 64, 0, 0, 72, 101, 108, 108, 111, 32, 116, 104, 101, 114, 101, 33, 255, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] 8 | [0, 94, 0, 0, 0, 65, 65, 65, 65, 0, 123, 20, 174, 71, 225, 154, 87, 64, 0, 0, 72, 101, 108, 108, 111, 32, 116, 104, 101, 114, 101, 33, 255, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] 9 | [0, 94, 0, 0, 0, 65, 65, 65, 65, 0, 123, 20, 174, 71, 225, 154, 87, 64, 0, 0, 72, 101, 108, 108, 111, 32, 116, 104, 101, 114, 101, 33, 255, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 94, 0, 0, 0, 65, 65, 65, 65, 0, 123, 20, 174, 71, 225, 154, 87, 64, 0, 0, 72, 101, 108, 108, 111, 32, 116, 104, 101, 114, 101, 33, 255, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0] 10 | 00 5E 00 00 00 41 41 41 41 00 7B 14 AE 47 E1 9A .^...AAAA.{..G.. 11 | 57 40 00 00 W@.. 12 | 13 | total size = 20 14 | 48 65 6C 6C 6F 20 74 68 65 72 65 21 FF FF 00 00 Hello there!.... 15 | 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................ 16 | 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................ 17 | 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................ 18 | 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 ................ 19 | 20 | total size = 80 21 | 1/1: Building Buffer (Buffer.idr) 22 | Main> Main> Bye for now! 23 | -------------------------------------------------------------------------------- /tests/chez/chez004/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez004/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 -p contrib --no-banner Buffer.idr < input 2 | rm -rf build test.buf 3 | -------------------------------------------------------------------------------- /tests/chez/chez005/Filter.idr: -------------------------------------------------------------------------------- 1 | data Vect : Nat -> Type -> Type where 2 | Nil : Vect Z a 3 | (::) : a -> Vect k a -> Vect (S k) a 4 | 5 | Show a => Show (Vect n a) where 6 | show xs = "[" ++ showV xs ++ "]" 7 | where 8 | showV : forall n . Vect n a -> String 9 | showV [] = "" 10 | showV [x] = show x 11 | showV (x :: xs) = show x ++ ", " ++ showV xs 12 | 13 | filter : (a -> Bool) -> Vect n a -> (p ** Vect p a) 14 | filter pred [] = (_ ** []) 15 | filter pred (x :: xs) 16 | = let (n ** xs') = filter pred xs in 17 | if pred x 18 | then (_ ** x :: xs') 19 | else (_ ** xs') 20 | 21 | test : (x ** Vect x Nat) 22 | test = (_ ** [1,2]) 23 | 24 | foo : String 25 | foo = show test 26 | 27 | even : Nat -> Bool 28 | even Z = True 29 | even (S k) = not (even k) 30 | -------------------------------------------------------------------------------- /tests/chez/chez005/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building Filter (Filter.idr) 2 | Main> (3 ** [2, 4, 6]) 3 | Main> Bye for now! 4 | -------------------------------------------------------------------------------- /tests/chez/chez005/input: -------------------------------------------------------------------------------- 1 | :exec printLn (filter even [S Z,2,3,4,5,6]) 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez005/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner Filter.idr < input 2 | 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/chez/chez006/TypeCase.idr: -------------------------------------------------------------------------------- 1 | data Bar = MkBar 2 | data Baz = MkBaz 3 | 4 | foo : (x : Type) -> String 5 | foo Nat = "Nat" 6 | foo Bool = "Bool" 7 | foo (List x) = "List of " ++ foo x 8 | foo Int = "Int" 9 | foo Type = "Type" 10 | foo _ = "Something else" 11 | 12 | strangeId : {a : Type} -> a -> a 13 | strangeId {a=Integer} x = x+1 14 | strangeId x = x 15 | 16 | partial 17 | strangeId' : {a : Type} -> a -> a 18 | strangeId' {a=Integer} x = x+1 19 | 20 | main : IO () 21 | main = do printLn (foo Nat) 22 | printLn (foo (List Nat)) 23 | printLn (foo (List Bar)) 24 | printLn (foo (List Baz)) 25 | printLn (foo (List Bool)) 26 | printLn (foo Int) 27 | printLn (foo String) 28 | printLn (foo (List Type)) 29 | printLn (foo (List Int)) 30 | printLn (strangeId 42) 31 | printLn (strangeId (the Int 42)) 32 | 33 | -------------------------------------------------------------------------------- /tests/chez/chez006/TypeCase2.idr: -------------------------------------------------------------------------------- 1 | data Bar = MkBar 2 | data Baz = MkBaz 3 | 4 | strangeId : a -> a 5 | strangeId {a=Nat} x = x+1 6 | strangeId x = x 7 | 8 | foo : (0 x : Type) -> String 9 | foo Nat = "Nat" 10 | foo Bool = "Bool" 11 | foo (List x) = "List of " ++ foo x 12 | foo Int = "Int" 13 | foo Type = "Type" 14 | foo _ = "Something else" 15 | -------------------------------------------------------------------------------- /tests/chez/chez006/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building TypeCase (TypeCase.idr) 2 | Main> "Nat" 3 | "List of Nat" 4 | "List of Something else" 5 | "List of Something else" 6 | "List of Bool" 7 | "Int" 8 | "Something else" 9 | "List of Type" 10 | "List of Int" 11 | 43 12 | 42 13 | Main> Main.strangeId is total 14 | Main> Main.strangeId': strangeId' _ 15 | Main> Bye for now! 16 | 1/1: Building TypeCase2 (TypeCase2.idr) 17 | Error: While processing left hand side of strangeId. Can't match on Nat (Erased argument). 18 | 19 | TypeCase2:5:14--5:17 20 | 1 | data Bar = MkBar 21 | 2 | data Baz = MkBaz 22 | 3 | 23 | 4 | strangeId : a -> a 24 | 5 | strangeId {a=Nat} x = x+1 25 | ^^^ 26 | 27 | Error: While processing left hand side of foo. Can't match on Nat (Erased argument). 28 | 29 | TypeCase2:9:5--9:8 30 | 5 | strangeId {a=Nat} x = x+1 31 | 6 | strangeId x = x 32 | 7 | 33 | 8 | foo : (0 x : Type) -> String 34 | 9 | foo Nat = "Nat" 35 | ^^^ 36 | 37 | -------------------------------------------------------------------------------- /tests/chez/chez006/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :total strangeId 3 | :missing strangeId' 4 | :q 5 | -------------------------------------------------------------------------------- /tests/chez/chez006/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner TypeCase.idr < input 2 | $1 --no-color --console-width 0 --no-banner TypeCase2.idr --check 3 | 4 | rm -rf build 5 | -------------------------------------------------------------------------------- /tests/chez/chez007/TypeCase.idr: -------------------------------------------------------------------------------- 1 | data Bar = MkBar 2 | data Baz = MkBaz 3 | 4 | data Vect : Nat -> Type -> Type where 5 | Nil : Vect Z a 6 | (::) : a -> Vect k a -> Vect (S k) a 7 | 8 | desc : Type -> String 9 | desc Int = "Int" 10 | desc Nat = "Nat" 11 | desc (Vect n a) = "Vector of " ++ show n ++ " " ++ desc a 12 | desc Type = "Type" 13 | desc _ = "Something else" 14 | 15 | descNat : Type -> String 16 | descNat t = "Function from Nat to " ++ desc t 17 | 18 | descFn : (x : Type) -> String 19 | descFn ((x : Nat) -> b) = descNat (b Z) 20 | descFn (a -> b) = "Function on " ++ desc a 21 | descFn x = desc x 22 | 23 | main : IO () 24 | main = do printLn (descFn (Nat -> Nat)) 25 | printLn (descFn ((x : Nat) -> Vect x Int)) 26 | printLn (descFn (Type -> Int)) 27 | -------------------------------------------------------------------------------- /tests/chez/chez007/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building TypeCase (TypeCase.idr) 2 | Main> "Function from Nat to Nat" 3 | "Function from Nat to Vector of 0 Int" 4 | "Function on Type" 5 | Main> Bye for now! 6 | -------------------------------------------------------------------------------- /tests/chez/chez007/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez007/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner TypeCase.idr < input 2 | 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/chez/chez008/Nat.idr: -------------------------------------------------------------------------------- 1 | myS : Nat -> Nat 2 | myS n = S n 3 | 4 | myS_crash : Nat -> Nat 5 | myS_crash = S 6 | 7 | main : IO () 8 | main = do 9 | printLn (S Z) 10 | printLn (myS Z) 11 | printLn (myS_crash Z) 12 | -------------------------------------------------------------------------------- /tests/chez/chez008/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building Nat (Nat.idr) 2 | Main> 1 3 | 1 4 | 1 5 | Main> Bye for now! 6 | -------------------------------------------------------------------------------- /tests/chez/chez008/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez008/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner Nat.idr < input 2 | 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/chez/chez009/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building uni (uni.idr) 2 | Main> 42 3 | ällo 4 | Main> Bye for now! 5 | -------------------------------------------------------------------------------- /tests/chez/chez009/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez009/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner uni.idr < input 2 | 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/chez/chez009/uni.idr: -------------------------------------------------------------------------------- 1 | foo : String 2 | foo = "ällo" 3 | 4 | ällo : Int 5 | ällo = 42 6 | 7 | main : IO () 8 | main = do printLn ällo 9 | putStrLn "ällo" 10 | -------------------------------------------------------------------------------- /tests/chez/chez010/.gitignore: -------------------------------------------------------------------------------- 1 | *.d 2 | *.o 3 | *.obj 4 | *.so 5 | *.dylib 6 | *.dll 7 | -------------------------------------------------------------------------------- /tests/chez/chez010/CB.idr: -------------------------------------------------------------------------------- 1 | libcb : String -> String 2 | libcb f = "C:" ++ f ++", libcb" 3 | 4 | %foreign libcb "add" 5 | add : Int -> Int -> Int 6 | 7 | %foreign libcb "applyIntFn" 8 | prim__applyIntFn : Int -> Int -> (Int -> Int -> PrimIO Int) -> PrimIO Int 9 | 10 | %foreign libcb "applyCharFn" 11 | prim__applyCharFn : Char -> Int -> (Char -> Int -> PrimIO Char) -> PrimIO Char 12 | 13 | %foreign libcb "applyIntFnPure" 14 | applyIntFnPure : Int -> Int -> (Int -> Int -> Int) -> Int 15 | 16 | applyIntFn : HasIO io => Int -> Int -> (Int -> Int -> IO Int) -> io Int 17 | applyIntFn x y fn 18 | = primIO $ prim__applyIntFn x y (\a, b => toPrim (fn a b)) 19 | 20 | applyCharFn : HasIO io => Char -> Int -> (Char -> Int -> IO Char) -> io Char 21 | applyCharFn x y fn 22 | = primIO $ prim__applyCharFn x y (\a, b => toPrim (fn a b)) 23 | 24 | cb : Int -> Int -> IO Int 25 | cb x y 26 | = do putStrLn $ "In callback with " ++ show (x, y) 27 | pure (x + y) 28 | 29 | main : IO () 30 | main 31 | = do printLn (add 4 5) 32 | res <- applyIntFn (add 4 5) 6 (\x, y => do putStrLn "In callback" 33 | pure (x * 2 + y)) 34 | printLn res 35 | res <- applyIntFn 1 2 cb 36 | printLn res 37 | printLn (applyIntFnPure 5 4 (\x, y => x + y)) 38 | res <- applyCharFn 'a' 10 (\x, y => pure (cast (cast x + y))) 39 | printLn res 40 | -------------------------------------------------------------------------------- /tests/chez/chez010/Makefile: -------------------------------------------------------------------------------- 1 | include ../../../config.mk 2 | 3 | TARGET = libcb 4 | 5 | SRCS = $(wildcard *.c) 6 | OBJS = $(SRCS:.c=.o) 7 | DEPS = $(OBJS:.o=.d) 8 | 9 | 10 | all: $(TARGET)$(SHLIB_SUFFIX) 11 | 12 | $(TARGET)$(SHLIB_SUFFIX): $(OBJS) 13 | $(CC) -shared $(LDFLAGS) -o $@ $^ 14 | 15 | 16 | -include $(DEPS) 17 | 18 | %.d: %.c 19 | @$(CPP) $(CFLAGS) $< -MM -MT $(@:.d=.o) >$@ 20 | 21 | 22 | .PHONY: clean 23 | 24 | clean : 25 | $(RM) $(OBJS) $(TARGET)$(SHLIB_SUFFIX) 26 | 27 | cleandep: clean 28 | $(RM) $(DEPS) 29 | -------------------------------------------------------------------------------- /tests/chez/chez010/cblib.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | typedef int(*IntFn)(int, int); 4 | typedef char(*CharFn)(char, int); 5 | 6 | int add(int x, int y) { 7 | return x+y; 8 | } 9 | 10 | int applyIntFn(int x, int y, IntFn f) { 11 | printf("Callback coming\n"); 12 | fflush(stdout); 13 | return f(x, y); 14 | } 15 | 16 | int applyIntFnPure(int x, int y, IntFn f) { 17 | return f(x, y); 18 | } 19 | 20 | char applyCharFn(char c, int x, CharFn f) { 21 | return f(c, x); 22 | } 23 | 24 | -------------------------------------------------------------------------------- /tests/chez/chez010/expected: -------------------------------------------------------------------------------- 1 | 9 2 | Callback coming 3 | In callback 4 | 24 5 | Callback coming 6 | In callback with (1, 2) 7 | 3 8 | 9 9 | 'k' 10 | 1/1: Building CB (CB.idr) 11 | Main> Main> Bye for now! 12 | -------------------------------------------------------------------------------- /tests/chez/chez010/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez010/run: -------------------------------------------------------------------------------- 1 | case `uname -s` in 2 | OpenBSD|FreeBSD|NetBSD) 3 | MAKE=gmake 4 | ;; 5 | 6 | *) 7 | MAKE=make 8 | ;; 9 | esac 10 | 11 | ${MAKE} all > /dev/null 12 | $1 --no-color --console-width 0 --no-banner CB.idr < input 13 | rm -rf build 14 | ${MAKE} clean > /dev/null 15 | -------------------------------------------------------------------------------- /tests/chez/chez011/bangs.idr: -------------------------------------------------------------------------------- 1 | 2 | add : Int -> Int -> Int 3 | add = (+) 4 | 5 | -- lift to nearest binder 6 | addm1 : Maybe Int -> Maybe Int -> Maybe Int 7 | addm1 x y = let z = x in pure (add !z !y) 8 | 9 | -- lift to nearest binder 10 | addm2 : Maybe Int -> Maybe Int -> Maybe Int 11 | addm2 = \x, y => pure (!x + !y) 12 | 13 | getLen : String -> IO Nat 14 | getLen str = pure (length str) 15 | 16 | fakeGetLine : String -> IO String 17 | fakeGetLine str = pure str 18 | 19 | -- lift out innermost first 20 | printThing1 : IO () 21 | printThing1 = printLn !(getLen !(fakeGetLine "line1")) 22 | 23 | -- lift out leftmost first 24 | printThing2 : IO () 25 | printThing2 = printLn (!(fakeGetLine "1") ++ !(fakeGetLine "2")) 26 | 27 | -- don't lift out of if 28 | printBool : Bool -> IO () 29 | printBool x 30 | = if x 31 | then putStrLn !(fakeGetLine "True") 32 | else putStrLn !(fakeGetLine "False") 33 | -------------------------------------------------------------------------------- /tests/chez/chez011/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building bangs (bangs.idr) 2 | Main> Just 7 3 | Main> Just 7 4 | Main> 5 5 | Main> "12" 6 | Main> True 7 | Main> False 8 | Main> Bye for now! 9 | -------------------------------------------------------------------------------- /tests/chez/chez011/input: -------------------------------------------------------------------------------- 1 | addm1 (Just 3) (Just 4) 2 | addm2 (Just 3) (Just 4) 3 | :exec printThing1 4 | :exec printThing2 5 | :exec printBool True 6 | :exec printBool False 7 | :q 8 | -------------------------------------------------------------------------------- /tests/chez/chez011/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner bangs.idr < input 2 | 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/chez/chez012/array.idr: -------------------------------------------------------------------------------- 1 | import Data.IOArray 2 | 3 | main : IO () 4 | main 5 | = do x <- newArray {io = IO, elem = String} 20 6 | ignore $ writeArray {io = IO} x 10 "Hello" 7 | ignore $ writeArray {io = IO} x 11 "World" 8 | printLn !(toList x) 9 | 10 | y <- fromList (map Just [1,2,3,4,5]) 11 | printLn !(toList y) 12 | -------------------------------------------------------------------------------- /tests/chez/chez012/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building array (array.idr) 2 | Main> [Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Just "Hello", Just "World", Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing] 3 | [Just 1, Just 2, Just 3, Just 4, Just 5] 4 | Main> Bye for now! 5 | -------------------------------------------------------------------------------- /tests/chez/chez012/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez012/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner array.idr < input 2 | rm -rf build 3 | -------------------------------------------------------------------------------- /tests/chez/chez013/.gitignore: -------------------------------------------------------------------------------- 1 | *.d 2 | *.o 3 | *.obj 4 | *.so 5 | *.dylib 6 | *.dll 7 | 8 | -------------------------------------------------------------------------------- /tests/chez/chez013/Makefile: -------------------------------------------------------------------------------- 1 | include ../../../config.mk 2 | 3 | TARGET = libstruct 4 | 5 | SRCS = $(wildcard *.c) 6 | OBJS = $(SRCS:.c=.o) 7 | DEPS = $(OBJS:.o=.d) 8 | 9 | 10 | all: $(TARGET)$(SHLIB_SUFFIX) 11 | 12 | $(TARGET)$(SHLIB_SUFFIX): $(OBJS) 13 | $(CC) -shared $(LDFLAGS) -o $@ $^ 14 | 15 | 16 | -include $(DEPS) 17 | 18 | %.d: %.c 19 | @$(CPP) $(CFLAGS) $< -MM -MT $(@:.d=.o) >$@ 20 | 21 | 22 | .PHONY: clean 23 | 24 | clean : 25 | $(RM) $(OBJS) $(TARGET)$(SHLIB_SUFFIX) 26 | 27 | cleandep: clean 28 | $(RM) $(DEPS) 29 | -------------------------------------------------------------------------------- /tests/chez/chez013/Struct.idr: -------------------------------------------------------------------------------- 1 | import System.FFI 2 | 3 | pfn : String -> String 4 | pfn fn = "C:" ++ fn ++ ",libstruct" 5 | 6 | Point : Type 7 | Point = Struct "point" [("x", Int), ("y", Int)] 8 | 9 | NamedPoint : Type 10 | NamedPoint = Struct "namedpoint" [("name", Ptr String), ("pt", Point)] 11 | 12 | %foreign (pfn "getString") 13 | getStr : Ptr String -> String 14 | 15 | %foreign (pfn "mkPoint") 16 | mkPoint : Int -> Int -> Point 17 | 18 | %foreign (pfn "freePoint") 19 | freePoint : Point -> PrimIO () 20 | 21 | %foreign (pfn "mkNamedPoint") 22 | mkNamedPoint : String -> Point -> PrimIO NamedPoint 23 | 24 | %foreign (pfn "freeNamedPoint") 25 | freeNamedPoint : NamedPoint -> PrimIO () 26 | 27 | showPoint : Point -> String 28 | showPoint pt 29 | = let x : Int = getField pt "x" 30 | y : Int = getField pt "y" in 31 | show (x, y) 32 | 33 | showNamedPoint : NamedPoint -> String 34 | showNamedPoint pt 35 | = let x : String = getStr (getField pt "name") 36 | p : Point = getField pt "pt" in 37 | show x ++ ": " ++ showPoint p 38 | 39 | main : IO () 40 | main = do let pt = mkPoint 20 30 41 | np <- primIO $ mkNamedPoint "Here" pt 42 | setField pt "x" (the Int 40) 43 | putStrLn $ showPoint pt 44 | putStrLn $ showNamedPoint np 45 | 46 | primIO $ freeNamedPoint np 47 | primIO $ freePoint pt 48 | -------------------------------------------------------------------------------- /tests/chez/chez013/expected: -------------------------------------------------------------------------------- 1 | Made it! 2 | (40, 30) 3 | "Here": (40, 30) 4 | 1/1: Building Struct (Struct.idr) 5 | Main> Main> Bye for now! 6 | -------------------------------------------------------------------------------- /tests/chez/chez013/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez013/run: -------------------------------------------------------------------------------- 1 | case `uname -s` in 2 | OpenBSD|FreeBSD|NetBSD) 3 | MAKE=gmake 4 | ;; 5 | 6 | *) 7 | MAKE=make 8 | ;; 9 | esac 10 | 11 | ${MAKE} all > /dev/null 12 | $1 --no-color --console-width 0 --no-banner Struct.idr < input 13 | rm -rf build 14 | ${MAKE} clean > /dev/null 15 | -------------------------------------------------------------------------------- /tests/chez/chez013/struct.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "struct.h" 4 | 5 | char* getString(void *p) { 6 | return (char*)p; 7 | } 8 | 9 | point* mkPoint(int x, int y) { 10 | point* pt = malloc(sizeof(point)); 11 | pt->x = x; 12 | pt->y = y; 13 | return pt; 14 | } 15 | 16 | void freePoint(point* pt) { 17 | free(pt); 18 | } 19 | 20 | namedpoint* mkNamedPoint(char* str, point* p) { 21 | namedpoint* np = malloc(sizeof(namedpoint)); 22 | np->name = str; 23 | np->pt = p; 24 | printf("Made it!\n"); 25 | 26 | return np; 27 | } 28 | 29 | void freeNamedPoint(namedpoint* np) { 30 | free(np); 31 | } 32 | 33 | -------------------------------------------------------------------------------- /tests/chez/chez013/struct.h: -------------------------------------------------------------------------------- 1 | #ifndef _STRUCT_H 2 | #define _STRUCT_H 3 | 4 | typedef struct { 5 | int x; 6 | int y; 7 | } point; 8 | 9 | typedef struct { 10 | char* name; 11 | point* pt; 12 | } namedpoint; 13 | 14 | point* mkPoint(int x, int y); 15 | void freePoint(point* pt); 16 | 17 | namedpoint* mkNamedPoint(char* str, point* p); 18 | void freeNamedPoint(namedpoint* np); 19 | 20 | char* getString(void *p); 21 | 22 | #endif 23 | -------------------------------------------------------------------------------- /tests/chez/chez014/Echo.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import System 4 | import System.Info 5 | import Network.Socket 6 | import Network.Socket.Data 7 | import Network.Socket.Raw 8 | 9 | runServer : IO (Either String (Port, ThreadID)) 10 | runServer = do 11 | Right sock <- socket AF_INET Stream 0 12 | | Left fail => pure (Left $ "Failed to open socket: " ++ show fail) 13 | res <- bind sock (Just (Hostname "localhost")) 0 14 | if res /= 0 15 | then pure (Left $ "Failed to bind socket with error: " ++ show res) 16 | else do 17 | port <- getSockPort sock 18 | res <- listen sock 19 | if res /= 0 20 | then pure (Left $ "Failed to listen on socket with error: " ++ show res) 21 | else do 22 | forked <- fork (serve port sock) 23 | pure $ Right (port, forked) 24 | 25 | where 26 | serve : Port -> Socket -> IO () 27 | serve port sock = do 28 | Right (s, _) <- accept sock 29 | | Left err => putStrLn ("Failed to accept on socket with error: " ++ show err) 30 | Right (str, _) <- recv s 1024 31 | | Left err => putStrLn ("Failed to accept on socket with error: " ++ show err) 32 | putStrLn ("Received: " ++ str) 33 | Right n <- send s ("echo: " ++ str) 34 | | Left err => putStrLn ("Server failed to send data with error: " ++ show err) 35 | pure () 36 | 37 | runClient : Port -> IO () 38 | runClient serverPort = do 39 | Right sock <- socket AF_INET Stream 0 40 | | Left fail => putStrLn ("Failed to open socket: " ++ show fail) 41 | res <- connect sock (Hostname "localhost") serverPort 42 | if res /= 0 43 | then putStrLn ("Failed to connect client to port " ++ show serverPort ++ ": " ++ show res) 44 | else do 45 | Right n <- send sock ("hello world!") 46 | | Left err => putStrLn ("Client failed to send data with error: " ++ show err) 47 | Right (str, _) <- recv sock 1024 48 | | Left err => putStrLn ("Client failed to receive on socket with error: " ++ show err) 49 | -- assuming that stdout buffers get flushed in between system calls, this is "guaranteed" 50 | -- to be printed after the server prints its own message 51 | putStrLn ("Received: " ++ str) 52 | 53 | main : IO () 54 | main = do 55 | Right (serverPort, tid) <- runServer 56 | | Left err => putStrLn $ "[server] " ++ err 57 | runClient serverPort 58 | -------------------------------------------------------------------------------- /tests/chez/chez014/expected: -------------------------------------------------------------------------------- 1 | Received: hello world! 2 | Received: echo: hello world! 3 | 1/1: Building Echo (Echo.idr) 4 | Main> Main> Bye for now! 5 | -------------------------------------------------------------------------------- /tests/chez/chez014/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez014/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner -p network Echo.idr < input 2 | 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/chez/chez015/Numbers.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Data.List 4 | 5 | %default partial 6 | 7 | large : (a: Type) -> a 8 | -- integer larger than 64 bits 9 | large Integer = 3518437212345678901234567890123 10 | -- int close to 2ˆ63 11 | -- we expect some operations will overflow 12 | large Int = 3518437212345678901234567890 13 | 14 | small : (a: Type) -> a 15 | small Integer = 437 16 | small Int = 377 17 | 18 | numOps : (Num a) => List ( a -> a -> a ) 19 | numOps = [ (+), (*) ] 20 | 21 | negOps : (Neg a) => List (a -> a -> a) 22 | negOps = [ (-) ] 23 | 24 | integralOps : (Integral a) => List (a -> a -> a) 25 | integralOps = [ div, mod ] 26 | 27 | binOps : (Num a, Neg a, Integral a) => List (a -> a -> a) 28 | binOps = numOps ++ negOps ++ integralOps 29 | 30 | main : IO () 31 | main = do 32 | putStrLn $ show (results Integer) 33 | putStrLn $ show (results Int) 34 | where 35 | results : (a:Type) -> (Num a, Neg a, Integral a) => List a 36 | results a = map (\ op => large a `op` small a) binOps 37 | -------------------------------------------------------------------------------- /tests/chez/chez015/expected: -------------------------------------------------------------------------------- 1 | [3518437212345678901234567890560, 1537557061795061679839506167983751, 3518437212345678901234567889686, 8051343735344802977653473432, 339] 2 | [8650625671965379659, 5435549321212129090, 8650625671965378905, 365458446121836181, 357] 3 | 1/1: Building Numbers (Numbers.idr) 4 | Main> Main> Bye for now! 5 | -------------------------------------------------------------------------------- /tests/chez/chez015/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez015/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner Numbers.idr < input 2 | 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/chez/chez016/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building Main (Main.idr) 2 | Main> Running Chez program located in folder with spaces 3 | Main> Bye for now! 4 | -------------------------------------------------------------------------------- /tests/chez/chez016/folder with spaces/Main.idr: -------------------------------------------------------------------------------- 1 | main : IO () 2 | main = putStrLn "Running Chez program located in folder with spaces" 3 | -------------------------------------------------------------------------------- /tests/chez/chez016/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez016/run: -------------------------------------------------------------------------------- 1 | # This test needs to run `idris2` from a sub-folder. 2 | # Split path to `idris2` executable into dirname and basename. 3 | # If the path is relative, add `..` to compensate for running `idris2` in a sub-folder. 4 | case "$1" in 5 | /*) 6 | # Absolute path 7 | IDRIS2_DIR="$(dirname "$1")" 8 | ;; 9 | *) 10 | # Relative path 11 | IDRIS2_DIR="../$(dirname "$1")" 12 | ;; 13 | esac 14 | 15 | IDRIS2_EXEC="$(basename "$1")" 16 | 17 | cd "folder with spaces" || exit 18 | 19 | "$IDRIS2_DIR/$IDRIS2_EXEC" --no-color --console-width 0 --no-banner Main.idr < ../input 20 | rm -rf build 21 | -------------------------------------------------------------------------------- /tests/chez/chez017/.gitignore: -------------------------------------------------------------------------------- 1 | /expected 2 | 3 | -------------------------------------------------------------------------------- /tests/chez/chez017/dir.idr: -------------------------------------------------------------------------------- 1 | import System.Directory 2 | 3 | main : IO () 4 | main = do Right () <- createDir "testdir" 5 | | Left err => printLn err 6 | Left err <- createDir "testdir" 7 | | _ => printLn "That wasn't supposed to work" 8 | printLn err 9 | ok <- changeDir "nosuchdir" 10 | printLn ok 11 | ok <- changeDir "testdir" 12 | printLn ok 13 | ignore $ writeFile "test.txt" "hello\n" 14 | printLn !currentDir 15 | 16 | -------------------------------------------------------------------------------- /tests/chez/chez017/expected.in: -------------------------------------------------------------------------------- 1 | 1/1: Building dir (dir.idr) 2 | Main> File Exists 3 | False 4 | True 5 | Just "__PWD__testdir" 6 | Main> Bye for now! 7 | hello 8 | -------------------------------------------------------------------------------- /tests/chez/chez017/gen_expected.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | if [ $OS = "windows" ]; then 3 | MY_PWD="$(cygpath -m $(pwd))\\\\" 4 | else 5 | MY_PWD=$(pwd)/ 6 | fi 7 | 8 | sed -e "s|__PWD__|${MY_PWD}|g" expected.in > expected 9 | -------------------------------------------------------------------------------- /tests/chez/chez017/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez017/run: -------------------------------------------------------------------------------- 1 | ./gen_expected.sh 2 | $1 --no-color --console-width 0 --no-banner dir.idr < input 3 | cat testdir/test.txt 4 | rm -rf build testdir 5 | -------------------------------------------------------------------------------- /tests/chez/chez018/File.idr: -------------------------------------------------------------------------------- 1 | import System.File 2 | 3 | main : IO () 4 | main 5 | = do Right ok <- readFile "test.txt" 6 | | Left err => printLn err 7 | putStr ok 8 | ignore $ writeFile "testout.txt" "abc\ndef\n" 9 | Right ok <- readFile "testout.txt" 10 | | Left err => printLn err 11 | putStr ok 12 | Right ok <- readFile "notfound" 13 | | Left err => printLn err 14 | putStr ok 15 | -------------------------------------------------------------------------------- /tests/chez/chez018/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building File (File.idr) 2 | Main> test test 3 | unfinished lineabc 4 | def 5 | File Not Found 6 | Main> Bye for now! 7 | -------------------------------------------------------------------------------- /tests/chez/chez018/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez018/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner File.idr < input 2 | 3 | rm -rf build testout.txt 4 | -------------------------------------------------------------------------------- /tests/chez/chez018/test.txt: -------------------------------------------------------------------------------- 1 | test test 2 | unfinished line -------------------------------------------------------------------------------- /tests/chez/chez019/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building partial (partial.idr) 2 | Main> ERROR: Unhandled input for Main.foo at partial:4:1--4:17 3 | Main> 2 4 | Main> ERROR: Unhandled input for Main.lookup' at partial:19:1--19:40 5 | Main> ERROR: Unhandled input for Main.lookup' at partial:19:1--19:40 6 | Main> Bye for now! 7 | -------------------------------------------------------------------------------- /tests/chez/chez019/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :exec printLn $ lookup (FS FZ) [1,2,3,4] 3 | :exec printLn $ lookup' (FS FZ) [1,2,3,4] 4 | :exec printLn $ lookup'' (FS FZ) [1,2,3,4] 5 | :q 6 | -------------------------------------------------------------------------------- /tests/chez/chez019/partial.idr: -------------------------------------------------------------------------------- 1 | %default partial 2 | 3 | foo : Maybe a -> a 4 | foo (Just x) = x 5 | 6 | data Vect : ? -> Type -> Type where 7 | Nil : Vect Z a 8 | (::) : a -> Vect k a -> Vect (S k) a 9 | 10 | data Fin : Nat -> Type where 11 | FZ : Fin (S k) 12 | FS : Fin k -> Fin (S k) 13 | 14 | lookup : Fin n -> Vect n a -> a 15 | lookup FZ (x :: xs) = x 16 | lookup (FS k) (x :: xs) = lookup k xs 17 | 18 | lookup' : Fin n -> Vect n a -> a 19 | lookup' (FS k) (x :: xs) = lookup' k xs 20 | 21 | lookup'' : Fin n -> Vect n a -> a 22 | lookup'' n xs = lookup' n xs 23 | 24 | main : IO () 25 | main = do let x = foo Nothing 26 | printLn (the Int x) 27 | -------------------------------------------------------------------------------- /tests/chez/chez019/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner partial.idr < input 2 | 3 | rm -rf build testout.txt 4 | -------------------------------------------------------------------------------- /tests/chez/chez020/Popen.idr: -------------------------------------------------------------------------------- 1 | import System 2 | import System.File 3 | import System.Info 4 | import Data.String 5 | import Data.List1 6 | 7 | windowsPath : String -> String 8 | windowsPath path = 9 | let replaceSlashes : List Char -> List Char 10 | replaceSlashes [] = [] 11 | replaceSlashes ('/' :: cs) = '\\' :: replaceSlashes cs 12 | replaceSlashes (c :: cs) = c :: replaceSlashes cs 13 | in 14 | pack $ replaceSlashes (unpack path) 15 | 16 | main : IO () 17 | main = do 18 | Just cmd <- getEnv "POPEN_CMD" 19 | | Nothing => putStrLn "POPEN_CMD env var not set" 20 | let cmd = if isWindows then windowsPath cmd else cmd 21 | Right fh <- popen cmd Read 22 | | Left err => printLn err 23 | putStrLn "opened" 24 | Right output <- fGetLine fh 25 | | Left err => printLn err 26 | pclose fh 27 | putStrLn "closed" 28 | let idris2 ::: _ = split ((==) ',') output 29 | putStrLn idris2 30 | -------------------------------------------------------------------------------- /tests/chez/chez020/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building Popen (Popen.idr) 2 | Main> opened 3 | closed 4 | Idris 2 5 | Main> Bye for now! 6 | -------------------------------------------------------------------------------- /tests/chez/chez020/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez020/run: -------------------------------------------------------------------------------- 1 | POPEN_CMD="$1 --version" $1 --no-color --console-width 0 --no-banner Popen.idr < input 2 | 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/chez/chez021/Bits.idr: -------------------------------------------------------------------------------- 1 | t1 : Bits8 2 | t1 = 2 3 | 4 | t2 : Bits8 5 | t2 = 255 6 | 7 | t3 : Bits8 8 | t3 = 100 9 | 10 | tests8 : List String 11 | tests8 = map show [t1 + t2, 12 | t1 * t3, 13 | the Bits8 (fromInteger (-8)), 14 | the Bits8 257, 15 | the Bits8 (fromInteger (-1)), 16 | prim__shl_Bits8 t3 1, 17 | prim__shl_Bits8 t2 1] 18 | 19 | testsCmp : List String 20 | testsCmp = map show [t1 < t2, t3 < (t2 + t1)] 21 | 22 | testsMax : List String 23 | testsMax = [show (the Bits8 (fromInteger (-1))), 24 | show (the Bits16 (fromInteger (-1))), 25 | show (the Bits32 (fromInteger (-1))), 26 | show (the Bits64 (fromInteger (-1)))] 27 | 28 | main : IO () 29 | main 30 | = do printLn (t1 + t2) 31 | printLn (t1 * t3) 32 | printLn (t1 < t2) 33 | printLn (prim__shl_Bits8 t3 1) 34 | printLn (prim__shl_Bits8 t2 1) 35 | printLn (t3 < (t2 + t1)) 36 | printLn (the Bits8 (fromInteger (-8))) 37 | printLn (the Bits8 257) 38 | printLn (the Bits64 1234567890) 39 | printLn (the Bits8 (fromInteger (-1))) 40 | printLn (the Bits16 (fromInteger (-1))) 41 | printLn (the Bits32 (fromInteger (-1))) 42 | printLn (the Bits64 (fromInteger (-1))) 43 | 44 | -------------------------------------------------------------------------------- /tests/chez/chez021/expected: -------------------------------------------------------------------------------- 1 | 1 2 | 200 3 | True 4 | 200 5 | 254 6 | False 7 | 248 8 | 1 9 | 1234567890 10 | 255 11 | 65535 12 | 4294967295 13 | 18446744073709551615 14 | 1/1: Building Bits (Bits.idr) 15 | Main> ["1", "200", "248", "1", "255", "200", "254"] 16 | Main> ["True", "False"] 17 | Main> ["255", "65535", "4294967295", "18446744073709551615"] 18 | Main> Main> Bye for now! 19 | -------------------------------------------------------------------------------- /tests/chez/chez021/input: -------------------------------------------------------------------------------- 1 | tests8 2 | testsCmp 3 | testsMax 4 | :exec main 5 | :q 6 | -------------------------------------------------------------------------------- /tests/chez/chez021/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner Bits.idr < input 2 | 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/chez/chez022/Makefile: -------------------------------------------------------------------------------- 1 | include ../../../config.mk 2 | 3 | TARGET = libmkalloc 4 | 5 | SRCS = $(wildcard *.c) 6 | OBJS = $(SRCS:.c=.o) 7 | DEPS = $(OBJS:.o=.d) 8 | 9 | 10 | all: $(TARGET)$(SHLIB_SUFFIX) 11 | 12 | $(TARGET)$(SHLIB_SUFFIX): $(OBJS) 13 | $(CC) -shared $(LDFLAGS) -o $@ $^ 14 | 15 | 16 | -include $(DEPS) 17 | 18 | %.d: %.c 19 | @$(CPP) $(CFLAGS) $< -MM -MT $(@:.d=.o) >$@ 20 | 21 | 22 | .PHONY: clean 23 | 24 | clean : 25 | $(RM) $(OBJS) $(TARGET)$(SHLIB_SUFFIX) 26 | 27 | cleandep: clean 28 | $(RM) $(DEPS) 29 | -------------------------------------------------------------------------------- /tests/chez/chez022/expected: -------------------------------------------------------------------------------- 1 | Hello 2 | Hello 3 | Done 4 | Free X 5 | Freeing 0 Hello 6 | Free Y 7 | Freeing 1 Hello 8 | 1/1: Building usealloc (usealloc.idr) 9 | Main> Main> Bye for now! 10 | -------------------------------------------------------------------------------- /tests/chez/chez022/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez022/mkalloc.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | typedef struct { 6 | int val; 7 | char* str; 8 | } Stuff; 9 | 10 | Stuff* mkThing() { 11 | static int num = 0; 12 | Stuff* x = malloc(sizeof(Stuff)); 13 | x->val = num++; 14 | x->str = malloc(20); 15 | strcpy(x->str,"Hello"); 16 | return x; 17 | } 18 | 19 | char* getStr(Stuff* x) { 20 | return x->str; 21 | } 22 | 23 | void freeThing(Stuff* x) { 24 | printf("Freeing %d %s\n", x->val, x->str); 25 | free(x->str); 26 | free(x); 27 | } 28 | -------------------------------------------------------------------------------- /tests/chez/chez022/mkalloc.d: -------------------------------------------------------------------------------- 1 | mkalloc.o: mkalloc.c 2 | -------------------------------------------------------------------------------- /tests/chez/chez022/run: -------------------------------------------------------------------------------- 1 | case `uname -s` in 2 | OpenBSD|FreeBSD|NetBSD) 3 | MAKE=gmake 4 | ;; 5 | 6 | *) 7 | MAKE=make 8 | ;; 9 | esac 10 | 11 | ${MAKE} all > /dev/null 12 | $1 --no-color --console-width 0 --no-banner usealloc.idr < input 13 | rm -rf build 14 | ${MAKE} clean > /dev/null 15 | -------------------------------------------------------------------------------- /tests/chez/chez022/usealloc.idr: -------------------------------------------------------------------------------- 1 | %foreign "C:mkThing, libmkalloc" 2 | prim__mkThing : PrimIO AnyPtr 3 | %foreign "C:getStr, libmkalloc" 4 | prim__getStr : GCAnyPtr -> PrimIO String 5 | %foreign "C:freeThing, libmkalloc" 6 | prim__freeThing : AnyPtr -> PrimIO () 7 | 8 | mkThing : IO AnyPtr 9 | mkThing = primIO prim__mkThing 10 | 11 | getThingStr : GCAnyPtr -> IO String 12 | getThingStr t = primIO (prim__getStr t) 13 | 14 | freeThing : AnyPtr -> IO () 15 | freeThing t = primIO (prim__freeThing t) 16 | 17 | doThings : IO () 18 | doThings 19 | = do xp <- mkThing 20 | yp <- mkThing 21 | 22 | x <- onCollectAny xp (\p => do putStrLn "Free X" 23 | freeThing p) 24 | y <- onCollectAny yp (\p => do putStrLn "Free Y" 25 | freeThing p) 26 | 27 | putStrLn !(getThingStr x) 28 | putStrLn !(getThingStr y) 29 | 30 | main : IO () 31 | main = do doThings 32 | putStrLn "Done" 33 | -------------------------------------------------------------------------------- /tests/chez/chez023/File.idr: -------------------------------------------------------------------------------- 1 | import System.File 2 | 3 | import Control.App 4 | import Control.App.FileIO 5 | import Control.App.Console 6 | 7 | testFileReadOps : File -> Has [Console, FileIO] e => App e () 8 | testFileReadOps file = do 9 | testStr <- fGetChars file 6 10 | putStrLn testStr 11 | chr <- fGetChar file 12 | putStrLn (show chr) 13 | rest <- fGetStr file 14 | putStrLn rest 15 | 16 | testFileWriteOps : File -> Has [Console, FileIO] e => App e () 17 | testFileWriteOps file = do 18 | fPutStr file "Hello " 19 | fPutStrLn file "Idris!" 20 | fPutStrLn file "Another line" 21 | 22 | runTests : Has [Console, FileIO] e => App e () 23 | runTests = do 24 | withFile "test.txt" WriteTruncate 25 | (\err => putStrLn $ "Failed to open file in write mode: " ++ show err) 26 | (\file => testFileWriteOps file) 27 | withFile "test.txt" Read 28 | (\err => putStrLn $ "Failed to open file in read mode: " ++ show err) 29 | (\file => testFileReadOps file) 30 | 31 | prog : App Init () 32 | prog = 33 | handle runTests 34 | (\() => putStrLn "No exceptions occurred") 35 | (\err: IOError => 36 | putStrLn $ "Caught file error : " ++ show err) 37 | 38 | main : IO () 39 | main = run prog 40 | -------------------------------------------------------------------------------- /tests/chez/chez023/expected: -------------------------------------------------------------------------------- 1 | Hello 2 | 'I' 3 | dris! 4 | 5 | No exceptions occurred 6 | 1/1: Building File (File.idr) 7 | Main> Main> Bye for now! 8 | -------------------------------------------------------------------------------- /tests/chez/chez023/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez023/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner File.idr < input 2 | 3 | rm -rf build test.txt 4 | -------------------------------------------------------------------------------- /tests/chez/chez024/Envy.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import System 4 | 5 | main : IO () 6 | main = do 7 | ok <- setEnv "HELLO" "HI" True 8 | printLn ok 9 | Just str <- getEnv "HELLO" 10 | | Nothing => pure () 11 | putStrLn str 12 | ok <- setEnv "HELLO" "HO" False 13 | printLn ok 14 | Just str <- getEnv "HELLO" 15 | | Nothing => pure () 16 | putStrLn str 17 | ok <- setEnv "HELLO" "EH" True 18 | printLn ok 19 | Just str <- getEnv "HELLO" 20 | | Nothing => pure () 21 | putStrLn str 22 | ok <- unsetEnv "HELLO" 23 | printLn ok 24 | Just str <- getEnv "HELLO" 25 | | Nothing => putStrLn "Nothing there" 26 | pure () 27 | -------------------------------------------------------------------------------- /tests/chez/chez024/expected: -------------------------------------------------------------------------------- 1 | True 2 | HI 3 | True 4 | HI 5 | True 6 | EH 7 | True 8 | Nothing there 9 | 1/1: Building Envy (Envy.idr) 10 | Main> Main> Bye for now! 11 | -------------------------------------------------------------------------------- /tests/chez/chez024/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez024/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner Envy.idr < input 2 | 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/chez/chez025/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building runst (runst.idr) 2 | Main> 500500 3 | Main> Bye for now! 4 | -------------------------------------------------------------------------------- /tests/chez/chez025/input: -------------------------------------------------------------------------------- 1 | :exec printLn (stsum [1..1000]) 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez025/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner runst.idr < input 2 | 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/chez/chez025/runst.idr: -------------------------------------------------------------------------------- 1 | import Data.Ref 2 | 3 | stsum : Num a => List a -> a 4 | stsum xs 5 | = runST $ 6 | do acc <- newRef 0 7 | add xs acc 8 | readRef acc 9 | where 10 | add : List a -> STRef s a -> ST s () 11 | add [] ref = pure () 12 | add (x :: xs) ref 13 | = do acc <- readRef ref 14 | writeRef ref (acc + x) 15 | add xs ref 16 | -------------------------------------------------------------------------------- /tests/chez/chez026/Dummy.idr: -------------------------------------------------------------------------------- 1 | module Dummy 2 | 3 | import System.Directory 4 | 5 | dirExists : String -> IO Bool 6 | dirExists dir = do 7 | Right d <- openDir dir 8 | | Left _ => pure False 9 | closeDir d 10 | pure True 11 | 12 | main : IO () 13 | main = do 14 | True <- dirExists "custom_build" 15 | | False => putStrLn "Could not find build directory" 16 | putStrLn "Found build directory" 17 | -------------------------------------------------------------------------------- /tests/chez/chez026/dummy.ipkg: -------------------------------------------------------------------------------- 1 | package dummy 2 | 3 | authors = "Joe Bloggs" 4 | maintainers = "Joe Bloggs" 5 | license = "BSD3 but see LICENSE for more information" 6 | brief = "This is a dummy package." 7 | readme = "README.md" 8 | 9 | modules = Dummy 10 | 11 | main = Dummy 12 | executable = check_dir 13 | opts = "--no-color --console-width 0" 14 | 15 | builddir = "custom_build" 16 | outputdir = "custom_output" 17 | -------------------------------------------------------------------------------- /tests/chez/chez026/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building Dummy (Dummy.idr) 2 | Found build directory 3 | -------------------------------------------------------------------------------- /tests/chez/chez026/run: -------------------------------------------------------------------------------- 1 | $1 --build dummy.ipkg 2 | 3 | ./custom_output/check_dir 4 | 5 | rm -rf custom_build custom_output 6 | -------------------------------------------------------------------------------- /tests/chez/chez027/StringParser.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Control.Monad.Identity 4 | import Control.Monad.Trans 5 | 6 | import Data.Maybe 7 | import Data.Vect 8 | import Data.String.Parser 9 | 10 | %default partial 11 | -- Build this program with '-p contrib' 12 | 13 | showRes : Show a => Either String (a, Int) -> IO () 14 | showRes res = case res of 15 | Left err => putStrLn err 16 | Right (xs, rem) => printLn xs 17 | 18 | -- test lifting 19 | parseStuff : ParseT IO () 20 | parseStuff = do a <- string "abc" 21 | lift $ putStrLn "hiya" 22 | b <- string "def" 23 | pure () 24 | 25 | -- test a parsing from a pure function 26 | pureParsing : String -> Either String ((List Char), Int) 27 | pureParsing str = parse (many (satisfy isDigit)) str 28 | 29 | 30 | -- test option 31 | optParser : ParseT IO String 32 | optParser = do res <- option "" (takeWhile isDigit) 33 | ignore $ string "def" 34 | pure $ res 35 | 36 | -- test optional 37 | maybeParser : ParseT IO Bool 38 | maybeParser = do res <- optional (string "abc") 39 | ignore $ string "def" 40 | pure $ isJust res 41 | 42 | main : IO () 43 | main = do 44 | res <- parseT parseStuff "abcdef" 45 | res <- parseT (string "hi") "hiyaaaaaa" 46 | case res of 47 | Left err => putStrLn "NOOOOOOO!" 48 | Right (_, i) => printLn i 49 | bad <- parseT (satisfy isDigit) "a" 50 | showRes bad 51 | bad2 <- parseT (string "good" "Not good") "bad bad bad" 52 | showRes bad2 53 | digs <- parseT (many (satisfy isDigit)) "766775" 54 | showRes digs 55 | showRes $ pureParsing "63553" 56 | s <- parseT (takeWhile isDigit) "887abc8993" 57 | showRes s 58 | res <- parseT optParser "123def" 59 | showRes res 60 | res <- parseT optParser "def" 61 | showRes res 62 | res <- parseT maybeParser "abcdef" 63 | showRes res 64 | res <- parseT maybeParser "def" 65 | showRes res 66 | res <- parseT (commaSep alphaNum) "a,1,b,2" 67 | showRes res 68 | res <- parseT (ntimes 4 letter) "abcd" 69 | showRes res 70 | res <- parseT (requireFailure letter) "1" 71 | showRes res 72 | res <- parseT (requireFailure letter) "a" -- Should error 73 | showRes res 74 | pure () 75 | 76 | -------------------------------------------------------------------------------- /tests/chez/chez027/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building StringParser (StringParser.idr) 2 | Main> hiya 3 | 2 4 | Parse failed at position 0: satisfy 5 | Parse failed at position 0: Not good 6 | ['7', '6', '6', '7', '7', '5'] 7 | ['6', '3', '5', '5', '3'] 8 | "887" 9 | "123" 10 | "" 11 | True 12 | False 13 | ['a', '1', 'b', '2'] 14 | ['a', 'b', 'c', 'd'] 15 | () 16 | Parse failed at position 0: Purposefully changed OK to Fail 17 | Main> Bye for now! 18 | -------------------------------------------------------------------------------- /tests/chez/chez027/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez027/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 --no-banner -p contrib StringParser.idr < input 2 | 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/chez/chez028/ExpressionParser.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import Control.Monad.Identity 4 | import Control.Monad.Trans 5 | 6 | import Data.Nat 7 | import Data.String.Parser 8 | import Data.String.Parser.Expression 9 | 10 | %default partial 11 | 12 | table : OperatorTable Nat 13 | table = 14 | [ [Infix (do token "^"; pure (power) ) AssocRight] 15 | , [ Infix (do token "*"; pure (*) ) AssocLeft ] 16 | , [ Infix (do token "+"; pure (+) ) AssocLeft ] 17 | ] 18 | 19 | table' : OperatorTable Integer 20 | table' = 21 | [ [ Infix (do token "*"; pure (*) ) AssocLeft 22 | , Infix (do token "/"; pure (div) ) AssocLeft 23 | ] 24 | , [ Infix (do token "+"; pure (+) ) AssocLeft 25 | , Infix (do token "-"; pure (-) ) AssocLeft 26 | ] 27 | ] 28 | 29 | mutual 30 | term : Parser Nat 31 | term = (natural <|> expr) <* spaces 32 | "simple expression" 33 | 34 | expr : Parser Nat 35 | expr = buildExpressionParser Nat table term 36 | 37 | mutual 38 | term' : Parser Integer 39 | term' = (integer <|> expr') <* spaces 40 | "simple expression" 41 | 42 | expr' : Parser Integer 43 | expr' = buildExpressionParser Integer table' term' 44 | 45 | showRes : Show a => Either String (a, Int) -> IO () 46 | showRes res = case res of 47 | Left err => putStrLn err 48 | Right (xs, rem) => printLn xs 49 | 50 | main : IO () 51 | main = do showRes (parse natural "5678") 52 | showRes (parse integer "-3") 53 | showRes (parse expr "1+4^3^2^1") 54 | showRes (parse expr' "4 + 2 * 3") 55 | showRes (parse expr' "13-3+1*2-10/2") 56 | -------------------------------------------------------------------------------- /tests/chez/chez028/expected: -------------------------------------------------------------------------------- 1 | 5678 2 | -3 3 | 262145 4 | 10 5 | 7 6 | 1/1: Building ExpressionParser (ExpressionParser.idr) 7 | Main> Main> Bye for now! 8 | -------------------------------------------------------------------------------- /tests/chez/chez028/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/chez/chez028/run: -------------------------------------------------------------------------------- 1 | $1 --no-banner --no-color --console-width 0 -p contrib ExpressionParser.idr < input 2 | 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/chez/chez029/BitCasts.idr: -------------------------------------------------------------------------------- 1 | -- Tests to check that casting between integer types works as expected 2 | -- 3 | -- This tests in `idris2/basic043`, `chez/chez028` and `node/node022` are the 4 | -- same and should all have the same output. 5 | 6 | -- 7 | -- Widening should not have any effect 8 | -- 9 | 10 | bits8WideningNoEffect : List String 11 | bits8WideningNoEffect = [ 12 | show $ cast {from = Bits8} {to = Bits16} 123, 13 | show $ cast {from = Bits8} {to = Bits32} 123, 14 | show $ cast {from = Bits8} {to = Bits64} 123, 15 | show $ cast {from = Bits8} {to = Int} 123, 16 | show $ cast {from = Bits8} {to = Integer} 123 17 | ] 18 | 19 | bits16WideningNoEffect : List String 20 | bits16WideningNoEffect = [ 21 | show $ cast {from = Bits16} {to = Bits32} 1234, 22 | show $ cast {from = Bits16} {to = Bits64} 1234, 23 | show $ cast {from = Bits16} {to = Int} 1234, 24 | show $ cast {from = Bits16} {to = Integer} 1234 25 | ] 26 | 27 | bits32WideningNoEffect : List String 28 | bits32WideningNoEffect = [ 29 | show $ cast {from = Bits32} {to = Bits64} 1234567, 30 | show $ cast {from = Bits32} {to = Int} 1234567, 31 | show $ cast {from = Bits32} {to = Integer} 1234567 32 | ] 33 | 34 | -- 35 | -- Narrowing 36 | -- 37 | 38 | b8max : Integer 39 | b8max = 0x100 40 | 41 | b16max : Integer 42 | b16max = 0x10000 43 | 44 | b32max : Integer 45 | b32max = 0x100000000 46 | 47 | b64max : Integer 48 | b64max = 18446744073709551616 -- 0x10000000000000000 49 | 50 | 51 | narrowFromInteger : List String 52 | narrowFromInteger = [ 53 | show $ cast {from = Integer} {to = Bits8} (b8max + 134), 54 | show $ cast {from = Integer} {to = Bits16} (b16max + 134), 55 | show $ cast {from = Integer} {to = Bits32} (b32max + 134), 56 | show $ cast {from = Integer} {to = Bits64} (b64max + 134) 57 | ] 58 | 59 | narrowFromInt : List String 60 | narrowFromInt = [ 61 | show $ cast {from = Int} {to = Bits8} (cast (b8max + 134)), 62 | show $ cast {from = Int} {to = Bits16} (cast (b16max + 134)), 63 | show $ cast {from = Int} {to = Bits32} (cast (b32max + 134)), 64 | show $ cast {from = Int} {to = Bits64} (cast (b64max + 134)) 65 | ] 66 | 67 | narrowFromBits64 : List String 68 | narrowFromBits64 = [ 69 | show $ cast {from = Bits64} {to = Bits8} (cast (b8max + 134)), 70 | show $ cast {from = Bits64} {to = Bits16} (cast (b16max + 134)), 71 | show $ cast {from = Bits64} {to = Bits32} (cast (b32max + 134)) 72 | ] 73 | 74 | narrowFromBits32 : List String 75 | narrowFromBits32 = [ 76 | show $ cast {from = Bits32} {to = Bits8} (cast (b8max + 134)), 77 | show $ cast {from = Bits32} {to = Bits16} (cast (b16max + 134)) 78 | ] 79 | 80 | narrowFromBits16 : List String 81 | narrowFromBits16 = [ 82 | show $ cast {from = Bits16} {to = Bits8} (cast (b8max + 134)) 83 | ] 84 | 85 | -- 86 | -- Negative numbers 87 | -- 88 | 89 | negativeNumberCast : List String 90 | negativeNumberCast = [ 91 | show $ cast {to = Bits8} (-19), 92 | show $ cast {to = Bits16} (-19), 93 | show $ cast {to = Bits32} (-19), 94 | show $ cast {to = Bits64} (-19) 95 | ] 96 | -------------------------------------------------------------------------------- /tests/chez/chez029/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building BitCasts (BitCasts.idr) 2 | Main> ["123", "123", "123", "123", "123"] 3 | Main> ["1234", "1234", "1234", "1234"] 4 | Main> ["1234567", "1234567", "1234567"] 5 | Main> ["134", "134", "134", "134"] 6 | Main> ["134", "134", "134", "134"] 7 | Main> ["134", "134", "134"] 8 | Main> ["134", "134"] 9 | Main> ["134"] 10 | Main> ["237", "65517", "4294967277", "18446744073709551597"] 11 | Main> Bye for now! 12 | -------------------------------------------------------------------------------- /tests/chez/chez029/input: -------------------------------------------------------------------------------- 1 | bits8WideningNoEffect 2 | bits16WideningNoEffect 3 | bits32WideningNoEffect 4 | narrowFromInteger 5 | narrowFromInt 6 | narrowFromBits64 7 | narrowFromBits32 8 | narrowFromBits16 9 | negativeNumberCast 10 | :q 11 | -------------------------------------------------------------------------------- /tests/chez/chez029/run: -------------------------------------------------------------------------------- 1 | $1 --no-banner --no-color --console-width 0 BitCasts.idr < input 2 | 3 | rm -rf build -------------------------------------------------------------------------------- /tests/chez/reg001/expected: -------------------------------------------------------------------------------- 1 | 3 2 | 4.2 3 | "1.2" 4 | 4 5 | 1 6 | "2.7" 7 | 5.9 8 | 2 9 | 2 10 | 2 11 | -------------------------------------------------------------------------------- /tests/chez/reg001/numbers.idr: -------------------------------------------------------------------------------- 1 | -- the commented-out cases are still wrong, 2 | -- but fixing them as well would make other tests fail for mysterious reasons 3 | -- see https://github.com/edwinb/Idris2/pull/281 4 | main : IO () 5 | main = do 6 | printLn $ 3 7 | printLn $ 4.2 8 | printLn $ "1.2" 9 | 10 | printLn $ cast {to = Int} 4.8 11 | printLn $ cast {to = Integer} 1.2 12 | printLn $ cast {to = String} 2.7 13 | 14 | -- printLn $ cast {to = Int} "1.2" 15 | -- printLn $ cast {to = Integer} "2.7" 16 | printLn $ cast {to = Double} "5.9" 17 | 18 | printLn $ (the Int 6 `div` the Int 3) 19 | printLn $ (the Integer 6 `div` the Integer 3) 20 | printLn $ (cast {to = Int} "6.6" `div` cast "3.9") 21 | -- printLn $ (cast {to = Integer} "6.6" `div` cast "3.9") 22 | -------------------------------------------------------------------------------- /tests/chez/reg001/run: -------------------------------------------------------------------------------- 1 | $1 --no-color --console-width 0 numbers.idr -x main 2 | 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/lua/lua001/Foreign.idr: -------------------------------------------------------------------------------- 1 | import Data.HVect 2 | import System.Info 3 | 4 | -- Signature of a %foreign hint: 5 | -- definition|require1(renameRequire1), require2(renameRequire2), ... 6 | -- prefix 'lua:' is optional if there is only one %foreign hint 7 | 8 | -- All Idris functions are compiled as curried Lua lambdas, foreign functions are no different. 9 | 10 | %foreign "lua:function () end|inspect, extra" 11 | imports : PrimIO () 12 | 13 | -- This function does nothing at runtime 14 | -- But we need to reference it from any runtime relevant function, to make sure idris 15 | -- includes 'imports' definition at runtime 16 | -- otherwise all 'require' statements, like 'inspect' and 'extra', won't be generated 17 | doImports : IO () 18 | doImports = primIO imports 19 | 20 | -- Make sure given names are present in compiled output 21 | %foreign "function (_) return function(_) return function (_) return function(w) return {tag='0'} end end end end" 22 | compile : HVect tyes -> IO () 23 | 24 | %foreign "function(_) return function(x) return idris.inspect(x) end end" 25 | inspect : a -> String 26 | 27 | -- Keep in mind that erased arguments are still present in function signatures, 28 | -- though they are always passed as 'nil' 29 | -- I think we should fix this behaviour, but it originates within the Idris compiler 30 | %foreign "function(_) return function(x) return idris.inspect(x) end end" 31 | inspectList : List a -> String 32 | 33 | -- 'a : Type' and 'b : Type' are erased, thus two underscores 34 | %foreign "function(_) return function(_) return function(f) return function(x) return idris.extra.apply(f, x) end end end end" 35 | apply : (a -> b) -> a -> b 36 | 37 | %foreign "function(_) return function(list) return idris.extra.printList(list) end end" 38 | printList : List a -> String 39 | 40 | -- Represents Lua dictionaries 41 | data Dict : Type where [external] 42 | 43 | -- Here we silently have another implicit argument of type Nat: length of 'tyes' 44 | %foreign "function(_) return function(_) return function(hv) return idris.extra.hVectToDict(hv, {}) end end end" 45 | toDict : HVect tyes -> Dict 46 | -- toDict : {0 n: Nat} -> {0 tyes : Vect n Type} -> HVect tyes -> Dict 47 | 48 | -- for demonstration purposes lets require 'extra' renaming it to 'extras' 49 | %foreign "function(f) return idris.extras.apply(f, 1) end|extra(extras)" 50 | applyTo1 : (Int -> Int) -> Int 51 | 52 | %foreign "function(idrisPlus) return idrisPlus(1)(3) end" 53 | four : (Int -> Int -> Int) -> Int 54 | 55 | %foreign "function(f) return function(w) f('A string from Lua !')(w); return 'ok' end end" 56 | callIdrisFromLua : (String -> IO String) -> IO String 57 | 58 | barePrint : String -> IO () 59 | barePrint = putStrLn 60 | 61 | %foreign "function(w) idris['Main.barePrint']('Another string from Lua !')(w); return 0 end" 62 | callIdrisFromLua' : IO () 63 | 64 | main : IO () 65 | main = do doImports 66 | compile [barePrint] 67 | putStrLn $ inspect "hey" 68 | putStrLn $ inspectList [1, 2, 3, the Int 4, 5] 69 | putStrLn $ show $ applyTo1 (* 2) 70 | putStrLn $ show $ Main.apply (+ 1) (the Int 1) 71 | putStrLn $ printList [1, the Int 2, 3, the Int 4] 72 | putStrLn $ inspect $ toDict [("a", the Int 1), ("b", "b"), ("c", the (List Integer) [1, 2, 3])] 73 | putStrLn $ "is four " ++ show (four (+)) 74 | ok <- callIdrisFromLua (\str => putStrLn str *> pure "ok") 75 | putStrLn $ "Got " ++ ok ++ " back" 76 | putStrLn $ inspect codegen 77 | () <- callIdrisFromLua' 78 | pure () 79 | -------------------------------------------------------------------------------- /tests/lua/lua001/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building Foreign (Foreign.idr) 2 | Main> "hey" 3 | { 4 | arg1 = 1, 5 | arg2 = { 6 | arg1 = 2, 7 | arg2 = { 8 | arg1 = 3, 9 | arg2 = { 10 | arg1 = 4, 11 | arg2 = { 12 | arg1 = 5, 13 | arg2 = { 14 | tag = "0" 15 | }, 16 | tag = "1" 17 | }, 18 | tag = "1" 19 | }, 20 | tag = "1" 21 | }, 22 | tag = "1" 23 | }, 24 | tag = "1" 25 | } 26 | 2 27 | 2 28 | [1 2 3 4] 29 | { 30 | a = 1, 31 | b = "b", 32 | c = { 33 | arg1 = , 34 | arg2 = { 35 | arg1 = , 36 | arg2 = { 37 | arg1 = , 38 | arg2 = { 39 | tag = "0" 40 | }, 41 | tag = "1" 42 | }, 43 | tag = "1" 44 | }, 45 | tag = "1" 46 | } 47 | } 48 | is four 4 49 | A string from Lua ! 50 | Got ok back 51 | "lua" 52 | Another string from Lua ! 53 | Main> Bye for now! 54 | -------------------------------------------------------------------------------- /tests/lua/lua001/extra.lua: -------------------------------------------------------------------------------- 1 | module = {} 2 | 3 | local inspect = require('inspect') 4 | 5 | function module.apply(f, ...) 6 | return f(...) 7 | end 8 | 9 | local function printListH(list) 10 | if list.tag == "0" then 11 | return "" 12 | elseif list.tag == "1" and list.arg2.tag == "0" then 13 | return inspect(list.arg1) 14 | else 15 | return inspect(list.arg1) .. " " .. printListH(list.arg2) 16 | end 17 | end 18 | 19 | 20 | function module.printList(list) 21 | return '[' .. printListH(list) .. ']' 22 | end 23 | 24 | -- converts HVect to lua's dictionary 25 | function module.hVectToDict(hv, dict) 26 | if hv.tag == "0" then 27 | return dict 28 | else 29 | dict[hv.arg1.arg1] = hv.arg1.arg2 30 | return module.hVectToDict(hv.arg2, dict) 31 | end 32 | end 33 | 34 | return module 35 | -------------------------------------------------------------------------------- /tests/lua/lua001/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/lua/lua001/run: -------------------------------------------------------------------------------- 1 | LUA_PATH="./?.lua;:$LUA_PATH" $1 --no-banner -p contrib Foreign.idr < input 2 | 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/lua/lua002/Foreign.idr: -------------------------------------------------------------------------------- 1 | import Data.String 2 | 3 | main : IO () 4 | main = do putStrLn $ fastPack ['a', 'b', 'c', 'π', 'Ω', '2'] 5 | printLn $ fastUnpack "abcπΩ2" 6 | putStrLn $ fastConcat ["a", "b", "c", "πΩ", "2"] 7 | -------------------------------------------------------------------------------- /tests/lua/lua002/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building Foreign (Foreign.idr) 2 | Main> abcπΩ2 3 | ['a', 'b', 'c', '\960', '\937', '2'] 4 | abcπΩ2 5 | Main> Bye for now! 6 | -------------------------------------------------------------------------------- /tests/lua/lua002/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/lua/lua002/run: -------------------------------------------------------------------------------- 1 | $1 --no-banner -p contrib Foreign.idr < input 2 | 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/lua/lua003/Test.idr: -------------------------------------------------------------------------------- 1 | 2 | import Data.Vect 3 | import Data.IORef 4 | import Data.IOArray 5 | import Data.String 6 | import Data.Vect 7 | import Data.List 8 | import System 9 | data MyData = MyCons0 Nat | MyCons1 10 | 11 | 12 | Show MyData where 13 | show (MyCons0 x) = "blah" ++ show x 14 | show MyCons1 = "babah" 15 | 16 | boom : Nat -> Nat 17 | boom (S k) = boom k 18 | boom Z = 32 19 | 20 | whatData : MyData -> Nat 21 | whatData (MyCons0 x) = x 22 | whatData MyCons1 = 99 23 | 24 | 25 | factorial : Integer -> Integer -> Integer 26 | factorial 0 ac = ac 27 | factorial x ac = factorial (x - 1) (ac * x) 28 | 29 | data BTree a = BBranch (BTree a) a (BTree a) | BLeaf 30 | 31 | 32 | intPow : Integer -> Integer -> Integer 33 | intPow base exp = 34 | if exp > 1 then base * (intPow base (exp - 1)) else if exp == 1 then base else 1 35 | 36 | 37 | fillIn : Nat -> List Nat -> (Nat -> Nat -> a) -> BTree a 38 | fillIn Z _ f = BLeaf 39 | fillIn (S k) l f = 40 | BBranch 41 | (fillIn k (0 :: l) f) 42 | (f k $ count k (reverse l)) 43 | (fillIn k (1 :: l) f) 44 | where 45 | count : Nat -> List Nat -> Nat 46 | count k (x :: xs) = let len = length xs in x * (integerToNat $ intPow 2 (cast len)) + count k xs 47 | count _ [] = 0 48 | 49 | printLeft : Show a => BTree a -> String 50 | printLeft BLeaf = "" 51 | printLeft (BBranch l x r) = printLeft l ++ " " ++ show x ++ " " ++ printLeft r 52 | 53 | indent : Nat -> String 54 | indent k = pack $ replicate (2 * k) ' ' 55 | 56 | Cast Nat String where 57 | cast x = cast $ cast {to = Int} x 58 | 59 | 60 | 61 | testInteger : Integer -> Integer -> Integer 62 | testInteger x y = x * x * x * x - 1 63 | 64 | %hide Prelude.print 65 | 66 | data Lua : Type where [external] 67 | 68 | %foreign "lua:function (_) return function (x) return idris.inspect(x) end end|inspect" 69 | inspect : (x : a) -> String 70 | 71 | %foreign "lua:function(x) return function (str) return x[str] end end|inspect" 72 | dot : Lua -> String -> Lua 73 | 74 | %foreign "lua:function (x) return require (x) end" 75 | require : String -> Lua 76 | 77 | %foreign "lua:function(a) return function(b) return function(f) return function(x) return f(x) end end end end" 78 | call : {0 a : Type} -> {0 b : Type} -> Lua -> a -> b 79 | 80 | 81 | 82 | %foreign "lua:print" 83 | print_ : String -> () 84 | 85 | print : (HasIO io) => String -> io () 86 | print x = pure $ print_ x 87 | 88 | 89 | main : IO () 90 | main = do 91 | let ins = require "inspect" 92 | putStrLn $ call (ins `dot` "inspect") [1, 2, the Int 3] {a = List _} {b = String} 93 | 94 | v <- newIORef "" 95 | print "enter something:" 96 | writeIORef v !(getLine) 97 | print $ "you said " ++ !(readIORef v) 98 | putStrLn $ if 1 > 2 then "not ok" else "ok" 99 | printLn $ (the Int 1) 100 | putStrLn $ show (the Nat 28) 101 | putStrLn $ show $ whatData $ MyCons0 7 102 | ar <- newArray 10 {elem = Int} 103 | pure () 104 | let from = the Int (fromInteger 10) 105 | putStrLn $ show $ "ok " ++ "or not" 106 | putStrLn $ show (5 == the Int 5) 107 | putStrLn $ show (0 == the Integer 0) 108 | putStrLn $ show (1 < the Integer 2) 109 | putStrLn $ show (7 < the Int 4) 110 | args <- getArgs 111 | traverse_ putStrLn args 112 | 113 | putStrLn $ show $ (the Integer 0) > 0 114 | putStrLn $ show $ testInteger 2 5 115 | putStrLn $ "2 ^ 6 == " ++ show (intPow 2 6) 116 | let tr = fillIn 4 [] (\d, i => show d ++ " " ++ show i) 117 | putStrLn $ printLeft tr 118 | 119 | putStrLn $ "the guts of BTree look like this: " ++ inspect tr 120 | 121 | putStrLn $ show from 122 | putStrLn $ show $ (the Integer (2 - 2)) == 0 123 | putStrLn $ show $ factorial 1000 1 124 | putStrLn "unicode string: lambda λ, sigma Σ, integral ∫, cyrillic F Ф" 125 | -------------------------------------------------------------------------------- /tests/lua/lua003/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building Test (Test.idr) 2 | Main> { 3 | arg1 = 1, 4 | arg2 = { 5 | arg1 = 2, 6 | arg2 = { 7 | arg1 = 3, 8 | arg2 = { 9 | tag = "0" 10 | }, 11 | tag = "1" 12 | }, 13 | tag = "1" 14 | }, 15 | tag = "1" 16 | } 17 | enter something: 18 | you said 19 | ok 20 | 1 21 | 28 22 | 7 23 | "ok or not" 24 | True 25 | True 26 | True 27 | False 28 | build/exec/generated.lua 29 | False 30 | 15 31 | 2 ^ 6 == 64 32 | "0 0" "1 0" "0 1" "2 0" "0 2" "1 1" "0 3" "3 0" "0 4" "1 2" "0 5" "2 1" "0 6" "1 3" "0 7" 33 | the guts of BTree look like this: { 34 | arg1 = { 35 | arg1 = { 36 | arg1 = { 37 | arg1 = { 38 | tag = "1" 39 | }, 40 | arg2 = "0 0", 41 | arg3 = { 42 | tag = "1" 43 | }, 44 | tag = "0" 45 | }, 46 | arg2 = "1 0", 47 | arg3 = { 48 | arg1 = { 49 | tag = "1" 50 | }, 51 | arg2 = "0 1", 52 | arg3 = { 53 | tag = "1" 54 | }, 55 | tag = "0" 56 | }, 57 | tag = "0" 58 | }, 59 | arg2 = "2 0", 60 | arg3 = { 61 | arg1 = { 62 | arg1 = { 63 | tag = "1" 64 | }, 65 | arg2 = "0 2", 66 | arg3 = { 67 | tag = "1" 68 | }, 69 | tag = "0" 70 | }, 71 | arg2 = "1 1", 72 | arg3 = { 73 | arg1 = { 74 | tag = "1" 75 | }, 76 | arg2 = "0 3", 77 | arg3 = { 78 | tag = "1" 79 | }, 80 | tag = "0" 81 | }, 82 | tag = "0" 83 | }, 84 | tag = "0" 85 | }, 86 | arg2 = "3 0", 87 | arg3 = { 88 | arg1 = { 89 | arg1 = { 90 | arg1 = { 91 | tag = "1" 92 | }, 93 | arg2 = "0 4", 94 | arg3 = { 95 | tag = "1" 96 | }, 97 | tag = "0" 98 | }, 99 | arg2 = "1 2", 100 | arg3 = { 101 | arg1 = { 102 | tag = "1" 103 | }, 104 | arg2 = "0 5", 105 | arg3 = { 106 | tag = "1" 107 | }, 108 | tag = "0" 109 | }, 110 | tag = "0" 111 | }, 112 | arg2 = "2 1", 113 | arg3 = { 114 | arg1 = { 115 | arg1 = { 116 | tag = "1" 117 | }, 118 | arg2 = "0 6", 119 | arg3 = { 120 | tag = "1" 121 | }, 122 | tag = "0" 123 | }, 124 | arg2 = "1 3", 125 | arg3 = { 126 | arg1 = { 127 | tag = "1" 128 | }, 129 | arg2 = "0 7", 130 | arg3 = { 131 | tag = "1" 132 | }, 133 | tag = "0" 134 | }, 135 | tag = "0" 136 | }, 137 | tag = "0" 138 | }, 139 | tag = "0" 140 | } 141 | 10 142 | True 143 | 402387260077093773543702433923003985719374864210714632543799910429938512398629020592044208486969404800479988610197196058631666872994808558901323829669944590997424504087073759918823627727188732519779505950995276120874975462497043601418278094646496291056393887437886487337119181045825783647849977012476632889835955735432513185323958463075557409114262417474349347553428646576611667797396668820291207379143853719588249808126867838374559731746136085379534524221586593201928090878297308431392844403281231558611036976801357304216168747609675871348312025478589320767169132448426236131412508780208000261683151027341827977704784635868170164365024153691398281264810213092761244896359928705114964975419909342221566832572080821333186116811553615836546984046708975602900950537616475847728421889679646244945160765353408198901385442487984959953319101723355556602139450399736280750137837615307127761926849034352625200015888535147331611702103968175921510907788019393178114194545257223865541461062892187960223838971476088506276862967146674697562911234082439208160153780889893964518263243671616762179168909779911903754031274622289988005195444414282012187361745992642956581746628302955570299024324153181617210465832036786906117260158783520751516284225540265170483304226143974286933061690897968482590125458327168226458066526769958652682272807075781391858178889652208164348344825993266043367660176999612831860788386150279465955131156552036093988180612138558600301435694527224206344631797460594682573103790084024432438465657245014402821885252470935190620929023136493273497565513958720559654228749774011413346962715422845862377387538230483865688976461927383814900140767310446640259899490222221765904339901886018566526485061799702356193897017860040811889729918311021171229845901641921068884387121855646124960798722908519296819372388642614839657382291123125024186649353143970137428531926649875337218940694281434118520158014123344828015051399694290153483077644569099073152433278288269864602789864321139083506217095002597389863554277196742822248757586765752344220207573630569498825087968928162753848863396909959826280956121450994871701244516461260379029309120889086942028510640182154399457156805941872748998094254742173582401063677404595741785160829230135358081840096996372524230560855903700624271243416909004153690105933983835777939410970027753472000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 144 | unicode string: lambda λ, sigma Σ, integral ∫, cyrillic F Ф 145 | Main> Bye for now! 146 | -------------------------------------------------------------------------------- /tests/lua/lua003/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/lua/lua003/run: -------------------------------------------------------------------------------- 1 | $1 --no-banner Test.idr < input 2 | rm -rf build 3 | -------------------------------------------------------------------------------- /tests/lua/lua004/Test.idr: -------------------------------------------------------------------------------- 1 | module Test 2 | 3 | import Data.Vect 4 | import System.File 5 | import System 6 | import Data.Buffer 7 | import Data.String 8 | 9 | test1 : Nat -> List String -> Vect n Int -> String 10 | test1 1 (x :: xs) (y :: ys) = show 1 ++ show x ++ show xs ++ show y ++ show ys 11 | test1 0 [] [x] = "m1 " ++ show x 12 | test1 2 (x :: xs) (y :: []) = "m2 " ++ show x ++ show xs ++ show y 13 | test1 (S k) d t = "m3 " ++ let x = test1 k (show k :: d) t in x 14 | test1 k d t = "m4 " ++ show k ++ show d ++ show t 15 | 16 | 17 | data MyDat = A1 | A2 | A3 | A4 | A5 | A6 | A7 | A8 18 | 19 | Show MyDat where 20 | show A1 = "A1" 21 | show A2 = "A2" 22 | show A3 = "A3" 23 | show A4 = "A4" 24 | show A5 = "A5" 25 | show A6 = "A6" 26 | show A7 = "A7" 27 | show A8 = "A8" 28 | 29 | ansiColorStr : String -> Vect 3 Int -> String 30 | ansiColorStr str [r, g, b] = "\x1b[38;2;" ++ show r ++ ";" ++ show g ++ ";" ++ show b ++ "m" ++ str ++ "\x1b[0m" 31 | 32 | namespace Either 33 | public export 34 | ignoreErr : (Show a) => IO (Either a b) -> IO b 35 | ignoreErr io = 36 | do 37 | (Right ok) <- io 38 | | Left err => 39 | do 40 | putStrLn $ show err 41 | exitFailure 42 | pure ok 43 | 44 | namespace Maybe 45 | public export 46 | ignoreErr : IO (Maybe a) -> IO a 47 | ignoreErr io = 48 | do 49 | (Just ok) <- io 50 | | Nothing => 51 | do 52 | putStrLn "Got nothing" 53 | exitFailure 54 | pure ok 55 | 56 | main : IO () 57 | main = do 58 | let aα = the Nat 5 59 | putStrLn $ show aα 60 | putStrLn $ test1 1 ["a", "b"] [2, 3, 4, 5] 61 | putStrLn $ test1 0 [] [6] 62 | putStrLn $ test1 2 ["c", "d", "e"] [1] 63 | putStrLn $ test1 3 ["p", "t"] [0] 64 | putStrLn $ test1 4 ["a"] [0, 1, 2, 3] 65 | putChar 'c' 66 | putChar 'b' 67 | putChar '\n' 68 | putStrLn $ show A1 69 | putStrLn $ show A8 70 | putStrLn $ show A6 71 | f <- ignoreErr $ openFile "data4.txt" Read 72 | putStrLn $ show !(fGetLine f) 73 | putStrLn $ show !(fEOF f) 74 | ignore $ fPutStrLn stdout "\x1b[38;2;255;100;0mThis is error\x1b[0m" 75 | ignore $ closeFile f 76 | ignore $ writeFile "data.txt" $ ansiColorStr "red\n" [255, 0, 0] 77 | ++ ansiColorStr "green\n" [0, 255, 0] 78 | ++ ansiColorStr "blue" [0, 0, 255] 79 | putStrLn $ show (the Int 257) 80 | putStrLn $ show !(ignoreErr $ readFile "data.txt") 81 | buf <- ignoreErr $ createBufferFromFile "data.txt" 82 | size <- rawSize buf 83 | putStrLn $ "buf size " ++ show size 84 | putStrLn $ "buf contents:\n" ++ !(getString buf 0 size) 85 | let i64s = 8 86 | ibuf <- ignoreErr $ newBuffer (i64s * 10) 87 | putStrLn $ "init size" ++ show !(rawSize ibuf) 88 | let list = [0..9] 89 | traverse_ (\i => do setInt ibuf (i64s * i) i;putStrLn $ "next size" ++ show !(rawSize ibuf)) list 90 | --setInt31 ibuf 114 (-991133) 91 | setInt ibuf 114 (-567) 92 | setDouble ibuf 122 (-241.123456789) 93 | setString ibuf 80 "hi there !" 94 | setString ibuf 90 "русский язык" 95 | dat2 <- ignoreErr $ openFile "data2.txt" WriteTruncate 96 | ignore $ writeBufferData dat2 ibuf 0 !(rawSize ibuf) 97 | putStrLn $ show $ !(getInt ibuf 0 ) 98 | putStrLn $ show $ !(getInt ibuf 8 ) 99 | putStrLn $ show $ !(getInt ibuf (8 * 9) ) 100 | ignore $ closeFile dat2 101 | ibuf <- ignoreErr $ createBufferFromFile "data2.txt" 102 | putStrLn $ show $ !(getInt ibuf 0 ) 103 | putStrLn $ show $ !(getInt ibuf 8 ) 104 | putStrLn $ show $ !(getInt ibuf (8 * 9) ) 105 | putStrLn $ show !(rawSize ibuf) 106 | putStrLn !(getString ibuf 80 10) 107 | putStrLn !(getString ibuf 90 24) 108 | putStrLn $ show !(getInt ibuf 114) 109 | putStrLn $ show !(getDouble ibuf 122) 110 | -------------------------------------------------------------------------------- /tests/lua/lua004/data.txt: -------------------------------------------------------------------------------- 1 | red 2 | green 3 | blue -------------------------------------------------------------------------------- /tests/lua/lua004/data4.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Russoul/Idris2-Lua/68aec59da57321643bafef1641f6de3577c4589d/tests/lua/lua004/data4.txt -------------------------------------------------------------------------------- /tests/lua/lua004/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building Test (Test.idr) 2 | Test> 5 3 | 1"a"["b"]2[3, 4, 5] 4 | m1 6 5 | m2 "c"["d", "e"]1 6 | m3 m2 "2"["p", "t"]0 7 | m3 m3 m3 1"1"["2", "3", "a"]0[1, 2, 3] 8 | cb 9 | A1 10 | A8 11 | A6 12 | Right "" 13 | True 14 | This is error 15 | 257 16 | "\ESC[38;2;255;0;0mred\n\ESC[0m\ESC[38;2;0;255;0mgreen\n\ESC[0m\ESC[38;2;0;0;255mblue\ESC[0m" 17 | buf size 71 18 | buf contents: 19 | red 20 | green 21 | blue 22 | init size0 23 | next size8 24 | next size16 25 | next size24 26 | next size32 27 | next size40 28 | next size48 29 | next size56 30 | next size64 31 | next size72 32 | next size80 33 | 0 34 | 1 35 | 9 36 | 0 37 | 1 38 | 9 39 | 130 40 | hi there ! 41 | русский язык-567 42 | -241.123456789 43 | Test> Bye for now! 44 | -------------------------------------------------------------------------------- /tests/lua/lua004/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/lua/lua004/run: -------------------------------------------------------------------------------- 1 | $1 --no-banner Test.idr < input 2 | rm data2.txt 3 | rm -rf build 4 | -------------------------------------------------------------------------------- /tests/lua/lua005/Test.idr: -------------------------------------------------------------------------------- 1 | 2 | namespace Lua 3 | export 4 | %foreign "x, y => x + y" 5 | plus : Int -> Int -> Int 6 | 7 | export -- there is now also a `W` local variable, accessible anywhere from FFI for convenience 8 | -- `W` is a special table standing for the %MkWorld value 9 | %foreign "callback, _ => callback('abc')(22)(W)" 10 | callback : (callback : String -> Int -> PrimIO String) -> PrimIO String 11 | 12 | export 13 | %foreign "x => idris.inspect(x)|inspect" 14 | inspect : ty -> String 15 | 16 | export 17 | %foreign "x, y, f => f(x)(y)" 18 | apply2 : a -> (0 b : Type {- for demo purposes -}) -> b -> (a -> b -> c) -> c 19 | 20 | export 21 | %foreign "_ => print(W)" 22 | printWorld : IO () 23 | 24 | main : IO () 25 | main = do printLn $ Lua.plus 1 3 26 | str <- fromPrim $ callback (\str, i => toPrim $ pure $ str ++ " " ++ show i) 27 | putStrLn str 28 | putStrLn (inspect $ with List [the Int 1, 2, 3]) 29 | putStrLn $ apply2 "abc" _ "def" (++) 30 | printWorld 31 | 32 | -------------------------------------------------------------------------------- /tests/lua/lua005/expected: -------------------------------------------------------------------------------- 1 | 1/1: Building Test (Test.idr) 2 | Main> 4 3 | abc 22 4 | { 5 | arg1 = 1, 6 | arg2 = { 7 | arg1 = 2, 8 | arg2 = { 9 | arg1 = 3, 10 | arg2 = { 11 | tag = "0" 12 | }, 13 | tag = "1" 14 | }, 15 | tag = "1" 16 | }, 17 | tag = "1" 18 | } 19 | abcdef 20 | %MkWorld 21 | Main> Bye for now! 22 | -------------------------------------------------------------------------------- /tests/lua/lua005/input: -------------------------------------------------------------------------------- 1 | :exec main 2 | :q 3 | -------------------------------------------------------------------------------- /tests/lua/lua005/run: -------------------------------------------------------------------------------- 1 | $1 --no-banner Test.idr < input 2 | rm -rf build 3 | -------------------------------------------------------------------------------- /tests/tests.ipkg: -------------------------------------------------------------------------------- 1 | package runtests 2 | 3 | depends = contrib 4 | main = Main 5 | executable = runtests --------------------------------------------------------------------------------