diff --git a/.github/workflows/ci-api.yml b/.github/workflows/ci-api.yml index ab2f915b8..d0c28bccd 100644 --- a/.github/workflows/ci-api.yml +++ b/.github/workflows/ci-api.yml @@ -11,6 +11,9 @@ on: env: SCHEME: scheme + IDRIS2_TESTS_CG: chez + ACTIONS_ALLOW_UNSECURE_COMMANDS: true + jobs: build: runs-on: ubuntu-latest @@ -26,4 +29,4 @@ jobs: shell: bash - name: Test API run: cd tests/idris2/api001 && ./run idris2 - shell: bash \ No newline at end of file + shell: bash diff --git a/.github/workflows/ci-macos.yml b/.github/workflows/ci-macos.yml index b8d2be1d4..42bb13f32 100644 --- a/.github/workflows/ci-macos.yml +++ b/.github/workflows/ci-macos.yml @@ -10,6 +10,9 @@ on: - master env: SCHEME: chez + IDRIS2_TESTS_CG: chez + ACTIONS_ALLOW_UNSECURE_COMMANDS: true + jobs: build: runs-on: macos-latest @@ -26,4 +29,4 @@ jobs: shell: bash - name: Build and test self-hosted run: make clean && make all && make test INTERACTIVE='' - shell: bash \ No newline at end of file + shell: bash diff --git a/.github/workflows/ci-ubuntu-racket.yml b/.github/workflows/ci-ubuntu-racket.yml index 58720c284..ac6f8fdd5 100644 --- a/.github/workflows/ci-ubuntu-racket.yml +++ b/.github/workflows/ci-ubuntu-racket.yml @@ -9,6 +9,10 @@ on: branches: - master +env: + IDRIS2_TESTS_CG: racket + ACTIONS_ALLOW_UNSECURE_COMMANDS: true + jobs: build: runs-on: ubuntu-latest @@ -17,9 +21,8 @@ jobs: uses: actions/checkout@v2 - name: Install build dependencies run: | - sudo apt-get update + sudo apt-get update sudo apt-get install -y racket - name: Build from bootstrap run: make bootstrap-racket shell: bash - diff --git a/.github/workflows/ci-ubuntu.yml b/.github/workflows/ci-ubuntu.yml index 0a2934a0d..dc7f23b9f 100644 --- a/.github/workflows/ci-ubuntu.yml +++ b/.github/workflows/ci-ubuntu.yml @@ -11,6 +11,9 @@ on: env: SCHEME: scheme + IDRIS2_TESTS_CG: chez + ACTIONS_ALLOW_UNSECURE_COMMANDS: true + jobs: build: runs-on: ubuntu-latest @@ -27,4 +30,3 @@ jobs: - name: Build and test self-hosted run: make clean && make all && make test INTERACTIVE='' shell: bash - diff --git a/.github/workflows/ci-windows.yml b/.github/workflows/ci-windows.yml index f0942d6ed..90ed33801 100644 --- a/.github/workflows/ci-windows.yml +++ b/.github/workflows/ci-windows.yml @@ -12,7 +12,9 @@ env: MSYSTEM: MINGW64 MSYS2_PATH_TYPE: inherit SCHEME: scheme + IDRIS2_TESTS_CG: chez CC: gcc + ACTIONS_ALLOW_UNSECURE_COMMANDS: true jobs: build: @@ -24,7 +26,7 @@ jobs: - name: Checkout uses: actions/checkout@v2 - name: Get Chez Scheme - run: | + run: | git clone --depth 1 https://github.com/cisco/ChezScheme c:\msys64\usr\bin\bash -l -c "pacman -S --noconfirm tar make" echo "::set-env name=PWD::$(c:\msys64\usr\bin\cygpath -u $(pwd))" @@ -43,4 +45,4 @@ jobs: run: | scheme --version - name: Bootstrap and install - run: c:\msys64\usr\bin\bash -l -c "cd $env:PWD && make bootstrap && make install" \ No newline at end of file + run: c:\msys64\usr\bin\bash -l -c "cd $env:PWD && make bootstrap && make install" diff --git a/CHANGELOG.md b/CHANGELOG.md index ee11838c2..ed7c940a3 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -19,6 +19,8 @@ Compiler changes: * Added primitives to the parsing library used in the compiler to get more precise boundaries to the AST nodes `FC`. +* New experimental ``refc`` code generator, which generates C with reference + counting. REPL/IDE mode changes: diff --git a/Makefile b/Makefile index 68891e40e..a1d61d5d4 100644 --- a/Makefile +++ b/Makefile @@ -87,9 +87,11 @@ test: support: @${MAKE} -C support/c + @${MAKE} -C support/refc support-clean: @${MAKE} -C support/c clean + @${MAKE} -C support/refc clean clean-libs: ${MAKE} -C libs/prelude clean @@ -129,6 +131,7 @@ install-support: install support/gambit/* ${PREFIX}/idris2-${IDRIS2_VERSION}/support/gambit install support/js/* ${PREFIX}/idris2-${IDRIS2_VERSION}/support/js @${MAKE} -C support/c install + @${MAKE} -C support/refc install install-libs: ${MAKE} -C libs/prelude install IDRIS2=../../${TARGET} IDRIS2_PATH=${IDRIS2_BOOT_PATH} diff --git a/Release/mkdist.sh b/Release/mkdist.sh index c7a8183ed..98d07a521 100644 --- a/Release/mkdist.sh +++ b/Release/mkdist.sh @@ -17,7 +17,7 @@ git checkout tags/v$1 rm -rf .git rm -rf .github rm .git* -rm .travis* +rm -f .travis* rm -rf Release find . -type f -name '.gitignore' -exec rm -f {} \; diff --git a/docs/source/backends/index.rst b/docs/source/backends/index.rst index 0a7712de4..4e48484e2 100644 --- a/docs/source/backends/index.rst +++ b/docs/source/backends/index.rst @@ -61,4 +61,5 @@ or via the `IDRIS2_CG` environment variable. racket gambit javascript + refc custom diff --git a/docs/source/backends/refc.rst b/docs/source/backends/refc.rst new file mode 100644 index 000000000..eb10d5765 --- /dev/null +++ b/docs/source/backends/refc.rst @@ -0,0 +1,35 @@ +************************* +C with Reference Counting +************************* + +There is an experimental code generator which compiles to an executable via C, +using a reference counting garbage collector. This is intended as a lightweight +(i.e. minimal dependencies) code generator that can be ported to multiple +platforms, especially those with memory constraints. + +Performance is not as good as the Scheme based code generators, partly because +the reference counting has not yet had any optimisation, and partly because of +the limitations of C. However, the main goal is portability: the generated +code should run on any platform that supports a C compiler. + +This code generator can be accessed via the REPL command: + +:: + + Main> :set cg refc + +Alternatively, you can set it via the ``IDRIS2_CG`` environment variable: + +:: + + $ export IDRIS2_CG=refc + +The C compiler it invokes is determined by either the ``IDRIS2_CC`` or ``CC`` +environment variables. If neither is set, it uses ``cc``. + +This code generator does not yet support `:exec`, just `:c`. + +Also note that, if you link with any dynamic libraries for interfacing with +C, you will need to arrange for them to be accessible via ``LD_LIBRARY_PATH`` +when running the executable. The default Idris 2 support libraries are +statically linked. diff --git a/docs/source/faq/faq.rst b/docs/source/faq/faq.rst index bf19b5ea0..cb525a817 100644 --- a/docs/source/faq/faq.rst +++ b/docs/source/faq/faq.rst @@ -32,7 +32,7 @@ is a very convenient way to bootstrap. Can Idris 2 generate Javascript? What about plug-in code generators? ==================================================================== -Yes! A `JavaScript code generator `_ +Yes! A `JavaScript code generator `_ is built in, and can target either the browser or NodeJS. Like Idris 1, Idris 2 diff --git a/docs/source/tutorial/starting.rst b/docs/source/tutorial/starting.rst index 7d01168d4..2893537a3 100644 --- a/docs/source/tutorial/starting.rst +++ b/docs/source/tutorial/starting.rst @@ -89,6 +89,8 @@ which you can run: $ idris2 hello.idr -o hello $ ./build/exec/hello Hello world + +(On Macos you may first need to install realpath: ```brew install coreutils```) Please note that the dollar sign ``$`` indicates the shell prompt! Some useful options to the Idris command are: diff --git a/idris2api.ipkg b/idris2api.ipkg index 27dc669a0..8d3caad98 100644 --- a/idris2api.ipkg +++ b/idris2api.ipkg @@ -21,6 +21,8 @@ modules = Compiler.ES.RemoveUnused, Compiler.ES.TailRec, + Compiler.RefC.RefC, + Compiler.Scheme.Chez, Compiler.Scheme.Racket, Compiler.Scheme.Gambit, diff --git a/libs/base/Data/List.idr b/libs/base/Data/List.idr index 9562b7f2c..ab9eca6a8 100644 --- a/libs/base/Data/List.idr +++ b/libs/base/Data/List.idr @@ -254,6 +254,10 @@ public export splitOn : Eq a => a -> List a -> List1 (List a) splitOn a = split (== a) +public export +replaceWhen : (a -> Bool) -> a -> List a -> List a +replaceWhen p b l = map (\c => if p c then b else c) l + ||| Replaces all occurences of the first argument with the second argument in a list. ||| ||| ```idris example @@ -262,7 +266,7 @@ splitOn a = split (== a) ||| public export replaceOn : Eq a => a -> a -> List a -> List a -replaceOn a b l = map (\c => if c == a then b else c) l +replaceOn a = replaceWhen (== a) public export reverseOnto : List a -> List a -> List a diff --git a/libs/base/Decidable/Equality.idr b/libs/base/Decidable/Equality.idr index 71c268a24..11c68ea89 100644 --- a/libs/base/Decidable/Equality.idr +++ b/libs/base/Decidable/Equality.idr @@ -84,12 +84,6 @@ DecEq t => DecEq (Maybe t) where -- Either -------------------------------------------------------------------------------- -Uninhabited (Left x = Right y) where - uninhabited Refl impossible - -Uninhabited (Right x = Left y) where - uninhabited Refl impossible - export (DecEq t, DecEq s) => DecEq (Either t s) where decEq (Left x) (Left y) with (decEq x y) diff --git a/libs/base/System/File.idr b/libs/base/System/File.idr index 8c592dd89..07dc02ef6 100644 --- a/libs/base/System/File.idr +++ b/libs/base/System/File.idr @@ -160,6 +160,21 @@ export closeFile : HasIO io => File -> io () closeFile (FHandle f) = primIO (prim__close f) +||| Check if a file exists for reading. +export +exists : HasIO io => String -> io Bool +exists f + = do Right ok <- openFile f Read + | Left err => pure False + closeFile ok + pure True + +||| Pick the first existing file +export +firstExists : HasIO io => List String -> io (Maybe String) +firstExists [] = pure Nothing +firstExists (x :: xs) = if !(exists x) then pure (Just x) else firstExists xs + export fileError : HasIO io => File -> io Bool fileError (FHandle f) diff --git a/libs/contrib/Data/Container.idr b/libs/contrib/Data/Container.idr new file mode 100644 index 000000000..f0ce738af --- /dev/null +++ b/libs/contrib/Data/Container.idr @@ -0,0 +1,359 @@ +------------------------------------------------------------------------ +-- This module is based on the following papers: + +-- Categories of Containers +-- Abbott, Altenkirch, Ghani + +-- Derivatives of Containers +-- Abbott, Altenkirch, Ghani, McBride +------------------------------------------------------------------------ + +module Data.Container + +import Data.Either +import Decidable.Equality + +%default total + +------------------------------------------------------------------------ +-- Container and their morphisms +-- * Extension is a functor from Container to Type + +-- Objects of the category of containers +namespace Container + + public export + record Container where + constructor MkContainer + Shape : Type + Position : Shape -> Type + + public export + record Extension (c : Container) (x : Type) where + constructor MkExtension + shape : Shape c + payloads : Position c shape -> x + + ||| The image of a container by @Extension@ is a functor + public export + Functor (Extension c) where map f (MkExtension s p) = MkExtension s (f . p) + +-- Morphisms of the category of containers +namespace Morphism + + public export + record Morphism (c, d : Container) where + constructor MkMorphism + shapeMorphism : Shape c -> Shape d + positionMorphism : {s : Shape c} -> Position d (shapeMorphism s) -> Position c s + + public export + Extension : Morphism c d -> Extension c x -> Extension d x + Extension phi (MkExtension s p) + = MkExtension (shapeMorphism phi s) (p . positionMorphism phi) + +------------------------------------------------------------------------ +-- Combinators to build containers + +namespace Combinators + + -- Constant + public export + Const : Type -> Container + Const k = MkContainer k (const Void) + + export + toConst : k -> Extension (Const k) x + toConst v = MkExtension v absurd + + export + fromConst : Extension (Const k) x -> k + fromConst (MkExtension v _) = v + + -- Identity + public export + Identity : Container + Identity = MkContainer () (\ () => ()) + + export + toIdentity : x -> Extension Identity x + toIdentity v = MkExtension () (const v) + + export + fromIdentity : Extension Identity x -> x + fromIdentity (MkExtension () chld) = chld () + + -- Composition + public export + Compose : (d, c : Container) -> Container + Compose d c = MkContainer + (Extension d (Shape c)) + (\ (MkExtension shp chld) => (p : Position d shp ** Position c (chld p))) + + export + toCompose : (Extension d . Extension c) x -> Extension (Compose d c) x + toCompose (MkExtension shp1 chld) + = MkExtension (MkExtension shp1 (shape . chld)) (\ (p ** q) => payloads (chld p) q) + + export + fromCompose : Extension (Compose d c) x -> (Extension d . Extension c) x + fromCompose (MkExtension (MkExtension shp1 shp2) chld) + = MkExtension shp1 (\ p => MkExtension (shp2 p) (\ q => chld (p ** q))) + + -- Direct sum + public export + Sum : (c, d : Container) -> Container + Sum c d = MkContainer (Either (Shape c) (Shape d)) (either (Position c) (Position d)) + + export + toSum : Either (Extension c x) (Extension d x) -> Extension (Sum c d) x + toSum (Left (MkExtension shp chld)) = MkExtension (Left shp) chld + toSum (Right (MkExtension shp chld)) = MkExtension (Right shp) chld + + export + fromSum : Extension (Sum c d) x -> Either (Extension c x) (Extension d x) + fromSum (MkExtension (Left shp) chld) = Left (MkExtension shp chld) + fromSum (MkExtension (Right shp) chld) = Right (MkExtension shp chld) + + -- Pairing + public export + Pair : (c, d : Container) -> Container + Pair c d = MkContainer (Shape c, Shape d) (\ (p, q) => Either (Position c p) (Position d q)) + + export + toPair : (Extension c x, Extension d x) -> Extension (Pair c d) x + toPair (MkExtension shp1 chld1, MkExtension shp2 chld2) + = MkExtension (shp1, shp2) (either chld1 chld2) + + export + fromPair : Extension (Pair c d) x -> (Extension c x, Extension d x) + fromPair (MkExtension (shp1, shp2) chld) + = (MkExtension shp1 (chld . Left), MkExtension shp2 (chld . Right)) + + -- Branching over a Type + public export + Exponential : Type -> Container -> Container + Exponential k c = MkContainer (k -> Shape c) (\ p => (v : k ** Position c (p v))) + + export + toExponential : (k -> Extension c x) -> Extension (Exponential k c) x + toExponential f = MkExtension (shape . f) (\ (v ** p) => payloads (f v) p) + + export + fromExponential : Extension (Exponential k c) x -> (k -> Extension c x) + fromExponential (MkExtension shp chld) k = MkExtension (shp k) (\ p => chld (k ** p)) + +------------------------------------------------------------------------ +-- Taking various fixpoints of containers + +namespace Initial + + public export + data W : Container -> Type where + MkW : Extension c (W c) -> W c + + export + map : Morphism c d -> W c -> W d + map f (MkW (MkExtension shp chld)) = MkW $ Extension f (MkExtension shp (\ p => map f (chld p))) + -- Container.map inlined because of -------------------^ + -- termination checking + + export + foldr : (Extension c x -> x) -> W c -> x + foldr alg (MkW (MkExtension shp chld)) = alg (MkExtension shp (\ p => foldr alg (chld p))) + + export + para : (Extension c (x, W c) -> x) -> W c -> x + para alg (MkW (MkExtension shp chld)) = alg (MkExtension shp (\ p => let w = chld p in (para alg w, w))) + +namespace Monad + + ||| @Free@ is a wrapper around @W@ to make it inference friendly. + ||| Without this wrapper, neither @pure@ nor @bind@ are able to infer their @c@ argument. + public export + record Free (c : Container) (x : Type) where + constructor MkFree + runFree : W (Sum c (Const x)) + + export + pure : x -> Free c x + pure x = MkFree $ MkW (toSum (Right (toConst x))) + + export + (>>=) : Free c x -> (x -> Free c y) -> Free c y + (>>=) (MkFree mx) k = foldr (alg . fromSum {c} {d = Const x}) mx where + + alg : Either (Extension c (Free c y)) (Extension (Const x) (Free c y)) -> Free c y + alg = either (MkFree . MkW . toSum {c} {d = Const y} . Left . map (runFree {c})) + (k . fromConst {k = x}) + + export + join : Free c (Free c x) -> Free c x + join = (>>= id) + +namespace Final + + public export + data M : Container -> Type where + MkM : Extension c (Inf (M c)) -> M c + + export + unfoldr : (s -> Extension c s) -> s -> M c + unfoldr next seed = + let (MkExtension shp chld) = next seed in + MkM (MkExtension shp (\ p => unfoldr next (chld p))) + +namespace Comonad + + ||| @Cofree@ is a wrapper around @M@ to make it inference friendly. + ||| Without this wrapper, neither @extract@ nor @extend@ are able to infer their @c@ argument. + public export + record Cofree (c : Container) (x : Type) where + constructor MkCofree + runCofree : M (Pair (Const x) c) + + export + extract : Cofree c x -> x + extract (MkCofree (MkM m)) = fst (shape m) + + export + extend : (Cofree c a -> b) -> Cofree c a -> Cofree c b + extend alg = MkCofree . unfoldr next . runCofree where + + next : M (Pair (Const a) c) -> Extension (Pair (Const b) c) (M (Pair (Const a) c)) + next m@(MkM layer) = + let (_, (MkExtension shp chld)) = fromPair {c = Const a} layer in + let b = toConst (alg (MkCofree m)) in + toPair (b, MkExtension shp (\ p => chld p)) +-- Eta-expanded to force Inf ------^ + + export + duplicate : Cofree c a -> Cofree c (Cofree c a) + duplicate = extend id + +------------------------------------------------------------------------ +-- Derivative + +namespace Derivative + + public export + Derivative : Container -> Container + Derivative c = MkContainer + (s : Shape c ** Position c s) + (\ (s ** p) => (p' : Position c s ** Not (p === p'))) + + export + hole : (v : Extension (Derivative c) x) -> Position c (fst (shape v)) + hole (MkExtension (shp ** p) _) = p + + export + unplug : (v : Extension c x) -> Position c (shape v) -> (Extension (Derivative c) x, x) + unplug (MkExtension shp chld) p = (MkExtension (shp ** p) (chld . fst), chld p) + + export + plug : (v : Extension (Derivative c) x) -> DecEq (Position c (fst (shape v))) => x -> Extension c x + plug (MkExtension (shp ** p) chld) x = MkExtension shp $ \ p' => case decEq p p' of + Yes eq => x + No neq => chld (p' ** neq) + + export + toConst : Extension (Const Void) x -> Extension (Derivative (Const k)) x + toConst v = absurd (fromConst v) + + export + fromConst : Extension (Derivative (Const k)) x -> Extension (Const Void) x + fromConst v = absurd (hole {c = Const _} v) + + export + toIdentity : Extension (Derivative Identity) x + toIdentity = MkExtension (() ** ()) (\ (() ** eq) => absurd (eq Refl)) + + export + toSum : Extension (Sum (Derivative c) (Derivative d)) x -> + Extension (Derivative (Sum c d)) x + toSum v = case fromSum {c = Derivative c} {d = Derivative d} v of + Left (MkExtension (shp ** p) chld) => MkExtension (Left shp ** p) chld + Right (MkExtension (shp ** p) chld) => MkExtension (Right shp ** p) chld + + export + fromSum : Extension (Derivative (Sum c d)) x -> + Extension (Sum (Derivative c) (Derivative d)) x + fromSum (MkExtension (shp ** p) chld) = toSum {c = Derivative c} {d = Derivative d} $ case shp of + Left shp => Left (MkExtension (shp ** p) chld) + Right shp => Right (MkExtension (shp ** p) chld) + + export + toPair : Extension (Sum (Pair (Derivative c) d) (Pair c (Derivative d))) x -> + Extension (Derivative (Pair c d)) x + toPair v = case fromSum {c = Pair (Derivative c) d} {d = Pair c (Derivative d)} v of + Left p => let (MkExtension (shp1 ** p1) chld1, MkExtension shp2 chld2) = fromPair {c = Derivative c} p in + MkExtension ((shp1, shp2) ** Left p1) $ \ (p' ** neq) => case p' of + Left p1' => chld1 (p1' ** (neq . cong Left)) + Right p2' => chld2 p2' + Right p => let (MkExtension shp1 chld1, MkExtension (shp2 ** p2) chld2) = fromPair {c} {d = Derivative d} p in + MkExtension ((shp1, shp2) ** Right p2) $ \ (p' ** neq) => case p' of + Left p1' => chld1 p1' + Right p2' => chld2 (p2' ** (neq . cong Right)) + + export + fromPair : Extension (Derivative (Pair c d)) x -> + Extension (Sum (Pair (Derivative c) d) (Pair c (Derivative d))) x + fromPair (MkExtension ((shp1, shp2) ** p) chld) = case p of + Left p1 => toSum {c = Pair (Derivative c) d} {d = Pair c (Derivative d)} + (Left (MkExtension ((shp1 ** p1), shp2) $ either + (\ p1' => chld (Left (DPair.fst p1') ** DPair.snd p1' . leftInjective)) + (\ p2 => chld (Right p2 ** absurd)))) + Right p2 => toSum {c = Pair (Derivative c) d} {d = Pair c (Derivative d)} + (Right (MkExtension (shp1, (shp2 ** p2)) $ either + (\ p1 => chld (Left p1 ** absurd)) + (\ p2' => chld (Right (DPair.fst p2') ** DPair.snd p2' . rightInjective)))) + + + export + fromCompose : Extension (Derivative (Compose c d)) x -> + Extension (Pair (Derivative d) (Compose (Derivative c) d)) x + fromCompose (MkExtension (MkExtension shp1 shp2 ** (p1 ** p2)) chld) + = toPair (left, right) where + + left : Extension (Derivative d) x + left = MkExtension (shp2 p1 ** p2) + $ \ (p2' ** neqp2) => chld ((p1 ** p2') ** neqp2 . mkDPairInjectiveSnd) + + right : Extension (Compose (Derivative c) d) x + right = toCompose + $ MkExtension (shp1 ** p1) + $ \ (p1' ** neqp1) => MkExtension (shp2 p1') + $ \ p2' => chld ((p1' ** p2') ** (neqp1 . cong fst)) + + export + toCompose : ((s : _) -> DecEq (Position c s)) -> ((s : _) -> DecEq (Position d s)) -> + Extension (Pair (Derivative d) (Compose (Derivative c) d)) x -> + Extension (Derivative (Compose c d)) x + toCompose dec1 dec2 v with (fromPair {c = Derivative d} {d = Compose (Derivative c) d} v) + toCompose dec1 dec2 v | (MkExtension (shp2 ** p2) chld2, w) with (fromCompose w) + toCompose dec1 dec2 v + | (MkExtension (shp2 ** p2) chld2, w) + | (MkExtension (shp1 ** p1) chld1) + = MkExtension (MkExtension shp1 (\ p1' => shp2' p1' (decEq @{dec1 shp1} p1 p1')) ** + (p1 ** (p2' (decEq @{dec1 shp1} p1 p1)))) + $ \ ((p1' ** p2'') ** neq) => chld2' p1' p2'' neq + + where + shp2' : (p1' : Position c shp1) -> Dec (p1 === p1') -> Shape d + shp2' p1' (Yes eq) = shp2 + shp2' p1' (No neq) = shape (chld1 (p1' ** neq)) + + p2' : (eq : Dec (p1 === p1)) -> Position d (shp2' p1 eq) + p2' (Yes Refl) = p2 + p2' (No neq) = absurd (neq Refl) + + chld2' : (p1' : Position c shp1) -> + (p2'' : Position d (shp2' p1' (decEq @{dec1 shp1} p1 p1'))) -> + (neq : Not (MkDPair p1 (p2' (decEq @{dec1 shp1} p1 p1)) = MkDPair p1' p2'')) -> x + chld2' p1' p2'' neq with (decEq @{dec1 shp1} p1 p1') + chld2' p1' p2'' neq | No neq1 = payloads (chld1 (p1' ** neq1)) p2'' + chld2' _ p2'' neq | Yes Refl with (decEq @{dec1 shp1} p1 p1) + chld2' _ p2'' neq | Yes Refl | No argh = absurd (argh Refl) + chld2' _ p2'' neq | Yes Refl | Yes Refl with (decEq @{dec2 shp2} p2 p2'') + chld2' _ p2'' neq | Yes Refl | Yes Refl | No neq2 = chld2 (p2'' ** neq2) + chld2' _ _ neq | Yes Refl | Yes Refl | Yes Refl = absurd (neq Refl) diff --git a/libs/contrib/Data/InductionRecursion/DybjerSetzer.idr b/libs/contrib/Data/InductionRecursion/DybjerSetzer.idr new file mode 100644 index 000000000..95c5f4653 --- /dev/null +++ b/libs/contrib/Data/InductionRecursion/DybjerSetzer.idr @@ -0,0 +1,65 @@ +||| There are different flavours of induction-recursion. This is the one +||| introduced in Dybjer and Setzer's paper: +||| Indexed induction-recursion + +module Data.InductionRecursion.DybjerSetzer + +%default total + +public export +data Code : (input : sort -> Type) -> (output : Type) -> Type where + Yield : output -> Code input output + Store : (payload : Type) -> (payload -> Code input output) -> Code input output + Branch : (label : Type) -> (toSort : label -> sort) -> + (((l : label) -> input (toSort l)) -> Code input output) -> + Code input output + +public export +DecodeType + : Code input output -> (x : sort -> Type) -> + (f : {s : sort} -> x s -> input s) -> + Type +DecodeType (Yield _) x f = () +DecodeType (Store payload k) x f = (v : payload ** DecodeType (k v) x f) +DecodeType (Branch label toSort k) x f + = (r : ((l : label) -> x (toSort l)) ** DecodeType (k (\ l => f (r l))) x f) + +public export +DecodeOutput + : (c : Code input output) -> (x : Lazy (sort -> Type)) -> + (f : {s : sort} -> x s -> input s) -> + DecodeType c x f -> output +DecodeOutput (Yield o) x f _ = o +DecodeOutput (Store p k) x f (v ** d) = DecodeOutput (k v) x f d +DecodeOutput (Branch l s k) x f (r ** d) = DecodeOutput (k (\ l => f (r l))) x f d + +mutual + + public export + data Mu : (f : (s : sort) -> Code input (input s)) -> (s : sort) -> Type where + MkMu : {f : (s : sort) -> Code input (input s)} -> {s : sort} -> + DecodeType (f s) (Mu f) Decode -> Mu {input} f s + + public export + Decode : {f : (s : sort) -> Code input (input s)} -> + {s : sort} -> Mu {input} f s -> input s + Decode (MkMu d) = DecodeOutput (f s) (Mu f) (\ d => assert_total (Decode d)) d + +public export +bind : Code i o -> (o -> Code i o') -> Code i o' +bind (Yield v) f = f v +bind (Store p k) f = Store p (\ v => bind (k v) f) +bind (Branch l s k) f = Branch l s (\ r => bind (k r) f) + +public export +Functor (Code i) where + map f v = bind v (Yield . f) + +public export +Applicative (Code i) where + pure = Yield + cf <*> co = bind cf (\ f => map (f $) co) + +public export +Monad (Code i) where + (>>=) = bind diff --git a/libs/contrib/Data/Late.idr b/libs/contrib/Data/Late.idr new file mode 100644 index 000000000..bf6f48712 --- /dev/null +++ b/libs/contrib/Data/Late.idr @@ -0,0 +1,81 @@ +module Data.Late + +%default total + +------------------------------------------------------------------------ +-- Type + +public export +data Late : Type -> Type where + Now : a -> Late a + Later : Inf (Late a) -> Late a + +------------------------------------------------------------------------ +-- Creating late values + +||| Never return +never : Late a +never = Later never + +||| Run a small state machine until it reaches a final state and yields a value. +public export +unfold : (seed -> Either seed value) -> seed -> Late value +unfold f s = case f s of + Left s' => Later (unfold f s') + Right v => Now v + +||| It's easier to define map and (<*>) in terms of bind so let's start +||| by defining it. +public export +bind : Late a -> (a -> Late b) -> Late b +bind (Now v) f = f v +bind (Later d) f = Later (bind d f) + +------------------------------------------------------------------------ +-- Inspecting late values + +||| Check whether we already have a value. +public export +isNow : Late a -> Maybe a +isNow (Now v) = Just v +isNow (Later d) = Nothing + +||| Wait for one tick, hoping to get a value. +public export +wait : Late a -> Late a +wait (Later d) = d +wait d = d + +||| Wait for a set number of ticks. +public export +engine : Nat -> Late a -> Late a +engine Z = id +engine (S n) = engine n . wait + +||| Wait for a set number of ticks, hoping to get a value. +public export +petrol : Nat -> Late a -> Maybe a +petrol n = isNow . engine n + +||| Accelerate makes things happen twice as fast. +public export +accelerate : Late a -> Late a +accelerate (Later (Later d)) = Later (accelerate d) +accelerate (Later (Now v)) = Now v +accelerate d = d + +------------------------------------------------------------------------ +-- Instances + +public export +Functor Late where + map f d = bind d (Now . f) + +public export +Applicative Late where + pure = Now + df <*> dx = bind df (\ f => map (f $) dx) + +public export +Monad Late where + (>>=) = bind diff --git a/libs/contrib/Data/Recursion/Free.idr b/libs/contrib/Data/Recursion/Free.idr new file mode 100644 index 000000000..7a6b5a0bd --- /dev/null +++ b/libs/contrib/Data/Recursion/Free.idr @@ -0,0 +1,285 @@ +||| Module partially based on McBride's paper: +||| Turing-Completeness Totally Free +||| +||| It gives us a type to describe computation using general recursion +||| and functions to run these computations for a while or to completion +||| if we are able to prove them total. +||| +||| The content of the Erased section is new. Instead of producing the +||| domain/evaluation pair by computing a Dybjer-Setzer code we build a +||| specialised structure that allows us to make the domain proof runtime +||| irrelevant. + +module Data.Recursion.Free + +import Data.Late +import Data.InductionRecursion.DybjerSetzer + +%default total + +------------------------------------------------------------------------ +-- Type + +||| Syntax for a program using general recursion +public export +data General : (a : Type) -> (b : a -> Type) -> (x : Type) -> Type where + ||| We can return a value without performing any recursive call. + Tell : x -> General a b x + ||| Or we can pick an input and ask an oracle to give us a return value + ||| for it. The second argument is a continuation explaining what we want + ||| to do with the returned value. + Ask : (i : a) -> (b i -> General a b x) -> General a b x + +||| Type of functions using general recursion +public export +PiG : (a : Type) -> (b : a -> Type) -> Type +PiG a b = (i : a) -> General a b (b i) + +||| Recursor for General +public export +fold : (x -> y) -> ((i : a) -> (b i -> y) -> y) -> General a b x -> y +fold pure ask (Tell x) = pure x +fold pure ask (Ask i k) = ask i (\ o => fold pure ask (k o)) + +------------------------------------------------------------------------ +-- Basic functions + +||| Perform a recursive call and return the value provided by the oracle. +public export +call : PiG a b +call i = Ask i Tell + +||| Monadic bind (defined outside of the interface to be able to use it for +||| map and (<*>)). +public export +bind : General a b x -> (x -> General a b y) -> General a b y +bind m f = fold f Ask m + +||| Given a monadic oracle we can give a monad morphism interpreting a +||| function using general recursion as a monadic process. +public export +monadMorphism : Monad m => (t : (i : a) -> m (b i)) -> General a b x -> m x +monadMorphism t = fold pure (\ i => (t i >>=)) + +------------------------------------------------------------------------ +-- Instances + +public export +Functor (General a b) where + map f = fold (Tell . f) Ask + +public export +Applicative (General a b) where + pure = Tell + gf <*> gv = bind gf (\ f => map (f $) gv) + +public export +Monad (General a b) where + (>>=) = bind + +------------------------------------------------------------------------ +-- Fuel-based (partial) evaluation + +||| Check whehther we are ready to return a value +public export +already : General a b x -> Maybe x +already = monadMorphism (\ i => Nothing) + +||| Use a function using general recursion to expand all of the oracle calls. +public export +expand : PiG a b -> General a b x -> General a b x +expand f = monadMorphism f + +||| Recursively call expand a set number of times. +public export +engine : PiG a b -> Nat -> General a b x -> General a b x +engine f Z = id +engine f (S n) = engine f n . expand f + +||| Check whether recursively calling expand a set number of times is enough +||| to produce a value. +public export +petrol : PiG a b -> Nat -> (i : a) -> Maybe (b i) +petrol f n i = already $ engine f n $ f i + +------------------------------------------------------------------------ +-- Late-based evaluation + +||| Rely on an oracle using general recursion to convert a function using +||| general recursion into a process returning a value in the (distant) future. +public export +late : PiG a b -> General a b x -> Late x +late f = monadMorphism (\ i => Later (assert_total $ late f (f i))) + +||| Interpret a function using general recursion as a process returning +||| a value in the (distant) future. +public export +lazy : PiG a b -> (i : a) -> Late (b i) +lazy f i = late f (f i) + +------------------------------------------------------------------------ +-- Domain as a Dybjer-Setzer code and total evaluation function + +namespace DybjerSetzer + + ||| Compute, as a Dybjer-Setzer code for an inductive-recursive type, the domain + ||| of a function defined by general recursion. + public export + Domain : PiG a b -> (i : a) -> Code b (b i) + Domain f i = monadMorphism ask (f i) where + + ask : (i : a) -> Code b (b i) + ask i = Branch () (const i) $ \ t => Yield (t ()) + + ||| If a given input is in the domain of the function then we may evaluate + ||| it fully on that input and obtain a pure return value. + public export + evaluate : (f : PiG a b) -> (i : a) -> Mu (Domain f) i -> b i + evaluate f i inDom = Decode inDom + + ||| If every input value is in the domain then the function is total. + public export + totally : (f : PiG a b) -> ((i : a) -> Mu (Domain f) i) -> + (i : a) -> b i + totally f allInDomain i = evaluate f i (allInDomain i) + +------------------------------------------------------------------------ +-- Runtime irrelevant domain and total evaluation function + +namespace Erased + + ------------------------------------------------------------------------ + -- Domain and evaluation functions + + ||| What it means to describe a terminating computation + ||| @ f is the function used to answer questions put to the oracle + ||| @ d is the description of the computation + public export + data Layer : (f : PiG a b) -> (d : General a b (b i)) -> Type + + ||| The domain of a function (i.e. the set of inputs for which it terminates) + ||| as a predicate on inputs + ||| @ f is the function whose domain is being described + ||| @ i is the input that is purported to be in the domain + Domain : (f : PiG a b) -> (i : a) -> Type + + ||| Fully evaluate a computation known to be terminating. + ||| Because of the careful design of the inductive family Layer, we can make + ||| the proof runtime irrelevant. + evaluateLayer : (f : PiG a b) -> (d : General a b (b i)) -> (0 _ : Layer f d) -> b i + + ||| Fully evaluate a function call for an input known to be in its domain. + evaluate : (f : PiG a b) -> (i : a) -> (0 _ : Domain f i) -> b i + + -- In a classic Dybjer-Setzer situation this is computed by induction over the + -- index of type `General a b (b i)` and the fixpoint called `Domain` is the + -- one thing defined as an inductive type. + -- Here we have to flip the script because Idris will only trust inductive data + -- as a legitimate source of termination metric for a recursive function. This + -- makes our definition of `evaluateLayer` obviously terminating. + data Layer : PiG a b -> General a b (b i) -> Type where + ||| A computation returning a value is trivially terminating + MkTell : {0 a : Type} -> {0 b : a -> Type} -> {0 f : PiG a b} -> {0 i : a} -> + (o : b i) -> Layer f (Tell o) + + ||| Performing a call to the oracle is termnating if the input is in its + ||| domain and if the rest of the computation is also finite. + MkAsk : {0 a : Type} -> {0 b : a -> Type} -> {0 f : PiG a b} -> {0 i : a} -> + (j : a) -> (jprf : Domain f j) -> + (k : b j -> General a b (b i)) -> Layer f (k (evaluate f j jprf)) -> + Layer f (Ask j k) + + -- Domain is simply defined as the top layer leading to a terminating + -- computation with the function used as its own oracle. + Domain f i = Layer f (f i) + + ||| A view that gives us a pattern-matching friendly presentation of the + ||| @ d computation known to be terminating + ||| @ l proof that it is + ||| This may seem like a useless definition but the function `view` + ||| demonstrates a very important use case: even if the proof is runtime + ||| irrelevant, we can manufacture a satisfying view of it. + data View : {d : General a b (b i)} -> (l : Layer f d) -> Type where + TView : {0 b : a -> Type} -> {0 f : PiG a b} -> (o : b i) -> View (MkTell {b} {f} o) + AView : {0 f : PiG a b} -> + (j : a) -> (0 jprf : Domain f j) -> + (k : b j -> General a b (b i)) -> (0 kprf : Layer f (k (evaluate f j jprf))) -> + View (MkAsk j jprf k kprf) + + ||| Function computing the view by pattern-matching on the computation and + ||| inverting the proof. Note that the proof is runtime irrelevant even though + ||| the resulting view is not: this is possible because the relevant constructor + ||| is uniquely determined by the shape of `d`. + public export + view : (d : General a b (b i)) -> (0 l : Layer f d) -> View l + view (Tell o) (MkTell o) = TView o + view (Ask j k) (MkAsk j jprf k kprf) = AView j jprf k kprf + + -- Just like `Domain` is defined in terms of `Layer`, the evaluation of a + -- function call for an input in its domain can be reduced to the evaluation + -- of a layer. + evaluate f i l = evaluateLayer f (f i) l + + -- The view defined earlier allows us to pattern on the runtime irrelevant + -- proof that the layer describes a terminating computation and therefore + -- define `evaluateLayer` in a way that is purely structural. + -- This becomes obvious if one spells out the (forced) pattern corresponding + -- to `d` in each branch of the case. + evaluateLayer f d l = case view d l of + TView o => o + AView j jprf k kprf => evaluateLayer f (k (evaluate f j jprf)) kprf + + ||| If a function's domain is total then it is a pure function. + public export + totally : (f : PiG a b) -> (0 _ : (i : a) -> Domain f i) -> + (i : a) -> b i + totally f dom i = evaluate f i (dom i) + + ------------------------------------------------------------------------ + -- Proofs + + ||| Domain is a singleton type + export + irrelevantDomain : (f : PiG a b) -> (i : a) -> (p, q : Domain f i) -> p === q + + ||| Layer is a singleton type + irrelevantLayer + : (f : PiG a b) -> (d : General a b (b i)) -> (l, m : Layer f d) -> l === m + + irrelevantDomain f i p q = irrelevantLayer f (f i) p q + + irrelevantLayer f (Tell o) + (MkTell o) (MkTell o) = Refl + irrelevantLayer f (Ask j k) + (MkAsk j jprf1 k kprf1) (MkAsk j jprf2 k kprf2) + with (irrelevantDomain f j jprf1 jprf2) + irrelevantLayer f (Ask j k) + (MkAsk j jprf k kprf1) (MkAsk j jprf k kprf2) + | Refl = cong (MkAsk j jprf k) + $ irrelevantLayer f (k (evaluate f j jprf)) kprf1 kprf2 + + ||| The result of `evaluateLayer` does not depend on the specific proof that + ||| `i` is in the domain of the layer of computation at hand. + export + evaluateLayerIrrelevance + : (f : PiG a b) -> (d : General a b (b i)) -> (0 p, q : Layer f d) -> + evaluateLayer f d p === evaluateLayer f d q + evaluateLayerIrrelevance f d p q + = rewrite irrelevantLayer f d p q in Refl + + ||| The result of `evaluate` does not depend on the specific proof that `i` + ||| is in the domain of the function at hand. + export + evaluateIrrelevance + : (f : PiG a b) -> (i : a) -> (0 p, q : Domain f i) -> + evaluate f i p === evaluate f i q + evaluateIrrelevance f i p q + = evaluateLayerIrrelevance f (f i) p q + + ||| The result computed by a total function is independent from the proof + ||| that it is total. + export + totallyIrrelevance + : (f : PiG a b) -> (0 p, q : (i : a) -> Domain f i) -> + (i : a) -> totally f p i === totally f q i + totallyIrrelevance f p q i = evaluateIrrelevance f i (p i) (q i) diff --git a/libs/contrib/Data/String/Parser.idr b/libs/contrib/Data/String/Parser.idr index 28ab1f01c..b3b1142da 100644 --- a/libs/contrib/Data/String/Parser.idr +++ b/libs/contrib/Data/String/Parser.idr @@ -1,11 +1,13 @@ ||| A simple parser combinator library for strings. Inspired by attoparsec zepto. module Data.String.Parser -import Control.Monad.Identity +import public Control.Monad.Identity import Control.Monad.Trans import Data.Strings import Data.Fin import Data.List +import Data.List1 +import Data.Vect %default total @@ -121,6 +123,17 @@ export optional : Functor m => ParseT m a -> ParseT m (Maybe a) optional = optionMap Nothing Just +||| Succeeds if and only if the argument parser fails. +||| +||| In Parsec, this combinator is called `notFollowedBy`. +export +requireFailure : Functor m => ParseT m a -> ParseT m () +requireFailure (P runParser) = P $ \s => reverseResult s <$> runParser s +where + reverseResult : State -> Result a -> Result () + reverseResult s (Fail _ _) = OK () s + reverseResult s (OK _ _) = Fail (pos s) "Purposefully changed OK to Fail" + ||| Fail with some error message export fail : Applicative m => String -> ParseT m a @@ -138,12 +151,12 @@ satisfy f = P $ \s => pure $ if s.pos < s.maxPos ||| Succeeds if the string `str` follows. export -string : Applicative m => String -> ParseT m () +string : Applicative m => String -> ParseT m String string str = P $ \s => pure $ let len = strLength str in if s.pos+len <= s.maxPos then let head = strSubstr s.pos len s.input in if head == str - then OK () (S s.input (s.pos + len) s.maxPos) + then OK str (S s.input (s.pos + len) s.maxPos) else Fail s.pos ("string " ++ show str) else Fail s.pos ("string " ++ show str) @@ -156,13 +169,25 @@ eos = P $ \s => pure $ if s.pos == s.maxPos ||| Succeeds if the next char is `c` export -char : Applicative m => Char -> ParseT m () -char c = skip $ satisfy (== c) +char : Applicative m => Char -> ParseT m Char +char c = satisfy (== c) "char " ++ show c ||| Parses a space character export space : Applicative m => ParseT m Char -space = satisfy isSpace +space = satisfy isSpace "space" + +||| Parses a letter or digit (a character between \'0\' and \'9\'). +||| Returns the parsed character. +export +alphaNum : Applicative m => ParseT m Char +alphaNum = satisfy isAlphaNum "letter or digit" + +||| Parses a letter (an upper case or lower case character). Returns the +||| parsed character. +export +letter : Applicative m => ParseT m Char +letter = satisfy isAlpha "letter" mutual ||| Succeeds if `p` succeeds, will continue to match `p` until it fails @@ -209,11 +234,23 @@ covering takeWhile : Monad m => (Char -> Bool) -> ParseT m String takeWhile f = pack <$> many (satisfy f) -||| Parses one or more space characters +||| Similar to `takeWhile` but fails if the resulting string is empty. +export +covering +takeWhile1 : Monad m => (Char -> Bool) -> ParseT m String +takeWhile1 f = pack <$> some (satisfy f) + +||| Parses zero or more space characters export covering spaces : Monad m => ParseT m () -spaces = skip (many space) "white space" +spaces = skip (many space) + +||| Parses one or more space characters +export +covering +spaces1 : Monad m => ParseT m () +spaces1 = skip (some space) "whitespaces" ||| Discards brackets around a matching parser export @@ -253,11 +290,11 @@ digit = do x <- satisfy isDigit , ('9', 9) ] -fromDigits : Num a => ((Fin 10) -> a) -> List (Fin 10) -> a +fromDigits : Num a => (Fin 10 -> a) -> List (Fin 10) -> a fromDigits f xs = foldl addDigit 0 xs where - addDigit : a -> (Fin 10) -> a - addDigit num d = 10*num + (f d) + addDigit : a -> Fin 10 -> a + addDigit num d = 10*num + f d intFromDigits : List (Fin 10) -> Integer intFromDigits = fromDigits finToInteger @@ -278,3 +315,47 @@ integer : Monad m => ParseT m Integer integer = do minus <- succeeds (char '-') x <- some digit pure $ if minus then (intFromDigits x)*(-1) else intFromDigits x + + +||| Parse repeated instances of at least one `p`, separated by `s`, +||| returning a list of successes. +||| +||| @ p the parser for items +||| @ s the parser for separators +export +covering +sepBy1 : Monad m => (p : ParseT m a) + -> (s : ParseT m b) + -> ParseT m (List1 a) +sepBy1 p s = [| p ::: many (s *> p) |] + +||| Parse zero or more `p`s, separated by `s`s, returning a list of +||| successes. +||| +||| @ p the parser for items +||| @ s the parser for separators +export +covering +sepBy : Monad m => (p : ParseT m a) + -> (s : ParseT m b) + -> ParseT m (List a) +sepBy p s = optionMap [] forget (p `sepBy1` s) + +||| Parses /one/ or more occurrences of `p` separated by `comma`. +export +covering +commaSep1 : Monad m => ParseT m a -> ParseT m (List1 a) +commaSep1 p = p `sepBy1` (char ',') + +||| Parses /zero/ or more occurrences of `p` separated by `comma`. +export +covering +commaSep : Monad m => ParseT m a -> ParseT m (List a) +commaSep p = p `sepBy` (char ',') + +||| Run the specified parser precisely `n` times, returning a vector +||| of successes. +export +ntimes : Monad m => (n : Nat) -> ParseT m a -> ParseT m (Vect n a) +ntimes Z p = pure Vect.Nil +ntimes (S n) p = [| p :: (ntimes n p) |] diff --git a/libs/contrib/Syntax/PreorderReasoning/Generic.idr b/libs/contrib/Syntax/PreorderReasoning/Generic.idr index 11054a604..7b5257d48 100644 --- a/libs/contrib/Syntax/PreorderReasoning/Generic.idr +++ b/libs/contrib/Syntax/PreorderReasoning/Generic.idr @@ -8,22 +8,22 @@ infix 1 ... public export data Step : (leq : a -> a -> Type) -> a -> a -> Type where - (...) : {leq : a -> a -> Type} -> (y : a) -> x `leq` y -> Step leq x y + (...) : (y : a) -> x `leq` y -> Step leq x y public export -data FastDerivation : {leq : a -> a -> Type} -> (x : a) -> (y : a) -> Type where - (|~) : (x : a) -> FastDerivation x x - (<~) : {leq : a -> a -> Type} -> {x,y : a} - -> FastDerivation {leq = leq} x y -> {z : a} -> (step : Step leq y z) - -> FastDerivation {leq = leq} x z +data FastDerivation : (leq : a -> a -> Type) -> (x : a) -> (y : a) -> Type where + (|~) : (x : a) -> FastDerivation leq x x + (<~) : {x, y : a} + -> FastDerivation leq x y -> {z : a} -> (step : Step leq y z) + -> FastDerivation leq x z -public export -CalcWith : Preorder dom leq => {x,y : dom} -> FastDerivation {leq = leq} x y -> x `leq` y +public export +CalcWith : Preorder dom leq => {x,y : dom} -> FastDerivation leq x y -> x `leq` y CalcWith (|~ x) = reflexive x CalcWith ((<~) der (z ... step)) = transitive {po = leq} _ _ _ (CalcWith der) step public export -(~~) : {x,y : dom} - -> FastDerivation {leq = leq} x y -> {z : dom} -> (step : Step Equal y z) - -> FastDerivation {leq = leq} x z +(~~) : {x,y : dom} + -> FastDerivation leq x y -> {z : dom} -> (step : Step Equal y z) + -> FastDerivation leq x z (~~) der (z ... Refl) = der diff --git a/libs/contrib/Test/Golden.idr b/libs/contrib/Test/Golden.idr new file mode 100644 index 000000000..1d99102c1 --- /dev/null +++ b/libs/contrib/Test/Golden.idr @@ -0,0 +1,322 @@ +||| Core features required to perform Golden file testing. +||| +||| We provide the core functionality to run a *single* golden file test, or +||| a whole test tree. +||| This allows the developer freedom to use as is or design the rest of the +||| test harness to their liking. +||| +||| This was originally used as part of Idris2's own test suite and +||| the core functionality is useful for the many and not the few. +||| Please see Idris2 test harness for example usage. +||| +||| # Test Structure +||| +||| This harness works from the assumption that each individual golden test +||| comprises of a directory with the following structure: +||| +||| + `run` a *shell* script that runs the test. We expect it to: +||| * Use `$1` as the variable standing for the idris executable to be tested +||| * May use `${IDRIS2_TESTS_CG}` to pick a codegen that ought to work +||| * Clean up after itself (e.g. by running `rm -rf build/`) +||| +||| + `expected` a file containting the expected output of `run` +||| +||| During testing, the test harness will generate an artefact named `output` and +||| display both outputs if there is a failure. +||| During an interactive session the following command is used to compare them as +||| they are: +||| +||| ```sh +||| git diff --no-index --exit-code --word-diff=color expected output +||| ``` +||| +||| If `git` fails then the runner will simply present the expected and 'given' +||| files side-by-side. +||| +||| Of note, it is helpful if `output` was added to a local `.gitignore` instance +||| to ensure that it is not mistakenly versioned. +||| +||| # Options +||| +||| The test harness has several options that may be set: +||| +||| + `idris2` The path of the executable we are testing. +||| + `onlyNames` The list of tests to run relative to the generated executable. +||| + `interactive` Whether to offer to update the expected file or not. +||| + `timing` Whether to display time taken for each test. +||| +||| We provide an options parser (`options`) that will take the command line arguments +||| and constructs this for you. +||| +||| # Usage +||| +||| When compiled to an executable the expected usage is: +||| +|||```sh +|||runtests [--timing] [--interactive] [--only [NAMES]] +|||``` +||| +||| assuming that the test runner is compiled to an executable named `runtests`. + +module Test.Golden + +import Data.Maybe +import Data.List +import Data.List1 +import Data.Strings + +import System +import System.Clock +import System.Directory +import System.File +import System.Info +import System.Path + +-- [ Options ] + +||| Options for the test driver. +public export +record Options where + constructor MkOptions + ||| Name of the idris2 executable + exeUnderTest : String + ||| Which codegen should we use? + codegen : Maybe String + ||| Should we only run some specific cases? + onlyNames : List String + ||| Should we run the test suite interactively? + interactive : Bool + ||| Should we time and display the tests + timing : Bool + +export +usage : String -> String +usage exe = unwords ["Usage:", exe, "runtests [--timing] [--interactive] [--cg CODEGEN] [--only [NAMES]]"] + +||| Process the command line options. +export +options : List String -> Maybe Options +options args = case args of + (_ :: exeUnderTest :: rest) => go rest (MkOptions exeUnderTest Nothing [] False False) + _ => Nothing + + where + + go : List String -> Options -> Maybe Options + go rest opts = case rest of + [] => pure opts + ("--timing" :: xs) => go xs (record { timing = True} opts) + ("--interactive" :: xs) => go xs (record { interactive = True } opts) + ("--cg" :: cg :: xs) => go xs (record { codegen = Just cg } opts) + ("--only" :: xs) => pure $ record { onlyNames = xs } opts + _ => Nothing + +-- [ Core ] + +export +fail : String -> IO () +fail err + = do putStrLn err + exitWith (ExitFailure 1) + + +||| Normalise strings between different OS. +||| +||| on Windows, we just ignore backslashes and slashes when comparing, +||| similarity up to that is good enough. Leave errors that depend +||| on the confusion of slashes and backslashes to unix machines. +normalize : String -> String +normalize str = + if isWindows + then pack $ filter (\ch => ch /= '/' && ch /= '\\') (unpack str) + else str + +||| Run the specified Golden test with the supplied options. +||| +||| See the module documentation for more information. +||| +||| @currdir absolute or relative path to root test directory. +||| @testpath the directory that contains the test. +export +runTest : Options -> (currdir, testPath : String) -> IO Bool +runTest opts currdir testPath + = do changeDir testPath + isSuccess <- runTest' + changeDir currdir + pure isSuccess + where + getAnswer : IO Bool + getAnswer = do + str <- getLine + case str of + "y" => pure True + "n" => pure False + _ => do putStrLn "Invalid Answer." + getAnswer + + printExpectedVsOutput : String -> String -> IO () + printExpectedVsOutput exp out = do + putStrLn "Expected:" + putStrLn exp + putStrLn "Given:" + putStrLn out + + mayOverwrite : Maybe String -> String -> IO () + mayOverwrite mexp out = do + the (IO ()) $ case mexp of + Nothing => putStr $ unlines + [ "Golden value missing. I computed the following result:" + , out + , "Accept new golden value? [yn]" + ] + Just exp => do + putStrLn "Golden value differs from actual value." + code <- system "git diff --no-index --exit-code --word-diff=color expected output" + when (code < 0) $ printExpectedVsOutput exp out + putStrLn "Accept actual value as new golden value? [yn]" + b <- getAnswer + when b $ do Right _ <- writeFile "expected" out + | Left err => print err + pure () + + printTiming : Bool -> Clock type -> String -> IO () + printTiming True clock msg = putStrLn (unwords [msg, show clock]) + printTiming False _ msg = putStrLn msg + + runTest' : IO Bool + runTest' + = do putStr $ testPath ++ ": " + start <- clockTime Thread + let cg = case codegen opts of + Nothing => "" + Just cg => "env IDRIS2_TESTS_CG=" ++ cg ++ " " + system $ cg ++ "sh ./run " ++ exeUnderTest opts ++ " | tr -d '\\r' > output" + end <- clockTime Thread + Right out <- readFile "output" + | Left err => do print err + pure False + Right exp <- readFile "expected" + | Left FileNotFound => do + if interactive opts + then mayOverwrite Nothing out + else print FileNotFound + pure False + | Left err => do print err + pure False + let result = normalize out == normalize exp + let time = timeDifference end start + if result + then printTiming (timing opts) time "success" + else do + printTiming (timing opts) time "FAILURE" + if interactive opts + then mayOverwrite (Just exp) out + else printExpectedVsOutput exp out + + pure result + +||| Find the first occurrence of an executable on `PATH`. +export +pathLookup : List String -> IO (Maybe String) +pathLookup names = do + path <- getEnv "PATH" + let pathList = forget $ split (== pathSeparator) $ fromMaybe "/usr/bin:/usr/local/bin" path + let candidates = [p ++ "/" ++ x | p <- pathList, + x <- names] + firstExists candidates + + +||| Some test may involve Idris' backends and have requirements. +||| We define here the ones supported by Idris +public export +data Requirement = Chez | Node | Racket + +export +Show Requirement where + show Chez = "Chez" + show Node = "node" + show Racket = "racket" + +export +checkRequirement : Requirement -> IO (Maybe String) +checkRequirement req + = do let (envvar, paths) = requirement req + Just exec <- getEnv envvar | Nothing => pathLookup paths + pure (Just exec) + + where + requirement : Requirement -> (String, List String) + requirement Chez = ("CHEZ", ["chez", "chezscheme9.5", "scheme", "scheme.exe"]) + requirement Node = ("NODE", ["node"]) + requirement Racket = ("RACKET", ["racket"]) + +export +findCG : IO (Maybe String) +findCG + = do Nothing <- getEnv "IDRIS2_TESTS_CG" | p => pure p + Nothing <- checkRequirement Chez | p => pure (Just "chez") + Nothing <- checkRequirement Node | p => pure (Just "node") + Nothing <- checkRequirement Racket | p => pure (Just "racket") + pure Nothing + +||| A test pool is characterised by +||| + a list of requirement +||| + and a list of directory paths +public export +record TestPool where + constructor MkTestPool + constraints : List Requirement + testCases : List String + +||| Only keep the tests that have been asked for +export +filterTests : Options -> List String -> List String +filterTests opts = case onlyNames opts of + [] => id + xs => filter (\ name => any (`isInfixOf` name) xs) + +||| A runner for a test pool +export +poolRunner : Options -> (currdir : String) -> TestPool -> IO (List Bool) +poolRunner opts currdir pool + = do -- check that we indeed want to run some of these tests + let tests = filterTests opts (testCases pool) + let (_ :: _) = tests + | [] => pure [] + -- if so make sure the constraints are satisfied + cs <- for (constraints pool) $ \ req => do + mfp <- checkRequirement req + putStrLn $ case mfp of + Nothing => show req ++ " not found" + Just fp => "Found " ++ show req ++ " at " ++ fp + pure mfp + let Just _ = the (Maybe (List String)) (sequence cs) + | Nothing => pure [] + -- if so run them all! + traverse (runTest opts currdir) tests + + +||| A runner for a whole test suite +export +runner : List TestPool -> IO () +runner tests + = do args <- getArgs + let (Just opts) = options args + | _ => do print args + putStrLn (usage "runtests") + -- if no CG has been set, find a sensible default based on what is available + opts <- case codegen opts of + Nothing => pure $ record { codegen = !findCG } opts + Just _ => pure opts + -- grab the current directory + Just pwd <- currentDir + | Nothing => putStrLn "FATAL: Could not get current working directory" + -- run the tests + res <- concat <$> traverse (poolRunner opts pwd) tests + putStrLn (show (length (filter id res)) ++ "/" ++ show (length res) + ++ " tests successful") + if (any not res) + then exitWith (ExitFailure 1) + else exitWith ExitSuccess + +-- [ EOF ] diff --git a/libs/contrib/contrib.ipkg b/libs/contrib/contrib.ipkg index 8dbf62afa..e6b55406e 100644 --- a/libs/contrib/contrib.ipkg +++ b/libs/contrib/contrib.ipkg @@ -14,7 +14,17 @@ modules = Control.ANSI, Data.Bool.Algebra, Data.Bool.Decidable, - + + Data.Container, + + Data.Fin.Extra, + + Data.Fun.Extra, + + Data.InductionRecursion.DybjerSetzer, + + Data.Late, + Data.Linear.Array, Data.List.Algebra, @@ -25,10 +35,6 @@ modules = Control.ANSI, Data.List.Views.Extra, Data.List.Palindrome, - Data.Fin.Extra, - - Data.Fun.Extra, - Data.Logic.Propositional, Data.Morphisms.Algebra, @@ -44,6 +50,8 @@ modules = Control.ANSI, Data.Nat.Order.Properties, Data.Nat.Properties, + Data.Recursion.Free, + Data.SortedMap, Data.SortedSet, Data.Stream.Extra, @@ -74,6 +82,8 @@ modules = Control.ANSI, Language.JSON.String.Tokens, Language.JSON.Tokens, + Test.Golden, + Text.Token, Text.Quantity, Text.Parser, diff --git a/libs/prelude/Builtin.idr b/libs/prelude/Builtin.idr index f4bf0a32a..33afd1742 100644 --- a/libs/prelude/Builtin.idr +++ b/libs/prelude/Builtin.idr @@ -165,6 +165,16 @@ public export trans : forall a, b, c . (0 l : a = b) -> (0 r : b = c) -> a = c trans Refl Refl = Refl +||| Injectivity of MkDPair (first components) +export +mkDPairInjectiveFst : MkDPair a pa === MkDPair b qb -> a === b +mkDPairInjectiveFst Refl = Refl + +||| Injectivity of MkDPair (snd components) +export +mkDPairInjectiveSnd : MkDPair a pa === MkDPair a qa -> pa === qa +mkDPairInjectiveSnd Refl = Refl + ||| Subvert the type checker. This function is abstract, so it will not reduce ||| in the type checker. Use it with care - it can result in segfaults or ||| worse! diff --git a/libs/prelude/Prelude/Types.idr b/libs/prelude/Prelude/Types.idr index 7f2442b4f..5b496d5ac 100644 --- a/libs/prelude/Prelude/Types.idr +++ b/libs/prelude/Prelude/Types.idr @@ -24,6 +24,13 @@ data Nat = %name Nat k, j, i +-- This is used in the compiler as an efficient substitute for integerToNat. +prim__integerToNat : Integer -> Nat +prim__integerToNat i + = if intToBool (prim__lte_Integer 0 i) + then believe_me i + else Z + public export integerToNat : Integer -> Nat integerToNat x @@ -194,6 +201,9 @@ data Dec : Type -> Type where ||| @ contra a demonstration that prop would be a contradiction No : (contra : prop -> Void) -> Dec prop +export Uninhabited (Yes p === No q) where uninhabited eq impossible +export Uninhabited (No p === Yes q) where uninhabited eq impossible + ------------ -- EITHER -- ------------ @@ -207,6 +217,9 @@ data Either : (a : Type) -> (b : Type) -> Type where ||| The other possibility, conventionally used to represent success. Right : forall a, b. (1 x : b) -> Either a b +export Uninhabited (Left p === Right q) where uninhabited eq impossible +export Uninhabited (Right p === Left q) where uninhabited eq impossible + ||| Simply-typed eliminator for Either. ||| @ f the action to take on Left ||| @ g the action to take on Right diff --git a/src/Compiler/ANF.idr b/src/Compiler/ANF.idr index dab641a05..8a0bbde94 100644 --- a/src/Compiler/ANF.idr +++ b/src/Compiler/ANF.idr @@ -72,7 +72,7 @@ mutual show (AApp fc c arg) = show c ++ " @ (" ++ show arg ++ ")" show (ALet fc x val sc) - = "%let v" ++ show x ++ " = " ++ show val ++ " in " ++ show sc + = "%let v" ++ show x ++ " = (" ++ show val ++ ") in (" ++ show sc ++ ")" show (ACon fc n t args) = "%con " ++ show n ++ "(" ++ showSep ", " (map show args) ++ ")" show (AOp fc op args) @@ -81,10 +81,10 @@ mutual = "%extprim " ++ show p ++ "(" ++ showSep ", " (map show args) ++ ")" show (AConCase fc sc alts def) = "%case " ++ show sc ++ " of { " - ++ showSep "| " (map show alts) ++ " " ++ show def + ++ showSep "| " (map show alts) ++ " " ++ show def ++ " }" show (AConstCase fc sc alts def) = "%case " ++ show sc ++ " of { " - ++ showSep "| " (map show alts) ++ " " ++ show def + ++ showSep "| " (map show alts) ++ " " ++ show def ++ " }" show (APrimVal _ x) = show x show (AErased _) = "___" show (ACrash _ x) = "%CRASH(" ++ show x ++ ")" diff --git a/src/Compiler/Common.idr b/src/Compiler/Common.idr index 815ba6e50..561e72dd2 100644 --- a/src/Compiler/Common.idr +++ b/src/Compiler/Common.idr @@ -180,8 +180,7 @@ natHackNames = [UN "prim__add_Integer", UN "prim__sub_Integer", UN "prim__mul_Integer", - NS preludeNS (UN "natToInteger"), - NS preludeNS (UN "integerToNat")] + NS typesNS (UN "prim__integerToNat")] -- Hmm, these dump functions are all very similar aren't they... dumpCases : Defs -> String -> List Name -> diff --git a/src/Compiler/CompileExpr.idr b/src/Compiler/CompileExpr.idr index 08d0683b9..01817d652 100644 --- a/src/Compiler/CompileExpr.idr +++ b/src/Compiler/CompileExpr.idr @@ -174,7 +174,7 @@ natHack = magic , MagicCRef typesNS "natToInteger" 1 (\ _, _, [k] => k) , MagicCRef typesNS "integerToNat" 1 - (\ _, _, [k] => k) + (\ fc, fc', [k] => CApp fc (CRef fc' (NS typesNS (UN "prim__integerToNat"))) [k]) , MagicCRef typesNS "plus" 2 (\ fc, fc', [m,n] => CApp fc (CRef fc' (UN "prim__add_Integer")) [m, n]) , MagicCRef typesNS "mult" 2 diff --git a/src/Compiler/ES/ES.idr b/src/Compiler/ES/ES.idr index 71caf7a3a..026acb5dc 100644 --- a/src/Compiler/ES/ES.idr +++ b/src/Compiler/ES/ES.idr @@ -109,7 +109,7 @@ keywordSafe "var" = "var_" keywordSafe s = s jsName : Name -> String -jsName (NS ns n) = showNSWithSep "_" ns ++ "_" ++ jsName n +jsName (NS ns n) = jsIdent (showNSWithSep "_" ns) ++ "_" ++ jsName n jsName (UN n) = keywordSafe $ jsIdent n jsName (MN n i) = jsIdent n ++ "_" ++ show i jsName (PV n d) = "pat__" ++ jsName n @@ -258,6 +258,7 @@ jsOp DoubleATan [x] = pure $ "Math.atan(" ++ x ++ ")" jsOp DoubleSqrt [x] = pure $ "Math.sqrt(" ++ x ++ ")" jsOp DoubleFloor [x] = pure $ "Math.floor(" ++ x ++ ")" jsOp DoubleCeiling [x] = pure $ "Math.ceil(" ++ x ++ ")" + jsOp (Cast IntType CharType) [x] = pure $ "String.fromCodePoint(" ++ fromBigInt x ++ ")" jsOp (Cast IntegerType CharType) [x] = pure $ "String.fromCodePoint(" ++ fromBigInt x ++ ")" jsOp (Cast CharType IntType) [x] = pure $ toBigInt $ x ++ ".codePointAt(0)" @@ -270,6 +271,16 @@ jsOp (Cast IntegerType IntType) [x] = boundedInt 63 x jsOp (Cast IntType IntegerType) [x] = pure x jsOp (Cast StringType DoubleType) [x] = pure $ "parseFloat(" ++ x ++ ")" +jsOp (Cast Bits8Type IntType) [x] = pure x +jsOp (Cast Bits16Type IntType) [x] = pure x +jsOp (Cast Bits32Type IntType) [x] = pure x +jsOp (Cast Bits64Type IntType) [x] = pure x + +jsOp (Cast Bits8Type IntegerType) [x] = pure x +jsOp (Cast Bits16Type IntegerType) [x] = pure x +jsOp (Cast Bits32Type IntegerType) [x] = pure x +jsOp (Cast Bits64Type IntegerType) [x] = pure x + jsOp (Cast IntType Bits8Type) [x] = boundedUInt 8 x jsOp (Cast IntType Bits16Type) [x] = boundedUInt 16 x jsOp (Cast IntType Bits32Type) [x] = boundedUInt 32 x @@ -297,7 +308,7 @@ jsOp (Cast Bits64Type Bits16Type) [x] = boundedUInt 16 x jsOp (Cast Bits64Type Bits32Type) [x] = boundedUInt 32 x jsOp (Cast ty StringType) [x] = pure $ "(''+" ++ x ++ ")" -jsOp (Cast ty ty2) [x] = jsCrashExp $ "invalid cast: + " ++ show ty ++ " + ' -> ' + " ++ show ty2 +jsOp (Cast ty ty2) [x] = jsCrashExp $ jsString $ "invalid cast: + " ++ show ty ++ " + ' -> ' + " ++ show ty2 jsOp BelieveMe [_,_,x] = pure x jsOp (Crash) [_, msg] = jsCrashExp msg @@ -366,6 +377,8 @@ jsPrim (NS _ (UN "prim__os")) [] = let oscalc = "(o => o === 'linux'?'unix':o==='win32'?'windows':o)" sysos <- addConstToPreamble "sysos" (oscalc ++ "(" ++ os ++ ".platform())") pure sysos +jsPrim (NS _ (UN "void")) [_, _] = jsCrashExp $ jsString $ "Error: Executed 'void'" -- DEPRECATED. TODO: remove when bootstrap has been updated +jsPrim (NS _ (UN "prim__void")) [_, _] = jsCrashExp $ jsString $ "Error: Executed 'void'" jsPrim x args = throw $ InternalError $ "prim not implemented: " ++ (show x) tag2es : Either Int String -> String diff --git a/src/Compiler/ES/Imperative.idr b/src/Compiler/ES/Imperative.idr index e84adb33d..aae7f3fb5 100644 --- a/src/Compiler/ES/Imperative.idr +++ b/src/Compiler/ES/Imperative.idr @@ -217,9 +217,9 @@ compileToImperative c tm = cdata <- getCompileData Cases tm let ndefs = namedDefs cdata let ctm = forget (mainExpr cdata) - s <- newRef Imps (MkImpSt 0) + newRef Imps (MkImpSt 0) lst_defs <- traverse getImp (defsUsedByNamedCExp ctm ndefs) let defs = concat lst_defs - let defs_optim = tailRecOptim defs + defs_optim <- tailRecOptim defs (s, main) <- impExp False ctm pure $ (defs_optim, s <+> EvalExpStatement main) diff --git a/src/Compiler/ES/ImperativeAst.idr b/src/Compiler/ES/ImperativeAst.idr index dd15849ad..38c855f36 100644 --- a/src/Compiler/ES/ImperativeAst.idr +++ b/src/Compiler/ES/ImperativeAst.idr @@ -15,7 +15,7 @@ mutual | IEPrimFnExt Name (List ImperativeExp) | IEConstructorHead ImperativeExp | IEConstructorTag (Either Int String) - | IEConstructorArg Int ImperativeExp + | IEConstructorArg Int ImperativeExp -- constructor arg index starts at 1 | IEConstructor (Either Int String) (List ImperativeExp) | IEDelay ImperativeExp | IEForce ImperativeExp @@ -81,64 +81,104 @@ mutual mutual public export - replaceNamesExp : List (Name, ImperativeExp) -> ImperativeExp -> ImperativeExp - replaceNamesExp reps (IEVar n) = - case lookup n reps of - Nothing => IEVar n - Just e => e - replaceNamesExp reps (IELambda args body) = - IELambda args $ replaceNamesExpS reps body - replaceNamesExp reps (IEApp f args) = - IEApp (replaceNamesExp reps f) (replaceNamesExp reps <$> args) - replaceNamesExp reps (IEConstant c) = - IEConstant c - replaceNamesExp reps (IEPrimFn f args) = - IEPrimFn f (replaceNamesExp reps <$> args) - replaceNamesExp reps (IEPrimFnExt f args) = - IEPrimFnExt f (replaceNamesExp reps <$> args) - replaceNamesExp reps (IEConstructorHead e) = - IEConstructorHead $ replaceNamesExp reps e - replaceNamesExp reps (IEConstructorTag i) = - IEConstructorTag i - replaceNamesExp reps (IEConstructorArg i e) = - IEConstructorArg i (replaceNamesExp reps e) - replaceNamesExp reps (IEConstructor t args) = - IEConstructor t (replaceNamesExp reps <$> args) - replaceNamesExp reps (IEDelay e) = - IEDelay $ replaceNamesExp reps e - replaceNamesExp reps (IEForce e) = - IEForce $ replaceNamesExp reps e - replaceNamesExp reps IENull = - IENull + replaceExp : (ImperativeExp -> Maybe ImperativeExp) -> ImperativeExp -> ImperativeExp + replaceExp rep x@(IEVar n) = + case rep x of + Just z => z + Nothing => x + replaceExp rep x@(IELambda args body) = + case rep x of + Just z => z + Nothing => IELambda args $ replaceExpS rep body + replaceExp rep x@(IEApp f args) = + case rep x of + Just z => z + Nothing => IEApp (replaceExp rep f) (replaceExp rep <$> args) + replaceExp rep x@(IEConstant c) = + case rep x of + Just z => z + Nothing => x + replaceExp rep x@(IEPrimFn f args) = + case rep x of + Just z => z + Nothing => IEPrimFn f (replaceExp rep <$> args) + replaceExp rep x@(IEPrimFnExt f args) = + case rep x of + Just z => z + Nothing => IEPrimFnExt f (replaceExp rep <$> args) + replaceExp rep x@(IEConstructorHead e) = + case rep x of + Just z => z + Nothing => IEConstructorHead $ replaceExp rep e + replaceExp rep x@(IEConstructorTag i) = + case rep x of + Just z => z + Nothing => x + replaceExp rep x@(IEConstructorArg i e) = + case rep x of + Just z => z + Nothing => IEConstructorArg i (replaceExp rep e) + replaceExp rep x@(IEConstructor t args) = + case rep x of + Just z => z + Nothing => IEConstructor t (replaceExp rep <$> args) + replaceExp rep x@(IEDelay e) = + case rep x of + Just z => z + Nothing => IEDelay $ replaceExp rep e + replaceExp rep x@(IEForce e) = + case rep x of + Just z => z + Nothing => IEForce $ replaceExp rep e + replaceExp rep x@IENull = + case rep x of + Just z => z + Nothing => x public export - replaceNamesExpS : List (Name, ImperativeExp) -> ImperativeStatement -> ImperativeStatement - replaceNamesExpS reps DoNothing = + replaceExpS : (ImperativeExp -> Maybe ImperativeExp) -> ImperativeStatement -> ImperativeStatement + replaceExpS rep DoNothing = DoNothing - replaceNamesExpS reps (SeqStatement x y) = - SeqStatement (replaceNamesExpS reps x) (replaceNamesExpS reps y) - replaceNamesExpS reps (FunDecl fc n args body) = - FunDecl fc n args $ replaceNamesExpS reps body - replaceNamesExpS reps decl@(ForeignDecl fc n path args ret) = + replaceExpS rep (SeqStatement x y) = + SeqStatement (replaceExpS rep x) (replaceExpS rep y) + replaceExpS rep (FunDecl fc n args body) = + FunDecl fc n args $ replaceExpS rep body + replaceExpS reps decl@(ForeignDecl fc n path args ret) = decl - replaceNamesExpS reps (ReturnStatement e) = - ReturnStatement $ replaceNamesExp reps e - replaceNamesExpS reps (SwitchStatement s alts def) = - let s_ = replaceNamesExp reps s - alts_ = (\(e,b) => (replaceNamesExp reps e, replaceNamesExpS reps b)) <$> alts - def_ = replaceNamesExpS reps <$> def + replaceExpS rep (ReturnStatement e) = + ReturnStatement $ replaceExp rep e + replaceExpS rep (SwitchStatement s alts def) = + let s_ = replaceExp rep s + alts_ = (\(e,b) => (replaceExp rep e, replaceExpS rep b)) <$> alts + def_ = replaceExpS rep <$> def in SwitchStatement s_ alts_ def_ - replaceNamesExpS reps (LetDecl n v) = - LetDecl n $ replaceNamesExp reps <$> v - replaceNamesExpS reps (ConstDecl n v) = - ConstDecl n $ replaceNamesExp reps v - replaceNamesExpS reps (MutateStatement n v) = - MutateStatement n $ replaceNamesExp reps v - replaceNamesExpS reps (ErrorStatement s) = + replaceExpS rep (LetDecl n v) = + LetDecl n $ replaceExp rep <$> v + replaceExpS rep (ConstDecl n v) = + ConstDecl n $ replaceExp rep v + replaceExpS rep (MutateStatement n v) = + MutateStatement n $ replaceExp rep v + replaceExpS rep (ErrorStatement s) = ErrorStatement s - replaceNamesExpS reps (EvalExpStatement x) = - EvalExpStatement $ replaceNamesExp reps x - replaceNamesExpS reps (CommentStatement x) = + replaceExpS rep (EvalExpStatement x) = + EvalExpStatement $ replaceExp rep x + replaceExpS rep (CommentStatement x) = CommentStatement x - replaceNamesExpS reps (ForEverLoop x) = - ForEverLoop $ replaceNamesExpS reps x + replaceExpS rep (ForEverLoop x) = + ForEverLoop $ replaceExpS rep x + + +rep : List (Name, ImperativeExp) -> ImperativeExp -> Maybe ImperativeExp +rep reps (IEVar n) = + lookup n reps +rep _ _ = Nothing + +public export +replaceNamesExpS : List (Name, ImperativeExp) -> ImperativeStatement -> ImperativeStatement +replaceNamesExpS reps x = + replaceExpS (rep reps) x + +public export +replaceNamesExp : List (Name, ImperativeExp) -> ImperativeExp -> ImperativeExp +replaceNamesExp reps x = + replaceExp (rep reps) x diff --git a/src/Compiler/ES/TailRec.idr b/src/Compiler/ES/TailRec.idr index 997de05d9..b70bdbc20 100644 --- a/src/Compiler/ES/TailRec.idr +++ b/src/Compiler/ES/TailRec.idr @@ -1,26 +1,52 @@ module Compiler.ES.TailRec +import Data.Maybe +import Data.List +import Data.Strings +import Data.SortedSet +import Data.SortedMap +import Core.Name +import Core.Context import Compiler.ES.ImperativeAst -hasTailCall : Name -> ImperativeStatement -> Bool -hasTailCall n (SeqStatement x y) = - hasTailCall n y -hasTailCall n (ReturnStatement x) = +import Debug.Trace + +data TailRecS : Type where + +record TailSt where + constructor MkTailSt + nextName : Int + +genName : {auto c : Ref TailRecS TailSt} -> Core Name +genName = + do + s <- get TailRecS + let i = nextName s + put TailRecS (record { nextName = i + 1 } s) + pure $ MN "imp_gen_tailoptim" i + +allTailCalls : ImperativeStatement -> SortedSet Name +allTailCalls (SeqStatement x y) = + allTailCalls y +allTailCalls (ReturnStatement x) = case x of - IEApp (IEVar cn) _ => n == cn - _ => False -hasTailCall n (SwitchStatement e alts d) = - (any (\(_, w)=>hasTailCall n w) alts) || (maybe False (hasTailCall n) d) -hasTailCall n (ForEverLoop x) = - hasTailCall n x -hasTailCall n o = False + IEApp (IEVar n) _ => insert n empty + _ => empty +allTailCalls (SwitchStatement e alts d) = + maybe empty allTailCalls d `union` concat (map allTailCalls (map snd alts)) +allTailCalls (ForEverLoop x) = + allTailCalls x +allTailCalls o = empty argsName : Name -argsName = MN "tailRecOptimArgs" 0 +argsName = MN "imp_gen_tailoptim_Args" 0 stepFnName : Name -stepFnName = MN "tailRecOptimStep" 0 +stepFnName = MN "imp_gen_tailoptim_step" 0 + +fusionArgsName : Name +fusionArgsName = MN "imp_gen_tailoptim_fusion_args" 0 createNewArgs : List ImperativeExp -> ImperativeExp createNewArgs values = @@ -40,8 +66,6 @@ replaceTailCall n (ReturnStatement x) = if n == cn then ReturnStatement $ createNewArgs arg_vals else defRet _ => defRet - - replaceTailCall n (SwitchStatement e alts d) = SwitchStatement e (map (\(x,y) => (x, replaceTailCall n y)) alts) (map (replaceTailCall n) d) replaceTailCall n (ForEverLoop x) = @@ -60,11 +84,169 @@ makeTailOptimToBody n argNames body = loop = ForEverLoop $ SwitchStatement (IEConstructorHead $ IEVar argsName) [(IEConstructorTag $ Left 0, loopRec)] (Just loopReturn) in stepFn <+> createArgInit argNames <+> loop +record CallGraph where + constructor MkCallGraph + calls, callers : SortedMap Name (SortedSet Name) + +showCallGraph : CallGraph -> String +showCallGraph x = + let calls = unlines $ map + (\(x,y) => show x ++ ": " ++ show (SortedSet.toList y)) + (SortedMap.toList x.calls) + callers = unlines $ map + (\(x,y) => show x ++ ": " ++ show (SortedSet.toList y)) + (SortedMap.toList x.callers) + in calls ++ "\n----\n" ++ callers + + +tailCallGraph : ImperativeStatement -> CallGraph +tailCallGraph (SeqStatement x y) = + let xg = tailCallGraph x + yg = tailCallGraph y + in MkCallGraph + (mergeWith union xg.calls yg.calls) + (mergeWith union xg.callers yg.callers) +tailCallGraph (FunDecl fc n args body) = + let calls = allTailCalls body + in MkCallGraph (insert n calls empty) (SortedMap.fromList $ map (\x => (x, SortedSet.insert n empty)) (SortedSet.toList calls)) +tailCallGraph _ = MkCallGraph empty empty + +kosarajuL : SortedSet Name -> List Name -> CallGraph -> (SortedSet Name, List Name) +kosarajuL visited [] graph = + (visited, []) +kosarajuL visited (x::xs) graph = + if contains x visited then kosarajuL visited xs graph + else let outNeighbours = maybe [] SortedSet.toList $ lookup x (graph.calls) + (visited_, l_) = kosarajuL (insert x visited) (toList outNeighbours) graph + (visited__, l__) = kosarajuL visited_ xs graph + in (visited__, l__ ++ (x :: l_)) + + + +kosarajuAssign : CallGraph -> Name -> Name -> SortedMap Name Name -> SortedMap Name Name +kosarajuAssign graph u root s = + case lookup u s of + Just _ => s + Nothing => let inNeighbours = maybe [] SortedSet.toList $ lookup u (graph.callers) + in foldl (\acc, elem => kosarajuAssign graph elem root acc) (insert u root s) inNeighbours + +kosaraju: CallGraph -> SortedMap Name Name +kosaraju graph = + let l = snd $ kosarajuL empty (keys $ graph.calls) graph + in foldl (\acc, elem => kosarajuAssign graph elem elem acc) empty l + +groupBy : (a -> a -> Bool) -> List a -> List (List a) +groupBy _ [] = [] +groupBy p' (x'::xs') = + let (ys',zs') = go p' x' xs' + in (x' :: ys') :: zs' + where + go : (a -> a -> Bool) -> a -> List a -> (List a, List (List a)) + go p z (x::xs) = + let (ys,zs) = go p x xs + in case p z x of + True => (x :: ys, zs) + False => ([], (x :: ys) :: zs) + go _ _ [] = ([], []) + +recursiveTailCallGroups : CallGraph -> List (List Name) +recursiveTailCallGroups graph = + let roots = kosaraju graph + groups = map (map fst) $ + groupBy (\x,y => Builtin.snd x == Builtin.snd y) $ + sortBy (\x,y=> compare (snd x) (snd y)) $ + toList roots + in [x | x<-groups, hasTailCalls x] + where + hasTailCalls : List Name -> Bool + hasTailCalls [] = + False + hasTailCalls [x] = + case lookup x (graph.calls) of + Nothing => + False + Just s => + case SortedSet.toList s of + [n] => n == x + _ => False + hasTailCalls _ = + True + + +extractFunctions : SortedSet Name -> ImperativeStatement -> + (ImperativeStatement, SortedMap Name (FC, List Name, ImperativeStatement)) +extractFunctions toExtract (SeqStatement x y) = + let (xs, xf) = extractFunctions toExtract x + (ys, yf) = extractFunctions toExtract y + in (xs <+> ys, mergeLeft xf yf) +extractFunctions toExtract f@(FunDecl fc n args body) = + if contains n toExtract then (neutral, insert n (fc, args, body) empty) + else (f, empty) +extractFunctions toExtract x = + (x, empty) + +getDef : SortedMap Name (FC, List Name, ImperativeStatement) -> Name -> Core (FC, List Name, ImperativeStatement) +getDef defs n = + case lookup n defs of + Nothing => throw $ (InternalError $ "Can't find function definition in tailRecOptim") + Just x => pure x + + +makeFusionBranch : Name -> List (Name, Nat) -> (Nat, FC, List Name, ImperativeStatement) -> + (ImperativeExp, ImperativeStatement) +makeFusionBranch fusionName functionsIdx (i, _, args, body) = + let newArgExp = map (\i => IEConstructorArg (cast i) (IEVar fusionArgsName)) [1..(length args)] + bodyRepArgs = replaceNamesExpS (zip args newArgExp) body + in (IEConstructorTag $ Left $ cast i, replaceExpS rep bodyRepArgs) + where + rep : ImperativeExp -> Maybe ImperativeExp + rep (IEApp (IEVar n) arg_vals) = + case lookup n functionsIdx of + Nothing => Nothing + Just i => Just $ IEApp + (IEVar fusionName) + [IEConstructor (Left $ cast i) arg_vals] + rep _ = Nothing + +changeBodyToUseFusion : Name -> (Nat, Name, FC, List Name, ImperativeStatement) -> ImperativeStatement +changeBodyToUseFusion fusionName (i, n, (fc, args, _)) = + FunDecl fc n args (ReturnStatement $ IEApp (IEVar fusionName) [IEConstructor (Left $ cast i) (map IEVar args)]) + +tailRecOptimGroup : {auto c : Ref TailRecS TailSt} -> + SortedMap Name (FC, List Name, ImperativeStatement) -> + List Name -> Core ImperativeStatement +tailRecOptimGroup defs [] = pure neutral +tailRecOptimGroup defs [n] = + do + (fc, args , body) <- getDef defs n + pure $ FunDecl fc n args (makeTailOptimToBody n args body) +tailRecOptimGroup defs names = + do + fusionName <- genName + d <- traverse (getDef defs) names + let ids = [0..(length names `minus` 1)] + let alts = map (makeFusionBranch fusionName (zip names ids)) (zip ids d) + let fusionBody = SwitchStatement + (IEConstructorHead $ IEVar fusionArgsName) + alts + Nothing + let fusionArgs = [fusionArgsName] + let fusion = FunDecl EmptyFC fusionName fusionArgs (makeTailOptimToBody fusionName fusionArgs fusionBody) + let newFunctions = Prelude.concat $ map + (changeBodyToUseFusion fusionName) + (ids `List.zip` (names `List.zip` d)) + pure $ fusion <+> newFunctions + + + export -tailRecOptim : ImperativeStatement -> ImperativeStatement -tailRecOptim (SeqStatement x y) = SeqStatement (tailRecOptim x) (tailRecOptim y) -tailRecOptim (FunDecl fc n args body) = - let new_body = if hasTailCall n body then makeTailOptimToBody n args body - else body - in FunDecl fc n args new_body -tailRecOptim x = x +tailRecOptim : ImperativeStatement -> Core ImperativeStatement +tailRecOptim x = + do + newRef TailRecS (MkTailSt 0) + let graph = tailCallGraph x + let groups = recursiveTailCallGroups graph + let functionsToOptimize = foldl SortedSet.union empty $ map SortedSet.fromList groups + let (unchanged, defs) = extractFunctions functionsToOptimize x + optimized <- traverse (tailRecOptimGroup defs) groups + pure $ unchanged <+> (concat optimized) diff --git a/src/Compiler/RefC/RefC.idr b/src/Compiler/RefC/RefC.idr new file mode 100644 index 000000000..24a486122 --- /dev/null +++ b/src/Compiler/RefC/RefC.idr @@ -0,0 +1,1145 @@ +module Compiler.RefC.RefC + +import Compiler.Common +import Compiler.CompileExpr +import Compiler.LambdaLift +import Compiler.ANF +import Compiler.Inline + +import Core.Context +import Core.Directory +import Core.Name +import Core.Options +import Core.TT + +import Data.IORef +import Data.List +import Data.NameMap +import Data.Nat +import Data.Strings +import Data.Vect + +import System +import System.Info +import System.File + +import Idris.Version +import Utils.Hex +import Utils.Path + +findCC : IO String +findCC + = do Just cc <- getEnv "IDRIS2_CC" + | Nothing => do Just cc <- getEnv "CC" + | Nothing => pure "cc" + pure cc + pure cc + +toString : List Char -> String +toString [] = "" +toString (c :: cx) = cast c ++ toString cx + +natMinus : (a,b:Nat) -> Nat +natMinus a b = case isLTE b a of + (Yes prf) => minus a b + (No _) => 0 + +showcCleanStringChar : Char -> String -> String +showcCleanStringChar '+' = ("_plus" ++) +showcCleanStringChar '-' = ("__" ++) +showcCleanStringChar '*' = ("_star" ++) +showcCleanStringChar '/' = ("_slash" ++) +showcCleanStringChar '\\' = ("_backslash" ++) +showcCleanStringChar '<' = ("_lt" ++) +showcCleanStringChar '>' = ("_gt" ++) +showcCleanStringChar '=' = ("_eq" ++) +showcCleanStringChar '&' = ("_and" ++) +showcCleanStringChar '|' = ("_or" ++) +showcCleanStringChar '\'' = ("_tick" ++) +showcCleanStringChar '"' = ("_quotation" ++) +showcCleanStringChar '(' = ("_parenOpen" ++) +showcCleanStringChar ')' = ("_parenClose" ++) +showcCleanStringChar '{' = ("_braceOpen" ++) +showcCleanStringChar '}' = ("_braceClose" ++) +showcCleanStringChar ' ' = ("_" ++) +showcCleanStringChar ':' = ("_colon" ++) +showcCleanStringChar '.' = ("_dot" ++) +showcCleanStringChar '$' = ("_dollar" ++) +showcCleanStringChar ',' = ("_comma" ++) +showcCleanStringChar '#' = ("_number" ++) +showcCleanStringChar '%' = ("_percent" ++) +showcCleanStringChar c + = if c < chr 32 || c > chr 126 + then (("u" ++ pad (asHex (cast c))) ++) + else strCons c + where + pad : String -> String + pad str + = case isLTE (length str) 4 of + Yes _ => toString (List.replicate (natMinus 4 (length str)) '0') ++ str + No _ => str + +showcCleanString : List Char -> String -> String +showcCleanString [] = id +showcCleanString (c ::cs) = (showcCleanStringChar c) . showcCleanString cs + +cCleanString : String -> String +cCleanString cs = showcCleanString (unpack cs) "" + +cName : Name -> String +cName (NS ns n) = cCleanString (showNSWithSep "_" ns) ++ "_" ++ cName n +cName (UN n) = cCleanString n +cName (MN n i) = cCleanString n ++ "_" ++ cCleanString (show i) +cName (PV n d) = "pat__" ++ cName n +cName (DN _ n) = cName n +cName (Nested i n) = "n__" ++ cCleanString (show i) ++ "_" ++ cName n +cName (CaseBlock x y) = "case__" ++ cCleanString (show x) ++ "_" ++ cCleanString (show y) +cName (WithBlock x y) = "with__" ++ cCleanString (show x) ++ "_" ++ cCleanString (show y) +cName (Resolved i) = "fn__" ++ cCleanString (show i) +cName _ = "UNKNOWNNAME" + +escapeChar : Char -> String +escapeChar '\DEL' = "127" +escapeChar '\NUL' = "0" +escapeChar '\SOH' = "1" +escapeChar '\STX' = "2" +escapeChar '\ETX' = "3" +escapeChar '\EOT' = "4" +escapeChar '\ENQ' = "5" +escapeChar '\ACK' = "6" +escapeChar '\BEL' = "7" +escapeChar '\BS' = "8" +escapeChar '\HT' = "9" +escapeChar '\LF' = "10" +escapeChar '\VT' = "11" +escapeChar '\FF' = "12" +escapeChar '\CR' = "13" +escapeChar '\SO' = "14" +escapeChar '\SI' = "15" +escapeChar '\DLE' = "16" +escapeChar '\DC1' = "17" +escapeChar '\DC2' = "18" +escapeChar '\DC3' = "19" +escapeChar '\DC4' = "20" +escapeChar '\NAK' = "21" +escapeChar '\SYN' = "22" +escapeChar '\ETB' = "23" +escapeChar '\CAN' = "24" +escapeChar '\EM' = "25" +escapeChar '\SUB' = "26" +escapeChar '\ESC' = "27" +escapeChar '\FS' = "28" +escapeChar '\GS' = "29" +escapeChar '\RS' = "30" +escapeChar '\US' = "31" +escapeChar c = show c + +-- escapeChar '\\' = "'\\\\'" +-- escapeChar c = show c + +cStringQuoted : String -> String +cStringQuoted cs = strCons '"' (showCString (unpack cs) "\"") +where + showCChar : Char -> String -> String + showCChar '\\' = ("bkslash" ++) + showCChar c + = if c < chr 32 || c > chr 126 + then (("\\x" ++ (asHex (cast c))) ++) + else strCons c + where + pad : String -> String + pad str + = case isLTE (length str) 2 of + --Yes _ => toString (List.replicate (natMinus 4 (length str)) '0') ++ str + Yes _ => "0" ++ str + No _ => str + + + showCString : List Char -> String -> String + showCString [] = id + showCString ('"'::cs) = ("\\\"" ++) . showCString cs + showCString (c ::cs) = (showCChar c) . showCString cs + + + +cConstant : Constant -> String +cConstant (I x) = "(Value*)makeInt32("++ show x ++")" -- (constant #:type 'i32 #:val " ++ show x ++ ")" +cConstant (BI x) = "(Value*)makeInt64("++ show x ++")" --"(constant #:type 'i64 #:val " ++ show x ++ ")" +cConstant (Db x) = "(Value*)makeDouble("++ show x ++")"--"(constant #:type 'double #:val " ++ show x ++ ")" +cConstant (Ch x) = "(Value*)makeChar("++ escapeChar x ++")" --"(constant #:type 'char #:val " ++ escapeChar x ++ ")" +cConstant (Str x) = "(Value*)makeString("++ cStringQuoted x ++")" + -- = "(constant #:type 'string #:val " ++ cStringQuoted x ++ ")" +cConstant WorldVal = "(Value*)makeWorld()" +cConstant IntType = "i32" +cConstant IntegerType = "i64" +cConstant StringType = "string" +cConstant CharType = "char" +cConstant DoubleType = "double" +cConstant WorldType = "f32" +cConstant (B8 x) = "(Value*)makeInt8("++ show x ++")" --"(constant #:type 'i64 #:val " ++ show x ++ ")" +cConstant (B16 x) = "(Value*)makeInt16("++ show x ++")" --"(constant #:type 'i64 #:val " ++ show x ++ ")" +cConstant (B32 x) = "(Value*)makeInt32("++ show x ++")" --"(constant #:type 'i64 #:val " ++ show x ++ ")" +cConstant (B64 x) = "(Value*)makeInt64("++ show x ++")" --"(constant #:type 'i64 #:val " ++ show x ++ ")" +cConstant Bits8Type = "Bits8" +cConstant Bits16Type = "Bits16" +cConstant Bits32Type = "Bits32" +cConstant Bits64Type = "Bits64" +cConstant _ = "UNKNOWN" + +extractConstant : Constant -> String +extractConstant (I x) = show x +extractConstant (BI x) = show x +extractConstant (Db x) = show x +extractConstant (Ch x) = show x +extractConstant (Str x) = cStringQuoted x +extractConstant (B8 x) = show x +extractConstant (B16 x) = show x +extractConstant (B32 x) = show x +extractConstant (B64 x) = show x +extractConstant c = "unable_to_extract constant >>" ++ cConstant c ++ "<<" + + +||| Generate scheme for a plain function. +plainOp : String -> List String -> String +plainOp op args = op ++ "(" ++ (showSep ", " args) ++ ")" + + +||| Generate scheme for a primitive function. +cOp : PrimFn arity -> Vect arity String -> String +cOp (Neg ty) [x] = "-" ++ x +cOp StrLength [x] = "stringLength(" ++ x ++ ")" +cOp StrHead [x] = "head(" ++ x ++ ")" +cOp StrTail [x] = "tail(" ++ x ++ ")" +cOp StrReverse [x] = "reverse(" ++ x ++ ")" +cOp (Cast i o) [x] = "cast_" ++ (cConstant i) ++ "_to_" ++ (cConstant o) ++ "(" ++ x ++ ")" +cOp DoubleExp [x] = "(Value*)makeDouble(exp(unpackDouble(" ++ x ++ ")))" +cOp DoubleLog [x] = "(Value*)makeDouble(log(unpackDouble(" ++ x ++ ")))" +cOp DoubleSin [x] = "(Value*)makeDouble(sin(unpackDouble(" ++ x ++ ")))" +cOp DoubleCos [x] = "(Value*)makeDouble(cos(unpackDouble(" ++ x ++ ")))" +cOp DoubleTan [x] = "(Value*)makeDouble(tan(unpackDouble(" ++ x ++ ")))" +cOp DoubleASin [x] = "(Value*)makeDouble(asin(unpackDouble(" ++ x ++ ")))" +cOp DoubleACos [x] = "(Value*)makeDouble(acos(unpackDouble(" ++ x ++ ")))" +cOp DoubleATan [x] = "(Value*)makeDouble(atan(unpackDouble(" ++ x ++ ")))" +cOp DoubleSqrt [x] = "(Value*)makeDouble(sqrt(unpackDouble(" ++ x ++ ")))" +cOp DoubleFloor [x] = "(Value*)makeDouble(floor(unpackDouble(" ++ x ++ ")))" +cOp DoubleCeiling [x] = "(Value*)makeDouble(ceil(unpackDouble(" ++ x ++ ")))" +cOp (Add ty) [x, y] = "add_" ++ cConstant ty ++ "(" ++ x ++ ", " ++ y ++ ")" +cOp (Sub ty) [x, y] = "sub_" ++ cConstant ty ++ "(" ++ x ++ ", " ++ y ++ ")" +cOp (Mul ty) [x, y] = "mul_" ++ cConstant ty ++ "(" ++ x ++ ", " ++ y ++ ")" +cOp (Div ty) [x, y] = "div_" ++ cConstant ty ++ "(" ++ x ++ ", " ++ y ++ ")" +cOp (Mod ty) [x, y] = "mod_" ++ cConstant ty ++ "(" ++ x ++ ", " ++ y ++ ")" +cOp (ShiftL ty) [x, y] = "shiftl_" ++ cConstant ty ++ "(" ++ x ++ ", " ++ y ++ ")" +cOp (ShiftR ty) [x, y] = "shiftr_" ++ cConstant ty ++ "(" ++ x ++ ", " ++ y ++ ")" +cOp (BAnd ty) [x, y] = "and_" ++ cConstant ty ++ "(" ++ x ++ ", " ++ y ++ ")" +cOp (BOr ty) [x, y] = "or_" ++ cConstant ty ++ "(" ++ x ++ ", " ++ y ++ ")" +cOp (BXOr ty) [x, y] = "xor_" ++ cConstant ty ++ "(" ++ x ++ ", " ++ y ++ ")" +cOp (LT ty) [x, y] = "lt_" ++ cConstant ty ++ "(" ++ x ++ ", " ++ y ++ ")" +cOp (GT ty) [x, y] = "gt_" ++ cConstant ty ++ "(" ++ x ++ ", " ++ y ++ ")" +cOp (EQ ty) [x, y] = "eq_" ++ cConstant ty ++ "(" ++ x ++ ", " ++ y ++ ")" +cOp (LTE ty) [x, y] = "lte_" ++ cConstant ty ++ "(" ++ x ++ ", " ++ y ++ ")" +cOp (GTE ty) [x, y] = "gte_" ++ cConstant ty ++ "(" ++ x ++ ", " ++ y ++ ")" +cOp StrIndex [x, i] = "strIndex(" ++ x ++ ", " ++ i ++ ")" +cOp StrCons [x, y] = "strCons(" ++ x ++ ", " ++ y ++ ")" +cOp StrAppend [x, y] = "strAppend(" ++ x ++ ", " ++ y ++ ")" +cOp StrSubstr [x, y, z] = "strSubstr(" ++ x ++ ", " ++ y ++ ", " ++ z ++ ")" +cOp BelieveMe [_, _, x] = x +cOp Crash [_, msg] = "idris2_crash(" ++ msg ++ ");" +cOp fn args = plainOp (show fn) (toList args) + + +data ExtPrim = NewIORef | ReadIORef | WriteIORef + | NewArray | ArrayGet | ArraySet + | GetField | SetField + | VoidElim + | SysOS | SysCodegen + | OnCollect + | OnCollectAny + | Unknown Name + +export +Show ExtPrim where + show NewIORef = "newIORef" + show ReadIORef = "readIORef" + show WriteIORef = "writeIORef" + show NewArray = "newArray" + show ArrayGet = "arrayGet" + show ArraySet = "arraySet" + show GetField = "getField" + show SetField = "setField" + show VoidElim = "voidElim" + show SysOS = "sysOS" + show SysCodegen = "sysCodegen" + show OnCollect = "onCollect" + show OnCollectAny = "onCollectAny" + show (Unknown n) = "Unknown " ++ show n + +||| Match on a user given name to get the scheme primitive +toPrim : Name -> ExtPrim +toPrim pn@(NS _ n) + = cond [(n == UN "prim__newIORef", NewIORef), + (n == UN "prim__readIORef", ReadIORef), + (n == UN "prim__writeIORef", WriteIORef), + (n == UN "prim__newArray", NewArray), + (n == UN "prim__arrayGet", ArrayGet), + (n == UN "prim__arraySet", ArraySet), + (n == UN "prim__getField", GetField), + (n == UN "prim__setField", SetField), + (n == UN "void", VoidElim), -- DEPRECATED. TODO: remove when bootstrap has been updated + (n == UN "prim__void", VoidElim), + (n == UN "prim__os", SysOS), + (n == UN "prim__codegen", SysCodegen), + (n == UN "prim__onCollect", OnCollect), + (n == UN "prim__onCollectAny", OnCollectAny) + ] + (Unknown pn) +toPrim pn = Unknown pn + + +varName : AVar -> String +varName (ALocal i) = "var_" ++ (show i) +varName (ANull) = "NULL" + +data ArgCounter : Type where +data FunctionDefinitions : Type where +data TemporaryVariableTracker : Type where +data OutfileText : Type where +data IndentLevel : Type where +data ExternalLibs : Type where + +getNextCounter : {auto a : Ref ArgCounter Nat} -> Core Nat +getNextCounter = do + c <- get ArgCounter + put ArgCounter (S c) + pure c + +registerVariableForAutomaticFreeing : {auto t : Ref TemporaryVariableTracker (List (List String))} + -> String + -> Core () +registerVariableForAutomaticFreeing var = do + lists <- get TemporaryVariableTracker + case lists of + [] => do + put TemporaryVariableTracker ([[var]]) + pure () + (l :: ls) => do + put TemporaryVariableTracker ((var :: l) :: ls) + pure () + +newTemporaryVariableLevel : {auto t : Ref TemporaryVariableTracker (List (List String))} -> Core () +newTemporaryVariableLevel = do + lists <- get TemporaryVariableTracker + put TemporaryVariableTracker ([] :: lists) + + +getNewVar : {auto a : Ref ArgCounter Nat} -> {auto t : Ref TemporaryVariableTracker (List (List String))} -> Core String +getNewVar = do + c <- getNextCounter + let var = "tmp_" ++ show c + registerVariableForAutomaticFreeing var + pure var + + +getNewVarThatWillNotBeFreedAtEndOfBlock : {auto a : Ref ArgCounter Nat} -> Core String +getNewVarThatWillNotBeFreedAtEndOfBlock = do + c <- getNextCounter + pure $ "tmp_" ++ show c + + +maxLineLengthForComment : Nat +maxLineLengthForComment = 60 + +lJust : (line:String) -> (fillPos:Nat) -> (filler:Char) -> String +lJust line fillPos filler = + case isLTE (length line) fillPos of + (Yes prf) => + let missing = minus fillPos (length line) + fillBlock = pack (replicate missing filler) + in + line ++ fillBlock + (No _) => line + +increaseIndentation : {auto il : Ref IndentLevel Nat} -> Core () +increaseIndentation = do + iLevel <- get IndentLevel + put IndentLevel (S iLevel) + pure () + +decreaseIndentation : {auto il : Ref IndentLevel Nat} -> Core () +decreaseIndentation = do + iLevel <- get IndentLevel + case iLevel of + Z => pure () + (S k) => do + put IndentLevel k + pure () + +indentation : {auto il : Ref IndentLevel Nat} -> Core String +indentation = do + iLevel <- get IndentLevel + pure $ pack $ replicate (4 * iLevel) ' ' + + +emit : {auto oft : Ref OutfileText (List String)} -> {auto il : Ref IndentLevel Nat} -> FC -> String -> Core () +emit EmptyFC line = do + lines <- get OutfileText + indent <- indentation + put OutfileText (lines ++ [indent ++ line]) + pure () +emit fc line' = do + let comment = "// " ++ show fc + lines <- get OutfileText + indent <- indentation + let line = line' + case isLTE (length (indent ++ line)) maxLineLengthForComment of + (Yes _) => put OutfileText (lines ++ [ (lJust (indent ++ line) maxLineLengthForComment ' ') ++ " " ++ comment] ) + (No _) => put OutfileText (lines ++ [indent ++ line, ((lJust "" maxLineLengthForComment ' ') ++ " " ++ comment)] ) + pure () + + +freeTmpVars : {auto t : Ref TemporaryVariableTracker (List (List String))} + -> {auto oft : Ref OutfileText (List String)} + -> {auto il : Ref IndentLevel Nat} + -> Core $ () +freeTmpVars = do + lists <- get TemporaryVariableTracker + case lists of + (vars :: varss) => do + traverse (\v => emit EmptyFC $ "removeReference(" ++ v ++ ");" ) vars + put TemporaryVariableTracker varss + pure () + [] => pure () + + +addExternalLib : {auto e : Ref ExternalLibs (List String)} + -> String + -> Core () +addExternalLib extLib = do + libs <- get ExternalLibs + case elem extLib libs of + True => pure () -- library already in list + False => do + put ExternalLibs (extLib :: libs) + + + +makeArglist : {auto a : Ref ArgCounter Nat} + -> {auto t : Ref TemporaryVariableTracker (List (List String))} + -> {auto oft : Ref OutfileText (List String)} + -> {auto il : Ref IndentLevel Nat} + -> Nat + -> List AVar + -> Core (String) +makeArglist missing xs = do + c <- getNextCounter + let arglist = "arglist_" ++ (show c) + emit EmptyFC $ "Value_Arglist *" + ++ arglist + ++ " = newArglist(" ++ show missing + ++ "," ++ show ((length xs) + missing) + ++ ");" + pushArgToArglist arglist xs 0 + pure arglist +where + pushArgToArglist : String + -> List AVar + -> Nat + -> Core () + pushArgToArglist arglist [] k = pure () + pushArgToArglist arglist (arg :: args) k = do + emit EmptyFC $ arglist + ++ "->args[" ++ show k ++ "] = " + ++ " newReference(" ++ varName arg ++");" + pushArgToArglist arglist args (S k) + +fillConstructorArgs : {auto oft : Ref OutfileText (List String)} + -> {auto il : Ref IndentLevel Nat} + -> String + -> List AVar + -> Nat + -> Core () +fillConstructorArgs _ [] _ = pure () +fillConstructorArgs constructor (v :: vars) k = do + emit EmptyFC $ constructor ++ "->args["++ show k ++ "] = newReference(" ++ varName v ++");" + fillConstructorArgs constructor vars (S k) + + +showTag : Maybe Int -> String +showTag Nothing = "-1" +showTag (Just i) = show i + +cArgsVectANF : Vect arity AVar -> Core (Vect arity String) +cArgsVectANF [] = pure [] +cArgsVectANF (x :: xs) = pure $ (varName x) :: !(cArgsVectANF xs) + +showEitherStringInt : Either String Int -> String +showEitherStringInt (Left s) = s +showEitherStringInt (Right i) = show i + +toIntEitherStringInt : Either String Int -> Int -> Int +toIntEitherStringInt (Left s) k = k +toIntEitherStringInt (Right i) _ = i + +integer_switch : List AConstAlt -> Bool +integer_switch [] = True +integer_switch (MkAConstAlt c _ :: _) = + case c of + (I x) => True + (BI x) => True + (Ch x) => True + _ => False + +const2Integer : Constant -> Integer -> Integer +const2Integer c i = + case c of + (I x) => cast x + (BI x) => x + (Ch x) => cast x + (B8 x) => cast x + (B16 x) => cast x + (B32 x) => cast x + (B64 x) => x + _ => i + + + + + +-- we return for each of the ANF a set of statements and two possible return statements +-- The first one for non-tail statements, the second one for tail statements +-- this way, we can deal with tail calls and tail recursion. +-- The higher-level invocation first executes the normal statements and then +-- assign the return value +record ReturnStatement where + constructor MkRS + nonTailCall : String + tailCall : String + + +mutual + copyConstructors : {auto a : Ref ArgCounter Nat} + -> {auto t : Ref TemporaryVariableTracker (List (List String))} + -> {auto oft : Ref OutfileText (List String)} + -> {auto il : Ref IndentLevel Nat} + -> String + -> List AConAlt + -> String + -> String + -> Nat + -> Core $ () + copyConstructors _ [] _ _ _ = pure () + copyConstructors sc ((MkAConAlt n mTag args body) :: xs) constrFieldVar retValVar k = do + --(restConstructionCopy, restBody) <- copyConstructors sc xs constrFieldVar retValVar (S k) + (tag', name') <- getNameTag mTag n + emit EmptyFC $ constrFieldVar ++ "[" ++ show k ++ "].tag = " ++ tag' ++ ";" + emit EmptyFC $ constrFieldVar ++ "[" ++ show k ++ "].name = " ++ name' ++ ";" + copyConstructors sc xs constrFieldVar retValVar (S k) + where + getNameTag : {auto a : Ref ArgCounter Nat} -> Maybe Int -> Name -> Core (String, String) + getNameTag Nothing n = pure ("-1", "\"" ++ cName n ++ "\"") + getNameTag (Just t) _ = pure (show t, "NULL") + + + conBlocks : {auto a : Ref ArgCounter Nat} + -> {auto t : Ref TemporaryVariableTracker (List (List String))} + -> {auto oft : Ref OutfileText (List String)} + -> {auto il : Ref IndentLevel Nat} + -> (scrutinee:String) + -> List AConAlt + -> (returnValueVariable:String) + -> (nrConBlock:Nat) + -> Core () + conBlocks _ [] _ _ = pure () + conBlocks sc ((MkAConAlt n mTag args body) :: xs) retValVar k = do + emit EmptyFC $ " case " ++ show k ++ ":" + emit EmptyFC $ " {" + increaseIndentation + newTemporaryVariableLevel + varBindLines sc args Z + assignment <- cStatementsFromANF body + emit EmptyFC $ retValVar ++ " = " ++ nonTailCall assignment ++ ";" + freeTmpVars + emit EmptyFC $ "break;" + decreaseIndentation + emit EmptyFC $ " }" + conBlocks sc xs retValVar (S k) + where + varBindLines : String -> (args : List Int) -> Nat -> Core () + varBindLines _ [] _ = pure () + varBindLines sc (target :: xs) source = do + emit EmptyFC $ "Value * var_" ++ show target ++ " = ((Value_Constructor*)" ++ sc ++ ")->args[" ++ show source ++ "];" + varBindLines sc xs (S source) + pure () + + + constBlockSwitch : {auto a : Ref ArgCounter Nat} + -> {auto t : Ref TemporaryVariableTracker (List (List String))} + -> {auto oft : Ref OutfileText (List String)} + -> {auto il : Ref IndentLevel Nat} + -> (alts:List AConstAlt) + -> (retValVar:String) + -> (alternativeIntMatcher:Integer) + -> Core () + constBlockSwitch [] _ _ = pure () + constBlockSwitch ((MkAConstAlt c' caseBody) :: alts) retValVar i = do + let c = const2Integer c' i + emit EmptyFC $ " case " ++ show c ++ " :" + emit EmptyFC " {" + increaseIndentation + newTemporaryVariableLevel + assignment <- cStatementsFromANF caseBody + emit EmptyFC $ retValVar ++ " = " ++ nonTailCall assignment ++ ";" + freeTmpVars + emit EmptyFC "break;" + decreaseIndentation + emit EmptyFC " }" + constBlockSwitch alts retValVar (i+1) + + + + constDefaultBlock : {auto a : Ref ArgCounter Nat} + -> {auto t : Ref TemporaryVariableTracker (List (List String))} + -> {auto oft : Ref OutfileText (List String)} + -> {auto il : Ref IndentLevel Nat} + -> (def:Maybe ANF) + -> (retValVar:String) + -> Core () + constDefaultBlock Nothing _ = pure () + constDefaultBlock (Just defaultBody) retValVar = do + emit EmptyFC " default :" + emit EmptyFC " {" + increaseIndentation + newTemporaryVariableLevel + assignment <- cStatementsFromANF defaultBody + emit EmptyFC $ retValVar ++ " = " ++ nonTailCall assignment ++ ";" + freeTmpVars + decreaseIndentation + emit EmptyFC " }" + + + + makeNonIntSwitchStatementConst : + {auto a : Ref ArgCounter Nat} + -> {auto t : Ref TemporaryVariableTracker (List (List String))} + -> {auto oft : Ref OutfileText (List String)} + -> {auto il : Ref IndentLevel Nat} + -> List AConstAlt + -> (k:Int) + -> (constantArray:String) + -> (compareFct:String) + -> Core (String, String) + makeNonIntSwitchStatementConst [] _ constantArray compareFct = pure (constantArray, compareFct) + makeNonIntSwitchStatementConst ((MkAConstAlt constant caseBody) :: alts) 0 _ _ = do + case constant of + (Str s) => do + c <- getNextCounter + let constantArray = "constantArray_" ++ show c + emit EmptyFC $ "char **" ++ constantArray ++ " = (char**)malloc(sizeof(char*) * " ++ show (1+(length alts)) ++");" + makeNonIntSwitchStatementConst ((MkAConstAlt constant caseBody) :: alts) 1 constantArray "multiStringCompare" + (Db d) => do + c <- getNextCounter + let constantArray = "constantArray_" ++ show c + emit EmptyFC $ "double *" ++ constantArray ++ " = (double*)malloc(sizeof(double) * " ++ show (1+(length alts)) ++");" + makeNonIntSwitchStatementConst ((MkAConstAlt constant caseBody) :: alts) 1 constantArray "multiDoubleCompare" + _ => pure ("ERROR_NOT_DOUBLE_OR_STRING", "ERROR_NOT_DOUBLE_OR_STRING") + makeNonIntSwitchStatementConst ((MkAConstAlt constant caseBody) :: alts) k constantArray compareFct = do + emit EmptyFC $ constantArray ++ "[" ++ show (k-1) ++ "] = \"" ++ extractConstant constant ++ "\";" + makeNonIntSwitchStatementConst alts (k+1) constantArray compareFct + + + checkTags : List AConAlt -> Core Bool + checkTags [] = pure False + checkTags ((MkAConAlt n Nothing args sc) :: xs) = pure False + checkTags _ = pure True + + + cStatementsFromANF : {auto a : Ref ArgCounter Nat} + -> {auto t : Ref TemporaryVariableTracker (List (List String))} + -> {auto oft : Ref OutfileText (List String)} + -> {auto il : Ref IndentLevel Nat} + -> ANF + -> Core ReturnStatement + cStatementsFromANF (AV fc x) = do + let returnLine = "newReference(" ++ varName x ++ ")" + pure $ MkRS returnLine returnLine + cStatementsFromANF (AAppName fc n args) = do + emit fc $ ("// start " ++ cName n ++ "(" ++ showSep ", " (map (\v => varName v) args) ++ ")") + arglist <- makeArglist 0 args + c <- getNextCounter + let f_ptr_name = "fPtr_" ++ show c + emit fc $ "Value *(*"++ f_ptr_name ++ ")(Value_Arglist*) = "++ cName n ++ "_arglist;" + let closure_name = "closure_" ++ show c + emit fc $ "Value *" + ++ closure_name + ++ " = (Value*)makeClosureFromArglist(" + ++ f_ptr_name + ++ ", " + ++ arglist + ++ ");" + emit fc $ ("// end " ++ cName n ++ "(" ++ showSep ", " (map (\v => varName v) args) ++ ")") + pure $ MkRS ("trampoline(" ++ closure_name ++ ")") closure_name + cStatementsFromANF (AUnderApp fc n missing args) = do + arglist <- makeArglist missing args + c <- getNextCounter + let f_ptr_name = "closure_" ++ show c + let f_ptr = "Value *(*"++ f_ptr_name ++ ")(Value_Arglist*) = "++ cName n ++ "_arglist;" + emit fc f_ptr + let returnLine = "(Value*)makeClosureFromArglist(" ++ f_ptr_name ++ ", " ++ arglist ++ ")" + pure $ MkRS returnLine returnLine + cStatementsFromANF (AApp fc closure arg) = + -- pure $ "apply_closure(" ++ varName closure ++ ", " ++ varName arg ++ ")" + pure $ MkRS ("apply_closure(" ++ varName closure ++ ", " ++ varName arg ++ ")") + ("tailcall_apply_closure(" ++ varName closure ++ ", " ++ varName arg ++ ")") + cStatementsFromANF (ALet fc var value body) = do + valueAssignment <- cStatementsFromANF value + emit fc $ "Value * var_" ++ (show var) ++ " = " ++ nonTailCall valueAssignment ++ ";" + registerVariableForAutomaticFreeing $ "var_" ++ (show var) + bodyAssignment <- cStatementsFromANF body + pure $ bodyAssignment + cStatementsFromANF (ACon fc n tag args) = do + c <- getNextCounter + let constr = "constructor_" ++ (show c) + emit fc $ "Value_Constructor* " + ++ constr ++ " = newConstructor(" + ++ (show (length args)) + ++ ", " ++ showTag tag ++ ", " + ++ "\"" ++ cName n ++ "\"" + ++ ");" + emit fc $ " // constructor " ++ cName n + + fillConstructorArgs constr args 0 + pure $ MkRS ("(Value*)" ++ constr) ("(Value*)" ++ constr) + --fillingStatements <- fillConstructorArgs constr args 0 + --pure $ (statement1 :: fillingStatements, "(Value*)" ++ constr ++ ";") + cStatementsFromANF (AOp fc op args) = do + argsVec <- cArgsVectANF args + let opStatement = cOp op argsVec + pure $ MkRS opStatement opStatement + cStatementsFromANF (AExtPrim fc p args) = do + emit fc $ "// call to external primitive " ++ cName p + let returnLine = (cCleanString (show (toPrim p)) ++ "("++ showSep ", " (map (\v => varName v) args) ++")") + pure $ MkRS returnLine returnLine + cStatementsFromANF (AConCase fc sc alts mDef) = do + c <- getNextCounter + switchReturnVar <- getNewVarThatWillNotBeFreedAtEndOfBlock + let newValueLine = "Value * " ++ switchReturnVar ++ " = NULL;" + let constructorField = "constructorField_" ++ show c + let constructorFieldLine = "AConAlt * " ++ constructorField + ++ "= newConstructorField(" ++ show (length alts) ++ ");" + let switchLine = "switch(compareConstructors(" + ++ varName sc + ++ ", " + ++ constructorField + ++ ", " + ++ show (length alts) + ++ ")){" + emit fc newValueLine + emit fc constructorFieldLine + copyConstructors (varName sc) alts constructorField switchReturnVar 0 + emit fc switchLine + conBlocks (varName sc) alts switchReturnVar 0 + case mDef of + Nothing => do + emit EmptyFC $ "}" + emit EmptyFC $ "free(" ++ constructorField ++ ");" + pure $ MkRS switchReturnVar switchReturnVar + (Just d) => do + emit EmptyFC $ " default : {" + increaseIndentation + newTemporaryVariableLevel + defaultAssignment <- cStatementsFromANF d + -- traverse (\l => emit EmptyFC (l) ) defaultBody + emit EmptyFC $ switchReturnVar ++ " = " ++ nonTailCall defaultAssignment ++ ";" + freeTmpVars + decreaseIndentation + emit EmptyFC $ " }" + emit EmptyFC $ "}" + -- let defaultBlock = [] + -- ++ (map (\s => s) defaultBody) + -- ++ [defaultLastLine1, defaultLastLine2] + emit EmptyFC $ "free(" ++ constructorField ++ ");" + pure $ MkRS switchReturnVar switchReturnVar + cStatementsFromANF (AConstCase fc sc alts def) = do + switchReturnVar <- getNewVarThatWillNotBeFreedAtEndOfBlock + let newValueLine = "Value * " ++ switchReturnVar ++ " = NULL;" + emit fc newValueLine + case integer_switch alts of + True => do + emit fc $ "switch(extractInt(" ++ varName sc ++")){" + constBlockSwitch alts switchReturnVar 0 + constDefaultBlock def switchReturnVar + emit EmptyFC "}" + pure $ MkRS switchReturnVar switchReturnVar + False => do + (compareField, compareFunction) <- makeNonIntSwitchStatementConst alts 0 "" "" + emit fc $ "switch("++ compareFunction ++ "(" ++ varName sc ++ ", " ++ show (length alts) ++ ", " ++ compareField ++ ")){" + constBlockSwitch alts switchReturnVar 0 + constDefaultBlock def switchReturnVar + emit EmptyFC "}" + emit EmptyFC $ "free(" ++ compareField ++ ");" + pure $ MkRS switchReturnVar switchReturnVar + cStatementsFromANF (APrimVal fc c) = pure $ MkRS (cConstant c) (cConstant c) + cStatementsFromANF (AErased fc) = pure $ MkRS "NULL" "NULL" + cStatementsFromANF (ACrash fc x) = do + emit fc $ "// CRASH" + pure $ MkRS "NULL" "NULL" + + + + + +readCCPart : Char -> String -> (String, String) +readCCPart b x = + let (cc, def) = break (== b) x + in (cc, drop 1 def) + where + drop : Int -> String -> String + drop headLength s = + let len = cast (length s) + subStrLen = len - headLength in + strSubstr headLength subStrLen s + +extractFFILocation : (lang:String) -> List String -> Maybe (String, String) +extractFFILocation targetLang [] = Nothing +extractFFILocation targetLang (def :: defs) = + let (thisLang,pos) = readCCPart ':' def in + case targetLang == thisLang of + True => Just (readCCPart ',' pos) + False => extractFFILocation targetLang defs + +addCommaToList : List String -> List String +addCommaToList [] = [] +addCommaToList (x :: xs) = (" " ++ x) :: map (", " ++) xs + +functionDefSignature : {auto c : Ref Ctxt Defs} -> Name -> (args:List Int) -> Core String +functionDefSignature n [] = do + let fn = (cName !(getFullName n)) + pure $ "\n\nValue *" ++ fn ++ "(void)" +functionDefSignature n args = do + let argsStringList = addCommaToList (map (\i => " Value * var_" ++ (show i)) args) + let fn = (cName !(getFullName n)) + pure $ "\n\nValue *" ++ fn ++ "\n(\n" ++ (showSep "\n" (argsStringList)) ++ "\n)" + +functionDefSignatureArglist : {auto c : Ref Ctxt Defs} -> Name -> Core String +functionDefSignatureArglist n = pure $ "Value *" ++ (cName !(getFullName n)) ++ "_arglist(Value_Arglist* arglist)" + + +getArgsNrList : {0 ty:Type} -> List ty -> Nat -> Core $ List Nat +getArgsNrList [] _ = pure [] +getArgsNrList (x :: xs) k = pure $ k :: !(getArgsNrList xs (S k)) + + +cTypeOfCFType : CFType -> Core $ String +cTypeOfCFType CFUnit = pure $ "void" +cTypeOfCFType CFInt = pure $ "int" +cTypeOfCFType CFUnsigned8 = pure $ "uint8_t" +cTypeOfCFType CFUnsigned16 = pure $ "uint16_t" +cTypeOfCFType CFUnsigned32 = pure $ "uint32_t" +cTypeOfCFType CFUnsigned64 = pure $ "uint64_t" +cTypeOfCFType CFString = pure $ "char *" +cTypeOfCFType CFDouble = pure $ "double" +cTypeOfCFType CFChar = pure $ "char" +cTypeOfCFType CFPtr = pure $ "void *" +cTypeOfCFType CFGCPtr = pure $ "void *" +cTypeOfCFType CFBuffer = pure $ "void *" +cTypeOfCFType CFWorld = pure $ "void *" +cTypeOfCFType (CFFun x y) = pure $ "void *" +cTypeOfCFType (CFIORes x) = pure $ "void *" +cTypeOfCFType (CFStruct x ys) = pure $ "void *" +cTypeOfCFType (CFUser x ys) = pure $ "void *" + +varNamesFromList : {0 ty : Type} -> List ty -> Nat -> Core (List String) +varNamesFromList [] _ = pure [] +varNamesFromList (x :: xs) k = pure $ ("var_" ++ show k) :: !(varNamesFromList xs (S k)) + +createFFIArgList : List CFType + -> Core $ List (String, String, CFType) +createFFIArgList cftypeList = do + sList <- traverse cTypeOfCFType cftypeList + varList <- varNamesFromList cftypeList 1 + let z = zip3 sList varList cftypeList + pure z + +emitFDef : {auto oft : Ref OutfileText (List String)} + -> {auto il : Ref IndentLevel Nat} + -> (funcName:Name) + -> (arglist:List (String, String, CFType)) + -> Core () +emitFDef funcName [] = emit EmptyFC $ cName funcName ++ "(void)" +emitFDef funcName ((varType, varName, varCFType) :: xs) = do + emit EmptyFC $ "Value *" ++ cName funcName + emit EmptyFC "(" + increaseIndentation + emit EmptyFC $ " Value *" ++ varName + traverse (\(varType, varName, varCFType) => emit EmptyFC $ ", Value *" ++ varName) xs + decreaseIndentation + emit EmptyFC ")" + +extractValue : (cfType:CFType) -> (varName:String) -> String +extractValue CFUnit varName = "void" +extractValue CFInt varName = "((Value_Int32*)" ++ varName ++ ")->i32" +extractValue CFUnsigned8 varName = "((Value_Int8*)" ++ varName ++ ")->i8" +extractValue CFUnsigned16 varName = "((Value_Int16*)" ++ varName ++ ")->i16" +extractValue CFUnsigned32 varName = "((Value_Int32*)" ++ varName ++ ")->i32" +extractValue CFUnsigned64 varName = "((Value_Int64*)" ++ varName ++ ")->i64" +extractValue CFString varName = "((Value_String*)" ++ varName ++ ")->str" +extractValue CFDouble varName = "((Value_Double*)" ++ varName ++ ")->d" +extractValue CFChar varName = "((Value_Char*)" ++ varName ++ ")->c" +extractValue CFPtr varName = "((Value_Pointer*)" ++ varName ++ ")->p" +extractValue CFGCPtr varName = "((Value_GCPointer*)" ++ varName ++ ")->p->p" +extractValue CFBuffer varName = "((Value_Buffer*)" ++ varName ++ ")->buffer" +extractValue CFWorld varName = "(Value_World*)" ++ varName +extractValue (CFFun x y) varName = "Value* " ++ varName ++ "/* function pointer not implemented */" +extractValue (CFIORes x) varName = extractValue x varName +extractValue (CFStruct x xs) varName = "Value* " ++ varName ++ "/* struct access not implemented */" +extractValue (CFUser x xs) varName = "Value* " ++ varName + +packCFType : (cfType:CFType) -> (varName:String) -> String +packCFType CFUnit varName = "NULL" +packCFType CFInt varName = "makeInt32(" ++ varName ++ ")" +packCFType CFUnsigned64 varName = "makeInt64(" ++ varName ++ ")" +packCFType CFUnsigned32 varName = "makeInt32(" ++ varName ++ ")" +packCFType CFUnsigned16 varName = "makeInt16(" ++ varName ++ ")" +packCFType CFUnsigned8 varName = "makeInt8(" ++ varName ++ ")" +packCFType CFString varName = "makeString(" ++ varName ++ ")" +packCFType CFDouble varName = "makeDouble(" ++ varName ++ ")" +packCFType CFChar varName = "makeChar(" ++ varName ++ ")" +packCFType CFPtr varName = "makePointer(" ++ varName ++ ")" +packCFType CFGCPtr varName = "makePointer(" ++ varName ++ ")" +packCFType CFBuffer varName = "makeBuffer(" ++ varName ++ ")" +packCFType CFWorld varName = "makeWorld(" ++ varName ++ ")" +packCFType (CFFun x y) varName = "makeFunction(" ++ varName ++ ")" +packCFType (CFIORes x) varName = packCFType x varName +packCFType (CFStruct x xs) varName = "makeStruct(" ++ varName ++ ")" +packCFType (CFUser x xs) varName = "makeCustomUser(" ++ varName ++ ")" + +discardLastArgument : {0 ty:Type} -> List ty -> List ty +discardLastArgument [] = [] +discardLastArgument (x :: []) = [] +discardLastArgument (x :: y :: ys) = x :: (discardLastArgument (y :: ys)) + + + +createCFunctions : {auto c : Ref Ctxt Defs} + -> {auto a : Ref ArgCounter Nat} + -> {auto f : Ref FunctionDefinitions (List String)} + -> {auto t : Ref TemporaryVariableTracker (List (List String))} + -> {auto oft : Ref OutfileText (List String)} + -> {auto il : Ref IndentLevel Nat} + -> {auto e : Ref ExternalLibs (List String)} + -> Name + -> ANFDef + -> Core () +createCFunctions n (MkAFun args anf) = do + fn <- functionDefSignature n args + fn' <- functionDefSignatureArglist n + otherDefs <- get FunctionDefinitions + put FunctionDefinitions ((fn ++ ";\n") :: (fn' ++ ";\n") :: otherDefs) + newTemporaryVariableLevel + argsNrs <- getArgsNrList args Z + emit EmptyFC fn + emit EmptyFC "{" + increaseIndentation + assignment <- cStatementsFromANF anf + emit EmptyFC $ "Value *returnValue = " ++ tailCall assignment ++ ";" + freeTmpVars + emit EmptyFC $ "return returnValue;" + decreaseIndentation + emit EmptyFC "}\n" + emit EmptyFC "" + emit EmptyFC fn' + emit EmptyFC "{" + increaseIndentation + emit EmptyFC $ "return " ++ (cName !(getFullName n)) + increaseIndentation + emit EmptyFC $ "(" + increaseIndentation + let commaSepArglist = addCommaToList (map (\a => "arglist->args["++ show a ++"]") argsNrs) + traverse (emit EmptyFC) commaSepArglist + decreaseIndentation + emit EmptyFC ");" + decreaseIndentation + decreaseIndentation + emit EmptyFC "}\n" + emit EmptyFC "" + pure () + + +createCFunctions n (MkACon tag arity) = do + emit EmptyFC $ ( "// Constructor tag " ++ show tag ++ " arity " ++ show arity) -- Nothing to compile here + pure () + + +createCFunctions n (MkAForeign ccs fargs (CFIORes ret)) = do + case extractFFILocation "C" ccs of + Nothing => case extractFFILocation "scheme" ccs of + Nothing => pure () + (Just (fctName, lib)) => emit EmptyFC $ "// call ffi to a scheme substitute for " ++ fctName + (Just (fctName, lib)) => do + addExternalLib lib + otherDefs <- get FunctionDefinitions + let fnDef = "Value *" ++ (cName n) ++ "(" ++ showSep ", " (replicate (length fargs) "Value *") ++ ");" + fn_arglist <- functionDefSignatureArglist n + put FunctionDefinitions ((fnDef ++ "\n") :: (fn_arglist ++ ";\n") :: otherDefs) + typeVarNameArgList <- createFFIArgList fargs + + emit EmptyFC fn_arglist + emit EmptyFC "{" + increaseIndentation + emit EmptyFC $ "return " ++ (cName n) + increaseIndentation + emit EmptyFC $ "(" + increaseIndentation + let commaSepArglist = addCommaToList (map (\a => "arglist->args["++ show a ++"]") !(getArgsNrList fargs Z)) + traverse (emit EmptyFC) commaSepArglist + decreaseIndentation + emit EmptyFC ");" + decreaseIndentation + decreaseIndentation + emit EmptyFC "}\n" + emit EmptyFC "" + + emitFDef n typeVarNameArgList + emit EmptyFC "{" + increaseIndentation + emit EmptyFC $ " // ffi call to " ++ fctName + case ret of + CFUnit => do + emit EmptyFC $ fctName + ++ "(" + ++ showSep ", " (map (\(_, vn, vt) => extractValue vt vn) (discardLastArgument typeVarNameArgList)) + ++ ");" + emit EmptyFC "return NULL;" + decreaseIndentation + emit EmptyFC "}\n" + _ => do + emit EmptyFC $ !(cTypeOfCFType ret) ++ " retVal = " ++ fctName + ++ "(" + ++ showSep ", " (map (\(_, vn, vt) => extractValue vt vn) (discardLastArgument typeVarNameArgList)) + ++ ");" + emit EmptyFC $ "return (Value*)" ++ packCFType ret "retVal" ++ ";" + decreaseIndentation + emit EmptyFC "}\n" + + -- decreaseIndentation + -- emit EmptyFC "}" + + --put FunctionDefinitions ((fn ++ ";\n") :: (fn' ++ ";\n") :: otherDefs) + --ffiString n fctName lib fargs (CFIORes ret) + +createCFunctions n (MkAForeign ccs fargs ret) = pure () -- unable to deal with return values that are not CFIORes +createCFunctions n (MkAError exp) = do + fn <- functionDefSignature n [] + fn' <- functionDefSignatureArglist n + otherDefs <- get FunctionDefinitions + put FunctionDefinitions (fn :: fn' :: otherDefs) + --(statements, assignment) <- cStatementsFromANF exp + emit EmptyFC $ fn + ++ "\n{" + ++ "fprintf(stderr, \"Error in " ++ (cName n) ++ "\");\n" + ++ "exit(-1);\n" + ++ "return NULL;" + ++ "\n}" + pure () + + +header : {auto f : Ref FunctionDefinitions (List String)} + -> {auto o : Ref OutfileText (List String)} + -> {auto il : Ref IndentLevel Nat} + -> {auto e : Ref ExternalLibs (List String)} + -> Core () +header = do + let initLines = [ "#include " + , "/* automatically generated using the Idris2 C Backend */" + , "#include // for libidris2_support"] + extLibs <- get ExternalLibs + let extLibLines = map (\lib => "// add header(s) for library: " ++ lib ++ "\n") extLibs + traverse (\l => coreLift (putStrLn $ " header for " ++ l ++ " needed")) extLibs + fns <- get FunctionDefinitions + outText <- get OutfileText + put OutfileText (initLines ++ extLibLines ++ ["\n// function definitions"] ++ fns ++ outText) + pure () + +footer : {auto il : Ref IndentLevel Nat} -> {auto f : Ref OutfileText (List String)} -> Core () +footer = do + emit EmptyFC "" + emit EmptyFC " // main function" + emit EmptyFC "int main()" + emit EmptyFC "{" + emit EmptyFC " Value *mainExprVal = __mainExpression_0();" + emit EmptyFC " trampoline(mainExprVal);" + emit EmptyFC " return 0; // bye bye" + emit EmptyFC "}" + pure () + +export +executeExpr : Ref Ctxt Defs -> (execDir : String) -> ClosedTerm -> Core () +executeExpr c _ tm + = do coreLift $ putStrLn "Execute expression not yet implemented for refc" + coreLift $ system "false" + pure () + +export +compileExpr : UsePhase + -> Ref Ctxt Defs + -> (tmpDir : String) + -> (outputDir : String) + -> ClosedTerm + -> (outfile : String) + -> Core (Maybe String) +compileExpr ANF c _ outputDir tm outfile = + do let outn = outputDir outfile ++ ".c" + let outobj = outputDir outfile ++ ".o" + let outexec = outputDir outfile + + coreLift $ mkdirAll outputDir + cdata <- getCompileData ANF tm + let defs = anf cdata + newRef ArgCounter 0 + newRef FunctionDefinitions [] + newRef TemporaryVariableTracker [] + newRef OutfileText [] + newRef ExternalLibs [] + newRef IndentLevel 0 + traverse (\(n, d) => createCFunctions n d) defs + header -- added after the definition traversal in order to add all encountered function defintions + footer + fileContent <- get OutfileText + let code = fastAppend (map (++ "\n") fileContent) + + coreLift (writeFile outn code) + coreLift $ putStrLn $ "Generated C file " ++ outn + + cc <- coreLift findCC + dirs <- getDirs + + let runccobj = cc ++ " -c " ++ outn ++ " -o " ++ outobj ++ " " ++ + "-I" ++ fullprefix_dir dirs "refc " ++ + "-I" ++ fullprefix_dir dirs "include" + + let runcc = cc ++ " " ++ outobj ++ " -o " ++ outexec ++ " " ++ + fullprefix_dir dirs "lib" "libidris2_support.a" ++ " " ++ + "-lidris2_refc " ++ + "-L" ++ fullprefix_dir dirs "refc " ++ + clibdirs (lib_dirs dirs) + + coreLift $ putStrLn runccobj + ok <- coreLift $ system runccobj + if ok == 0 + then do coreLift $ putStrLn runcc + ok <- coreLift $ system runcc + if ok == 0 + then pure (Just outexec) + else pure Nothing + else pure Nothing + where + fullprefix_dir : Dirs -> String -> String + fullprefix_dir dirs sub + = prefix_dir dirs "idris2-" ++ showVersion False version sub + + clibdirs : List String -> String + clibdirs ds = concat (map (\d => "-L" ++ d ++ " ") ds) +compileExpr _ _ _ _ _ _ = pure Nothing + +export +codegenRefC : Codegen +codegenRefC = MkCG (compileExpr ANF) executeExpr diff --git a/src/Compiler/Scheme/Common.idr b/src/Compiler/Scheme/Common.idr index 85f94058f..8b7eb17c5 100644 --- a/src/Compiler/Scheme/Common.idr +++ b/src/Compiler/Scheme/Common.idr @@ -31,7 +31,7 @@ schString s = concatMap okchar (unpack s) export schName : Name -> String -schName (NS ns n) = showNSWithSep "-" ns ++ "-" ++ schName n +schName (NS ns n) = schString (showNSWithSep "-" ns) ++ "-" ++ schName n schName (UN n) = schString n schName (MN n i) = schString n ++ "-" ++ show i schName (PV n d) = "pat--" ++ schName n @@ -236,7 +236,8 @@ toPrim pn@(NS _ n) (n == UN "prim__arraySet", ArraySet), (n == UN "prim__getField", GetField), (n == UN "prim__setField", SetField), - (n == UN "void", VoidElim), + (n == UN "void", VoidElim), -- DEPRECATED. TODO: remove when bootstrap has been updated + (n == UN "prim__void", VoidElim), (n == UN "prim__os", SysOS), (n == UN "prim__codegen", SysCodegen), (n == UN "prim__onCollect", OnCollect), diff --git a/src/Core/CaseBuilder.idr b/src/Core/CaseBuilder.idr index d27fd9915..cdae4876c 100644 --- a/src/Core/CaseBuilder.idr +++ b/src/Core/CaseBuilder.idr @@ -605,8 +605,10 @@ groupCons fc fn pvars cs = if a == length pargs then addConG n t pargs pats pid rhs acc else throw (CaseCompile cfc fn (NotFullyApplied n)) - addGroup (PTyCon _ n a pargs) pprf pats pid rhs acc - = addConG n 0 pargs pats pid rhs acc + addGroup (PTyCon cfc n a pargs) pprf pats pid rhs acc + = if a == length pargs + then addConG n 0 pargs pats pid rhs acc + else throw (CaseCompile cfc fn (NotFullyApplied n)) addGroup (PArrow _ _ s t) pprf pats pid rhs acc = addConG (UN "->") 0 [s, t] pats pid rhs acc -- Go inside the delay; we'll flag the case as needing to force its diff --git a/src/Core/Context.idr b/src/Core/Context.idr index 37b115dc0..0fcca7475 100644 --- a/src/Core/Context.idr +++ b/src/Core/Context.idr @@ -336,8 +336,11 @@ record Context where -- access in a program - in all other cases, we'll assume everything is -- visible visibleNS : List Namespace - allPublic : Bool -- treat everything as public. This is only intended + allPublic : Bool -- treat everything as public. This is intended -- for checking partially evaluated definitions + -- or for use outside of the main compilation + -- process (e.g. when implementing interactive + -- features such as case splitting). inlineOnly : Bool -- only return things with the 'alwaysReduce' flag hidden : NameMap () -- Never return these @@ -757,6 +760,15 @@ HasNames (Env Term vars) where resolved gam (b :: bs) = pure $ !(traverse (resolved gam) b) :: !(resolved gam bs) +export +HasNames Clause where + full gam (MkClause env lhs rhs) + = pure $ MkClause !(full gam env) !(full gam lhs) !(full gam rhs) + + resolved gam (MkClause env lhs rhs) + = [| MkClause (resolved gam env) (resolved gam lhs) (resolved gam rhs) |] + + export HasNames Def where full gam (PMDef r args ct rt pats) diff --git a/src/Core/Core.idr b/src/Core/Core.idr index d6eee7edf..28a7510ee 100644 --- a/src/Core/Core.idr +++ b/src/Core/Core.idr @@ -438,6 +438,10 @@ export %inline (<$>) : (a -> b) -> Core a -> Core b (<$>) f (MkCore a) = MkCore (map (map f) a) +export %inline +ignore : Core a -> Core () +ignore = map (\ _ => ()) + -- Monad (specialised) export %inline (>>=) : Core a -> (a -> Core b) -> Core b diff --git a/src/Core/Coverage.idr b/src/Core/Coverage.idr index b0883334a..ab13b12fd 100644 --- a/src/Core/Coverage.idr +++ b/src/Core/Coverage.idr @@ -2,6 +2,7 @@ module Core.Coverage import Core.CaseTree import Core.Context +import Core.Context.Log import Core.Env import Core.Normalise import Core.TT @@ -11,6 +12,8 @@ import Data.Bool.Extra import Data.List import Data.NameMap +import Text.PrettyPrint.Prettyprinter + %default covering -- Return whether any of the name matches conflict @@ -119,8 +122,11 @@ isEmpty : {vars : _} -> {auto c : Ref Ctxt Defs} -> Defs -> Env Term vars -> NF vars -> Core Bool isEmpty defs env (NTCon fc n t a args) - = case !(lookupDefExact n (gamma defs)) of - Just (TCon _ _ _ _ flags _ cons _) + = do Just nty <- lookupDefExact n (gamma defs) + | _ => pure False + log "coverage.empty" 10 $ "Checking type: " ++ show nty + case nty of + TCon _ _ _ _ flags _ cons _ => if not (external flags) then allM (conflict defs env (NTCon fc n t a args)) cons else pure False @@ -482,7 +488,15 @@ export checkMatched : {auto c : Ref Ctxt Defs} -> List Clause -> ClosedTerm -> Core (Maybe ClosedTerm) checkMatched cs ulhs - = tryClauses cs !(eraseApps ulhs) + = do logTerm "coverage" 5 "Checking coverage for" ulhs + logC "coverage" 10 $ pure $ "(raw term: " ++ show !(toFullNames ulhs) ++ ")" + ulhs <- eraseApps ulhs + logTerm "coverage" 5 "Erased to" ulhs + logC "coverage" 5 $ do + cs <- traverse toFullNames cs + pure $ "Against clauses:\n" ++ + (show $ indent {ann = ()} 2 $ vcat $ map (pretty . show) cs) + tryClauses cs ulhs where tryClauses : List Clause -> ClosedTerm -> Core (Maybe ClosedTerm) tryClauses [] ulhs diff --git a/src/Core/FC.idr b/src/Core/FC.idr index e96dffd7e..52e3465a4 100644 --- a/src/Core/FC.idr +++ b/src/Core/FC.idr @@ -79,6 +79,17 @@ export toplevelFC : FC toplevelFC = MkFC "(toplevel)" (0, 0) (0, 0) +------------------------------------------------------------------------ +-- Basic operations +export +mergeFC : FC -> FC -> Maybe FC +mergeFC (MkFC fname1 start1 end1) (MkFC fname2 start2 end2) = + if fname1 == fname2 + then Just $ MkFC fname1 (min start1 start2) (max end1 end2) + else Nothing +mergeFC _ _ = Nothing + + %name FC fc ------------------------------------------------------------------------ diff --git a/src/Core/Options.idr b/src/Core/Options.idr index 416dfacad..c85873683 100644 --- a/src/Core/Options.idr +++ b/src/Core/Options.idr @@ -53,6 +53,7 @@ data CG = Chez | Gambit | Node | Javascript + | RefC | Other String export @@ -62,6 +63,7 @@ Eq CG where Gambit == Gambit = True Node == Node = True Javascript == Javascript = True + RefC == RefC = True Other s == Other t = s == t _ == _ = False @@ -72,6 +74,7 @@ Show CG where show Gambit = "gambit" show Node = "node" show Javascript = "javascript" + show RefC = "refc" show (Other s) = s public export @@ -164,6 +167,7 @@ availableCGs o ("racket", Racket), ("node", Node), ("javascript", Javascript), + ("refc", RefC), ("gambit", Gambit)] ++ additionalCGs o export diff --git a/src/Core/TTC.idr b/src/Core/TTC.idr index 448cf62ab..cb87c6baa 100644 --- a/src/Core/TTC.idr +++ b/src/Core/TTC.idr @@ -751,6 +751,7 @@ TTC CG where toBuf b (Other s) = do tag 4; toBuf b s toBuf b Node = tag 5 toBuf b Javascript = tag 6 + toBuf b RefC = tag 7 fromBuf b = case !getTag of @@ -761,6 +762,7 @@ TTC CG where pure (Other s) 5 => pure Node 6 => pure Javascript + 7 => pure RefC _ => corrupt "CG" export diff --git a/src/Core/Termination.idr b/src/Core/Termination.idr index 1d3e8b1fa..a2f422f19 100644 --- a/src/Core/Termination.idr +++ b/src/Core/Termination.idr @@ -25,8 +25,10 @@ totRefs defs (n :: ns) | Nothing => pure rest case isTerminating (totality d) of IsTerminating => pure rest - Unchecked => pure rest - bad => case rest of + Unchecked => do + log "totality" 20 $ "Totality unchecked for " ++ show !(toFullNames n) + pure rest + _ => case rest of NotTerminating (BadCall ns) => toFullNames $ NotTerminating (BadCall (n :: ns)) _ => toFullNames $ NotTerminating (BadCall [n]) @@ -43,7 +45,7 @@ export checkIfGuarded : {auto c : Ref Ctxt Defs} -> FC -> Name -> Core () checkIfGuarded fc n - = do log "totality.termination.guarded" 6 $ "Check if Guarded: " ++ show n + = do log "totality.termination.guarded" 6 $ "Check if Guarded: " ++ show !(toFullNames n) defs <- get Ctxt Just (PMDef _ _ _ _ pats) <- lookupDefExact n (gamma defs) | _ => pure () @@ -363,7 +365,7 @@ mutual = do Just gdef <- lookupCtxtExact fn_in (gamma defs) | Nothing => throw (UndefinedName fc fn_in) let fn = fullname gdef - log "totality.termination.sizechange" 10 $ "Looking under " ++ show fn + log "totality.termination.sizechange" 10 $ "Looking under " ++ show !(toFullNames fn) aSmaller <- resolved (gamma defs) (NS builtinNS (UN "assert_smaller")) cond [(fn == NS builtinNS (UN "assert_total"), pure []), (caseFn fn, @@ -410,7 +412,7 @@ export calculateSizeChange : {auto c : Ref Ctxt Defs} -> FC -> Name -> Core (List SCCall) calculateSizeChange loc n - = do log "totality.termination.sizechange" 5 $ "Calculating Size Change: " ++ show n + = do log "totality.termination.sizechange" 5 $ "Calculating Size Change: " ++ show !(toFullNames n) defs <- get Ctxt Just def <- lookupCtxtExact n (gamma defs) | Nothing => throw (UndefinedName loc n) @@ -447,15 +449,15 @@ checkSC : {auto a : Ref APos Arg} -> List (Name, List (Maybe Arg)) -> -- calls we've seen so far Core Terminating checkSC defs f args path - = do log "totality.termination.sizechange" 7 $ "Checking Size Change Graph: " ++ show f + = do log "totality.termination.sizechange" 7 $ "Checking Size Change Graph: " ++ show !(toFullNames f) let pos = (f, map (map Builtin.fst) args) if pos `elem` path - then do log "totality.termination.sizechange.inPath" 8 $ "Checking arguments: " ++ show f + then do log "totality.termination.sizechange.inPath" 8 $ "Checking arguments: " ++ show !(toFullNames f) toFullNames $ checkDesc (mapMaybe (map Builtin.snd) args) path else case !(lookupCtxtExact f (gamma defs)) of - Nothing => do log "totality.termination.sizechange.isTerminating" 8 $ "Size Change Graph is Terminating for: " ++ show f + Nothing => do log "totality.termination.sizechange.isTerminating" 8 $ "Size Change Graph is Terminating for: " ++ show !(toFullNames f) pure IsTerminating - Just def => do log "totality.termination.sizechange.needsChecking" 8 $ "Size Change Graph needs traversing: " ++ show f + Just def => do log "totality.termination.sizechange.needsChecking" 8 $ "Size Change Graph needs traversing: " ++ show !(toFullNames f) continue (sizeChange def) (pos :: path) where -- Look for something descending in the list of size changes @@ -492,7 +494,7 @@ checkSC defs f args path let Unchecked = isTerminating (totality gdef) | IsTerminating => pure IsTerminating | _ => pure (NotTerminating (BadCall [fnCall sc])) - log "totality.termination.sizechange.checkCall" 8 $ "CheckCall Size Change Graph: " ++ show (fnCall sc) + log "totality.termination.sizechange.checkCall" 8 $ "CheckCall Size Change Graph: " ++ show !(toFullNames (fnCall sc)) term <- checkSC defs (fnCall sc) (mkArgs (fnArgs sc)) path if not inpath then case term of @@ -501,12 +503,12 @@ checkSC defs f args path -- was mutually recursive, so start again with new -- arguments (that is, where we'd start if the -- function was the top level thing we were checking) - do log "totality.termination.sizechange.checkCall.inPathNot.restart" 9 $ "ReChecking Size Change Graph: " ++ show (fnCall sc) + do log "totality.termination.sizechange.checkCall.inPathNot.restart" 9 $ "ReChecking Size Change Graph: " ++ show !(toFullNames (fnCall sc)) args' <- initArgs (length (fnArgs sc)) checkSC defs (fnCall sc) args' path - t => do log "totality.termination.sizechange.checkCall.inPathNot.return" 9 $ "Have result: " ++ show (fnCall sc) + t => do log "totality.termination.sizechange.checkCall.inPathNot.return" 9 $ "Have result: " ++ show !(toFullNames (fnCall sc)) pure t - else do log "totality.termination.sizechange.checkCall.inPath" 9 $ "Have Result: " ++ show (fnCall sc) + else do log "totality.termination.sizechange.checkCall.inPath" 9 $ "Have Result: " ++ show !(toFullNames (fnCall sc)) pure term getWorst : Terminating -> List Terminating -> Terminating @@ -524,7 +526,7 @@ calcTerminating : {auto c : Ref Ctxt Defs} -> FC -> Name -> Core Terminating calcTerminating loc n = do defs <- get Ctxt - log "totality.termination.calc" 7 $ "Calculating termination: " ++ show n + log "totality.termination.calc" 7 $ "Calculating termination: " ++ show !(toFullNames n) case !(lookupCtxtExact n (gamma defs)) of Nothing => throw (UndefinedName loc n) Just def => @@ -558,7 +560,7 @@ checkTerminating : {auto c : Ref Ctxt Defs} -> FC -> Name -> Core Terminating checkTerminating loc n = do tot <- getTotality loc n - log "totality.termination" 6 $ "Checking termination: " ++ show n + log "totality.termination" 6 $ "Checking termination: " ++ show !(toFullNames n) case isTerminating tot of Unchecked => do tot' <- calcTerminating loc n @@ -651,7 +653,7 @@ calcPositive : {auto c : Ref Ctxt Defs} -> FC -> Name -> Core (Terminating, List Name) calcPositive loc n = do defs <- get Ctxt - log "totality.positivity" 6 $ "Calculating positivity: " ++ show n + log "totality.positivity" 6 $ "Calculating positivity: " ++ show !(toFullNames n) case !(lookupDefTyExact n (gamma defs)) of Just (TCon _ _ _ _ _ tns dcons _, ty) => case !(totRefsIn defs ty) of @@ -670,7 +672,7 @@ checkPositive : {auto c : Ref Ctxt Defs} -> checkPositive loc n_in = do n <- toResolvedNames n_in tot <- getTotality loc n - log "totality.positivity" 6 $ "Checking positivity: " ++ show n + log "totality.positivity" 6 $ "Checking positivity: " ++ show !(toFullNames n) case isTerminating tot of Unchecked => do (tot', cons) <- calcPositive loc n @@ -679,6 +681,7 @@ checkPositive loc n_in pure tot' t => pure t + -- Check and record totality of the given name; positivity if it's a data -- type, termination if it's a function export @@ -690,7 +693,7 @@ checkTotal loc n_in | Nothing => throw (UndefinedName loc n_in) let n = Resolved nidx tot <- getTotality loc n - log "totality" 5 $ "Checking totality: " ++ show n + log "totality" 5 $ "Checking totality: " ++ show !(toFullNames n) defs <- get Ctxt case isTerminating tot of Unchecked => diff --git a/src/Idris/DocString.idr b/src/Idris/DocString.idr index 8e1e9e748..17eec207b 100644 --- a/src/Idris/DocString.idr +++ b/src/Idris/DocString.idr @@ -188,5 +188,5 @@ getContents ns pure (visibility def /= Private) inNS : Name -> Bool - inNS (NS xns (UN _)) = xns == ns + inNS (NS xns (UN _)) = ns `isParentOf` xns inNS _ = False diff --git a/src/Idris/IDEMode/REPL.idr b/src/Idris/IDEMode/REPL.idr index e0432b3dd..c75234e03 100644 --- a/src/Idris/IDEMode/REPL.idr +++ b/src/Idris/IDEMode/REPL.idr @@ -84,6 +84,7 @@ initIDESocketFile h p = do pure (Left ("Failed to listen on socket with error: " ++ show res)) else do putStrLn (show p) + fflush stdout res <- accept sock case res of Left err => diff --git a/src/Idris/Parser.idr b/src/Idris/Parser.idr index befe0ce3f..6646a2d9d 100644 --- a/src/Idris/Parser.idr +++ b/src/Idris/Parser.idr @@ -1390,13 +1390,14 @@ topDecl fname indents -- collectDefs : List PDecl -> List PDecl collectDefs [] = [] collectDefs (PDef annot cs :: ds) - = let (cs', rest) = spanBy isClause ds in - PDef annot (cs ++ concat cs') :: assert_total (collectDefs rest) - where - isClause : PDecl -> Maybe (List PClause) - isClause (PDef annot cs) - = Just cs - isClause _ = Nothing + = let (csWithFC, rest) = spanBy isPDef ds + cs' = cs ++ concat (map snd csWithFC) + annot' = foldr + (\fc1, fc2 => fromMaybe EmptyFC (mergeFC fc1 fc2)) + annot + (map fst csWithFC) + in + PDef annot' cs' :: assert_total (collectDefs rest) collectDefs (PNamespace annot ns nds :: ds) = PNamespace annot ns (collectDefs nds) :: collectDefs ds collectDefs (PMutual annot nds :: ds) diff --git a/src/Idris/REPL.idr b/src/Idris/REPL.idr index 99bcc8be3..93ecc38f1 100644 --- a/src/Idris/REPL.idr +++ b/src/Idris/REPL.idr @@ -6,6 +6,7 @@ import Compiler.Scheme.Gambit import Compiler.ES.Node import Compiler.ES.Javascript import Compiler.Common +import Compiler.RefC.RefC import Core.AutoSearch import Core.CaseTree @@ -189,6 +190,7 @@ findCG Gambit => pure codegenGambit Node => pure codegenNode Javascript => pure codegenJavascript + RefC => pure codegenRefC Other s => case !(getCodegen s) of Just cg => pure cg Nothing => do coreLift $ putStrLn ("No such code generator: " ++ s) @@ -704,7 +706,7 @@ process Edit Nothing => pure NoFileLoaded Just f => do let line = maybe "" (\i => " +" ++ show (i + 1)) (errorLine opts) - coreLift $ system (editor opts ++ " " ++ f ++ line) + coreLift $ system (editor opts ++ " \"" ++ f ++ "\"" ++ line) loadMainFile f process (Compile ctm outfile) = compileExp ctm outfile diff --git a/src/Idris/Syntax.idr b/src/Idris/Syntax.idr index 476c051dc..f9eeb1fba 100644 --- a/src/Idris/Syntax.idr +++ b/src/Idris/Syntax.idr @@ -334,6 +334,12 @@ mutual getPDeclLoc (PRunElabDecl fc _) = fc getPDeclLoc (PDirective fc _) = fc + export + isPDef : PDecl -> Maybe (FC, List PClause) + isPDef (PDef annot cs) = Just (annot, cs) + isPDef _ = Nothing + + definedInData : PDataDecl -> List Name definedInData (MkPData _ n _ _ cons) = n :: map getName cons where diff --git a/src/Parser/Rule/Common.idr b/src/Parser/Rule/Common.idr index b439bad8d..7dd1e95c4 100644 --- a/src/Parser/Rule/Common.idr +++ b/src/Parser/Rule/Common.idr @@ -16,20 +16,20 @@ EmptyRule token ty = Grammar token False ty export location : {token : _} -> EmptyRule token (Int, Int) location - = do tok <- bounds peek - pure (tok.startLine, tok.startCol) + = do tok <- removeIrrelevance <$> bounds peek + pure $ start tok export endLocation : {token : _} -> EmptyRule token (Int, Int) endLocation - = do tok <- bounds peek - pure (tok.endLine, tok.endCol) + = do tok <- removeIrrelevance <$> bounds peek + pure $ end tok export position : {token : _} -> EmptyRule token ((Int, Int), (Int, Int)) position - = do tok <- bounds peek - pure ((tok.startLine, tok.startCol), (tok.endLine, tok.endCol)) + = do tok <- removeIrrelevance <$> bounds peek + pure (start tok, end tok) export diff --git a/src/TTImp/Interactive/CaseSplit.idr b/src/TTImp/Interactive/CaseSplit.idr index c704bac99..303055cf9 100644 --- a/src/TTImp/Interactive/CaseSplit.idr +++ b/src/TTImp/Interactive/CaseSplit.idr @@ -318,13 +318,21 @@ mkCase {c} {u} fn orig lhs_raw defs <- get Ctxt ust <- get UST catch - (do -- Use 'Rig0' since it might be a type level function, or it might + (do + -- Fixes Issue #74. The problem is that if the function is defined in a sub module, + -- then the current namespace (accessed by calling getNS) differs from the function + -- namespace, therefore it is not considered visible by TTImp.Elab.App.checkVisibleNS + setAllPublic True + + -- Use 'Rig0' since it might be a type level function, or it might -- be an erased name in a case block (which will be bound elsewhere -- once split and turned into a pattern) (lhs, _) <- elabTerm {c} {m} {u} fn (InLHS erased) [] (MkNested []) [] (IBindHere (getFC lhs_raw) PATTERN lhs_raw) Nothing + -- Revert all public back to false + setAllPublic False put Ctxt defs -- reset the context, we don't want any updates put UST ust lhs' <- unelabNoSugar [] lhs diff --git a/src/TTImp/ProcessDecls.idr b/src/TTImp/ProcessDecls.idr index 6569e3a13..810dc7c0c 100644 --- a/src/TTImp/ProcessDecls.idr +++ b/src/TTImp/ProcessDecls.idr @@ -72,14 +72,22 @@ checkTotalityOK n = do defs <- get Ctxt Just gdef <- lookupCtxtExact n (gamma defs) | Nothing => pure Nothing + let fc = location gdef + + -- #524: need to check positivity even if we're not in a total context + -- because a definition coming later may need to know it is positive + case definition gdef of + (TCon _ _ _ _ _ _ _ _) => ignore $ checkPositive fc n + _ => pure () + + -- Once that is done, we build up errors if necessary let treq = fromMaybe !getDefaultTotalityOption (findSetTotal (flags gdef)) let tot = totality gdef - let fc = location gdef log "totality" 3 $ show n ++ " must be: " ++ show treq case treq of - PartialOK => pure Nothing - CoveringOnly => checkCovering fc (isCovering tot) - Total => checkTotality fc + PartialOK => pure Nothing + CoveringOnly => checkCovering fc (isCovering tot) + Total => checkTotality fc where checkCovering : FC -> Covering -> Core (Maybe Error) checkCovering fc IsCovering = pure Nothing diff --git a/src/TTImp/ProcessDef.idr b/src/TTImp/ProcessDef.idr index 27d1d4477..527e1d7f3 100644 --- a/src/TTImp/ProcessDef.idr +++ b/src/TTImp/ProcessDef.idr @@ -107,28 +107,48 @@ recoverable : {auto c : Ref Ctxt Defs} -> {vars : _} -> Defs -> NF vars -> NF vars -> Core Bool -- Unlike the above, any mismatch will do + +-- TYPE CONSTRUCTORS recoverable defs (NTCon _ xn xt xa xargs) (NTCon _ yn yt ya yargs) = if xn /= yn then pure False else pure $ not !(anyM (mismatch defs) (zip xargs yargs)) +-- Type constructor vs. primitive type +recoverable defs (NTCon _ _ _ _ _) (NPrimVal _ _) = pure False +recoverable defs (NPrimVal _ _) (NTCon _ _ _ _ _) = pure False +recoverable defs (NTCon _ _ _ _ _) _ = pure True + +-- DATA CONSTRUCTORS recoverable defs (NDCon _ _ xt _ xargs) (NDCon _ _ yt _ yargs) = if xt /= yt then pure False else pure $ not !(anyM (mismatch defs) (zip xargs yargs)) +recoverable defs (NDCon _ _ _ _ _) _ = pure True + +-- FUNCTION CALLS recoverable defs (NApp _ (NRef _ f) fargs) (NApp _ (NRef _ g) gargs) = pure True -- both functions; recoverable -recoverable defs (NTCon _ _ _ _ _) _ = pure True -recoverable defs (NDCon _ _ _ _ _) _ = pure True + +-- PRIMITIVES recoverable defs (NPrimVal _ x) (NPrimVal _ y) = pure (x == y) -recoverable defs (NPrimVal _ _) (NDCon _ _ _ _ _) = pure False + +-- OTHERWISE: no recoverable defs x y = pure False export recoverableErr : {auto c : Ref Ctxt Defs} -> Defs -> Error -> Core Bool recoverableErr defs (CantConvert fc env l r) - = recoverable defs !(nf defs env l) - !(nf defs env r) + = do l <- nf defs env l + r <- nf defs env r + log "coverage.recover" 10 $ unlines + [ "Recovering from CantConvert?" + , "Checking:" + , " " ++ show l + , " " ++ show r + ] + recoverable defs l r + recoverableErr defs (CantSolveEq fc env l r) = recoverable defs !(nf defs env l) !(nf defs env r) @@ -811,9 +831,11 @@ processDef opts nest env fc n_in cs_in defs <- get Ctxt lhs <- normaliseHoles defs [] lhstm if !(hasEmptyPat defs [] lhs) - then do put Ctxt ctxt + then do log "declare.def.impossible" 5 "No empty pat" + put Ctxt ctxt pure Nothing - else do empty <- clearDefs ctxt + else do log "declare.def.impossible" 5 "Some empty pat" + empty <- clearDefs ctxt rtm <- closeEnv empty !(nf empty [] lhs) put Ctxt ctxt pure (Just rtm)) diff --git a/src/Text/Bounded.idr b/src/Text/Bounded.idr index 635bf86d3..444bbad7e 100644 --- a/src/Text/Bounded.idr +++ b/src/Text/Bounded.idr @@ -46,6 +46,10 @@ export irrelevantBounds : ty -> WithBounds ty irrelevantBounds x = MkBounded x True (-1) (-1) (-1) (-1) +export +removeIrrelevance : WithBounds ty -> WithBounds ty +removeIrrelevance (MkBounded val ir sl sc el ec) = MkBounded val True sl sc el ec + export mergeBounds : WithBounds ty -> WithBounds ty' -> WithBounds ty' mergeBounds (MkBounded _ True _ _ _ _) (MkBounded val True _ _ _ _) = irrelevantBounds val diff --git a/src/Text/Literate.idr b/src/Text/Literate.idr index f957f40b0..4a451f46d 100644 --- a/src/Text/Literate.idr +++ b/src/Text/Literate.idr @@ -64,11 +64,11 @@ rawTokens delims ls = ||| Merge the tokens into a single source file. reduce : List (WithBounds Token) -> List String -> String reduce [] acc = fastAppend (reverse acc) -reduce (MkBounded (Any x) _ _ _ _ _ :: rest) acc = reduce rest (blank_content::acc) - where - -- Preserve the original document's line count. - blank_content : String - blank_content = fastAppend (replicate (length (lines x)) "\n") +reduce (MkBounded (Any x) _ _ _ _ _ :: rest) acc = + -- newline will always be tokenized as a single token + if x == "\n" + then reduce rest ("\n"::acc) + else reduce rest acc reduce (MkBounded (CodeLine m src) _ _ _ _ _ :: rest) acc = if m == trim src @@ -83,7 +83,8 @@ reduce (MkBounded (CodeBlock l r src) _ _ _ _ _ :: rest) acc with (lines src) -- reduce (MkBounded (CodeBlock l r src) _ _ _ _ _ :: rest) acc | (s :: ys) with (snocList ys) reduce (MkBounded (CodeBlock l r src) _ _ _ _ _ :: rest) acc | (s :: []) | Empty = reduce rest acc -- 2 reduce (MkBounded (CodeBlock l r src) _ _ _ _ _ :: rest) acc | (s :: (srcs ++ [f])) | (Snoc f srcs rec) = - reduce rest ("\n" :: unlines srcs :: acc) + -- the "\n" counts for the open deliminator; the closing deliminator should always be followed by a (Any "\n"), so we don't add a newline + reduce rest (unlines srcs :: "\n" :: acc) -- [ NOTE ] 1 & 2 shouldn't happen as code blocks are well formed i.e. have two deliminators. diff --git a/src/Text/Parser/Core.idr b/src/Text/Parser/Core.idr index ea24424a5..dc91352e1 100644 --- a/src/Text/Parser/Core.idr +++ b/src/Text/Parser/Core.idr @@ -240,7 +240,7 @@ mutual doParse com (NextIs err f) [] = Failure com False "End of input" [] doParse com (NextIs err f) (x :: xs) = if f x - then Res com x (x :: xs) + then Res com (removeIrrelevance x) (x :: xs) else Failure com False err (x :: xs) doParse com (Alt {c1} {c2} x y) xs = case doParse False x xs of diff --git a/support/refc/Makefile b/support/refc/Makefile new file mode 100644 index 000000000..338f0a312 --- /dev/null +++ b/support/refc/Makefile @@ -0,0 +1,49 @@ +include ../../config.mk + +TARGET = libidris2_refc + +LIBTARGET = $(TARGET).a + +CFLAGS += -O2 + +SRCS = $(wildcard *.c) +ifeq ($(OS), windows) + LDFLAGS += -lws2_32 +ifeq ($(OLD_WIN), 1) + CFLAGS += -D_OLD_WIN +endif +endif +OBJS = $(SRCS:.c=.o) +DEPS = $(OBJS:.o=.d) + + +all: build + +.PHONY: build + +build: $(LIBTARGET) + +$(LIBTARGET): $(OBJS) + $(AR) rc $@ $^ + $(RANLIB) $@ + +-include $(DEPS) + +%.d: %.c + @$(CPP) $(CFLAGS) $< -MM -MT $(@:.d=.o) >$@ + + +.PHONY: clean + +clean: + $(RM) $(OBJS) $(LIBTARGET) + +cleandep: clean + $(RM) $(DEPS) + + +.PHONY: install + +install: build + mkdir -p ${PREFIX}/idris2-${IDRIS2_VERSION}/refc + install $(LIBTARGET) *.h ${PREFIX}/idris2-${IDRIS2_VERSION}/refc diff --git a/support/refc/cBackend.h b/support/refc/cBackend.h new file mode 100644 index 000000000..af8787bd1 --- /dev/null +++ b/support/refc/cBackend.h @@ -0,0 +1,17 @@ +#ifndef __C_BACKEND_H__ +#define __C_BACKEND_H__ +#include +#include +#include +#include + +#include "datatypes.h" +#include "memoryManagement.h" +#include "mathFunctions.h" +#include "runtime.h" +#include "stringOps.h" +#include "casts.h" +#include "conCaseHelper.h" +#include "prim.h" + +#endif diff --git a/support/refc/casts.c b/support/refc/casts.c new file mode 100644 index 000000000..5786d38be --- /dev/null +++ b/support/refc/casts.c @@ -0,0 +1,644 @@ +#include "casts.h" +#include + +Value *cast_i32_to_Bits8(Value *input) +{ + Value_Int8 *retVal = (Value_Int8 *)newValue(); + retVal->header.tag = INT8_TAG; + Value_Int32 *from = (Value_Int32 *)input; + retVal->i8 = (int8_t)from->i32; + + return (Value *)retVal; +} + +Value *cast_i32_to_Bits16(Value *input) +{ + Value_Int16 *retVal = (Value_Int16 *)newValue(); + retVal->header.tag = INT16_TAG; + Value_Int32 *from = (Value_Int32 *)input; + retVal->i16 = (int16_t)from->i32; + + return (Value *)retVal; +} +Value *cast_i32_to_Bits32(Value *input) +{ + return input; +} +Value *cast_i32_to_Bits64(Value *input) +{ + return cast_i32_to_i64(input); +} + +Value *cast_i32_to_i64(Value *input) +{ + Value_Int64 *retVal = (Value_Int64 *)newValue(); + retVal->header.tag = INT64_TAG; + Value_Int32 *from = (Value_Int32 *)input; + retVal->i64 = (int64_t)from->i32; + + return (Value *)retVal; +} + +Value *cast_i32_to_double(Value *input) +{ + Value_Double *retVal = (Value_Double *)newValue(); + retVal->header.tag = DOUBLE_TAG; + Value_Int32 *from = (Value_Int32 *)input; + retVal->d = (double)from->i32; + + return (Value *)retVal; +} + +Value *cast_i32_to_char(Value *input) +{ + Value_Char *retVal = (Value_Char *)newValue(); + retVal->header.tag = CHAR_TAG; + Value_Int32 *from = (Value_Int32 *)input; + retVal->c = (char)from->i32; + + return (Value *)retVal; +} + +Value *cast_i32_to_string(Value *input) +{ + Value_String *retVal = (Value_String *)newValue(); + retVal->header.tag = STRING_TAG; + Value_Int32 *from = (Value_Int32 *)input; + int l = snprintf(NULL, 0, "%i", from->i32); + retVal->str = malloc((l + 1) * sizeof(char)); + memset(retVal->str, 0, l + 1); + sprintf(retVal->str, "%i", from->i32); + + return (Value *)retVal; +} + +Value *cast_i64_to_Bits8(Value *input) +{ + Value_Int8 *retVal = (Value_Int8 *)newValue(); + retVal->header.tag = INT8_TAG; + Value_Int64 *from = (Value_Int64 *)input; + retVal->i8 = (int8_t)from->i64; + + return (Value *)retVal; +} +Value *cast_i64_to_Bits16(Value *input) +{ + Value_Int16 *retVal = (Value_Int16 *)newValue(); + retVal->header.tag = INT16_TAG; + Value_Int64 *from = (Value_Int64 *)input; + retVal->i16 = (int16_t)from->i64; + + return (Value *)retVal; +} +Value *cast_i64_to_Bits32(Value *input) +{ + return cast_i64_to_i32(input); +} + +Value *cast_i64_to_Bits64(Value *input) +{ + return input; +} + +Value *cast_i64_to_i32(Value *input) +{ + Value_Int32 *retVal = (Value_Int32 *)newValue(); + retVal->header.tag = INT32_TAG; + Value_Int64 *from = (Value_Int64 *)input; + retVal->i32 = (int32_t)from->i64; + + return (Value *)retVal; +} + +Value *cast_i64_to_double(Value *input) +{ + Value_Double *retVal = (Value_Double *)newValue(); + retVal->header.tag = DOUBLE_TAG; + Value_Int64 *from = (Value_Int64 *)input; + retVal->d = (double)from->i64; + + return (Value *)retVal; +} + +Value *cast_i64_to_char(Value *input) +{ + Value_Char *retVal = (Value_Char *)newValue(); + retVal->header.tag = CHAR_TAG; + Value_Int64 *from = (Value_Int64 *)input; + retVal->c = (char)from->i64; + + return (Value *)retVal; +} + +Value *cast_i64_to_string(Value *input) +{ + Value_String *retVal = (Value_String *)newValue(); + retVal->header.tag = STRING_TAG; + Value_Int64 *from = (Value_Int64 *)input; + int l = snprintf(NULL, 0, "%" PRIu64 "", from->i64); + retVal->str = malloc((l + 1) * sizeof(char)); + memset(retVal->str, 0, l + 1); + sprintf(retVal->str, "%" PRIu64 "", from->i64); + + return (Value *)retVal; +} + +Value *cast_double_to_Bits8(Value *input) +{ + Value_Int8 *retVal = (Value_Int8 *)newValue(); + retVal->header.tag = INT8_TAG; + Value_Double *from = (Value_Double *)input; + retVal->i8 = (int8_t)from->d; + + return (Value *)retVal; +} +Value *cast_double_to_Bits16(Value *input) +{ + Value_Int16 *retVal = (Value_Int16 *)newValue(); + retVal->header.tag = INT16_TAG; + Value_Double *from = (Value_Double *)input; + retVal->i16 = (int16_t)from->d; + + return (Value *)retVal; +} +Value *cast_double_to_Bits32(Value *input) +{ + return cast_double_to_i32(input); +} +Value *cast_double_to_Bits64(Value *input) +{ + return cast_double_to_i64(input); +} +Value *cast_double_to_i32(Value *input) +{ + Value_Int32 *retVal = (Value_Int32 *)newValue(); + retVal->header.tag = INT32_TAG; + Value_Double *from = (Value_Double *)input; + retVal->i32 = (int32_t)from->d; + + return (Value *)retVal; +} + +Value *cast_double_to_i64(Value *input) +{ + Value_Int64 *retVal = (Value_Int64 *)newValue(); + retVal->header.tag = INT64_TAG; + Value_Double *from = (Value_Double *)input; + retVal->i64 = (int64_t)from->d; + + return (Value *)retVal; +} + +Value *cast_double_to_char(Value *input) +{ + Value_Char *retVal = (Value_Char *)newValue(); + retVal->header.tag = CHAR_TAG; + Value_Double *from = (Value_Double *)input; + retVal->c = (char)from->d; + + return (Value *)retVal; +} + +Value *cast_double_to_string(Value *input) +{ + Value_String *retVal = (Value_String *)newValue(); + retVal->header.tag = STRING_TAG; + Value_Double *from = (Value_Double *)input; + int l = snprintf(NULL, 0, "%f", from->d); + retVal->str = malloc((l + 1) * sizeof(char)); + memset(retVal->str, 0, l + 1); + sprintf(retVal->str, "%f", from->d); + + return (Value *)retVal; +} + +Value *cast_char_to_Bits8(Value *input) +{ + Value_Int8 *retVal = (Value_Int8 *)newValue(); + retVal->header.tag = INT8_TAG; + Value_Char *from = (Value_Char *)input; + retVal->i8 = (int8_t)from->c; + + return (Value *)retVal; +} +Value *cast_char_to_Bits16(Value *input) +{ + Value_Int16 *retVal = (Value_Int16 *)newValue(); + retVal->header.tag = INT16_TAG; + Value_Char *from = (Value_Char *)input; + retVal->i16 = (int16_t)from->c; + + return (Value *)retVal; +} +Value *cast_char_to_Bits32(Value *input) +{ + return cast_char_to_i32(input); +} +Value *cast_char_to_Bits64(Value *input) +{ + return cast_char_to_i64(input); +} +Value *cast_char_to_i32(Value *input) +{ + Value_Int32 *retVal = (Value_Int32 *)newValue(); + retVal->header.tag = INT32_TAG; + Value_Char *from = (Value_Char *)input; + retVal->i32 = (int32_t)from->c; + + return (Value *)retVal; +} + +Value *cast_char_to_i64(Value *input) +{ + Value_Int64 *retVal = (Value_Int64 *)newValue(); + retVal->header.tag = INT64_TAG; + Value_Char *from = (Value_Char *)input; + retVal->i64 = (int64_t)from->c; + + return (Value *)retVal; +} + +Value *cast_char_to_double(Value *input) +{ + Value_Double *retVal = (Value_Double *)newValue(); + retVal->header.tag = DOUBLE_TAG; + Value_Char *from = (Value_Char *)input; + retVal->d = (double)from->c; + + return (Value *)retVal; +} + +Value *cast_char_to_string(Value *input) +{ + Value_String *retVal = (Value_String *)newValue(); + retVal->header.tag = STRING_TAG; + Value_Char *from = (Value_Char *)input; + retVal->str = malloc(2 * sizeof(char)); + memset(retVal->str, 0, 2); + retVal->str[0] = from->c; + + return (Value *)retVal; +} + +Value *cast_string_to_Bits8(Value *input) +{ + Value_Int8 *retVal = (Value_Int8 *)newValue(); + retVal->header.tag = INT8_TAG; + Value_String *from = (Value_String *)input; + retVal->i8 = (uint8_t)atoi(from->str); + + return (Value *)retVal; +} +Value *cast_string_to_Bits16(Value *input) +{ + Value_Int16 *retVal = (Value_Int16 *)newValue(); + retVal->header.tag = INT16_TAG; + Value_String *from = (Value_String *)input; + retVal->i16 = (uint16_t)atoi(from->str); + + return (Value *)retVal; +} +Value *cast_string_to_Bits32(Value *input) +{ + return cast_string_to_i32(input); +} +Value *cast_string_to_Bits64(Value *input) +{ + return cast_string_to_i64(input); +} +Value *cast_string_to_i32(Value *input) +{ + Value_Int32 *retVal = (Value_Int32 *)newValue(); + retVal->header.tag = INT32_TAG; + Value_String *from = (Value_String *)input; + retVal->i32 = atoi(from->str); + + return (Value *)retVal; +} + +Value *cast_string_to_i64(Value *input) +{ + Value_Int64 *retVal = (Value_Int64 *)newValue(); + retVal->header.tag = INT64_TAG; + Value_String *from = (Value_String *)input; + retVal->i64 = atoi(from->str); + + return (Value *)retVal; +} + +Value *cast_string_to_double(Value *input) +{ + Value_Double *retVal = (Value_Double *)newValue(); + retVal->header.tag = DOUBLE_TAG; + Value_String *from = (Value_String *)input; + retVal->d = atof(from->str); + + return (Value *)retVal; +} + +Value *cast_string_to_char(Value *input) +{ + Value_Char *retVal = (Value_Char *)newValue(); + retVal->header.tag = CHAR_TAG; + Value_String *from = (Value_String *)input; + retVal->c = from->str[0]; + + return (Value *)retVal; +} + +// Bits cast +// autogenerated using Ruby + +/* conversions from Bits8 */ +Value *cast_Bits8_to_Bits16(Value *input) +{ + Value_Int16 *retVal = (Value_Int16 *)newValue(); + retVal->header.tag = INT16_TAG; + Value_Int8 *from = (Value_Int8 *)input; + retVal->i16 = (int16_t)from->i8; + + return (Value *)retVal; +} +Value *cast_Bits8_to_Bits32(Value *input) +{ + Value_Int32 *retVal = (Value_Int32 *)newValue(); + retVal->header.tag = INT32_TAG; + Value_Int8 *from = (Value_Int8 *)input; + retVal->i32 = (int32_t)from->i8; + + return (Value *)retVal; +} +Value *cast_Bits8_to_Bits64(Value *input) +{ + Value_Int64 *retVal = (Value_Int64 *)newValue(); + retVal->header.tag = INT64_TAG; + Value_Int8 *from = (Value_Int8 *)input; + retVal->i64 = (int64_t)from->i8; + + return (Value *)retVal; +} +Value *cast_Bits8_to_i32(Value *input) +{ + Value_Int32 *retVal = (Value_Int32 *)newValue(); + retVal->header.tag = INT32_TAG; + Value_Int8 *from = (Value_Int8 *)input; + retVal->i32 = (int32_t)from->i8; + + return (Value *)retVal; +} +Value *cast_Bits8_to_i64(Value *input) +{ + Value_Int64 *retVal = (Value_Int64 *)newValue(); + retVal->header.tag = INT64_TAG; + Value_Int8 *from = (Value_Int8 *)input; + retVal->i64 = (int64_t)from->i8; + + return (Value *)retVal; +} +Value *cast_Bits8_to_double(Value *input) +{ + Value_Double *retVal = (Value_Double *)newValue(); + retVal->header.tag = DOUBLE_TAG; + Value_Int8 *from = (Value_Int8 *)input; + retVal->d = (double)from->i8; + + return (Value *)retVal; +} + +Value *cast_Bits8_to_char(Value *input) +{ + Value_Char *retVal = (Value_Char *)newValue(); + retVal->header.tag = CHAR_TAG; + Value_Int8 *from = (Value_Int8 *)input; + retVal->c = (char)from->i8; + + return (Value *)retVal; +} +Value *cast_Bits8_to_string(Value *input) +{ + Value_String *retVal = (Value_String *)newValue(); + retVal->header.tag = STRING_TAG; + Value_Int8 *from = (Value_Int8 *)input; + int l = snprintf(NULL, 0, "%" PRIu8 "", from->i8); + retVal->str = malloc((l + 1) * sizeof(char)); + memset(retVal->str, 0, l + 1); + sprintf(retVal->str, "%" PRIu8 "", from->i8); + + return (Value *)retVal; +} + +/* conversions from Bits16 */ +Value *cast_Bits16_to_Bits8(Value *input) +{ + Value_Int8 *retVal = (Value_Int8 *)newValue(); + retVal->header.tag = INT8_TAG; + Value_Int16 *from = (Value_Int16 *)input; + retVal->i8 = (int8_t)from->i16; + + return (Value *)retVal; +} +Value *cast_Bits16_to_Bits32(Value *input) +{ + Value_Int32 *retVal = (Value_Int32 *)newValue(); + retVal->header.tag = INT32_TAG; + Value_Int16 *from = (Value_Int16 *)input; + retVal->i32 = (int32_t)from->i16; + + return (Value *)retVal; +} +Value *cast_Bits16_to_Bits64(Value *input) +{ + Value_Int64 *retVal = (Value_Int64 *)newValue(); + retVal->header.tag = INT64_TAG; + Value_Int16 *from = (Value_Int16 *)input; + retVal->i64 = (int64_t)from->i16; + + return (Value *)retVal; +} +Value *cast_Bits16_to_i32(Value *input) +{ + Value_Int32 *retVal = (Value_Int32 *)newValue(); + retVal->header.tag = INT32_TAG; + Value_Int16 *from = (Value_Int16 *)input; + retVal->i32 = (int32_t)from->i16; + + return (Value *)retVal; +} +Value *cast_Bits16_to_i64(Value *input) +{ + Value_Int64 *retVal = (Value_Int64 *)newValue(); + retVal->header.tag = INT64_TAG; + Value_Int16 *from = (Value_Int16 *)input; + retVal->i64 = (int64_t)from->i16; + + return (Value *)retVal; +} +Value *cast_Bits16_to_double(Value *input) +{ + Value_Double *retVal = (Value_Double *)newValue(); + retVal->header.tag = DOUBLE_TAG; + Value_Int16 *from = (Value_Int16 *)input; + retVal->d = (double)from->i16; + + return (Value *)retVal; +} + +Value *cast_Bits16_to_char(Value *input) +{ + Value_Char *retVal = (Value_Char *)newValue(); + retVal->header.tag = CHAR_TAG; + Value_Int16 *from = (Value_Int16 *)input; + retVal->c = (char)from->i16; + + return (Value *)retVal; +} +Value *cast_Bits16_to_string(Value *input) +{ + Value_String *retVal = (Value_String *)newValue(); + retVal->header.tag = STRING_TAG; + Value_Int16 *from = (Value_Int16 *)input; + int l = snprintf(NULL, 0, "%" PRIu16 "", from->i16); + retVal->str = malloc((l + 1) * sizeof(char)); + memset(retVal->str, 0, l + 1); + sprintf(retVal->str, "%" PRIu16 "", from->i16); + + return (Value *)retVal; +} + +/* conversions from Bits32 */ +Value *cast_Bits32_to_Bits8(Value *input) +{ + Value_Int8 *retVal = (Value_Int8 *)newValue(); + retVal->header.tag = INT8_TAG; + Value_Int32 *from = (Value_Int32 *)input; + retVal->i8 = (int8_t)from->i32; + + return (Value *)retVal; +} +Value *cast_Bits32_to_Bits16(Value *input) +{ + Value_Int16 *retVal = (Value_Int16 *)newValue(); + retVal->header.tag = INT16_TAG; + Value_Int32 *from = (Value_Int32 *)input; + retVal->i16 = (int16_t)from->i32; + + return (Value *)retVal; +} +Value *cast_Bits32_to_Bits64(Value *input) +{ + Value_Int64 *retVal = (Value_Int64 *)newValue(); + retVal->header.tag = INT64_TAG; + Value_Int32 *from = (Value_Int32 *)input; + retVal->i64 = (int64_t)from->i32; + + return (Value *)retVal; +} +Value *cast_Bits32_to_i32(Value *input) +{ + return input; +} +Value *cast_Bits32_to_i64(Value *input) +{ + Value_Int64 *retVal = (Value_Int64 *)newValue(); + retVal->header.tag = INT64_TAG; + Value_Int32 *from = (Value_Int32 *)input; + retVal->i64 = (int64_t)from->i32; + + return (Value *)retVal; +} +Value *cast_Bits32_to_double(Value *input) +{ + Value_Double *retVal = (Value_Double *)newValue(); + retVal->header.tag = DOUBLE_TAG; + Value_Int32 *from = (Value_Int32 *)input; + retVal->d = (double)from->i32; + + return (Value *)retVal; +} + +Value *cast_Bits32_to_char(Value *input) +{ + Value_Char *retVal = (Value_Char *)newValue(); + retVal->header.tag = CHAR_TAG; + Value_Int32 *from = (Value_Int32 *)input; + retVal->c = (char)from->i32; + + return (Value *)retVal; +} +Value *cast_Bits32_to_string(Value *input) +{ + Value_String *retVal = (Value_String *)newValue(); + retVal->header.tag = STRING_TAG; + Value_Int32 *from = (Value_Int32 *)input; + int l = snprintf(NULL, 0, "%" PRIu32 "", (uint32_t)from->i32); + retVal->str = malloc((l + 1) * sizeof(char)); + memset(retVal->str, 0, l + 1); + sprintf(retVal->str, "%" PRIu32 "", (uint32_t)from->i32); + + return (Value *)retVal; +} + +/* conversions from Bits64 */ +Value *cast_Bits64_to_Bits8(Value *input) +{ + Value_Int8 *retVal = (Value_Int8 *)newValue(); + retVal->header.tag = INT8_TAG; + Value_Int64 *from = (Value_Int64 *)input; + retVal->i8 = (int8_t)from->i64; + + return (Value *)retVal; +} +Value *cast_Bits64_to_Bits16(Value *input) +{ + Value_Int16 *retVal = (Value_Int16 *)newValue(); + retVal->header.tag = INT16_TAG; + Value_Int64 *from = (Value_Int64 *)input; + retVal->i16 = (int16_t)from->i64; + + return (Value *)retVal; +} +Value *cast_Bits64_to_Bits32(Value *input) +{ + Value_Int32 *retVal = (Value_Int32 *)newValue(); + retVal->header.tag = INT32_TAG; + Value_Int64 *from = (Value_Int64 *)input; + retVal->i32 = (int32_t)from->i64; + + return (Value *)retVal; +} +Value *cast_Bits64_to_i32(Value *input) +{ + Value_Int32 *retVal = (Value_Int32 *)newValue(); + retVal->header.tag = INT32_TAG; + Value_Int64 *from = (Value_Int64 *)input; + retVal->i32 = (int32_t)from->i64; + + return (Value *)retVal; +} +Value *cast_Bits64_to_i64(Value *input) +{ + return input; +} +Value *cast_Bits64_to_double(Value *input) +{ + Value_Double *retVal = (Value_Double *)newValue(); + retVal->header.tag = DOUBLE_TAG; + Value_Int64 *from = (Value_Int64 *)input; + retVal->d = (double)from->i64; + + return (Value *)retVal; +} + +Value *cast_Bits64_to_char(Value *input) +{ + Value_Char *retVal = (Value_Char *)newValue(); + retVal->header.tag = CHAR_TAG; + Value_Int64 *from = (Value_Int64 *)input; + retVal->c = (char)from->i64; + + return (Value *)retVal; +} +Value *cast_Bits64_to_string(Value *input) +{ + return cast_i64_to_string(input); +} diff --git a/support/refc/casts.h b/support/refc/casts.h new file mode 100644 index 000000000..78bb0c994 --- /dev/null +++ b/support/refc/casts.h @@ -0,0 +1,85 @@ +#ifndef __CASTS_H__ +#define __CASTS_H__ + +#include "cBackend.h" +#include + +Value *cast_i32_to_Bits8(Value *); +Value *cast_i32_to_Bits16(Value *); +Value *cast_i32_to_Bits32(Value *); +Value *cast_i32_to_Bits64(Value *); +Value *cast_i32_to_i64(Value *); +Value *cast_i32_to_double(Value *); +Value *cast_i32_to_char(Value *); +Value *cast_i32_to_string(Value *); + +Value *cast_i64_to_Bits8(Value *); +Value *cast_i64_to_Bits16(Value *); +Value *cast_i64_to_Bits32(Value *); +Value *cast_i64_to_Bits64(Value *); +Value *cast_i64_to_i32(Value *); +Value *cast_i64_to_double(Value *); +Value *cast_i64_to_char(Value *); +Value *cast_i64_to_string(Value *); + +Value *cast_double_to_Bits8(Value *); +Value *cast_double_to_Bits16(Value *); +Value *cast_double_to_Bits32(Value *); +Value *cast_double_to_Bits64(Value *); +Value *cast_double_to_i32(Value *); +Value *cast_double_to_i64(Value *); +Value *cast_double_to_char(Value *); +Value *cast_double_to_string(Value *); + +Value *cast_char_to_Bits8(Value *); +Value *cast_char_to_Bits16(Value *); +Value *cast_char_to_Bits32(Value *); +Value *cast_char_to_Bits64(Value *); +Value *cast_char_to_i32(Value *); +Value *cast_char_to_i64(Value *); +Value *cast_char_to_double(Value *); +Value *cast_char_to_string(Value *); + +Value *cast_string_to_Bits8(Value *); +Value *cast_string_to_Bits16(Value *); +Value *cast_string_to_Bits32(Value *); +Value *cast_string_to_Bits64(Value *); +Value *cast_string_to_i32(Value *); +Value *cast_string_to_i64(Value *); +Value *cast_string_to_double(Value *); +Value *cast_string_to_char(Value *); + +Value *cast_Bits8_to_Bits16(Value *input); +Value *cast_Bits8_to_Bits32(Value *input); +Value *cast_Bits8_to_Bits64(Value *input); +Value *cast_Bits8_to_i32(Value *input); +Value *cast_Bits8_to_i64(Value *input); +Value *cast_Bits8_to_double(Value *input); +Value *cast_Bits8_to_char(Value *input); +Value *cast_Bits8_to_string(Value *input); +Value *cast_Bits16_to_Bits8(Value *input); +Value *cast_Bits16_to_Bits32(Value *input); +Value *cast_Bits16_to_Bits64(Value *input); +Value *cast_Bits16_to_i32(Value *input); +Value *cast_Bits16_to_i64(Value *input); +Value *cast_Bits16_to_double(Value *input); +Value *cast_Bits16_to_char(Value *input); +Value *cast_Bits16_to_string(Value *input); +Value *cast_Bits32_to_Bits8(Value *input); +Value *cast_Bits32_to_Bits16(Value *input); +Value *cast_Bits32_to_Bits64(Value *input); +Value *cast_Bits32_to_i32(Value *input); +Value *cast_Bits32_to_i64(Value *input); +Value *cast_Bits32_to_double(Value *input); +Value *cast_Bits32_to_char(Value *input); +Value *cast_Bits32_to_string(Value *input); +Value *cast_Bits64_to_Bits8(Value *input); +Value *cast_Bits64_to_Bits16(Value *input); +Value *cast_Bits64_to_Bits32(Value *input); +Value *cast_Bits64_to_i32(Value *input); +Value *cast_Bits64_to_i64(Value *input); +Value *cast_Bits64_to_double(Value *input); +Value *cast_Bits64_to_char(Value *input); +Value *cast_Bits64_to_string(Value *input); + +#endif diff --git a/support/refc/conCaseHelper.c b/support/refc/conCaseHelper.c new file mode 100644 index 000000000..51714cfb1 --- /dev/null +++ b/support/refc/conCaseHelper.c @@ -0,0 +1,75 @@ +#include "conCaseHelper.h" + +AConAlt *newConstructorField(int nr) +{ + AConAlt *retVal = (AConAlt *)malloc(nr * sizeof(AConAlt)); + for (int i = 0; i < nr; i++) + { + retVal[i].tag = -1; + } + return retVal; +} + +void freeConstructorField(AConAlt *cf) +{ + free(cf); +} + +void constructorFieldFNextEntry(AConAlt *field, char *name, int tag) +{ + AConAlt *nextEntry = field; + while (nextEntry->tag == -1) + { + nextEntry++; + } + nextEntry->name = name; + nextEntry->tag = tag; +} + +int compareConstructors(Value *sc, AConAlt *field, int nr) +{ + Value_Constructor *constr = (Value_Constructor *)sc; + for (int i = 0; i < nr; i++) + { + if (field->name) //decide my name + { + if (!strcmp(field->name, constr->name)) + { + return i; + } + } + else // decide by tag + { + if (field->tag == constr->tag) + { + return i; + } + } + field++; + } + return -1; +} + +int multiStringCompare(Value *sc, int nrDecicionOptions, char **options) +{ + for (int i = 0; i < nrDecicionOptions; i++) + { + if (!strcmp(((Value_String *)sc)->str, options[i])) + { + return i; + } + } + return -1; +} + +int multiDoubleCompare(Value *sc, int nrDecicionOptions, double *options) +{ + for (int i = 0; i < nrDecicionOptions; i++) + { + if (((Value_Double *)sc)->d == options[i]) + { + return i; + } + } + return -1; +} diff --git a/support/refc/conCaseHelper.h b/support/refc/conCaseHelper.h new file mode 100644 index 000000000..d3faf0403 --- /dev/null +++ b/support/refc/conCaseHelper.h @@ -0,0 +1,20 @@ +#ifndef __CON_CASE_HELPER_H__ +#define __CON_CASE_HELPER_H__ + +#include "cBackend.h" + +typedef struct +{ + char *name; + int tag; +} AConAlt; + +AConAlt *newConstructorField(int); +int compareConstructors(Value *, AConAlt *, int); +void constructorFieldFNextEntry(AConAlt *, char *, int); +void freeConstructorField(AConAlt *); + +int multiStringCompare(Value *, int, char **); +int multiDoubleCompare(Value *, int, double *); + +#endif diff --git a/support/refc/datatypes.h b/support/refc/datatypes.h new file mode 100644 index 000000000..715e17da0 --- /dev/null +++ b/support/refc/datatypes.h @@ -0,0 +1,172 @@ +#ifndef __DATATYPES_H__ +#define __DATATYPES_H__ +#include +#include +#include +#include +#include + +#define NO_TAG 0 +#define INT8_TAG 1 +#define INT16_TAG 2 +#define INT32_TAG 3 +#define INT64_TAG 4 +#define DOUBLE_TAG 5 +#define CHAR_TAG 6 +#define STRING_TAG 7 + +#define CLOSURE_TAG 10 +#define ARGLIST_TAG 11 +#define CONSTRUCTOR_TAG 12 + +#define IOREF_TAG 20 +#define ARRAY_TAG 21 +#define POINTER_TAG 22 +#define GC_POINTER_TAG 23 +#define BUFFER_TAG 24 + +#define MUTEX_TAG 30 +#define CONDITION_TAG 31 + +#define COMPLETE_CLOSURE_TAG 98 // for trampoline tail recursion handling +#define WORLD_TAG 99 + +typedef struct +{ + int refCounter; + int tag; +} Value_header; + +typedef struct +{ + Value_header header; + char payload[25]; +} Value; + +typedef struct +{ + Value_header header; + uint8_t i8; +} Value_Int8; + +typedef struct +{ + Value_header header; + uint16_t i16; +} Value_Int16; + +typedef struct +{ + Value_header header; + int32_t i32; +} Value_Int32; + +typedef struct +{ + Value_header header; + int64_t i64; +} Value_Int64; + +typedef struct +{ + Value_header header; + double d; +} Value_Double; + +typedef struct +{ + Value_header header; + char c; +} Value_Char; + +typedef struct +{ + Value_header header; + char *str; +} Value_String; + +typedef struct +{ + Value_header header; + int32_t total; + int32_t tag; + char *name; + Value **args; +} Value_Constructor; + +typedef struct +{ + Value_header header; + int32_t total; + int32_t filled; + Value **args; +} Value_Arglist; + +typedef Value *(*fun_ptr_t)(Value_Arglist *); + +typedef struct +{ + Value_header header; + fun_ptr_t f; + Value_Arglist *arglist; +} Value_Closure; + +typedef struct +{ + Value_header header; + int32_t index; +} Value_IORef; + +typedef struct +{ + Value_header header; + void *p; +} Value_Pointer; + +typedef struct +{ + Value_header header; + Value_Pointer *p; + Value_Closure *onCollectFct; +} Value_GCPointer; + +typedef struct +{ + Value_header header; + int capacity; + Value **arr; +} Value_Array; + +typedef struct +{ + Value_header header; + size_t len; + char *buffer; +} Value_Buffer; + +typedef struct +{ + Value_header header; + pthread_mutex_t *mutex; +} Value_Mutex; + +typedef struct +{ + Value_header header; + pthread_cond_t *cond; +} Value_Condition; + +typedef struct +{ + Value **refs; + int filled; + int total; +} IORef_Storage; + +typedef struct +{ + Value_header header; + IORef_Storage *listIORefs; +} Value_World; + +#endif diff --git a/support/refc/mathFunctions.c b/support/refc/mathFunctions.c new file mode 100644 index 000000000..48c46b6c8 --- /dev/null +++ b/support/refc/mathFunctions.c @@ -0,0 +1,370 @@ +#include "mathFunctions.h" +#include "runtime.h" +#include "memoryManagement.h" + +double unpackDouble(Value *d) +{ + return ((Value_Double *)d)->d; +} + +Value *believe_me(Value *a, Value *b, Value *c) +{ + return c; +} + +/* add */ +Value *add_i32(Value *x, Value *y) +{ + return (Value *)makeInt32(((Value_Int32 *)x)->i32 + ((Value_Int32 *)y)->i32); +} +Value *add_i64(Value *x, Value *y) +{ + return (Value *)makeInt64(((Value_Int64 *)x)->i64 + ((Value_Int64 *)y)->i64); +} +Value *add_double(Value *x, Value *y) +{ + return (Value *)makeDouble(((Value_Double *)x)->d + ((Value_Double *)y)->d); +} + +/* sub */ +Value *sub_i32(Value *x, Value *y) +{ + return (Value *)makeInt32(((Value_Int32 *)x)->i32 - ((Value_Int32 *)y)->i32); +} +Value *sub_i64(Value *x, Value *y) +{ + return (Value *)makeInt64(((Value_Int64 *)x)->i64 - ((Value_Int64 *)y)->i64); +} +Value *sub_double(Value *x, Value *y) +{ + return (Value *)makeDouble(((Value_Double *)x)->d - ((Value_Double *)y)->d); +} + +/* mul */ +Value *mul_i32(Value *x, Value *y) +{ + return (Value *)makeInt32(((Value_Int32 *)x)->i32 * ((Value_Int32 *)y)->i32); +} +Value *mul_i64(Value *x, Value *y) +{ + return (Value *)makeInt64(((Value_Int64 *)x)->i64 * ((Value_Int64 *)y)->i64); +} +Value *mul_double(Value *x, Value *y) +{ + return (Value *)makeDouble(((Value_Double *)x)->d * ((Value_Double *)y)->d); +} + +/* div */ +Value *div_i32(Value *x, Value *y) +{ + return (Value *)makeInt32(((Value_Int32 *)x)->i32 / ((Value_Int32 *)y)->i32); +} +Value *div_i64(Value *x, Value *y) +{ + return (Value *)makeInt64(((Value_Int64 *)x)->i64 / ((Value_Int64 *)y)->i64); +} +Value *div_double(Value *x, Value *y) +{ + return (Value *)makeDouble(((Value_Double *)x)->d / ((Value_Double *)y)->d); +} + +/* mod */ +Value *mod_i32(Value *x, Value *y) +{ + return (Value *)makeInt32(((Value_Int32 *)x)->i32 % ((Value_Int32 *)y)->i32); +} +Value *mod_i64(Value *x, Value *y) +{ + return (Value *)makeInt64(((Value_Int64 *)x)->i64 % ((Value_Int64 *)y)->i64); +} + +/* shiftl */ +Value *shiftl_i32(Value *x, Value *y) +{ + return (Value *)makeInt32(((Value_Int32 *)x)->i32 << ((Value_Int32 *)y)->i32); +} +Value *shiftl_i64(Value *x, Value *y) +{ + return (Value *)makeInt64(((Value_Int64 *)x)->i64 << ((Value_Int64 *)y)->i64); +} + +/* shiftr */ +Value *shiftr_i32(Value *x, Value *y) +{ + return (Value *)makeInt32(((Value_Int32 *)x)->i32 >> ((Value_Int32 *)y)->i32); +} +Value *shiftr_i64(Value *x, Value *y) +{ + return (Value *)makeInt64(((Value_Int64 *)x)->i64 >> ((Value_Int64 *)y)->i64); +} + +/* and */ +Value *and_i32(Value *x, Value *y) +{ + return (Value *)makeInt32(((Value_Int32 *)x)->i32 & ((Value_Int32 *)y)->i32); +} +Value *and_i64(Value *x, Value *y) +{ + return (Value *)makeInt64(((Value_Int64 *)x)->i64 & ((Value_Int64 *)y)->i64); +} + +/* or */ +Value *or_i32(Value *x, Value *y) +{ + return (Value *)makeInt32(((Value_Int32 *)x)->i32 | ((Value_Int32 *)y)->i32); +} +Value *or_i64(Value *x, Value *y) +{ + return (Value *)makeInt64(((Value_Int64 *)x)->i64 | ((Value_Int64 *)y)->i64); +} + +/* xor */ +Value *xor_i32(Value *x, Value *y) +{ + return (Value *)makeInt32(((Value_Int32 *)x)->i32 ^ ((Value_Int32 *)y)->i32); +} +Value *xor_i64(Value *x, Value *y) +{ + return (Value *)makeInt64(((Value_Int64 *)x)->i64 ^ ((Value_Int64 *)y)->i64); +} + +/* lt */ +Value *lt_i32(Value *x, Value *y) +{ + if (((Value_Int32 *)x)->i32 < ((Value_Int32 *)y)->i32) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} +Value *lt_i64(Value *x, Value *y) +{ + if (((Value_Int64 *)x)->i64 < ((Value_Int64 *)y)->i64) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} +Value *lt_double(Value *x, Value *y) +{ + if (((Value_Double *)x)->d < ((Value_Double *)y)->d) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} +Value *lt_char(Value *x, Value *y) +{ + if (((Value_Char *)x)->c < ((Value_Char *)y)->c) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} + +/* gt */ +Value *gt_i32(Value *x, Value *y) +{ + if (((Value_Int32 *)x)->i32 > ((Value_Int32 *)y)->i32) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} +Value *gt_i64(Value *x, Value *y) +{ + if (((Value_Int64 *)x)->i64 > ((Value_Int64 *)y)->i64) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} +Value *gt_double(Value *x, Value *y) +{ + if (((Value_Double *)x)->d > ((Value_Double *)y)->d) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} +Value *gt_char(Value *x, Value *y) +{ + if (((Value_Char *)x)->c > ((Value_Char *)y)->c) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} + +/* eq */ +Value *eq_i32(Value *x, Value *y) +{ + if (((Value_Int32 *)x)->i32 == ((Value_Int32 *)y)->i32) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} +Value *eq_i64(Value *x, Value *y) +{ + if (((Value_Int64 *)x)->i64 == ((Value_Int64 *)y)->i64) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} +Value *eq_double(Value *x, Value *y) +{ + if (((Value_Double *)x)->d == ((Value_Double *)y)->d) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} +Value *eq_char(Value *x, Value *y) +{ + if (((Value_Char *)x)->c == ((Value_Char *)y)->c) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} +Value *eq_string(Value *x, Value *y) +{ + if (!strcmp(((Value_String *)x)->str, ((Value_String *)y)->str)) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} + +/* lte */ +Value *lte_i32(Value *x, Value *y) +{ + if (((Value_Int32 *)x)->i32 <= ((Value_Int32 *)y)->i32) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} +Value *lte_i64(Value *x, Value *y) +{ + if (((Value_Int64 *)x)->i64 <= ((Value_Int64 *)y)->i64) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} +Value *lte_double(Value *x, Value *y) +{ + if (((Value_Double *)x)->d <= ((Value_Double *)y)->d) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} +Value *lte_char(Value *x, Value *y) +{ + if (((Value_Char *)x)->c <= ((Value_Char *)y)->c) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} + +/* gte */ +Value *gte_i32(Value *x, Value *y) +{ + if (((Value_Int32 *)x)->i32 >= ((Value_Int32 *)y)->i32) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} +Value *gte_i64(Value *x, Value *y) +{ + if (((Value_Int64 *)x)->i64 >= ((Value_Int64 *)y)->i64) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} +Value *gte_double(Value *x, Value *y) +{ + if (((Value_Double *)x)->d >= ((Value_Double *)y)->d) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} +Value *gte_char(Value *x, Value *y) +{ + if (((Value_Char *)x)->c >= ((Value_Char *)y)->c) + { + return (Value *)makeInt32(1); + } + else + { + return (Value *)makeInt32(0); + } +} diff --git a/support/refc/mathFunctions.h b/support/refc/mathFunctions.h new file mode 100644 index 000000000..bdd09cf63 --- /dev/null +++ b/support/refc/mathFunctions.h @@ -0,0 +1,84 @@ +#ifndef __MATH_FUNCTIONS_H__ +#define __MATH_FUNCTIONS_H__ +#include "cBackend.h" +#include + +double unpackDouble(Value *d); +Value *believe_me(Value *, Value *, Value *); + +/* add */ +Value *add_i32(Value *x, Value *y); +Value *add_i64(Value *x, Value *y); +Value *add_double(Value *x, Value *y); + +/* sub */ +Value *sub_i32(Value *x, Value *y); +Value *sub_i64(Value *x, Value *y); +Value *sub_double(Value *x, Value *y); + +/* mul */ +Value *mul_i32(Value *x, Value *y); +Value *mul_i64(Value *x, Value *y); +Value *mul_double(Value *x, Value *y); + +/* div */ +Value *div_i32(Value *x, Value *y); +Value *div_i64(Value *x, Value *y); +Value *div_double(Value *x, Value *y); + +/* mod */ +Value *mod_i32(Value *x, Value *y); +Value *mod_i64(Value *x, Value *y); + +/* shiftl */ +Value *shiftl_i32(Value *x, Value *y); +Value *shiftl_i64(Value *x, Value *y); + +/* shiftr */ +Value *shiftr_i32(Value *x, Value *y); +Value *shiftr_i64(Value *x, Value *y); + +/* and */ +Value *and_i32(Value *x, Value *y); +Value *and_i64(Value *x, Value *y); + +/* or */ +Value *or_i32(Value *x, Value *y); +Value *or_i64(Value *x, Value *y); + +/* xor */ +Value *xor_i32(Value *x, Value *y); +Value *xor_i64(Value *x, Value *y); + +/* lt */ +Value *lt_i32(Value *x, Value *y); +Value *lt_i64(Value *x, Value *y); +Value *lt_double(Value *x, Value *y); +Value *lt_char(Value *x, Value *y); + +/* gt */ +Value *gt_i32(Value *x, Value *y); +Value *gt_i64(Value *x, Value *y); +Value *gt_double(Value *x, Value *y); +Value *gt_char(Value *x, Value *y); + +/* eq */ +Value *eq_i32(Value *x, Value *y); +Value *eq_i64(Value *x, Value *y); +Value *eq_double(Value *x, Value *y); +Value *eq_char(Value *x, Value *y); +Value *eq_string(Value *x, Value *y); + +/* lte */ +Value *lte_i32(Value *x, Value *y); +Value *lte_i64(Value *x, Value *y); +Value *lte_double(Value *x, Value *y); +Value *lte_char(Value *x, Value *y); + +/* gte */ +Value *gte_i32(Value *x, Value *y); +Value *gte_i64(Value *x, Value *y); +Value *gte_double(Value *x, Value *y); +Value *gte_char(Value *x, Value *y); + +#endif diff --git a/support/refc/memoryManagement.c b/support/refc/memoryManagement.c new file mode 100644 index 000000000..275c394e7 --- /dev/null +++ b/support/refc/memoryManagement.c @@ -0,0 +1,268 @@ +#include "runtime.h" + +Value *newValue() +{ + Value *retVal = (Value *)malloc(sizeof(Value)); + retVal->header.refCounter = 1; + retVal->header.tag = NO_TAG; + return retVal; +} + +Value_Arglist *newArglist(int missing, int total) +{ + Value_Arglist *retVal = (Value_Arglist *)newValue(); + retVal->header.tag = ARGLIST_TAG; + retVal->total = total; + retVal->filled = total - missing; + retVal->args = (Value **)malloc(sizeof(Value *) * total); + memset(retVal->args, 0, sizeof(Value *) * total); + return retVal; +} + +Value_Constructor *newConstructor(int total, int tag, const char *name) +{ + Value_Constructor *retVal = (Value_Constructor *)newValue(); + retVal->header.tag = CONSTRUCTOR_TAG; + retVal->total = total; + retVal->tag = tag; + int nameLength = strlen(name); + retVal->name = malloc(nameLength + 1); + memset(retVal->name, 0, nameLength + 1); + memcpy(retVal->name, name, nameLength); + retVal->args = (Value **)malloc(sizeof(Value *) * total); + return retVal; +} + +Value_Closure *makeClosureFromArglist(fun_ptr_t f, Value_Arglist *arglist) +{ + Value_Closure *retVal = (Value_Closure *)newValue(); + retVal->header.tag = CLOSURE_TAG; + retVal->arglist = arglist; // (Value_Arglist *)newReference((Value*)arglist); + retVal->f = f; + if (retVal->arglist->filled >= retVal->arglist->total) + { + retVal->header.tag = COMPLETE_CLOSURE_TAG; + } + return retVal; +} + +Value_Double *makeDouble(double d) +{ + Value_Double *retVal = (Value_Double *)newValue(); + retVal->header.tag = DOUBLE_TAG; + retVal->d = d; + return retVal; +} + +Value_Char *makeChar(char c) +{ + Value_Char *retVal = (Value_Char *)newValue(); + retVal->header.tag = CHAR_TAG; + retVal->c = c; + return retVal; +} + +Value_Int8 *makeInt8(int8_t i) +{ + Value_Int8 *retVal = (Value_Int8 *)newValue(); + retVal->header.tag = INT8_TAG; + retVal->i8 = i; + return retVal; +} + +Value_Int16 *makeInt16(int16_t i) +{ + Value_Int16 *retVal = (Value_Int16 *)newValue(); + retVal->header.tag = INT16_TAG; + retVal->i16 = i; + return retVal; +} + +Value_Int32 *makeInt32(int32_t i) +{ + Value_Int32 *retVal = (Value_Int32 *)newValue(); + retVal->header.tag = INT32_TAG; + retVal->i32 = i; + return retVal; +} + +Value_Int64 *makeInt64(int64_t i) +{ + Value_Int64 *retVal = (Value_Int64 *)newValue(); + retVal->header.tag = INT64_TAG; + retVal->i64 = i; + return retVal; +} + +Value_String *makeEmptyString(size_t l) +{ + Value_String *retVal = (Value_String *)newValue(); + retVal->header.tag = STRING_TAG; + retVal->str = malloc(l); + memset(retVal->str, 0, l); + return retVal; +} + +Value_String *makeString(char *s) +{ + Value_String *retVal = (Value_String *)newValue(); + int l = strlen(s); + retVal->header.tag = STRING_TAG; + retVal->str = malloc(l + 1); + memset(retVal->str, 0, l + 1); + memcpy(retVal->str, s, l); + return retVal; +} + +Value_Pointer *makePointer(void *ptr_Raw) +{ + Value_Pointer *p = (Value_Pointer *)newValue(); + p->header.tag = POINTER_TAG; + p->p = ptr_Raw; + return p; +} + +Value_Array *makeArray(int length) +{ + Value_Array *a = (Value_Array *)newValue(); + a->header.tag = ARRAY_TAG; + a->capacity = length; + a->arr = (Value **)malloc(sizeof(Value *) * length); + memset(a->arr, 0, sizeof(Value *) * length); + return a; +} + +Value_World *makeWorld() +{ + Value_World *retVal = (Value_World *)newValue(); + retVal->header.tag = WORLD_TAG; + retVal->listIORefs = NULL; + return retVal; +} + +Value *newReference(Value *source) +{ + // note that we explicitly allow NULL as source (for erased arguments) + if (source) + { + source->header.refCounter++; + } + return source; +} + +void removeReference(Value *elem) +{ + if (!elem) + { + return; + } + // remove reference counter + elem->header.refCounter--; + if (elem->header.refCounter == 0) + // recursively remove all references to all children + { + switch (elem->header.tag) + { + case INT32_TAG: + /* nothing to delete, added for sake of completeness */ + break; + case INT64_TAG: + /* nothing to delete, added for sake of completeness */ + break; + case DOUBLE_TAG: + /* nothing to delete, added for sake of completeness */ + break; + case CHAR_TAG: + /* nothing to delete, added for sake of completeness */ + break; + case STRING_TAG: + free(((Value_String *)elem)->str); + break; + + case CLOSURE_TAG: + { + Value_Closure *cl = (Value_Closure *)elem; + Value_Arglist *al = cl->arglist; + removeReference((Value *)al); + break; + } + case COMPLETE_CLOSURE_TAG: + { + Value_Closure *cl = (Value_Closure *)elem; + Value_Arglist *al = cl->arglist; + removeReference((Value *)al); + break; + } + case ARGLIST_TAG: + { + Value_Arglist *al = (Value_Arglist *)elem; + for (int i = 0; i < al->filled; i++) + { + removeReference(al->args[i]); + } + free(al->args); + break; + } + case CONSTRUCTOR_TAG: + { + Value_Constructor *constr = (Value_Constructor *)elem; + for (int i = 0; i < constr->total; i++) + { + removeReference(constr->args[i]); + } + if (constr->name) + { + free(constr->name); + } + free(constr->args); + break; + } + case IOREF_TAG: + /* nothing to delete, added for sake of completeness */ + break; + + case ARRAY_TAG: + { + Value_Array *a = (Value_Array *)elem; + for (int i = 0; i < a->capacity; i++) + { + removeReference(a->arr[i]); + } + free(a->arr); + break; + } + case POINTER_TAG: + /* nothing to delete, added for sake of completeness */ + break; + + case GC_POINTER_TAG: + { + /* maybe here we need to invoke onCollectAny */ + Value_GCPointer *vPtr = (Value_GCPointer *)elem; + Value *closure1 = apply_closure((Value *)vPtr->onCollectFct, (Value *)vPtr->p); + apply_closure(closure1, NULL); + removeReference(closure1); + removeReference((Value *)vPtr->onCollectFct); + removeReference((Value *)vPtr->p); + break; + } + case WORLD_TAG: + { + Value_World *w = (Value_World *)elem; + if (w->listIORefs) + { + for (int i = 0; i < w->listIORefs->filled; i++) + { + removeReference(w->listIORefs->refs[i]); + } + free(w->listIORefs->refs); + free(w->listIORefs); + } + } + default: + break; + } + // finally, free element + free(elem); + } +} diff --git a/support/refc/memoryManagement.h b/support/refc/memoryManagement.h new file mode 100644 index 000000000..23a307123 --- /dev/null +++ b/support/refc/memoryManagement.h @@ -0,0 +1,28 @@ +#ifndef __MEMORY_MANAGEMENT_H__ +#define __MEMORY_MANAGEMENT_H__ +#include "cBackend.h" + +Value *newValue(void); +Value *newReference(Value *source); +void removeReference(Value *source); + +Value_Arglist *newArglist(int missing, int total); +Value_Constructor *newConstructor(int total, int tag, const char *name); + +// copies arglist, no pointer bending +Value_Closure *makeClosureFromArglist(fun_ptr_t f, Value_Arglist *); + +Value_Double *makeDouble(double d); +Value_Char *makeChar(char d); +Value_Int8 *makeInt8(int8_t i); +Value_Int16 *makeInt16(int16_t i); +Value_Int32 *makeInt32(int32_t i); +Value_Int64 *makeInt64(int64_t i); +Value_String *makeEmptyString(size_t l); +Value_String *makeString(char *); + +Value_Pointer *makePointer(void *); +Value_Array *makeArray(int length); +Value_World *makeWorld(void); + +#endif diff --git a/support/refc/prim.c b/support/refc/prim.c new file mode 100644 index 000000000..d5cd5c0db --- /dev/null +++ b/support/refc/prim.c @@ -0,0 +1,323 @@ +#include +#include "prim.h" + +Value *Prelude_IO_prim__getChar(Value *world) +{ + char c = getchar(); + return (Value *)makeChar(c); +} + +// This is NOT THREAD SAFE in the current implementation + +IORef_Storage *newIORef_Storage(int capacity) +{ + IORef_Storage *retVal = (IORef_Storage *)malloc(sizeof(IORef_Storage)); + retVal->filled = 0; + retVal->total = capacity; + retVal->refs = (Value **)malloc(sizeof(Value *) * retVal->total); + return retVal; +} + +void doubleIORef_Storage(IORef_Storage *ior) +{ + Value **values = (Value **)malloc(sizeof(Value *) * ior->total * 2); + ior->total *= 2; + for (int i = 0; i < ior->filled; i++) + { + values[i] = ior->refs[i]; + } + free(ior->refs); + ior->refs = values; +} + +Value *newIORef(Value *erased, Value *input_value, Value *_world) +{ + // if no ioRef Storag exist, start with one + Value_World *world = (Value_World *)_world; + if (!world->listIORefs) + { + world->listIORefs = newIORef_Storage(128); + } + // expand size of needed + if (world->listIORefs->filled >= world->listIORefs->total) + { + doubleIORef_Storage(world->listIORefs); + } + + // store value + Value_IORef *ioRef = (Value_IORef *)newValue(); + ioRef->header.tag = IOREF_TAG; + ioRef->index = world->listIORefs->filled; + world->listIORefs->refs[world->listIORefs->filled] = newReference(input_value); + world->listIORefs->filled++; + + return (Value *)ioRef; +} + +Value *readIORef(Value *erased, Value *_index, Value *_world) +{ + Value_World *world = (Value_World *)_world; + Value_IORef *index = (Value_IORef *)_index; + return newReference(world->listIORefs->refs[index->index]); +} + +Value *writeIORef(Value *erased, Value *_index, Value *new_value, Value *_world) +{ + Value_World *world = (Value_World *)_world; + Value_IORef *index = (Value_IORef *)_index; + removeReference(world->listIORefs->refs[index->index]); + world->listIORefs->refs[index->index] = newReference(new_value); + return newReference(_index); +} + +// ----------------------------------- +// System operations +// ----------------------------------- + +Value *sysOS(void) +{ +#ifdef _WIN32 + return (Value *)makeString("windows"); +#elif _WIN64 + return (Value *)makeString("windows"); +#elif __APPLE__ || __MACH__ + return (Value *)makeString("Mac OSX"); +#elif __linux__ + return (Value *)makeString("Linux"); +#elif __FreeBSD__ + return (Value *)makeString("FreeBSD"); +#elif __OpenBSD__ + return (Value *)makeString("OpenBSD"); +#elif __NetBSD__ + return (Value *)makeString("NetBSD"); +#elif __DragonFly__ + return (Value *)makeString("DragonFly"); +#elif __unix || __unix__ + return (Value *)makeString("Unix"); +#else + return (Value *)makeString("Other"); +#endif +} + +Value* idris2_crash(Value* msg) { + Value_String* str = (Value_String*)msg; + printf("ERROR: %s\n", str->str); + exit(-1); +} + + +// +// +// +// // ----------------------------------- +// // Array operations +// // ----------------------------------- + +Value *newArray(Value *erased, Value *_length, Value *v, Value *_word) +{ + int length = extractInt(_length); + Value_Array *a = makeArray(length); + + for (int i = 0; i < length; i++) + { + a->arr[i] = newReference(v); + } + + return (Value *)a; +} + +Value *arrayGet(Value *erased, Value *_array, Value *_index, Value *_word) +{ + Value_Array *a = (Value_Array *)_array; + return newReference(a->arr[((Value_Int32 *)_index)->i32]); +} + +Value *arraySet(Value *erased, Value *_array, Value *_index, Value *v, Value *_word) +{ + Value_Array *a = (Value_Array *)_array; + removeReference(a->arr[((Value_Int32 *)_index)->i32]); + a->arr[((Value_Int32 *)_index)->i32] = newReference(v); + return NULL; +} + +// +// ----------------------------------- +// Pointer operations +// ----------------------------------- + +Value *PrimIO_prim__nullAnyPtr(Value *ptr) +{ + void *p; + switch (ptr->header.tag) + { + case STRING_TAG: + p = ((Value_String *)ptr)->str; + break; + case POINTER_TAG: + p = ((Value_Pointer *)ptr)->p; + break; + default: + p = NULL; + } + if (p) + { + return (Value *)makeInt32(0); + } + else + { + return (Value *)makeInt32(1); + } +} + +Value *onCollect(Value *_erased, Value *_anyPtr, Value *_freeingFunction, Value *_world) +{ + printf("onCollect called\n"); + Value_GCPointer *retVal = (Value_GCPointer *)newValue(); + retVal->header.tag = GC_POINTER_TAG; + retVal->p = (Value_Pointer *)newReference(_anyPtr); + retVal->onCollectFct = (Value_Closure *)newReference(_freeingFunction); + return (Value *)retVal; +} + +Value *onCollectAny(Value *_erased, Value *_anyPtr, Value *_freeingFunction, Value *_world) +{ + printf("onCollectAny called\n"); + Value_GCPointer *retVal = (Value_GCPointer *)newValue(); + retVal->header.tag = GC_POINTER_TAG; + retVal->p = (Value_Pointer *)_anyPtr; + retVal->onCollectFct = (Value_Closure *)_freeingFunction; + return (Value *)retVal; +} + +Value *voidElim(Value *erased1, Value *erased2) +{ + return NULL; +} + +// Threads + +// %foreign "scheme:blodwen-mutex" +// prim__makeMutex : PrimIO Mutex +// using pthread_mutex_init(pthread_mutex_t *mutex, const pthread_mutexattr_t *attr) +Value *System_Concurrency_Raw_prim__makeMutex(Value *_world) +{ + Value_Mutex *mut = (Value_Mutex *)newValue(); + mut->header.tag = MUTEX_TAG; + mut->mutex = (pthread_mutex_t *)malloc(sizeof(pthread_mutex_t)); + if (pthread_mutex_init(mut->mutex, NULL)) + { + fprintf(stderr, "Error init Mutex\n"); + exit(-1); + } + return (Value *)mut; +} + +// %foreign "scheme:blodwen-lock" +// prim__mutexAcquire : Mutex -> PrimIO () +// using pthread_mutex_lock(pthread_mutex_t *mutex) +Value *System_Concurrency_Raw_prim__mutexAcquire(Value *_mutex, Value *_world) +{ + if (pthread_mutex_lock(((Value_Mutex *)_mutex)->mutex)) + { + fprintf(stderr, "Error locking mutex\n"); + exit(-1); + } + return NULL; +} + +// %foreign "scheme:blodwen-unlock" +// prim__mutexRelease : Mutex -> PrimIO () +//using int pthread_mutex_unlock(pthread_mutex_t *mutex) +Value *System_Concurrency_Raw_prim__mutexRelease(Value *_mutex, Value *_world) +{ + if (pthread_mutex_unlock(((Value_Mutex *)_mutex)->mutex)) + { + fprintf(stderr, "Error locking mutex\n"); + exit(-1); + } + return NULL; +} + +// %foreign "scheme:blodwen-condition" +// prim__makeCondition : PrimIO Condition +// using int pthread_cond_init(pthread_cond_t *cond, const pthread_condattr_t *attr) +// with standard initialisation +Value *System_Concurrency_Raw_prim__makeCondition(Value *_world) +{ + // typedef struct{ + // Value_header header; + // pthread_cond_t *cond; + // }Value_Condition; + + Value_Condition *c = (Value_Condition *)newValue(); + c->header.tag = CONDITION_TAG; + c->cond = (pthread_cond_t *)malloc(sizeof(pthread_cond_t)); + if (pthread_cond_init(c->cond, NULL)) + { + fprintf(stderr, "error init condition\n"); + exit(-1); + } + return (Value *)c; +} + +// %foreign "scheme:blodwen-condition-wait" +// prim__conditionWait : Condition -> Mutex -> PrimIO () +// using int pthread_cond_wait(pthread_cond_t *, pthread_mutex_t *mutex) +Value *System_Concurrency_Raw_prim__conditionWait(Value *_condition, Value *_mutex, Value *_world) +{ + Value_Condition *cond = (Value_Condition *)_condition; + Value_Mutex *mutex = (Value_Mutex *)_mutex; + if (pthread_cond_wait(cond->cond, mutex->mutex)) + { + fprintf(stderr, "Error Conditional Wait\n"); + exit(-1); + } + return NULL; +} + +// %foreign "scheme:blodwen-condition-wait-timeout" +// prim__conditionWaitTimeout : Condition -> Mutex -> Int -> PrimIO () +// using int pthread_cond_timedwait(pthread_cond_t *cond, pthread_mutex_t *mutex, const struct timespec *abstime) +Value *System_Concurrency_Raw_prim__conditionWaitTimeout(Value *_condition, Value *_mutex, Value *_timeout, Value *_world) +{ + Value_Condition *cond = (Value_Condition *)_condition; + Value_Mutex *mutex = (Value_Mutex *)_mutex; + Value_Int32 *timeout = (Value_Int32 *)_timeout; + struct timespec t; + t.tv_sec = timeout->i32 / 1000000; + t.tv_nsec = timeout->i32 % 1000000; + if (pthread_cond_timedwait(cond->cond, mutex->mutex, &t)) + { + fprintf(stderr, "Error in pthread_cond_timedwait\n"); + exit(-1); + } + return NULL; +} + +// %foreign "scheme:blodwen-condition-signal" +// prim__conditionSignal : Condition -> PrimIO () +// using int pthread_cond_signal(pthread_cond_t *cond) +Value *System_Concurrency_Raw_prim__conditionSignal(Value *_condition, Value *_world) +{ + Value_Condition *cond = (Value_Condition *)_condition; + if (pthread_cond_signal(cond->cond)) + { + fprintf(stderr, "Error in pthread_cond_signal\n"); + exit(-1); + } + return NULL; +} + +// %foreign "scheme:blodwen-condition-broadcast" +// prim__conditionBroadcast : Condition -> PrimIO () +// using int pthread_cond_broadcast(pthread_cond_t *cond) +Value *System_Concurrency_Raw_prim__conditionBroadcast(Value *_condition, Value *_mutex) +{ + Value_Condition *cond = (Value_Condition *)_condition; + if (pthread_cond_broadcast(cond->cond)) + { + fprintf(stderr, "Error in pthread_cond_broadcast\n"); + exit(-1); + } + return NULL; +} diff --git a/support/refc/prim.h b/support/refc/prim.h new file mode 100644 index 000000000..5dd2ee9df --- /dev/null +++ b/support/refc/prim.h @@ -0,0 +1,52 @@ +#ifndef __PRIM_H__ +#define __PRIM_H__ + +#include "cBackend.h" + + + +// Value * Prelude_IO_prim__putStr(Value *, Value *); +Value *Prelude_IO_prim__getChar(Value *); + +// IORef + +Value *newIORef(Value *, Value *, Value *); +Value *readIORef(Value *, Value *, Value *); +Value *writeIORef(Value *, Value *, Value *, Value *); + +// Sys + +Value *sysOS(void); +Value* idris2_crash(Value* msg); + +// Array + +Value *newArray(Value *, Value *, Value *, Value *); +Value *arrayGet(Value *, Value *, Value *, Value *); +Value *arraySet(Value *, Value *, Value *, Value *, Value *); + +// Pointer +Value *PrimIO_prim__nullAnyPtr(Value *); + +Value *onCollect(Value *, Value *, Value *, Value *); +Value *onCollectAny(Value *, Value *, Value *, Value *); + +Value *voidElim(Value *, Value *); + +// Threads +Value *System_Concurrency_Raw_prim__mutexRelease(Value *, Value *); + +Value *System_Concurrency_Raw_prim__mutexAcquire(Value *, Value *); + +Value *System_Concurrency_Raw_prim__makeMutex(Value *); + +Value *System_Concurrency_Raw_prim__makeCondition(Value *); + +Value *System_Concurrency_Raw_prim__conditionWait(Value *, Value *, Value *); + +Value *System_Concurrency_Raw_prim__conditionWaitTimeout(Value *, Value *, Value *, Value *); + +Value *System_Concurrency_Raw_prim__conditionSignal(Value *, Value *); + +Value *System_Concurrency_Raw_prim__conditionBroadcast(Value *, Value *); +#endif diff --git a/support/refc/runtime.c b/support/refc/runtime.c new file mode 100644 index 000000000..701164f82 --- /dev/null +++ b/support/refc/runtime.c @@ -0,0 +1,114 @@ +#include "runtime.h" + +void push_Arglist(Value_Arglist *arglist, Value *arg) +{ + if (arglist->filled >= arglist->total) + { + fprintf(stderr, "unable to add more arguments to arglist\n"); + exit(1); + } + + arglist->args[arglist->filled] = newReference(arg); + arglist->filled++; +} + +Value *apply_closure(Value *_clos, Value *arg) +{ + // create a new arg list + Value_Arglist *oldArgs = ((Value_Closure *)_clos)->arglist; + Value_Arglist *newArgs = newArglist(0, oldArgs->total); + newArgs->filled = oldArgs->filled + 1; + // add argument to new arglist + for (int i = 0; i < oldArgs->filled; i++) + { + newArgs->args[i] = newReference(oldArgs->args[i]); + } + newArgs->args[oldArgs->filled] = newReference(arg); + + Value_Closure *clos = (Value_Closure *)_clos; + + // check if enough arguments exist + if (newArgs->filled >= newArgs->total) + { + fun_ptr_t f = clos->f; + while (1) + { + Value *retVal = f(newArgs); + removeReference((Value *)newArgs); + if (!retVal || retVal->header.tag != COMPLETE_CLOSURE_TAG) + { + return retVal; + } + f = ((Value_Closure *)retVal)->f; + newArgs = ((Value_Closure *)retVal)->arglist; + newArgs = (Value_Arglist *)newReference((Value *)newArgs); + removeReference(retVal); + } + } + + return (Value *)makeClosureFromArglist(clos->f, newArgs); +} + +Value *tailcall_apply_closure(Value *_clos, Value *arg) +{ + // create a new arg list + Value_Arglist *oldArgs = ((Value_Closure *)_clos)->arglist; + Value_Arglist *newArgs = newArglist(0, oldArgs->total); + newArgs->filled = oldArgs->filled + 1; + // add argument to new arglist + for (int i = 0; i < oldArgs->filled; i++) + { + newArgs->args[i] = newReference(oldArgs->args[i]); + } + newArgs->args[oldArgs->filled] = newReference(arg); + + Value_Closure *clos = (Value_Closure *)_clos; + + // check if enough arguments exist + if (newArgs->filled >= newArgs->total) + return (Value *)makeClosureFromArglist(clos->f, newArgs); + + return (Value *)makeClosureFromArglist(clos->f, newArgs); +} + +int extractInt(Value *v) +{ + if (v->header.tag == INT64_TAG) + { + return (int)((Value_Int64 *)v)->i64; + } + + if (v->header.tag == INT32_TAG) + { + return ((Value_Int32 *)v)->i32; + } + + if (v->header.tag == DOUBLE_TAG) + { + return (int)((Value_Double *)v)->d; + } + + return -1; +} + +Value *trampoline(Value *closure) +{ + fun_ptr_t f = ((Value_Closure *)closure)->f; + Value_Arglist *_arglist = ((Value_Closure *)closure)->arglist; + Value_Arglist *arglist = (Value_Arglist *)newReference((Value *)_arglist); + removeReference(closure); + while (1) + { + Value *retVal = f(arglist); + removeReference((Value *)arglist); + if (!retVal || retVal->header.tag != COMPLETE_CLOSURE_TAG) + { + return retVal; + } + f = ((Value_Closure *)retVal)->f; + arglist = ((Value_Closure *)retVal)->arglist; + arglist = (Value_Arglist *)newReference((Value *)arglist); + removeReference(retVal); + } + return NULL; +} diff --git a/support/refc/runtime.h b/support/refc/runtime.h new file mode 100644 index 000000000..2b96ba4d1 --- /dev/null +++ b/support/refc/runtime.h @@ -0,0 +1,12 @@ +#ifndef __RUNTIME_H__ +#define __RUNTIME_H__ + +#include "cBackend.h" + +Value *apply_closure(Value *, Value *arg); +void push_Arglist(Value_Arglist *arglist, Value *arg); + +int extractInt(Value *); +Value *trampoline(Value *closure); +Value *tailcall_apply_closure(Value *_clos, Value *arg); +#endif diff --git a/support/refc/stringOps.c b/support/refc/stringOps.c new file mode 100644 index 000000000..05737c771 --- /dev/null +++ b/support/refc/stringOps.c @@ -0,0 +1,91 @@ +#include "stringOps.h" + +Value *stringLength(Value *s) +{ + int length = strlen(((Value_String *)s)->str); + return (Value *)makeInt32(length); +} + +Value *head(Value *str) +{ + Value_Char *c = (Value_Char *)newValue(); + c->header.tag = CHAR_TAG; + c->c = ((Value_String *)str)->str[0]; + return (Value *)c; +} + +Value *tail(Value *str) +{ + Value_Char *c = (Value_Char *)newValue(); + c->header.tag = CHAR_TAG; + Value_String *s = (Value_String *)str; + int l = strlen(s->str); + c->c = s->str[l - 1]; + return (Value *)c; +} + +Value *reverse(Value *str) +{ + Value_String *retVal = (Value_String *)newValue(); + retVal->header.tag = STRING_TAG; + Value_String *input = (Value_String *)str; + int l = strlen(input->str); + retVal->str = malloc(l + 1); + memset(retVal->str, 0, l + 1); + char *p = retVal->str; + char *q = input->str + (l - 1); + for (int i = 1; i < l; i++) + { + *p++ = *q--; + } + return (Value *)retVal; +} + +Value *strIndex(Value *str, Value *i) +{ + Value_Char *c; + switch (i->header.tag) + { + case INT64_TAG: + c = makeChar(((Value_String *)str)->str[((Value_Int64 *)i)->i64]); + return (Value *)c; + default: + c = makeChar(((Value_String *)str)->str[((Value_Int32 *)i)->i32]); + return (Value *)c; + } +} + +Value *strCons(Value *c, Value *str) +{ + int l = strlen(((Value_String *)str)->str); + Value_String *retVal = makeEmptyString(l + 2); + retVal->str[0] = ((Value_Char *)c)->c; + memcpy(retVal->str + 1, ((Value_String *)str)->str, l); + return (Value *)retVal; +} + +Value *strAppend(Value *a, Value *b) +{ + int la = strlen(((Value_String *)a)->str); + int lb = strlen(((Value_String *)b)->str); + Value_String *retVal = makeEmptyString(la + lb + 1); + memcpy(retVal->str, ((Value_String *)a)->str, la); + memcpy(retVal->str + la, ((Value_String *)b)->str, lb); + return (Value *)retVal; +} + +Value *strSubstr(Value *s, Value *start, Value *len) +{ + Value_String *retVal; + switch (len->header.tag) + { + case INT64_TAG: + retVal = makeEmptyString(((Value_Int64 *)len)->i64 + 1); + memcpy(retVal->str, ((Value_String *)s)->str, ((Value_Int64 *)len)->i64); + return (Value *)retVal; + default: + retVal = makeEmptyString(((Value_Int32 *)len)->i32 + 1); + memcpy(retVal->str, ((Value_String *)s)->str, ((Value_Int32 *)len)->i32); + return (Value *)retVal; + } +} diff --git a/support/refc/stringOps.h b/support/refc/stringOps.h new file mode 100644 index 000000000..7b02ea946 --- /dev/null +++ b/support/refc/stringOps.h @@ -0,0 +1,15 @@ +#ifndef __STRING_OPS_H__ +#define __STRING_OPS_H__ + +#include "cBackend.h" + +Value *stringLength(Value *); +Value *head(Value *str); +Value *tail(Value *str); +Value *reverse(Value *str); +Value *strIndex(Value *str, Value *i); +Value *strCons(Value *c, Value *str); +Value *strAppend(Value *a, Value *b); +Value *strSubstr(Value *s, Value *start, Value *len); + +#endif diff --git a/tests/Lib.idr b/tests/Lib.idr new file mode 100644 index 000000000..7e8960822 --- /dev/null +++ b/tests/Lib.idr @@ -0,0 +1,322 @@ +||| Core features required to perform Golden file testing. +||| +||| We provide the core functionality to run a *single* golden file test, or +||| a whole test tree. +||| This allows the developer freedom to use as is or design the rest of the +||| test harness to their liking. +||| +||| This was originally used as part of Idris2's own test suite and +||| the core functionality is useful for the many and not the few. +||| Please see Idris2 test harness for example usage. +||| +||| # Test Structure +||| +||| This harness works from the assumption that each individual golden test +||| comprises of a directory with the following structure: +||| +||| + `run` a *shell* script that runs the test. We expect it to: +||| * Use `$1` as the variable standing for the idris executable to be tested +||| * May use `${IDRIS2_TESTS_CG}` to pick a codegen that ought to work +||| * Clean up after itself (e.g. by running `rm -rf build/`) +||| +||| + `expected` a file containting the expected output of `run` +||| +||| During testing, the test harness will generate an artefact named `output` and +||| display both outputs if there is a failure. +||| During an interactive session the following command is used to compare them as +||| they are: +||| +||| ```sh +||| git diff --no-index --exit-code --word-diff=color expected output +||| ``` +||| +||| If `git` fails then the runner will simply present the expected and 'given' +||| files side-by-side. +||| +||| Of note, it is helpful if `output` was added to a local `.gitignore` instance +||| to ensure that it is not mistakenly versioned. +||| +||| # Options +||| +||| The test harness has several options that may be set: +||| +||| + `idris2` The path of the executable we are testing. +||| + `onlyNames` The list of tests to run relative to the generated executable. +||| + `interactive` Whether to offer to update the expected file or not. +||| + `timing` Whether to display time taken for each test. +||| +||| We provide an options parser (`options`) that will take the command line arguments +||| and constructs this for you. +||| +||| # Usage +||| +||| When compiled to an executable the expected usage is: +||| +|||```sh +|||runtests [--timing] [--interactive] [--only [NAMES]] +|||``` +||| +||| assuming that the test runner is compiled to an executable named `runtests`. + +module Lib + +import Data.Maybe +import Data.List +import Data.List1 +import Data.Strings + +import System +import System.Clock +import System.Directory +import System.File +import System.Info +import System.Path + +-- [ Options ] + +||| Options for the test driver. +public export +record Options where + constructor MkOptions + ||| Name of the idris2 executable + exeUnderTest : String + ||| Which codegen should we use? + codegen : Maybe String + ||| Should we only run some specific cases? + onlyNames : List String + ||| Should we run the test suite interactively? + interactive : Bool + ||| Should we time and display the tests + timing : Bool + +export +usage : String -> String +usage exe = unwords ["Usage:", exe, "runtests [--timing] [--interactive] [--cg CODEGEN] [--only [NAMES]]"] + +||| Process the command line options. +export +options : List String -> Maybe Options +options args = case args of + (_ :: exeUnderTest :: rest) => go rest (MkOptions exeUnderTest Nothing [] False False) + _ => Nothing + + where + + go : List String -> Options -> Maybe Options + go rest opts = case rest of + [] => pure opts + ("--timing" :: xs) => go xs (record { timing = True} opts) + ("--interactive" :: xs) => go xs (record { interactive = True } opts) + ("--cg" :: cg :: xs) => go xs (record { codegen = Just cg } opts) + ("--only" :: xs) => pure $ record { onlyNames = xs } opts + _ => Nothing + +-- [ Core ] + +export +fail : String -> IO () +fail err + = do putStrLn err + exitWith (ExitFailure 1) + + +||| Normalise strings between different OS. +||| +||| on Windows, we just ignore backslashes and slashes when comparing, +||| similarity up to that is good enough. Leave errors that depend +||| on the confusion of slashes and backslashes to unix machines. +normalize : String -> String +normalize str = + if isWindows + then pack $ filter (\ch => ch /= '/' && ch /= '\\') (unpack str) + else str + +||| Run the specified Golden test with the supplied options. +||| +||| See the module documentation for more information. +||| +||| @currdir absolute or relative path to root test directory. +||| @testpath the directory that contains the test. +export +runTest : Options -> (currdir, testPath : String) -> IO Bool +runTest opts currdir testPath + = do changeDir testPath + isSuccess <- runTest' + changeDir currdir + pure isSuccess + where + getAnswer : IO Bool + getAnswer = do + str <- getLine + case str of + "y" => pure True + "n" => pure False + _ => do putStrLn "Invalid Answer." + getAnswer + + printExpectedVsOutput : String -> String -> IO () + printExpectedVsOutput exp out = do + putStrLn "Expected:" + putStrLn exp + putStrLn "Given:" + putStrLn out + + mayOverwrite : Maybe String -> String -> IO () + mayOverwrite mexp out = do + the (IO ()) $ case mexp of + Nothing => putStr $ unlines + [ "Golden value missing. I computed the following result:" + , out + , "Accept new golden value? [yn]" + ] + Just exp => do + putStrLn "Golden value differs from actual value." + code <- system "git diff --no-index --exit-code --word-diff=color expected output" + when (code < 0) $ printExpectedVsOutput exp out + putStrLn "Accept actual value as new golden value? [yn]" + b <- getAnswer + when b $ do Right _ <- writeFile "expected" out + | Left err => print err + pure () + + printTiming : Bool -> Clock type -> String -> IO () + printTiming True clock msg = putStrLn (unwords [msg, show clock]) + printTiming False _ msg = putStrLn msg + + runTest' : IO Bool + runTest' + = do putStr $ testPath ++ ": " + start <- clockTime Thread + let cg = case codegen opts of + Nothing => "" + Just cg => "env IDRIS2_TESTS_CG=" ++ cg ++ " " + system $ cg ++ "sh ./run " ++ exeUnderTest opts ++ " | tr -d '\\r' > output" + end <- clockTime Thread + Right out <- readFile "output" + | Left err => do print err + pure False + Right exp <- readFile "expected" + | Left FileNotFound => do + if interactive opts + then mayOverwrite Nothing out + else print FileNotFound + pure False + | Left err => do print err + pure False + let result = normalize out == normalize exp + let time = timeDifference end start + if result + then printTiming (timing opts) time "success" + else do + printTiming (timing opts) time "FAILURE" + if interactive opts + then mayOverwrite (Just exp) out + else printExpectedVsOutput exp out + + pure result + +||| Find the first occurrence of an executable on `PATH`. +export +pathLookup : List String -> IO (Maybe String) +pathLookup names = do + path <- getEnv "PATH" + let pathList = forget $ split (== pathSeparator) $ fromMaybe "/usr/bin:/usr/local/bin" path + let candidates = [p ++ "/" ++ x | p <- pathList, + x <- names] + firstExists candidates + + +||| Some test may involve Idris' backends and have requirements. +||| We define here the ones supported by Idris +public export +data Requirement = Chez | Node | Racket + +export +Show Requirement where + show Chez = "Chez" + show Node = "node" + show Racket = "racket" + +export +checkRequirement : Requirement -> IO (Maybe String) +checkRequirement req + = do let (envvar, paths) = requirement req + Just exec <- getEnv envvar | Nothing => pathLookup paths + pure (Just exec) + + where + requirement : Requirement -> (String, List String) + requirement Chez = ("CHEZ", ["chez", "chezscheme9.5", "scheme", "scheme.exe"]) + requirement Node = ("NODE", ["node"]) + requirement Racket = ("RACKET", ["racket"]) + +export +findCG : IO (Maybe String) +findCG + = do Nothing <- getEnv "IDRIS2_TESTS_CG" | p => pure p + Nothing <- checkRequirement Chez | p => pure (Just "chez") + Nothing <- checkRequirement Node | p => pure (Just "node") + Nothing <- checkRequirement Racket | p => pure (Just "racket") + pure Nothing + +||| A test pool is characterised by +||| + a list of requirement +||| + and a list of directory paths +public export +record TestPool where + constructor MkTestPool + constraints : List Requirement + testCases : List String + +||| Only keep the tests that have been asked for +export +filterTests : Options -> List String -> List String +filterTests opts = case onlyNames opts of + [] => id + xs => filter (\ name => any (`isInfixOf` name) xs) + +||| A runner for a test pool +export +poolRunner : Options -> (currdir : String) -> TestPool -> IO (List Bool) +poolRunner opts currdir pool + = do -- check that we indeed want to run some of these tests + let tests = filterTests opts (testCases pool) + let (_ :: _) = tests + | [] => pure [] + -- if so make sure the constraints are satisfied + cs <- for (constraints pool) $ \ req => do + mfp <- checkRequirement req + putStrLn $ case mfp of + Nothing => show req ++ " not found" + Just fp => "Found " ++ show req ++ " at " ++ fp + pure mfp + let Just _ = the (Maybe (List String)) (sequence cs) + | Nothing => pure [] + -- if so run them all! + traverse (runTest opts currdir) tests + + +||| A runner for a whole test suite +export +runner : List TestPool -> IO () +runner tests + = do args <- getArgs + let (Just opts) = options args + | _ => do print args + putStrLn (usage "runtests") + -- if no CG has been set, find a sensible default based on what is available + opts <- case codegen opts of + Nothing => pure $ record { codegen = !findCG } opts + Just _ => pure opts + -- grab the current directory + Just pwd <- currentDir + | Nothing => putStrLn "FATAL: Could not get current working directory" + -- run the tests + res <- concat <$> traverse (poolRunner opts pwd) tests + putStrLn (show (length (filter id res)) ++ "/" ++ show (length res) + ++ " tests successful") + if (any not res) + then exitWith (ExitFailure 1) + else exitWith ExitSuccess + +-- [ EOF ] diff --git a/tests/Main.idr b/tests/Main.idr index 206f241cb..9aa1e315f 100644 --- a/tests/Main.idr +++ b/tests/Main.idr @@ -11,14 +11,16 @@ import System.File import System.Info import System.Path +import Lib + %default covering ------------------------------------------------------------------------ -- Test cases -ttimpTests : List String -ttimpTests - = ["basic001", "basic002", "basic003", "basic004", "basic005", +ttimpTests : TestPool +ttimpTests = MkTestPool [] + ["basic001", "basic002", "basic003", "basic004", "basic005", "basic006", "coverage001", "coverage002", "dot001", @@ -30,9 +32,9 @@ ttimpTests "qtt001", "qtt003", "total001", "total002", "total003"] -idrisTests : List String -idrisTests - = -- Fundamental language features +idrisTests : TestPool +idrisTests = MkTestPool [] + -- Fundamental language features ["basic001", "basic002", "basic003", "basic004", "basic005", "basic006", "basic007", "basic008", "basic009", "basic010", "basic011", "basic012", "basic013", "basic014", "basic015", @@ -42,19 +44,19 @@ idrisTests "basic031", "basic032", "basic033", "basic034", "basic035", "basic036", "basic037", "basic038", "basic039", "basic040", "basic041", "basic042", "basic043", "basic044", "basic045", - "basic046", "basic047", + "basic046", "basic047", "basic048", -- Coverage checking "coverage001", "coverage002", "coverage003", "coverage004", "coverage005", "coverage006", "coverage007", "coverage008", - "coverage009", "coverage010", + "coverage009", "coverage010", "coverage011", -- Documentation strings "docs001", "docs002", -- Evaluator - "evaluator001", "evaluator002", "evaluator003", + "evaluator001", "evaluator002", "evaluator003", "evaluator004", -- Error messages "error001", "error002", "error003", "error004", "error005", "error006", "error007", "error008", "error009", "error010", - "error011", "error012", "error013", + "error011", "error012", "error013", "error014", -- Modules and imports "import001", "import002", "import003", "import004", "import005", -- Interactive editing support @@ -82,14 +84,14 @@ idrisTests "literate001", "literate002", "literate003", "literate004", "literate005", "literate006", "literate007", "literate008", "literate009", "literate010", "literate011", "literate012", - "literate013", "literate014", + "literate013", "literate014", "literate015", "literate016", -- Namespace blocks "namespace001", -- Parameters blocks "params001", -- Performance: things which have been slow in the past, or which -- pose interesting challenges for the elaborator - "perf001", "perf002", "perf003", "perf004", "perf005", + "perf001", "perf002", "perf003", "perf004", "perf005", "perf006", -- Parse errors "perror001", "perror002", "perror003", "perror004", "perror005", "perror006", @@ -121,15 +123,15 @@ idrisTests -- with-disambiguation "with003"] -typeddTests : List String -typeddTests - = ["chapter01", "chapter02", "chapter03", "chapter04", "chapter05", +typeddTests : TestPool +typeddTests = MkTestPool [] + ["chapter01", "chapter02", "chapter03", "chapter04", "chapter05", "chapter06", "chapter07", "chapter08", "chapter09", "chapter10", "chapter11", "chapter12", "chapter13", "chapter14"] -chezTests : List String -chezTests - = ["chez001", "chez002", "chez003", "chez004", "chez005", "chez006", +chezTests : TestPool +chezTests = MkTestPool [Chez] + ["chez001", "chez002", "chez003", "chez004", "chez005", "chez006", "chez007", "chez008", "chez009", "chez010", "chez011", "chez012", "chez013", "chez014", "chez015", "chez016", "chez017", "chez018", "chez019", "chez020", "chez021", "chez022", "chez023", "chez024", @@ -138,9 +140,9 @@ chezTests "perf001", "reg001"] -nodeTests : List String -nodeTests - = [ "node001", "node002", "node003", "node004", "node005", "node006", "node007", "node008", "node009" +nodeTests : TestPool +nodeTests = MkTestPool [Node] + [ "node001", "node002", "node003", "node004", "node005", "node006", "node007", "node008", "node009" , "node011", "node012", "node015", "node017", "node018", "node019" -- node014 , "node021", "node022" --, "node020" , "reg001" @@ -149,209 +151,29 @@ nodeTests , "idiom001" ] -ideModeTests : List String -ideModeTests - = [ "ideMode001", "ideMode002", "ideMode003", "ideMode004" ] +ideModeTests : TestPool +ideModeTests = MkTestPool [] + [ "ideMode001", "ideMode002", "ideMode003", "ideMode004" ] -preludeTests : List String -preludeTests - = [ "reg001" ] +preludeTests : TestPool +preludeTests = MkTestPool [] + [ "reg001" ] ------------------------------------------------------------------------- --- Options - -||| Options for the test driver. -record Options where - constructor MkOptions - ||| Name of the idris2 executable - idris2 : String - ||| Should we only run some specific cases? - onlyNames : List String - ||| Should we run the test suite interactively? - interactive : Bool - -usage : String -usage = "Usage: runtests [--interactive] [--only [NAMES]]" - -options : List String -> Maybe Options -options args = case args of - (_ :: idris2 :: rest) => go rest (MkOptions idris2 [] False) - _ => Nothing - - where - - go : List String -> Options -> Maybe Options - go rest opts = case rest of - [] => pure opts - ("--interactive" :: xs) => go xs (record { interactive = True } opts) - ("--only" :: xs) => pure $ record { onlyNames = xs } opts - _ => Nothing - ------------------------------------------------------------------------- --- Actual test runner - -fail : String -> IO () -fail err - = do putStrLn err - exitWith (ExitFailure 1) - --- on Windows, we just ignore backslashes and slashes when comparing, --- similarity up to that is good enough. Leave errors that depend --- on the confusion of slashes and backslashes to unix machines. -normalize : String -> String -normalize str = - if isWindows - then pack $ filter (\ch => ch /= '/' && ch /= '\\') (unpack str) - else str - -runTest : Options -> String -> IO Bool -runTest opts testPath - = do changeDir testPath - isSuccess <- runTest' - changeDir "../.." - pure isSuccess - where - getAnswer : IO Bool - getAnswer = do - str <- getLine - case str of - "y" => pure True - "n" => pure False - _ => do putStrLn "Invalid Answer." - getAnswer - - printExpectedVsOutput : String -> String -> IO () - printExpectedVsOutput exp out = do - putStrLn "Expected:" - printLn exp - putStrLn "Given:" - printLn out - - mayOverwrite : Maybe String -> String -> IO () - mayOverwrite mexp out = do - the (IO ()) $ case mexp of - Nothing => putStr $ unlines - [ "Golden value missing. I computed the following result:" - , out - , "Accept new golden value? [yn]" - ] - Just exp => do - putStrLn "Golden value differs from actual value." - code <- system "git diff --no-index --exit-code --word-diff=color expected output" - when (code < 0) $ printExpectedVsOutput exp out - putStrLn "Accept actual value as new golden value? [yn]" - b <- getAnswer - when b $ do Right _ <- writeFile "expected" out - | Left err => print err - pure () - runTest' : IO Bool - runTest' - = do putStr $ testPath ++ ": " - system $ "sh ./run " ++ idris2 opts ++ " | tr -d '\\r' > output" - Right out <- readFile "output" - | Left err => do print err - pure False - Right exp <- readFile "expected" - | Left FileNotFound => do - if interactive opts - then mayOverwrite Nothing out - else print FileNotFound - pure False - | Left err => do print err - pure False - let result = normalize out == normalize exp - if result - then putStrLn "success" - else do - putStrLn "FAILURE" - if interactive opts - then mayOverwrite (Just exp) out - else printExpectedVsOutput exp out - - pure result - -exists : String -> IO Bool -exists f - = do Right ok <- openFile f Read - | Left err => pure False - closeFile ok - pure True - -firstExists : List String -> IO (Maybe String) -firstExists [] = pure Nothing -firstExists (x :: xs) = if !(exists x) then pure (Just x) else firstExists xs - -pathLookup : List String -> IO (Maybe String) -pathLookup names = do - path <- getEnv "PATH" - let pathList = forget $ split (== pathSeparator) $ fromMaybe "/usr/bin:/usr/local/bin" path - let candidates = [p ++ "/" ++ x | p <- pathList, - x <- names] - firstExists candidates - -findChez : IO (Maybe String) -findChez - = do Just chez <- getEnv "CHEZ" | Nothing => pathLookup ["chez", "chezscheme9.5", "scheme", "scheme.exe"] - pure $ Just chez - -findNode : IO (Maybe String) -findNode - = do Just chez <- getEnv "NODE" | Nothing => pathLookup ["node"] - pure $ Just chez - -runChezTests : Options -> List String -> IO (List Bool) -runChezTests opts tests - = do chexec <- findChez - maybe (do putStrLn "Chez Scheme not found" - pure []) - (\c => do putStrLn $ "Found Chez Scheme at " ++ c - traverse (runTest opts) tests) - chexec - -runNodeTests : Options -> List String -> IO (List Bool) -runNodeTests opts tests - = do nodeexec <- findNode - maybe (do putStrLn "node not found" - pure []) - (\c => do putStrLn $ "Found node at " ++ c - traverse (runTest opts) tests) - nodeexec - - -filterTests : Options -> List String -> List String -filterTests opts = case onlyNames opts of - [] => id - xs => filter (\ name => any (`isInfixOf` name) xs) +templateTests : TestPool +templateTests = MkTestPool [] + [ "simple-test", "ttimp", "with-ipkg" ] main : IO () -main - = do args <- getArgs - let (Just opts) = options args - | _ => do print args - putStrLn usage - let filteredNonCGTests = - filterTests opts $ concat $ - [ testPaths "ttimp" ttimpTests - , testPaths "idris2" idrisTests - , testPaths "typedd-book" typeddTests - , testPaths "ideMode" ideModeTests - , testPaths "prelude" preludeTests - ] - let filteredChezTests = filterTests opts (testPaths "chez" chezTests) - let filteredNodeTests = filterTests opts (testPaths "node" nodeTests) - nonCGTestRes <- traverse (runTest opts) filteredNonCGTests - chezTestRes <- if length filteredChezTests > 0 - then runChezTests opts filteredChezTests - else pure [] - nodeTestRes <- if length filteredNodeTests > 0 - then runNodeTests opts filteredNodeTests - else pure [] - let res = nonCGTestRes ++ chezTestRes ++ nodeTestRes - putStrLn (show (length (filter id res)) ++ "/" ++ show (length res) - ++ " tests successful") - if (any not res) - then exitWith (ExitFailure 1) - else exitWith ExitSuccess - where - testPaths : String -> List String -> List String - testPaths dir tests = map (\test => dir ++ "/" ++ test) tests +main = runner + [ testPaths "ttimp" ttimpTests + , testPaths "idris2" idrisTests + , testPaths "typedd-book" typeddTests + , testPaths "ideMode" ideModeTests + , testPaths "prelude" preludeTests + , testPaths "chez" chezTests + , testPaths "node" nodeTests + , testPaths "templates" templateTests + ] where + + testPaths : String -> TestPool -> TestPool + testPaths dir = record { testCases $= map ((dir ++ "/") ++) } diff --git a/tests/README.md b/tests/README.md index 6f5b5c8c0..7be4d74ba 100644 --- a/tests/README.md +++ b/tests/README.md @@ -11,3 +11,5 @@ Examples: - `make test only=chez` will run all Chez Scheme tests. - `make test only=ttimp/basic` will run all basic tests for `TTImp`. - `make test only=idris2/basic001` will run a specific test. + +Templates for common test instances can be found in the `templates` folder. diff --git a/tests/chez/chez027/StringParser.idr b/tests/chez/chez027/StringParser.idr index 38e7cfdfd..c0a6963a6 100644 --- a/tests/chez/chez027/StringParser.idr +++ b/tests/chez/chez027/StringParser.idr @@ -4,6 +4,7 @@ import Control.Monad.Identity import Control.Monad.Trans import Data.Maybe +import Data.Vect import Data.String.Parser %default partial @@ -44,7 +45,7 @@ main = do res <- parseT (string "hi") "hiyaaaaaa" case res of Left err => putStrLn "NOOOOOOO!" - Right ((), i) => printLn i + Right (_, i) => printLn i bad <- parseT (satisfy isDigit) "a" showRes bad bad2 <- parseT (string "good" "Not good") "bad bad bad" @@ -62,4 +63,12 @@ main = do showRes res res <- parseT maybeParser "def" showRes res - pure () \ No newline at end of file + res <- parseT (commaSep alphaNum) "a,1,b,2" + showRes res + res <- parseT (ntimes 4 letter) "abcd" + showRes res + res <- parseT (requireFailure letter) "1" + showRes res + res <- parseT (requireFailure letter) "a" -- Should error + showRes res + pure () diff --git a/tests/chez/chez027/expected b/tests/chez/chez027/expected index c8a8a1818..b2264b8bc 100644 --- a/tests/chez/chez027/expected +++ b/tests/chez/chez027/expected @@ -9,5 +9,9 @@ Parse failed at position 0: Not good "" True False +['a', '1', 'b', '2'] +['a', 'b', 'c', 'd'] +() +Parse failed at position 0: Purposefully changed OK to Fail 1/1: Building StringParser (StringParser.idr) Main> Main> Bye for now! diff --git a/tests/chez/chez029/BitCasts.idr b/tests/chez/chez029/BitCasts.idr index 1eb595bb0..bf0fe0344 100644 --- a/tests/chez/chez029/BitCasts.idr +++ b/tests/chez/chez029/BitCasts.idr @@ -1,6 +1,6 @@ -- Tests to check that casting between integer types works as expected -- --- This tests in `idris2/basic043`, `chez/chez028` and `node/node022` are the +-- The tests in `idris2/basic043`, `chez/chez029` and `node/node022` are the -- same and should all have the same output. -- @@ -93,3 +93,19 @@ negativeNumberCast = [ show $ cast {to = Bits32} (-19), show $ cast {to = Bits64} (-19) ] + +-- +-- Run via code generator +-- + +main : IO () +main = do + printLn bits8WideningNoEffect + printLn bits16WideningNoEffect + printLn bits32WideningNoEffect + printLn narrowFromInteger + printLn narrowFromInt + printLn narrowFromBits64 + printLn narrowFromBits32 + printLn narrowFromBits16 + printLn negativeNumberCast diff --git a/tests/chez/chez029/expected b/tests/chez/chez029/expected index 458735ca0..f9be96a9f 100644 --- a/tests/chez/chez029/expected +++ b/tests/chez/chez029/expected @@ -1,11 +1,11 @@ +["123", "123", "123", "123", "123"] +["1234", "1234", "1234", "1234"] +["1234567", "1234567", "1234567"] +["134", "134", "134", "134"] +["134", "134", "134", "134"] +["134", "134", "134"] +["134", "134"] +["134"] +["237", "65517", "4294967277", "18446744073709551597"] 1/1: Building BitCasts (BitCasts.idr) -Main> ["123", "123", "123", "123", "123"] -Main> ["1234", "1234", "1234", "1234"] -Main> ["1234567", "1234567", "1234567"] -Main> ["134", "134", "134", "134"] -Main> ["134", "134", "134", "134"] -Main> ["134", "134", "134"] -Main> ["134", "134"] -Main> ["134"] -Main> ["237", "65517", "4294967277", "18446744073709551597"] -Main> Bye for now! +Main> Main> Bye for now! diff --git a/tests/chez/chez029/input b/tests/chez/chez029/input index bb7799aee..fc5992c29 100644 --- a/tests/chez/chez029/input +++ b/tests/chez/chez029/input @@ -1,10 +1,2 @@ -bits8WideningNoEffect -bits16WideningNoEffect -bits32WideningNoEffect -narrowFromInteger -narrowFromInt -narrowFromBits64 -narrowFromBits32 -narrowFromBits16 -negativeNumberCast +:exec main :q diff --git a/tests/chez/chez031/expected b/tests/chez/chez031/expected index 8fb7d88d0..d3308ccec 100644 --- a/tests/chez/chez031/expected +++ b/tests/chez/chez031/expected @@ -1,33 +1,29 @@ Error: The given specifier was not accepted by any backend. Available backends: - chez, racket, node, javascript, gambit + chez, racket, node, javascript, refc, gambit Some backends have additional specifier rules, refer to their documentation. -Specifiers.idr:29:1--34:5 +Specifiers.idr:29:1--30:35 29 | %foreign "scheme,racket:+" 30 | plusRacketFail : Int -> Int -> Int - 31 | - 32 | -- We don't actually do any printing this is just to use the specifiers so the - 33 | -- failures are exposed. - 34 | main : IO () Error: The given specifier was not accepted by any backend. Available backends: - chez, racket, node, javascript, gambit + chez, racket, node, javascript, refc, gambit Some backends have additional specifier rules, refer to their documentation. -Specifiers.idr:29:1--34:5 +Specifiers.idr:29:1--30:35 Main> Loaded file Specifiers.idr Specifiers> Error: The given specifier was not accepted by any backend. Available backends: - chez, racket, node, javascript, gambit + chez, racket, node, javascript, refc, gambit Some backends have additional specifier rules, refer to their documentation. -Specifiers.idr:29:1--34:5 +Specifiers.idr:29:1--30:35 Specifiers> [exec] Specifiers> Error: The given specifier was not accepted by any backend. Available backends: - chez, racket, node, javascript, gambit + chez, racket, node, javascript, refc, gambit Some backends have additional specifier rules, refer to their documentation. -Specifiers.idr:29:1--34:5 +Specifiers.idr:29:1--30:35 [exec] Specifiers> Bye for now! diff --git a/tests/ideMode/ideMode001/expected b/tests/ideMode/ideMode001/expected index d6eb41823..d721d95cf 100644 --- a/tests/ideMode/ideMode001/expected +++ b/tests/ideMode/ideMode001/expected @@ -2,13 +2,13 @@ 000038(:write-string "1/1: Building LocType (LocType.idr)" 1) 0000ca(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 23) (:end 7 24)) ((:name "x") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "a")))))) 1) 0000d9(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 38) (:end 7 40)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect m a)")))))) 1) -0000df(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 35) (:end 7 37)) ((:name "xs") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect {k:295} a)")))))) 1) -0000d3(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 9) (:end 7 10)) ((:name "x") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "?{_:296}_[]")))))) 1) -0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 14) (:end 7 16)) ((:name "xs") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{k:295}_[] ?{_:296}_[])")))))) 1) -0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 18) (:end 7 20)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:297}_[] ?{_:296}_[])")))))) 1) +0000df(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 35) (:end 7 37)) ((:name "xs") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect {k:372} a)")))))) 1) +0000d3(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 9) (:end 7 10)) ((:name "x") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "?{_:373}_[]")))))) 1) +0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 14) (:end 7 16)) ((:name "xs") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{k:372}_[] ?{_:373}_[])")))))) 1) +0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 18) (:end 7 20)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:374}_[] ?{_:373}_[])")))))) 1) 0000d9(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 16) (:end 6 18)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect m a)")))))) 1) -0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 11) (:end 6 13)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:286}_[] ?{_:285}_[])")))))) 1) -0001eb(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 1) (:end 6 7)) ((:name "Main.append") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "{0 m : Prelude.Types.Nat} -> {0 a : Type} -> {0 n : Prelude.Types.Nat} -> ({arg:276} : (Main.Vect n[0] a[1])) -> ({arg:277} : (Main.Vect m[3] a[2])) -> (Main.Vect (Prelude.Num.+ Prelude.Types.Nat Prelude.Types.Num implementation at Prelude/Types.idr:57:1--64:7 n[2] m[4]) a[3]))))))")))))) 1) +0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 11) (:end 6 13)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:363}_[] ?{_:362}_[])")))))) 1) +0001ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 1) (:end 5 48)) ((:name "Main.append") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "{0 m : Prelude.Types.Nat} -> {0 a : Type} -> {0 n : Prelude.Types.Nat} -> ({arg:353} : (Main.Vect n[0] a[1])) -> ({arg:354} : (Main.Vect m[3] a[2])) -> (Main.Vect (Prelude.Num.+ Prelude.Types.Nat Prelude.Types.Num implementation at Prelude/Types.idr:64:1--69:33 n[2] m[4]) a[3]))))))")))))) 1) 0000cc(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 47) (:end 5 48)) ((:name "a") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Type")))))) 1) 0000d9(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 44) (:end 5 45)) ((:name "m") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Prelude.Types.Nat")))))) 1) 0000d9(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 40) (:end 5 41)) ((:name "n") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Prelude.Types.Nat")))))) 1) diff --git a/tests/ideMode/ideMode003/expected b/tests/ideMode/ideMode003/expected index 3f8278cfb..c7a995d9f 100644 --- a/tests/ideMode/ideMode003/expected +++ b/tests/ideMode/ideMode003/expected @@ -2,13 +2,13 @@ 000038(:write-string "1/1: Building LocType (LocType.idr)" 1) 0000ca(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 23) (:end 7 24)) ((:name "x") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "a")))))) 1) 0000d9(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 38) (:end 7 40)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect m a)")))))) 1) -0000df(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 35) (:end 7 37)) ((:name "xs") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect {k:295} a)")))))) 1) -0000d3(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 9) (:end 7 10)) ((:name "x") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "?{_:296}_[]")))))) 1) -0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 14) (:end 7 16)) ((:name "xs") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{k:295}_[] ?{_:296}_[])")))))) 1) -0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 18) (:end 7 20)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:297}_[] ?{_:296}_[])")))))) 1) +0000df(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 35) (:end 7 37)) ((:name "xs") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect {k:372} a)")))))) 1) +0000d3(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 9) (:end 7 10)) ((:name "x") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "?{_:373}_[]")))))) 1) +0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 14) (:end 7 16)) ((:name "xs") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{k:372}_[] ?{_:373}_[])")))))) 1) +0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 18) (:end 7 20)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:374}_[] ?{_:373}_[])")))))) 1) 0000d9(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 16) (:end 6 18)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect m a)")))))) 1) -0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 11) (:end 6 13)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:286}_[] ?{_:285}_[])")))))) 1) -0001eb(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 1) (:end 6 7)) ((:name "Main.append") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "{0 m : Prelude.Types.Nat} -> {0 a : Type} -> {0 n : Prelude.Types.Nat} -> ({arg:276} : (Main.Vect n[0] a[1])) -> ({arg:277} : (Main.Vect m[3] a[2])) -> (Main.Vect (Prelude.Num.+ Prelude.Types.Nat Prelude.Types.Num implementation at Prelude/Types.idr:57:1--64:7 n[2] m[4]) a[3]))))))")))))) 1) +0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 11) (:end 6 13)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:363}_[] ?{_:362}_[])")))))) 1) +0001ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 1) (:end 5 48)) ((:name "Main.append") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "{0 m : Prelude.Types.Nat} -> {0 a : Type} -> {0 n : Prelude.Types.Nat} -> ({arg:353} : (Main.Vect n[0] a[1])) -> ({arg:354} : (Main.Vect m[3] a[2])) -> (Main.Vect (Prelude.Num.+ Prelude.Types.Nat Prelude.Types.Num implementation at Prelude/Types.idr:64:1--69:33 n[2] m[4]) a[3]))))))")))))) 1) 0000cc(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 47) (:end 5 48)) ((:name "a") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Type")))))) 1) 0000d9(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 44) (:end 5 45)) ((:name "m") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Prelude.Types.Nat")))))) 1) 0000d9(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 40) (:end 5 41)) ((:name "n") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Prelude.Types.Nat")))))) 1) diff --git a/tests/idris2/basic043/BitCasts.idr b/tests/idris2/basic043/BitCasts.idr index 1eb595bb0..fb23c838e 100644 --- a/tests/idris2/basic043/BitCasts.idr +++ b/tests/idris2/basic043/BitCasts.idr @@ -1,6 +1,6 @@ -- Tests to check that casting between integer types works as expected -- --- This tests in `idris2/basic043`, `chez/chez028` and `node/node022` are the +-- The tests in `idris2/basic043`, `chez/chez029` and `node/node022` are the -- same and should all have the same output. -- diff --git a/tests/idris2/basic044/expected b/tests/idris2/basic044/expected index 31af11911..ef874ccc9 100644 --- a/tests/idris2/basic044/expected +++ b/tests/idris2/basic044/expected @@ -98,7 +98,7 @@ Term> Bye for now! LOG declare.type:1: Processing Vec.Vec LOG declare.def:2: Case tree for Vec.Vec: [0] ({arg:N} : (Data.Fin.Fin {arg:N}[1])) -> {arg:N}[1]) LOG declare.type:1: Processing Vec.Nil -LOG declare.def:2: Case tree for Vec.Nil: [0] (Prelude.Uninhabited.absurd {arg:N}[0] ?Vec.{t:N}_[{arg:N}[0]] Data.Fin.Uninhabited implementation at Data/Fin.idr:19:1--24:7) +LOG declare.def:2: Case tree for Vec.Nil: [0] (Prelude.Uninhabited.absurd {arg:N}[0] ?Vec.{t:N}_[{arg:N}[0]] Data.Fin.Uninhabited implementation at Data/Fin.idr:19:1--22:32) LOG declare.type:1: Processing Vec.:: LOG declare.def:2: Case tree for Vec.::: case {arg:N}[4] : (Data.Fin.Fin (Prelude.Types.S {arg:N}[0])) of { Data.Fin.FZ {e:N} => [0] {arg:N}[3] diff --git a/tests/idris2/basic048/Module'.idr b/tests/idris2/basic048/Module'.idr new file mode 100644 index 000000000..33d33d30c --- /dev/null +++ b/tests/idris2/basic048/Module'.idr @@ -0,0 +1,7 @@ +module Module' + +function' : Int -> Int +function' x = x + 1 + +main : IO () +main = printLn . show $ function' 4 diff --git a/tests/idris2/basic048/expected b/tests/idris2/basic048/expected new file mode 100644 index 000000000..1e74b83ae --- /dev/null +++ b/tests/idris2/basic048/expected @@ -0,0 +1,7 @@ +1/1: Building Module' (Module'.idr) +Module'> 2 +Module'> Bye for now! +"5" +Module'> Loaded file Module'.idr +Module'> +Bye for now! diff --git a/tests/idris2/basic048/input b/tests/idris2/basic048/input new file mode 100644 index 000000000..441ce8daa --- /dev/null +++ b/tests/idris2/basic048/input @@ -0,0 +1,2 @@ +function' 1 +:q diff --git a/tests/idris2/basic048/input-ed b/tests/idris2/basic048/input-ed new file mode 100644 index 000000000..43e460ec6 --- /dev/null +++ b/tests/idris2/basic048/input-ed @@ -0,0 +1 @@ +:e diff --git a/tests/idris2/basic048/run b/tests/idris2/basic048/run new file mode 100644 index 000000000..558302c9e --- /dev/null +++ b/tests/idris2/basic048/run @@ -0,0 +1,5 @@ +$1 --no-banner --no-color --console-width 0 "Module'.idr" < input +$1 --exec main --cg ${IDRIS2_TESTS_CG} "Module'.idr" +EDITOR=true $1 --no-banner --no-color --console-width 0 "Module'.idr" < input-ed + +rm -rf build diff --git a/tests/idris2/coverage010/expected b/tests/idris2/coverage010/expected index f1ee8169c..f33573935 100644 --- a/tests/idris2/coverage010/expected +++ b/tests/idris2/coverage010/expected @@ -1,8 +1,9 @@ 1/1: Building casetot (casetot.idr) Error: main is not covering. -casetot.idr:12:1--13:5 +casetot.idr:12:1--12:13 + | 12 | main : IO () - 13 | main = do + | ^^^^^^^^^^^^ Calls non covering function Main.case block in case block in main diff --git a/tests/idris2/coverage011/Sing.idr b/tests/idris2/coverage011/Sing.idr new file mode 100644 index 000000000..959101e14 --- /dev/null +++ b/tests/idris2/coverage011/Sing.idr @@ -0,0 +1,13 @@ +module Sing + +%default total + +data Fing : Type -> Type where + StringFing : String -> Fing String + BoolFing : Bool -> Fing Bool + +stringFing : Fing String -> String +stringFing (StringFing s) = s + +boolFing : Fing Bool -> Bool +boolFing (BoolFing b) = b diff --git a/tests/idris2/coverage011/expected b/tests/idris2/coverage011/expected new file mode 100644 index 000000000..f35d0dff7 --- /dev/null +++ b/tests/idris2/coverage011/expected @@ -0,0 +1 @@ +1/1: Building Sing (Sing.idr) diff --git a/tests/idris2/coverage011/run b/tests/idris2/coverage011/run new file mode 100755 index 000000000..234b097cc --- /dev/null +++ b/tests/idris2/coverage011/run @@ -0,0 +1,3 @@ +$1 --no-color --console-width 0 --check Sing.idr + +rm -rf build diff --git a/tests/idris2/error004/expected b/tests/idris2/error004/expected index 8c07baf7d..6c5928f45 100644 --- a/tests/idris2/error004/expected +++ b/tests/idris2/error004/expected @@ -16,8 +16,8 @@ Error2.idr:13:38--13:45 | ^^^^^^^ Possible correct results: - Show implementation at Error2.idr:11:1--15:6 - Show implementation at Error2.idr:7:1--11:5 + Show implementation at Error2.idr:11:1--13:45 + Show implementation at Error2.idr:7:1--9:45 Error: While processing right hand side of wrong. Multiple solutions found in search of: Show (Vect 1 Integer) @@ -27,5 +27,5 @@ Error2.idr:16:9--16:34 | ^^^^^^^^^^^^^^^^^^^^^^^^^ Possible correct results: - Show implementation at Error2.idr:11:1--15:6 - Show implementation at Error2.idr:7:1--11:5 + Show implementation at Error2.idr:11:1--13:45 + Show implementation at Error2.idr:7:1--9:45 diff --git a/tests/idris2/error013/expected b/tests/idris2/error013/expected index a3c6ff619..fba1d1630 100644 --- a/tests/idris2/error013/expected +++ b/tests/idris2/error013/expected @@ -1,21 +1,22 @@ 1/1: Building Issue361 (Issue361.idr) -Error: main is not total, possibly not terminating due to recursive path Main.main -> Main.Eq implementation at Issue361.idr:5:1--7:5 -> Main.== -> Main./= -> Main.== +Error: main is not total, possibly not terminating due to recursive path Main.main -> Main.Eq implementation at Issue361.idr:5:1--5:11 -> Main.== -> Main./= -> Main.== -Issue361.idr:7:1--8:5 +Issue361.idr:7:1--7:13 + | 7 | main : IO () - 8 | main = printLn $ T == T + | ^^^^^^^^^^^^ Error: /= is not total, possibly not terminating due to recursive path Main./= -> Main.== -> Main./= -> Main.== -Issue361.idr:5:1--7:5 +Issue361.idr:5:1--5:11 + | 5 | Eq S where - 6 | - 7 | main : IO () + | ^^^^^^^^^^ Error: == is not total, possibly not terminating due to call to Main./= -Issue361.idr:5:1--7:5 +Issue361.idr:5:1--5:11 + | 5 | Eq S where - 6 | - 7 | main : IO () + | ^^^^^^^^^^ diff --git a/tests/idris2/error014/Issue735.idr b/tests/idris2/error014/Issue735.idr new file mode 100644 index 000000000..bb79733d8 --- /dev/null +++ b/tests/idris2/error014/Issue735.idr @@ -0,0 +1,13 @@ +module Issue735 + +-- Not allowed to pattern-match on under-applied constructors +isCons : (a -> List a -> List a) -> Bool +isCons (::) = True +isCons _ = False + +interface A a where + +-- Not allowed to pattern-match on under-applied type constructors +test : (kind : Type -> Type) -> Maybe Nat +test A = Just 1 +test _ = Nothing diff --git a/tests/idris2/error014/expected b/tests/idris2/error014/expected new file mode 100644 index 000000000..881c7243d --- /dev/null +++ b/tests/idris2/error014/expected @@ -0,0 +1,15 @@ +1/1: Building Issue735 (Issue735.idr) +Error: Constructor Prelude.Types.:: is not fully applied. + +Issue735.idr:5:8--5:12 + | + 5 | isCons (::) = True + | ^^^^ + +Error: Constructor Issue735.A is not fully applied. + +Issue735.idr:12:6--12:7 + | + 12 | test A = Just 1 + | ^ + diff --git a/tests/idris2/error014/run b/tests/idris2/error014/run new file mode 100755 index 000000000..ed404ba10 --- /dev/null +++ b/tests/idris2/error014/run @@ -0,0 +1,3 @@ +$1 --no-color --console-width 0 Issue735.idr --check + +rm -rf build/ \ No newline at end of file diff --git a/tests/idris2/evaluator004/Issue735.idr b/tests/idris2/evaluator004/Issue735.idr new file mode 100644 index 000000000..14f16f7a3 --- /dev/null +++ b/tests/idris2/evaluator004/Issue735.idr @@ -0,0 +1,13 @@ +interface Natty (n : Nat) where + +fromNatty : Type -> Nat +fromNatty (Natty Z) = Z +fromNatty (Natty (S n)) = S (fromNatty (Natty n)) +fromNatty _ = Z + +main : IO () +main = ignore $ traverse printLn + [ fromNatty (Natty 3) + , fromNatty (Natty (2 + 6)) + , fromNatty (List (Natty 1)) + ] diff --git a/tests/idris2/evaluator004/expected b/tests/idris2/evaluator004/expected new file mode 100644 index 000000000..cd02b26cc --- /dev/null +++ b/tests/idris2/evaluator004/expected @@ -0,0 +1,10 @@ +1/1: Building Issue735 (Issue735.idr) +Main> 0 +Main> 3 +Main> 0 +Main> 9 +Main> +Bye for now! +3 +8 +0 diff --git a/tests/idris2/evaluator004/input b/tests/idris2/evaluator004/input new file mode 100644 index 000000000..c05bdbf27 --- /dev/null +++ b/tests/idris2/evaluator004/input @@ -0,0 +1,5 @@ +fromNatty (Natty 0) +fromNatty (Natty 3) +fromNatty Nat +fromNatty (Natty (2 + 7)) +:q \ No newline at end of file diff --git a/tests/idris2/evaluator004/run b/tests/idris2/evaluator004/run new file mode 100644 index 000000000..6dbb56450 --- /dev/null +++ b/tests/idris2/evaluator004/run @@ -0,0 +1,4 @@ +$1 --no-banner --no-color --console-width 0 Issue735.idr < input +$1 --exec main --cg ${IDRIS2_TESTS_CG} Issue735.idr + +rm -rf build diff --git a/tests/idris2/interface016/expected b/tests/idris2/interface016/expected index 9b8348055..d34d15911 100644 --- a/tests/idris2/interface016/expected +++ b/tests/idris2/interface016/expected @@ -9,4 +9,4 @@ TwoNum.idr:4:7--4:8 Possible correct results: conArg (implicitly bound at TwoNum.idr:4:3--4:8) - conArg (implicitly bound at TwoNum.idr:2:1--5:1) + conArg (implicitly bound at TwoNum.idr:2:1--4:8) diff --git a/tests/idris2/linear007/expected b/tests/idris2/linear007/expected index 45536151a..e10d0652b 100644 --- a/tests/idris2/linear007/expected +++ b/tests/idris2/linear007/expected @@ -1,10 +1,9 @@ 1/1: Building LCase (LCase.idr) Error: While processing right hand side of foo. There are 0 uses of linear name y. -LCase.idr:7:11--10:15 - 07 | = let 1 test = the Nat $ case z of - 08 | Z => Z - 09 | (S k) => S z - 10 | in +LCase.idr:7:11--9:37 + 7 | = let 1 test = the Nat $ case z of + 8 | Z => Z + 9 | (S k) => S z Suggestion: linearly bounded variables must be used exactly once. diff --git a/tests/idris2/literate016/IEdit.org b/tests/idris2/literate016/IEdit.org new file mode 100644 index 000000000..0f0028e22 --- /dev/null +++ b/tests/idris2/literate016/IEdit.org @@ -0,0 +1,31 @@ +#+TITLE: Interactive Editing Working +#+Date: 11/22/2020 + +#+begin_src idris +data Vect : Nat -> Type -> Type where + Nil : Vect Z a + (::) : a -> Vect k a -> Vect (S k) a +#+end_src + +#+IDRIS: %name Vect xs, ys, zs + +#+begin_src idris +append : Vect n a -> Vect m a -> Vect (n + m) a +append {n} xs ys = ?foo +#+end_src + +#+begin_src idris +vadd : Num a => Vect n a -> Vect n a -> Vect n a +vadd [] ys = ?bar +vadd (x :: xs) ys = ?baz +#+end_src + +#+begin_src idris +suc : (x : Nat) -> (y : Nat) -> x = y -> S x = S y +suc x y prf = ?quux +#+end_src + +#+begin_src idris +suc' : x = y -> S x = S y +suc' {x} {y} prf = ?quuz +#+end_src diff --git a/tests/idris2/literate016/IEdit2.org b/tests/idris2/literate016/IEdit2.org new file mode 100644 index 000000000..6178fa019 --- /dev/null +++ b/tests/idris2/literate016/IEdit2.org @@ -0,0 +1,31 @@ +#+TITLE: Interactive Editing Working + +#+begin_src idris +data Vect : Nat -> Type -> Type where + Nil : Vect Z a + (::) : a -> Vect k a -> Vect (S k) a +#+end_src + +#+IDRIS: %name Vect xs, ys, zs + +#+begin_src idris +append : Vect n a -> Vect m a -> Vect (n + m) a +append {n = Z} [] ys = ?foo_1 +append {n = (S k)} (x :: xs) ys = ?foo_2 +#+end_src + +#+begin_src idris +vadd : Num a => Vect n a -> Vect n a -> Vect n a +vadd [] [] = ?bar_1 +vadd (x :: xs) (y :: ys) = ?baz_1 +#+end_src + +#+begin_src idris +suc : (x : Nat) -> (y : Nat) -> x = y -> S x = S y +suc x x Refl = ?quux_1 +#+end_src + +#+begin_src idris +suc' : x = y -> S x = S y +suc' {x = y} {y = y} Refl = ?quuz_1 +#+end_src diff --git a/tests/idris2/literate016/expected b/tests/idris2/literate016/expected new file mode 100644 index 000000000..668aec99b --- /dev/null +++ b/tests/idris2/literate016/expected @@ -0,0 +1,8 @@ +1/1: Building IEdit (IEdit.org) +Main> append {n = 0} [] ys = ?foo_1 +append {n = (S k)} (x :: xs) ys = ?foo_2 +Main> vadd [] [] = ?bar_1 +Main> vadd (x :: xs) (y :: ys) = ?baz_1 +Main> suc x x Refl = ?quux_1 +Main> suc' {x = y} {y = y} Refl = ?quuz_1 +Main> Bye for now! diff --git a/tests/idris2/literate016/input b/tests/idris2/literate016/input new file mode 100644 index 000000000..424c79c7d --- /dev/null +++ b/tests/idris2/literate016/input @@ -0,0 +1,6 @@ +:cs 14 11 xs +:cs 19 8 ys +:cs 20 15 ys +:cs 25 8 prf +:cs 30 13 prf +:q diff --git a/tests/idris2/literate016/run b/tests/idris2/literate016/run new file mode 100755 index 000000000..a7f2e2344 --- /dev/null +++ b/tests/idris2/literate016/run @@ -0,0 +1,3 @@ +$1 --no-color --console-width 0 --no-banner IEdit.org < input + +rm -rf build diff --git a/tests/idris2/namespace001/expected b/tests/idris2/namespace001/expected index 99710e1f0..03082ef20 100644 --- a/tests/idris2/namespace001/expected +++ b/tests/idris2/namespace001/expected @@ -1,7 +1,7 @@ 1/1: Building Dup (Dup.idr) Error: Main.Test is already defined. -Dup.idr:13:1--15:1 +Dup.idr:13:1--14:18 13 | private 14 | data Test = A | B diff --git a/tests/idris2/perf006/Issue775.idr b/tests/idris2/perf006/Issue775.idr new file mode 100644 index 000000000..675fb26d2 --- /dev/null +++ b/tests/idris2/perf006/Issue775.idr @@ -0,0 +1,4 @@ +main : IO () +main = do + printLn $ the Nat $ fromInteger (-1) + printLn $ the Nat $ fromInteger 1000000000 diff --git a/tests/idris2/perf006/expected b/tests/idris2/perf006/expected new file mode 100644 index 000000000..10a56449e --- /dev/null +++ b/tests/idris2/perf006/expected @@ -0,0 +1,2 @@ +0 +1000000000 diff --git a/tests/idris2/perf006/run b/tests/idris2/perf006/run new file mode 100644 index 000000000..d318ed37e --- /dev/null +++ b/tests/idris2/perf006/run @@ -0,0 +1,3 @@ +$1 --exec main --cg ${IDRIS2_TESTS_CG} Issue775.idr + +rm -rf build diff --git a/tests/idris2/positivity004/Issue524.idr b/tests/idris2/positivity004/Issue524.idr new file mode 100644 index 000000000..783a90dcf --- /dev/null +++ b/tests/idris2/positivity004/Issue524.idr @@ -0,0 +1,18 @@ +module Issue524 + +%logging totality 20 + +data Bad = MkBad (Not Bad) + +hmmm : Bad -> Not Bad +hmmm (MkBad n) = n + +ok : Not Bad +ok bad = hmmm bad bad + +bad : Bad +bad = MkBad ok + +total +ohno : Void +ohno = ok bad diff --git a/tests/idris2/positivity004/expected b/tests/idris2/positivity004/expected new file mode 100644 index 000000000..93ee994fa --- /dev/null +++ b/tests/idris2/positivity004/expected @@ -0,0 +1 @@ +1/1: Building Issue524 (Issue524.idr) diff --git a/tests/idris2/positivity004/run b/tests/idris2/positivity004/run new file mode 100644 index 000000000..a1c6501fb --- /dev/null +++ b/tests/idris2/positivity004/run @@ -0,0 +1,3 @@ +$1 --no-banner --no-color --console-width 0 Issue524.idr --check + +rm -rf build \ No newline at end of file diff --git a/tests/idris2/reflection001/expected b/tests/idris2/reflection001/expected index d6aa04430..88e7ec4b6 100644 --- a/tests/idris2/reflection001/expected +++ b/tests/idris2/reflection001/expected @@ -23,7 +23,7 @@ quote.idr:37:1--37:21 Main> IApp (MkFC "quote.idr" (3, 12) (3, 23)) (IApp (MkFC "quote.idr" (3, 12) (3, 23)) (IVar (MkFC "quote.idr" (3, 12) (3, 23)) (UN "+")) (IApp (MkFC "quote.idr" (6, 13) (6, 14)) (IVar (MkFC "quote.idr" (6, 13) (6, 14)) (UN "fromInteger")) (IPrimVal (MkFC "quote.idr" (6, 13) (6, 14)) (BI 3)))) (IApp (MkFC "quote.idr" (6, 18) (6, 19)) (IVar (MkFC "quote.idr" (6, 18) (6, 19)) (UN "fromInteger")) (IPrimVal (MkFC "quote.idr" (6, 18) (6, 19)) (BI 4))) Main> IApp (MkFC "quote.idr" (3, 12) (3, 23)) (IApp (MkFC "quote.idr" (3, 12) (3, 23)) (IVar (MkFC "quote.idr" (3, 12) (3, 23)) (UN "+")) (IVar (MkFC "(interactive)" (0, 6) (0, 10)) (UN "True"))) (IVar (MkFC "(interactive)" (0, 14) (0, 19)) (UN "False")) -Main> ILocal (MkFC "quote.idr" (10, 12) (11, 32)) [IClaim (MkFC "quote.idr" (10, 12) (11, 15)) MW Private [] (MkTy (MkFC "quote.idr" (10, 12) (10, 28)) (UN "xfn") (IPi (MkFC "quote.idr" (10, 18) (10, 21)) MW ExplicitArg Nothing (IPrimVal (MkFC "quote.idr" (10, 18) (10, 21)) IntType) (IPrimVal (MkFC "quote.idr" (10, 25) (10, 28)) IntType))), IDef (MkFC "quote.idr" (11, 12) (11, 29)) (UN "xfn") [PatClause (MkFC "quote.idr" (11, 12) (11, 29)) (IApp (MkFC "quote.idr" (11, 12) (11, 19)) (IVar (MkFC "quote.idr" (11, 12) (11, 15)) (UN "xfn")) (IBindVar (MkFC "quote.idr" (11, 16) (11, 19)) "var")) (IApp (MkFC "quote.idr" (11, 22) (11, 29)) (IApp (MkFC "quote.idr" (11, 22) (11, 29)) (IVar (MkFC "quote.idr" (11, 22) (11, 29)) (UN "*")) (IVar (MkFC "quote.idr" (11, 22) (11, 25)) (UN "var"))) (IApp (MkFC "quote.idr" (11, 28) (11, 29)) (IVar (MkFC "quote.idr" (11, 28) (11, 29)) (UN "fromInteger")) (IPrimVal (MkFC "quote.idr" (11, 28) (11, 29)) (BI 2))))]] (IApp (MkFC "quote.idr" (12, 12) (12, 22)) (IVar (MkFC "quote.idr" (12, 12) (12, 15)) (UN "xfn")) (IApp (MkFC "(interactive)" (0, 9) (0, 22)) (IApp (MkFC "(interactive)" (0, 9) (0, 22)) (IVar (MkFC "(interactive)" (0, 9) (0, 12)) (UN "the")) (IPrimVal (MkFC "(interactive)" (0, 13) (0, 16)) IntType)) (IApp (MkFC "(interactive)" (0, 17) (0, 22)) (IVar (MkFC "(interactive)" (0, 17) (0, 22)) (UN "fromInteger")) (IPrimVal (MkFC "(interactive)" (0, 17) (0, 22)) (BI 99994))))) -Main> ILocal (MkFC "quote.idr" (16, 12) (17, 32)) [IClaim (MkFC "quote.idr" (16, 12) (17, 15)) MW Private [] (MkTy (MkFC "quote.idr" (16, 12) (16, 28)) (UN "xfn") (IPi (MkFC "quote.idr" (16, 18) (16, 21)) MW ExplicitArg Nothing (IPrimVal (MkFC "quote.idr" (16, 18) (16, 21)) IntType) (IPrimVal (MkFC "quote.idr" (16, 25) (16, 28)) IntType))), IDef (MkFC "quote.idr" (17, 12) (17, 29)) (UN "xfn") [PatClause (MkFC "quote.idr" (17, 12) (17, 29)) (IApp (MkFC "quote.idr" (17, 12) (17, 19)) (IVar (MkFC "quote.idr" (17, 12) (17, 15)) (UN "xfn")) (IBindVar (MkFC "quote.idr" (17, 16) (17, 19)) "var")) (IApp (MkFC "quote.idr" (17, 22) (17, 29)) (IApp (MkFC "quote.idr" (17, 22) (17, 29)) (IVar (MkFC "quote.idr" (17, 22) (17, 29)) (UN "*")) (IVar (MkFC "quote.idr" (17, 22) (17, 25)) (UN "var"))) (IApp (MkFC "quote.idr" (17, 28) (17, 29)) (IVar (MkFC "quote.idr" (17, 28) (17, 29)) (UN "fromInteger")) (IPrimVal (MkFC "quote.idr" (17, 28) (17, 29)) (BI 2))))]] (IApp (MkFC "quote.idr" (18, 12) (18, 43)) (IVar (MkFC "quote.idr" (18, 12) (18, 15)) (UN "xfn")) (IPrimVal EmptyFC (I 99994))) +Main> ILocal (MkFC "quote.idr" (10, 12) (11, 29)) [IClaim (MkFC "quote.idr" (10, 12) (10, 28)) MW Private [] (MkTy (MkFC "quote.idr" (10, 12) (10, 28)) (UN "xfn") (IPi (MkFC "quote.idr" (10, 18) (10, 21)) MW ExplicitArg Nothing (IPrimVal (MkFC "quote.idr" (10, 18) (10, 21)) IntType) (IPrimVal (MkFC "quote.idr" (10, 25) (10, 28)) IntType))), IDef (MkFC "quote.idr" (11, 12) (11, 29)) (UN "xfn") [PatClause (MkFC "quote.idr" (11, 12) (11, 29)) (IApp (MkFC "quote.idr" (11, 12) (11, 19)) (IVar (MkFC "quote.idr" (11, 12) (11, 15)) (UN "xfn")) (IBindVar (MkFC "quote.idr" (11, 16) (11, 19)) "var")) (IApp (MkFC "quote.idr" (11, 22) (11, 29)) (IApp (MkFC "quote.idr" (11, 22) (11, 29)) (IVar (MkFC "quote.idr" (11, 22) (11, 29)) (UN "*")) (IVar (MkFC "quote.idr" (11, 22) (11, 25)) (UN "var"))) (IApp (MkFC "quote.idr" (11, 28) (11, 29)) (IVar (MkFC "quote.idr" (11, 28) (11, 29)) (UN "fromInteger")) (IPrimVal (MkFC "quote.idr" (11, 28) (11, 29)) (BI 2))))]] (IApp (MkFC "quote.idr" (12, 12) (12, 22)) (IVar (MkFC "quote.idr" (12, 12) (12, 15)) (UN "xfn")) (IApp (MkFC "(interactive)" (0, 9) (0, 22)) (IApp (MkFC "(interactive)" (0, 9) (0, 22)) (IVar (MkFC "(interactive)" (0, 9) (0, 12)) (UN "the")) (IPrimVal (MkFC "(interactive)" (0, 13) (0, 16)) IntType)) (IApp (MkFC "(interactive)" (0, 17) (0, 22)) (IVar (MkFC "(interactive)" (0, 17) (0, 22)) (UN "fromInteger")) (IPrimVal (MkFC "(interactive)" (0, 17) (0, 22)) (BI 99994))))) +Main> ILocal (MkFC "quote.idr" (16, 12) (17, 29)) [IClaim (MkFC "quote.idr" (16, 12) (16, 28)) MW Private [] (MkTy (MkFC "quote.idr" (16, 12) (16, 28)) (UN "xfn") (IPi (MkFC "quote.idr" (16, 18) (16, 21)) MW ExplicitArg Nothing (IPrimVal (MkFC "quote.idr" (16, 18) (16, 21)) IntType) (IPrimVal (MkFC "quote.idr" (16, 25) (16, 28)) IntType))), IDef (MkFC "quote.idr" (17, 12) (17, 29)) (UN "xfn") [PatClause (MkFC "quote.idr" (17, 12) (17, 29)) (IApp (MkFC "quote.idr" (17, 12) (17, 19)) (IVar (MkFC "quote.idr" (17, 12) (17, 15)) (UN "xfn")) (IBindVar (MkFC "quote.idr" (17, 16) (17, 19)) "var")) (IApp (MkFC "quote.idr" (17, 22) (17, 29)) (IApp (MkFC "quote.idr" (17, 22) (17, 29)) (IVar (MkFC "quote.idr" (17, 22) (17, 29)) (UN "*")) (IVar (MkFC "quote.idr" (17, 22) (17, 25)) (UN "var"))) (IApp (MkFC "quote.idr" (17, 28) (17, 29)) (IVar (MkFC "quote.idr" (17, 28) (17, 29)) (UN "fromInteger")) (IPrimVal (MkFC "quote.idr" (17, 28) (17, 29)) (BI 2))))]] (IApp (MkFC "quote.idr" (18, 12) (18, 43)) (IVar (MkFC "quote.idr" (18, 12) (18, 15)) (UN "xfn")) (IPrimVal EmptyFC (I 99994))) Main> [UN "names", NS (MkNS ["Prelude"]) (UN "+")] Main> Bye for now! diff --git a/tests/idris2/reg013/expected b/tests/idris2/reg013/expected index 27292d8ff..f85e0fcdf 100644 --- a/tests/idris2/reg013/expected +++ b/tests/idris2/reg013/expected @@ -20,7 +20,7 @@ UnboundImplicits.idr:14:25--14:26 14 | interface Foo (a : Vect n Nat) where | ^ -Error: While processing type of Functor implementation at UnboundImplicits.idr:17:1--18:1. Undefined name n. +Error: While processing type of Functor implementation at UnboundImplicits.idr:17:1--17:38. Undefined name n. UnboundImplicits.idr:17:30--17:31 | diff --git a/tests/idris2/total007/expected b/tests/idris2/total007/expected index c0ee71dfd..25b7d6520 100644 --- a/tests/idris2/total007/expected +++ b/tests/idris2/total007/expected @@ -1,18 +1,16 @@ 1/1: Building partial (partial.idr) Error: foo is not covering. -partial.idr:5:1--7:4 +partial.idr:5:1--6:19 5 | total 6 | foo : Maybe a -> a - 7 | foo (Just x) = x Missing cases: foo Nothing Error: qsortBad is not total, possibly not terminating due to recursive path Main.qsortBad -> Main.qsortBad -> Main.qsortBad -partial.idr:13:1--15:9 +partial.idr:13:1--14:37 13 | total 14 | qsortBad : Ord a => List a -> List a - 15 | qsortBad [] = [] diff --git a/tests/idris2/total008/expected b/tests/idris2/total008/expected index 292ddd3ed..81817c625 100644 --- a/tests/idris2/total008/expected +++ b/tests/idris2/total008/expected @@ -1,7 +1,7 @@ 1/1: Building partial (partial.idr) Error: foo is not covering. -partial.idr:11:1--13:1 +partial.idr:11:1--12:19 11 | Foo (Maybe Int) where 12 | foo Nothing = () diff --git a/tests/node/node022/BitCasts.idr b/tests/node/node022/BitCasts.idr index 1eb595bb0..bf0fe0344 100644 --- a/tests/node/node022/BitCasts.idr +++ b/tests/node/node022/BitCasts.idr @@ -1,6 +1,6 @@ -- Tests to check that casting between integer types works as expected -- --- This tests in `idris2/basic043`, `chez/chez028` and `node/node022` are the +-- The tests in `idris2/basic043`, `chez/chez029` and `node/node022` are the -- same and should all have the same output. -- @@ -93,3 +93,19 @@ negativeNumberCast = [ show $ cast {to = Bits32} (-19), show $ cast {to = Bits64} (-19) ] + +-- +-- Run via code generator +-- + +main : IO () +main = do + printLn bits8WideningNoEffect + printLn bits16WideningNoEffect + printLn bits32WideningNoEffect + printLn narrowFromInteger + printLn narrowFromInt + printLn narrowFromBits64 + printLn narrowFromBits32 + printLn narrowFromBits16 + printLn negativeNumberCast diff --git a/tests/node/node022/expected b/tests/node/node022/expected index 458735ca0..f9be96a9f 100644 --- a/tests/node/node022/expected +++ b/tests/node/node022/expected @@ -1,11 +1,11 @@ +["123", "123", "123", "123", "123"] +["1234", "1234", "1234", "1234"] +["1234567", "1234567", "1234567"] +["134", "134", "134", "134"] +["134", "134", "134", "134"] +["134", "134", "134"] +["134", "134"] +["134"] +["237", "65517", "4294967277", "18446744073709551597"] 1/1: Building BitCasts (BitCasts.idr) -Main> ["123", "123", "123", "123", "123"] -Main> ["1234", "1234", "1234", "1234"] -Main> ["1234567", "1234567", "1234567"] -Main> ["134", "134", "134", "134"] -Main> ["134", "134", "134", "134"] -Main> ["134", "134", "134"] -Main> ["134", "134"] -Main> ["134"] -Main> ["237", "65517", "4294967277", "18446744073709551597"] -Main> Bye for now! +Main> Main> Bye for now! diff --git a/tests/node/node022/input b/tests/node/node022/input index bb7799aee..fc5992c29 100644 --- a/tests/node/node022/input +++ b/tests/node/node022/input @@ -1,10 +1,2 @@ -bits8WideningNoEffect -bits16WideningNoEffect -bits32WideningNoEffect -narrowFromInteger -narrowFromInt -narrowFromBits64 -narrowFromBits32 -narrowFromBits16 -negativeNumberCast +:exec main :q diff --git a/tests/node/tailrec001/expected b/tests/node/tailrec001/expected index b4e718937..5ab14ec0f 100644 --- a/tests/node/tailrec001/expected +++ b/tests/node/tailrec001/expected @@ -1,3 +1,4 @@ 93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000 28462596809170545189064132121198688901480514017027992307941799942744113400037644437729907867577847758158840621423175288300423399401535187390524211613827161748198241998275924182892597878981242531205946599625986706560161572036032397926328736717055741975962099479720346153698119897092611277500484198845410475544642442136573303076703628825803548967461117097369578603670191071512730587281041158640561281165385325968425825995584688146430425589836649317059251717204276597407446133400054194052462303436869154059404066227828248371512038322178644627183822923899638992827221879702459387693803094627332292570555459690027875282242544348021127559019169425429028916907219097083690539873747452483372899521802363282741217040268086769210451555840567172555372015852132829034279989818449313610640381489304499621599999359670892980190336998484404665419236258424947163178961192041233108268651071354516845540936033009607210346944377982349430780626069422302681885227592057029230843126188497606560742586279448827155956831533440534425446648416894580425709461673613187605234982286326452921529423479870603344290737158688499178932580691483168854251956006172372636323974420786924642956012306288720122652952964091508301336630982733806353972901506581822574295475894399765113865541208125788683704239208764484761569001264889271590706306409661628038784044485191643790807186112370622133415415065991843875961023926713276546986163657706626438638029848051952769536195259240930908614471907390768585755934786981720734372093104825475628567777694081564074962275254993384112809289637516990219870492405617531786346939798024619737079041868329931016554150742308393176878366923694849025999607729684293977427536263119825416681531891763234839190821000147178932184227805135181734921901146246875769835373441456013122615221391178759688367364087207937002992038279198038702372078039140312368997608152840306051116709484722224870389199993442071395836983063962232079115624044250808919914319837120445598344047556759489212101498152454543594285414390843564419984224855478532163624030098442855331829253154206551237079705816393460296247697010388742206441536626733715428700789122749340684336442889847100840641600093623935261248037975293343928764398316390312776450722479267851700826669598389526150759007349215197592659192708873202594066382118801988854748266048342256457705743973122259700671936061763513579529821794290797705327283267501488024443528681645026165662837546519006171873442260438919298506071515390031106684727360135816706437861756757439184376479658136100599638689552334648781746143243573224864326798481981458432703035895508420534788493364582482592033288089025782388233265770205248970937047210214248413342465268206806732314214483854074182139621846870108359582946965235632764870475718351616879235068366271743711915723361143070121120767608697851559721846485985918643641716850899625516820910793570231118518174775010804622585521314764897490660752877082897667514951009682329689732000622392888056658036140311285465929084078033974900664953205873164948093883816198658850827382468034897864757116679890423568018303504133875731972630897909435710687797301633918087868474943633533893373586906405848417828065196275826434429258058422212947649402948622670761832988229004072390403733168207417413251656688443079339447019208905620788387585342512820957359307018197708340163817638278562539516825426644614941044711579533262372815468794080423718587423026200264221822694188626212107297776657401018376182280136857586442185863011539843712299107010094061929413223202773193959467006713695377097897778118288242442920864816134179562017471831609687661043140497958198236445807368209404022211181530051433387076607063149616107771117448059552764348333385744040212757031851527298377435921878558552795591028664457917362007221858143309977294778923720717942857756271300923982397921957581197264742642878266682353915687857271620146192244266266708400765665625807109474398740110772811669918806268726626565583345665007890309050656074633078027158530817691223772813510584527326591626219647620571434880215630815259005343721141000303039242866457207328473481712034168186328968865048287367933398443971236735084527340196309427697652684170174990756947982757825835229994315633322107439131550124459005324702680312912392297979030417587823398622373535054642646913502503951009239286585108682088070662734733200354995720397086488066040929854607006339409885836349865466136727880748764700702458790118046518296111277090609016152022111461543158317669957060974618085359390400067892878548827850938637353703904049412684618991272871562655001270833039950257879931705431882752659225814948950746639976007316927310831735883056612614782997663188070063044632429112260691931278881566221591523270457695867512821990938942686601963904489718918597472925310322480210543841044325828472830584297804162405108110326914001900568784396341502696521048920272140232160234898588827371428695339681755106287470907473718188014223487248498558198439094651708364368994306189650243288353279667190184527620551085707626204244509623323204744707831190434499351442625501701771017379551124746159471731862701565571266295855125077711738338208419705893367323724453280456537178514960308802580284067847809414641838659226652806867978843250660537943046250287105104929347267471267499892634627358167146935060495110340755404658170393481046758485625967767959768299409334026387269378365320912287718077451152622642548771835461108886360843272806227776643097283879056728618036048633464893371439415250259459652501520959536157977135595794965729775650902694428088479761276664847003619648906043761934694270444070215317943583831051404915462608728486678750541674146731648999356381312866931427616863537305634586626957894568275065810235950814888778955073939365341937365700848318504475682215444067599203138077073539978036339267334549549296668759922530893898086430606532961793164029612492673080638031873912596151131890359351266480818568366770286537742390746582390910955517179770580797789289752490230737801753142680363914244720257728891784950078117889336629750436804214668197824272980697579391742229456683185815676816288797870624531246651727622758295493421483658868919299587402095696000243560305289829866386892076992834030549710266514322306125231915131843876903823706205399206933943716880466429711476743564486375026847698148853105354063328845062012173302630676481322931561043551941761050712449024873277273112091945865137493190965162497691657553812198566432207978666300398938660238607357858114394715872800893374165033792965832618436073133327526023605115524227228447251463863269369763762510196714380125691227784428426999440829152215904694437282498658085205186576292992775508833128672638418713277780874446643875352644733562441139447628780974650683952982108174967958836452273344694873793471790710064978236466016680572034297929207446822322848665839522211446859572858403863377278030227591530497865873919513650246274195899088374387331594287372029770620207120213038572175933211162413330422773742416353553587977065309647685886077301432778290328894795818404378858567772932094476778669357537460048142376741194182671636870481056911156215614357516290527351224350080604653668917458196549482608612260750293062761478813268955280736149022525819682815051033318132129659664958159030421238775645990973296728066683849166257949747922905361845563741034791430771561168650484292490281102992529678735298767829269040788778480262479222750735948405817439086251877946890045942060168605142772244486272469911146200149880662723538837809380628544384763053235070132028029488392008132135446450056134987017834271106158177289819290656498688081045562233703067254251277277330283498433595772575956224703707793387146593033088629699440318332665797514676502717346298883777397848218700718026741265997158728035440478432478674907127921672898523588486943546692255101337606377915164597254257116968477339951158998349081888281263984400505546210066988792614558214565319696909827253934515760408613476258778165867294410775358824162315779082538054746933540582469717674324523451498483027170396543887737637358191736582454273347490424262946011299881916563713847111849156915054768140411749801454265712394204425441028075806001388198650613759288539038922644322947990286482840099598675963580999112695367601527173086852756572147583507122298296529564917835071750835741362282545055620270969417476799259229774888627411314587676147531456895328093117052696486410187407673296986649236437382565475022816471926815559883196629848307776666840622314315884384910519058281816740764463033300119710293036455866594651869074475250837841987622990415911793682799760654186088721626654886492344391030923256910633775969739051781122764668486791736049404393703339351900609387268397299246478483727274770977466693599784857120156789000241947269220974984127323147401549980920381459821416481176357147801554231599667838534854486406936410556913531335231184053581348940938191821898694825383960989942822027599339635206217705343572073396250574216769465101608495601439303244304271576099527308684609204422226103154229984444802110098161333824827375218998738205315164927134498105950159974800571591912202154487748750103473246190633941303030892399411985006225902184164409988173214324422108554248620896250260604398180189026317781146617454999771440665232863846363847001655618153861098188111181734191305505024860345856755585637511729774299329074944236579668332700918367338977347901759248885660379952771540569083017311723894140326159612292912225191095948743805673381278538616491842786938417556898047100859868372033615175158097022566275200160956192229925401759878522038545913771783976389811198485803291048751666921195104514896677761598249468727420663437593207852618922687285527671324883267794152912839165407968344190239094803676688707838011367042753971396201424784935196735301444404037823526674437556740883025225745273806209980451233188102729012042997989005423126217968135237758041162511459175993279134176507292826762236897291960528289675223521425234217247841869317397460411877634604625637135309801590617736758715336803958559054827361876112151384673432884325090045645358186681905108731791346215730339540580987172013844377099279532797675531099381365840403556795731894141976511436325526270639743146526348120032720096755667701926242585057770617893798231096986788448546659527327061670308918277206432551919393673591346037757083193180845929565158875244597601729455720505595085929175506510115665075521635142318153548176884196032085050871496270494017684183980582594038182593986461260275954247433376226256287153916069025098985070798660621732200163593938611475394561406635675718526617031471453516753007499213865207768523824884600623735896608054951652406480547295869918694358811197833680141488078321213457152360124065922208508912956907835370576734671667863780908811283450395784812212101117250718383359083886187574661201317298217131072944737656265172310694884425498369514147383892477742320940207831200807235326288053906266018186050424938788677872495503255424284226596271050692646071767467502337805671893450110737377034119346113374033865364675136733661394731550211457104671161445253324850197901083431641989998414045044901130163759520675715567509485243580269104077637210998671624254795385312852889930956570729218673523216666097874989635362610529821472569482799996220825775840988458484250391189447608729685184983976367918242266571167166580157914500811657192200233759765317495922397884982814705506190689275625210462185661305800255607974609726715033327032310025274640428755556546883765838802543227403507431684278620637697054791726484378174446361520570933228587284315690756255569305558818822603590006739339952504379887470935079276181116276309771257983975996526612120317495882059435754883862282508401408885720583992400971219212548074097752974278775912566026443482713647231849125180866278708626116699989634812405803684794587364820124653663228889011636572270887757736152003450102268890189101673572058661410011723664762657835396364297819011647056170279631922332294228739309233330748258937626198997596530084135383241125899639629445129082802023225498936627506499530838925632246794695960669046906686292645006219740121782899872979704859021775060092893328957272392019589994471945147360850770400725717439318148461909406269545285030526341000565022226152309364882887122046454267700577148994335147162504252365173710266068647253458120186683273953682547456536553597546685788700056988360286686450740256993087483441094086086303707908295240576731684941855810482475304758923392801571302824106234999945932390521409856559565661346003396150515164758852742214732517999548977992849522746029855666700811871200856155016457400484170210303038996339253337466556817824410737409336919294104632307731994759826307383499600770372410446285414648704116273895649834555162165685114551383822047005483996671706246467566101291382048909121117229386244253158913066987462045587244806052829378148302622164542280421757760762365459828223070815503469404938317755053305094698999476119419231280721807216964378433313606760676965187138394338772485493689061845700572043696666465080734495814495966306246698679832872586300064215220210171813917325275173672262621454945468506006334692713838311715849753092643252486960220059099802663765386225463265168414963306369548086551101256757717890616694758344043486218485369591602172030456183497524162039926441331651884768606830642004858557924473340290142588876403712518642229016333691585063273727199596362912783344786218887871009533753551054688980236378263714926913289564339440899470121452134572117715657591451734895195016800621353927175419843876163543479806920886666227099512371706241924914282576453125769939735341673046864585181979668232015693792684926999983992413571941496882273704022820805171808003400480615261792013978945186295290558440703738300533552421153903385185829366779190610116306233673144419202893857201855569596330833615450290424822309297087124788002017383072060482680156675397593789931793515799958929562156307338416294599900276730832827716595064217966523190439250543226753731811755315476780739470338931185107297724318378972674957455778183345495942317353558291046967315391275975687281861691161083156337232639968881490543943261197182274996791176628553401860198315809629981791107208804992292016062059067271273599461871634945774995805337947187105456452579396024210259136415528398395201773012712514892051061708228008339985665786646920737114269682301770416324829479409558694699089379165191006305185352102345189798127619143061864362703081977124992751056732909481202057747100687703379708934229207183903744167503493818836342229284946790660285674293251642569044363473087656797056595677285291081242733154406580199802711579126254172797452862574865921933293805915239524735518887119860391319654287576290190503964083560246277534314409155642181729459941596061979622633242715863425977947348682074802021538734729707999753332987785531053820162169791880380753006334350766147737135939362651905222242528141084747045295688647757913502160922040348449149950778743107189655725492651282693489515795075486172341394610365176616750329948642244039659511882264981315925080185126386635308622223491094629059317829408195640484702456538305432056506924422671863255307640761872086780391711356363501269525091291020496042823232628996502758951052844368177415730941874894428065427561430975828127698124936993313028946670560414084308942231140912722238148470364341019630413630736771060038159590829746410114421358321042574358350220737173219745089035573187350445827238770728271406162997919629357224104477155051652535867544109395079218369015261138440382680054150924346511711436477899444553993653667727589565713987505542990824585609510036934663100673714708029927656933435500927189854050109917474979991554392031908961967615444686048175400695689471463928245383807010444181045506171305160584355817521032338465829201071030061124283407458607006060194830551364867021020364708470807422704371893706965688795617928713045224516842027402021966415605280335061293558739079393524404092584248380607177444609964035221891022961909032569042381374492494906892314330884224399631396391545854065286326468807581148748371408284176455226386313520264894016262494802388568231599102952620337126449279901938211134518446387544516391239377974190576649911764237637722282802318465738050121277809680315691477264910257503508758792248110223544524410872448565700755187132146592093548504552829170749596775404450779494836371756062326925757412813110241910373338080434325310884694831555729402265394972913817581338619457057799561808755951413644907613109617155928376585840036489374076822257523935988731081689667688287403837192827690431514106997678303819085690713091931340846019511147482766350724676534922040058626677632935516631939622498979912708004465982264899125226813124300528104995058595676527123591494442612554437618645029202881358582871789577224116380815161831603129728796987480139828621645629196153096358337313619724773332353025466571196902611237380629030242904275794549030022660847446513161741691916851746464945459696005330885252792083472495235473110674109099223541055506299687642153951249355986311346661725116890785633328935569150449485189113488301876365100638502565916433021928565596263914382895068324838727165616560111531517055222955765944972454788815532316417453267167978861141165355597588331979638070962998880767303616940317736448140427867784251232449974693421348217179595190698204602997172001174857303889719205597414742453011135869766256607770970225633261701108463784795555258504578058879440756064974127974530918418405207558526462208821483646754652237609210787539190454684852349759986044943322828073120679922402477507514105890774627334319091255451352225329275913842047384603056163154236552935312278389759446515787337343463172280001031380425481404022090580405056003860937403435068863081434683848900708938565050027569059678069404698435184535134141031615133683043714786642925389717165978629010728400758939700388317742648163725113277369926827709465342583596111881955092462062153978121197244762623771534452048069819082524943963962251113831177428978535825590832490480497516047104257569753442551515779815600370847230603484753977513688390404316017486248871339311818523029425425676202485688393970836748788453789172574145155917919035398535077200900594979352939459631213445503368260690059828717723533375221941915547303742062343262892968397015058892191112049249864792053410872349115430987182160055762209075732304626106597744947658346313025598636315029959672352476943975462530206788193304372284800209305354155640664838569378144603138697563459200233462606995955513484754147891180830329816421587452922952678937925647752029052675349356673744293182673374571642465407748267901046778759085408130531447176455869894169668940436489952465247443988349583871206296485413357553813419500498743813369062703973874586604296871595820715766599826607317005624465541763024501349159567288942619746144496908671655859782729228702723774835097362901019130417812735773037781804081589136005207315806941034305003184349342360269244733060013861119781774472669608928321052543116496033420102032603863672532889648333405862204843616575362001468405476649666473566979572953394809138263703324220930839366954980688240491622063147911494642042500022450413425558561937442905257252436320054487441524307305215070491020434076572476865095751174125413729531644521765577235348601821566833352520532830000108344008762266843817023235605645158256954177359197813649975559601912567744942717986360045847405209290089397315276024304951653864431388147876977541478757432610159879709758855625806766197973098472460769484821127948427976536607055051639104415022554420329721292033009353356687294595912327965886376486894188433640548494009574965791657687213927330153555097865114767947399690623184878377515462613823651665956337209345708208301840482797005728071432925727577436229587047361641609731817241594204270366066404089740245521530725227388637241859646455223673260411164598464020010216920823315155388821071527191267876531795071908204525100447821291318544054814494151867114207103693891129125012750853466337717749376016543454696390042711129829255096830420665725364279472200020835313883708781649957189717629338794854271276882652003766325924561614868744897471519366219275665852462114457407010675380427564184440834805203838265052601698584060084788422421887856927897751810442805474427229455167420335686460609977973124950433321425205053675790499520783597650415379001132579536040655172654879022173595444151139429231648950663177813039057462082449171921311864129633704661406456900178942356738775523130952785912774533241855442484484493664210731348819180640189222317302156645813473186449997905781662091469870718039388885781280740226363602294114354869871402143572055947730892808653678920201935102605361567924483276749476117858316071865710310842200560259545115191391309119544447844361032741876102338843391687589233423790859841968266525610628751237572318491474951945985728897934981791761822652480408237128109790772638864286067917082288575852703470839714561619926247844794692794996845945632382702297364173503430783194115698247820013290851202878474805860188960045901745974055630732714487679085288867978809970695240681006625611440014983413580889737246844064948857074167687916413224205373654067330186392497910915474785959163865597507090581175924899502214799250945635582514315814464060134283490422798357939659258985200763845646681640732681928346007767285876284900068874564639274964415904034033672337814491597032941787294155061054129515400159393851663929325677429557549480046658273579653990940233543644649376827272541873627547532976808190325336141086433084237771738995221536763095302045902438694632702895293994483013577589081214884558493819874505920914067209522469096263076941753340983698859363700314973728977996360018626500174929290087931189997822963712306642297996163582572600112288983647651418045975770042120833949364659647336464289044499325396227091907373705772051322815957863227591912786054297862953188615559804728160710864132803585400160055575686855791785977899197902656592621283007225351401525973569300729015392211116868504740402172174442051738000251361000494534119324331668344243125963098812396962202358858395587831685194833126653577353244379935683215269177042249034574534858913812582681366908929476809052635560638119661306063936938411817713545929884317232912236262458868394202889981693561169865429884776513118227662526739978808816010470651542335015671353744817086234314662531190291040152262927104099285072418843329007277794754111637552176563589316326636049381218401837512818884771168975479483767664084842753623074019542183217985496260666590347925816342392670947839907062923166535037285019751324813803837070894638925470887039085723581006130628646664710006104352115778926613432214655311411882596942926284522109026688414975763341554921135581254616558078273470115814006008345762133130389987843270653719956709570847385786092649188858378739239165554263577301292243641604062551736892335636568854365851646207821875741724364525814143487632761341752707376754922276287782264765154315341585713773522730335403376364204258034257264749686217823666951353410677378421131371131987373222891805275062812277716412494412401207125954319991746574745892582613712825555535080404143944557295994554635608487251339462936358940832098964801619583130429720964794128539388996265368928263807677168759588502216464582430940165009688797366157733560316836710386895228270941509545222744002735499253670214715994056544813842186380128799900820933576320736369405991424263718294000613741900579513096298545330748197802568301089672873802234820488862973130369689882640657904781562389778485365025691064231795736025330908763271784911189748432246868086340383964176127605788646574472284824932687443062551220506955168464669477183681911432873544815836350548146411099960143390595799766290646881295025039150923633011076070632863317393378149693380247580035052789782755750928604039420506342939327064636161031822879248152679306862749237275631852225654266008556849497720285909150930495425967473648331437236349555448901598668408362176913559656039519670425368863482369587129462524759031776813184977588276576740482558136502103649585505703259219957675334264223783723586058509403583977103476670644788640831109650302565215607464019652716999732373465237173456595514559493098166644006211599349133180135150528651842178828026343325934755850761168697709125580056185683710540856081249519403148064618719402577663285267019698387567561524696759028106864896869293315954352097687527137201616160931174250199709289684940034696242325688410665113304377412256176258658941236728171145526423894512631717834790276921171452887352955019336759218908006048633737786728180610254782570436788449503518925787499836694785908612975543084122677060954347612133717433156783790162012337237023338316414706428592185977610158232721997915062871868186750981665537745013020880333904353639770263363809098526494532628146558065546504823486429495390613257400496912888340518222933644476683855037967975809619983575807027759535968788226194659612223044549275600274955168583542582295336042834426318478068825395450746691877897765406038432512843812811316856204608617289408229658626174420766920297427930088129519854678713548623236610413216581279267151545961594352593456757445992307889205519540082316409719591250025455237503106735639748835542480449681383030671851931491335789202123605308199952020584503423499932150962634977812456658304680581824563524814625849331926195406884818446445248429486063016169476663242625231476322371109695369483824482316410396224507675405614287468267835723704895606990652792688455844512046654853378534026646645042339638488257719874953611300494215593735545211926186721478265416885604094928290056616883807637656690510740892510549165222968878676968631652514917701499900066637344546120262780701925698706225540928945194718778004306130021828287425867048748480826948573444778244078734102710824870269523830804910960482013901294024631244800159336670212658317677879752965963472576894326540435889267293950687860830626266263287392087327302547910099932113388977807814336728791448768373686467748528777737403547472871644217767820712964506270880978637928144071192505141148004907055608097229299792441471062852247029870699869227676341773513258602908903875707454368077876422385333700692089616351009233587303986543906071880952557553380364725895007306772122528078179471056481171378557451057691044322925429024149433588396093679321361696954251299731031032804436954501929843820842383121265825740594509426942777307124802176915781835720087170538773256017987133005505911377823841791640280841409623820847637393013930778428554545222367559824666250608754284876104145661362227642405914304455580856318180935230407793891614902116292400515074914068443203230365609954878620999194306564455332547135557365318516011700321550690787716752062881527885897149410320986984083048966524351030502444679931779147659103428949129054120361601695671222140806369405940304552186212879933092856231022418446365289097444640151986623183881962444822590783585914043686193019041458962693878907034982169868696934448086213990534591792826654304798207219634134755646525483143771156678459077797196510772468000293581546267646310224279007313631352522067062951125935874473134186492497282784796644585448962932905262058065248588707020879389134476083344653170939242408249328008915731319541348311820927752486880548733943315867562666122179355051190609992911379445634995627391898459029021713155706096267881673302940198464237390445098028030948975981259252055850973537436556825780313681902007151675693827281818824587541710721180806556448039122504537089422695358382192535075692834095639859265599740391316709290043996275976830375217503360879028295673068862263077729733533853682668734519035709709687322323738300494090123239274318759046526327095178406267264828893646896593219169521106361729757074376148061601331104911692271318609404145014842866423634716982892418180484365230538864559809839273836490685480823014267803143937440431807822678779494006206489151248952516543005634448375046751754207043313372486870633237561645232360481932024377596890914783372179553676992603235715185513391098402739063753280702313301755754269396202629423910945323537910125948964941812563672992967084250667599803456273455598559628512281414582556024841783305645240508450065988755987518601335860624932784487772006842296591945516539562982960591610046578907214842054861830418175604559815168088031783080261445994444677918012432146400983610678683412974872596729258786806223080115822026289014364459002301645823666709265571264559925790622304745235625575111770791512002789380975775468546121017307522799241407026308137792971909461413145802081087738121624539858769697371425881836152605069380926917712087321915005831977113322793572385071940612761291872572099404930250277748156614021327434743881966413330052634229082906400927944924808556131183440161804801357032507836323938921567643159620442612809700944107776130638909071294456394056601559246025454204771186140420155233371270501377121034570009578009389265329385720478576508777149663403003562380595757191609382171312222810465858388943507176431939973012661591423837170284400120399485880996231859472474858776584355077006934099220340378772192728370301380838144394114984971730766162961342059105014814283949700695951676939041557902856356911055547312684571497449635320554677940775184056667637222969090346128706829887104278761090090999160443821794511763620835379716161833124364431267855435550800507986124664397724135502128238026726719914989727248512981287283697489276420792868666970177259794407858155909332508554131299946581118527691652464790819119384233275897699573012098103009171001695718791616942270079528915191912521053891838538959315167400505723817401030621004380243011187977704252328073236575129609372456053680037516596164236147709330391224409752871732067976128120428026739256557305675931512645750047875756531854825821411574030473147492511910835615765732002546109686701890307648531373832912682481741181359032826625082549313211431478953352317043989053928534946642886074268371824902498092479487226633686823799580875637040808655649321905489637785549531167397935270799470452399153297534358690514105864096534514182896474439367182852711843560799285895978176543950113088848419163516673213692860830956744502801800373716458009168082972708715609185038654053436660045504985624687376022557041595800250174095361839287643458003670864954057941720085136357127163768323493134230703821274484501440529541695374381945459456533165140990993722722801019654652726227831512103467686166826131471843610025517863247950150022953695466317739589344131481485834694374523981159954666071205997794363440185078360899108948073419633939259318973940943110042116729120199722626609871927014024105805515315100109804996044147291039451030312664114726736839973315035036742741546992633165270432940675237449075056739508929674779115800864399992564817208847429250821546279856079127768611946086210349405535850134472190244543824521089284409498132717010673966471114931896789977661595488186193176900175027901783824624387873831483279500879026433992577026588005849778984624295660321276945810824348129690840972550671054732471317254997191901039553305847040728081693158626093886019147689944137673621432083607375131574376316754666479186753896571555100850626810005119827486807780592667765654100834778571024250133253391587384761024129794736751001163498977803745930025457609870671092153597115178252014281216647543034075128600240297038428615984289816602143429849088917359682192284469123035904329877231843309914187264674607558318725713138832356015809009594182530207799397648462597901883341793830920965841463574411985878296475850943053008148341821747826603773762252997703468752903517310792083220038080809212164346586817989810504274375385786789186350517717501606531826406928883250135919517178537687865881752366421534010961295763074762648070312757365787762352859057153932484576503944390496668087711899192498933896524852395536795827530614167131757915756386606004839994179548705868209201195154952031294562451315422506574858629161606523796643010172693950282294667489681746821163996794950294284013099235901278250437428192557634533217576162292751110598368271567229778620053722932314082887058749444060116236521627717558503013451471452765841864277071769968435499620257547431811994883385806759692359580622165832464092095350648357935817742903018315351290014321495518177456908388719320697769695657771754499149911431368950836160692539606469893374870942933219185601299108564470256257163505508620689240297589684714283678684735455533583477652536156578189996983068654671736445996343136468195427420490472433064675001442697508322369013083895492637066778406531328664886080129513771720847581157719491012345141774941482773580041432667332379617716965698582785832300505265883502247868050648201444570593197343382923860072601696510903258980909912837652275381493529845099414966933862815568031306981064525192703818515872648691762563239441425216118427769145067718411735714396681005615483952443154944864238384298900399826113322468963346522104692545137969276009719645338955332105584245640187448611050959111766828942711640054010503770420346052521318228045892998637903572350665108782350043349942391285236308896510989246641056331584171142885304143772286629832318970869030400301325951476774237516158840915838059151673504519131178193943428482922272304061422582078027829148070426761629302539228321084917759984200595105312164731818409493139800444072847325902609169730998153853939031280878823902948001579008000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 "[\"red\", \"green\", \"blue\"]" +['a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a', 'a'] diff --git a/tests/node/tailrec001/tailrec.idr b/tests/node/tailrec001/tailrec.idr index 0de4b366f..b6489f5ed 100644 --- a/tests/node/tailrec001/tailrec.idr +++ b/tests/node/tailrec001/tailrec.idr @@ -1,6 +1,10 @@ module Main import Data.Vect +import Data.Stream + +foo : List Char +foo = unpack $ pack $ take 4000 (repeat 'a') factorialAux : Integer -> Integer -> Integer factorialAux 0 a = a @@ -15,3 +19,4 @@ main = printLn $ factorial 100 printLn $ factorial 10000 printLn $ show $ the (Vect 3 String) ["red", "green", "blue"] + printLn foo diff --git a/tests/templates/simple-test/Test.idr b/tests/templates/simple-test/Test.idr new file mode 100644 index 000000000..d8712bd72 --- /dev/null +++ b/tests/templates/simple-test/Test.idr @@ -0,0 +1,3 @@ +data EitherOrBoth a b = Left a | Rigth b | Both a b + +foo : EitherOrBoth a b -> () diff --git a/tests/templates/simple-test/expected b/tests/templates/simple-test/expected new file mode 100644 index 000000000..822a488a1 --- /dev/null +++ b/tests/templates/simple-test/expected @@ -0,0 +1,3 @@ +1/1: Building Test (Test.idr) +Main> 4 +Main> Bye for now! diff --git a/tests/templates/simple-test/input b/tests/templates/simple-test/input new file mode 100644 index 000000000..dd93581e1 --- /dev/null +++ b/tests/templates/simple-test/input @@ -0,0 +1,2 @@ +2 + 2 +:q diff --git a/tests/templates/simple-test/notes.md b/tests/templates/simple-test/notes.md new file mode 100644 index 000000000..c656f8fac --- /dev/null +++ b/tests/templates/simple-test/notes.md @@ -0,0 +1,17 @@ +## Description + +Template for simpler tests where we need to check or compile single modules. For tests that require a package, see the +template `with-ipkg`. + +### Mandatory steps +* Create a new subdirectory for the tests. Try to adhere to the naming scheme of existing tests. +* Update the `tests/Main.idr`, adding the new subdirectory to the lists of tests. +* In the `run` script, the compiler location is bound to `$1` and all calls must have the `--no-color --console-width 0 +--no-banner` flags to avoid system dependent differences. Also keep the `rm -rf build` line as keeping build files can +lead unexpected differences in the output, due to compiler logs and not errors. +* If the tests open a REPL session, remember to put a quit command, `:q`in the input file. +* The files named `run`, `expected`, `output` are reserved by the test runner, do not overwrite them by running the test. + +### Optional steps +* The expected file can be updated for the first time manually, or by running the test, after updating `tests/Main.idr`, +with `make test only="testdir/testname000"` (substitute the only arguments with the subdirectory of the test). diff --git a/tests/templates/simple-test/run b/tests/templates/simple-test/run new file mode 100755 index 000000000..c126d2fe4 --- /dev/null +++ b/tests/templates/simple-test/run @@ -0,0 +1,3 @@ +$1 --no-color --console-width 0 --no-banner Test.idr < input + +rm -rf build diff --git a/tests/templates/ttimp/Interp.yaff b/tests/templates/ttimp/Interp.yaff new file mode 100644 index 000000000..2fa5885dd --- /dev/null +++ b/tests/templates/ttimp/Interp.yaff @@ -0,0 +1,79 @@ +data Nat : Type where + Z : Nat + S : Nat -> Nat + +plus : Nat -> Nat -> Nat +plus Z y = y +plus (S k) y = S (plus k y) + +data Vect : Nat -> Type -> Type where + Nil : Vect Z a + Cons : a -> Vect k a -> Vect (S k) a + +append : Vect n a -> Vect m a -> Vect (plus n m) a +append Nil ys = ys +append (Cons x xs) ys = Cons x (append xs ys) + +data Fin : Nat -> Type where + FZ : Fin (S $k) + FS : Fin $k -> Fin (S $k) + +lookup : Fin $k -> Vect $k $ty -> $ty +lookup FZ (Cons $t $ts) = t; +lookup (FS $i) (Cons $t $ts) = lookup i ts; + +-- As a larger example, we'll implement the well-typed interpreter. +-- So we'll need to represent the types of our expression language: + +data Ty : Type where + Base : Type -> Ty + Arrow : Ty -> Ty -> Ty + +-- Ty can be translated to a host language type + +interpTy : Ty -> Type +interpTy (Base $t) = t +interpTy (Arrow $s $t) = (argTy : interpTy s) -> interpTy t + +data HasType : Fin $k -> Ty -> Vect $k Ty -> Type where + Stop : HasType FZ $t (Cons $t $gam) + Pop : HasType $i $t $gam -> HasType (FS $i) $t (Cons $u $gam) + +-- Expressions in our language, indexed by their contexts and types: + +data Lang : Vect $k Ty -> Ty -> Type where + Var : HasType $i $t $gam -> Lang $gam $t + Val : (x : interpTy $a) -> Lang $gam $a + Lam : (scope : Lang (Cons $s $gam) $t) -> Lang $gam (Arrow $s $t) + App : Lang $gam (Arrow $s $t) -> Lang $gam $s -> Lang $gam $t; + Op : (interpTy $a -> interpTy $b -> interpTy $c) -> + Lang $gam $a -> Lang $gam $b -> Lang $gam $c + +data Env : Vect $n Ty -> Type where + ENil : Env Nil + ECons : (x : interpTy $a) -> Env $xs -> Env (Cons $a $xs) + +-- Find a value in an environment +lookupEnv : HasType $i $t $gam -> Env $gam -> interpTy $t +lookupEnv Stop (ECons $x $xs) = x +lookupEnv (Pop $var) (ECons $x $env) = lookupEnv var env + +interp : Env $gam -> Lang $gam $t -> interpTy $t +interp $env (Var $i) = lookupEnv i env +interp $env (Val $x) = x +interp $env (App $f $a) = interp env f (interp env a) +interp $env (Lam {s = $s} $scope) + = \var => interp (ECons var env) scope +interp $env (Op $fn $x $y) = fn (interp env x) (interp env y) + +testAdd : Lang $gam (Arrow (Base Nat) (Arrow (Base Nat) (Base Nat))) +testAdd = Lam (Lam (Op plus (Var Stop) (Var (Pop Stop)))) + +testAdd2 : Lang $gam (Base Nat) +testAdd2 = App (App testAdd (Val (S (S Z)))) (Val (S (S (S Z)))) + +test1 : Nat +test1 = interp ENil testAdd (S (S Z)) (S (S Z)) + +test2 : Nat +test2 = interp ENil testAdd2 diff --git a/tests/templates/ttimp/expected b/tests/templates/ttimp/expected new file mode 100644 index 000000000..a4422e9ef --- /dev/null +++ b/tests/templates/ttimp/expected @@ -0,0 +1,10 @@ +Processing as TTImp +Written TTC +Yaffle> (Main.S (Main.S (Main.S (Main.S Main.Z)))) +Yaffle> (Main.S (Main.S (Main.S (Main.S (Main.S Main.Z))))) +Yaffle> Bye for now! +Processing as TTC +Read TTC +Yaffle> (Main.S (Main.S (Main.S (Main.S Main.Z)))) +Yaffle> (Main.S (Main.S (Main.S (Main.S (Main.S Main.Z))))) +Yaffle> Bye for now! diff --git a/tests/templates/ttimp/input b/tests/templates/ttimp/input new file mode 100644 index 000000000..f5ebd7d49 --- /dev/null +++ b/tests/templates/ttimp/input @@ -0,0 +1,3 @@ +test1 +test2 +:q diff --git a/tests/templates/ttimp/notes.md b/tests/templates/ttimp/notes.md new file mode 100644 index 000000000..25f4b8b7f --- /dev/null +++ b/tests/templates/ttimp/notes.md @@ -0,0 +1,17 @@ +## Description + +Template for tests on the `TTImp` representation. + +### Mandatory steps +* Create a new subdirectory for the tests. Try to adhere to the naming scheme of existing tests. For `TTImp` files the +convention is to use the `.yaff` extension. +* Update the `tests/Main.idr`, adding the new subdirectory to the lists of tests. +* In the `run` script, Each invocation to the `TTImp` REPL must be prefixed by the `--yaffle` flag. Also keep the `rm -rf build` line as keeping build files can +lead unexpected differences in the output, due to compiler logs and not errors. +* If the tests open a REPL session, remember to put a quit command, `:q`in the input file. +* The files named `run`, `expected`, `output` are reserved by the test runner, do not overwrite them by running the test. + +### Optional steps +* The expected file can be updated for the first time manually, or by running the test, after updating `tests/Main.idr`, +with `make test only="testdir/testname000"` (substitute the only arguments with the subdirectory of the test). +* With the `--yaffle` options, the compiler can also read `TTC` files, as show in the template. diff --git a/tests/templates/ttimp/run b/tests/templates/ttimp/run new file mode 100755 index 000000000..04cc9c364 --- /dev/null +++ b/tests/templates/ttimp/run @@ -0,0 +1,4 @@ +$1 --yaffle Interp.yaff < input +$1 --yaffle build/ttc/Interp.ttc < input + +rm -rf build diff --git a/tests/templates/with-ipkg/Dummy.idr b/tests/templates/with-ipkg/Dummy.idr new file mode 100644 index 000000000..e928847e3 --- /dev/null +++ b/tests/templates/with-ipkg/Dummy.idr @@ -0,0 +1,69 @@ +module Dummy + +import Data.Vect + +namespace DList + + ||| A list construct for dependent types. + ||| + ||| @aTy The type of the value contained within the list element type. + ||| @elemTy The type of the elements within the list + ||| @as The List used to contain the different values within the type. + public export + data DList : (aTy : Type) + -> (elemTy : aTy -> Type) + -> (as : List aTy) + -> Type where + ||| Create an empty List + Nil : DList aTy elemTy Nil + ||| Cons + ||| + ||| @elem The element to add + ||| @rest The list for `elem` to be added to. + (::) : (elem : elemTy x) + -> (rest : DList aTy elemTy xs) + -> DList aTy elemTy (x::xs) + +namespace DVect + ||| A list construct for dependent types. + ||| + ||| @aTy The type of the value contained within the list element type. + ||| @elemTy The type of the elements within the list + ||| @len The length of the list. + ||| @as The List used to contain the different values within the type. + public export + data DVect : (aTy : Type) + -> (elemTy : aTy -> Type) + -> (len : Nat) + -> (as : Vect len aTy) + -> Type where + ||| Create an empty List + Nil : DVect aTy elemTy Z Nil + ||| Cons + ||| + ||| @ex The element to add + ||| @rest The list for `elem` to be added to. + (::) : (ex : elemTy x) + -> (rest : DVect aTy elemTy n xs) + -> DVect aTy elemTy (S n) (x::xs) + +namespace PList + public export + data PList : (aTy : Type) + -> (elemTy : aTy -> Type) + -> (predTy : aTy -> Type) + -> (as : List aTy) + -> (prf : DList aTy predTy as) + -> Type + where + ||| Create an empty List + Nil : PList aTy elemTy predTy Nil Nil + + ||| Cons + ||| + ||| @elem The element to add and proof that the element's type satisfies a certain predicate. + ||| @rest The list for `elem` to be added to. + (::) : (elem : elemTy x) + -> {prf : predTy x} + -> (rest : PList aTy elemTy predTy xs prfs) + -> PList aTy elemTy predTy (x :: xs) (prf :: prfs) diff --git a/tests/templates/with-ipkg/dummy.ipkg b/tests/templates/with-ipkg/dummy.ipkg new file mode 100644 index 000000000..3eedc3806 --- /dev/null +++ b/tests/templates/with-ipkg/dummy.ipkg @@ -0,0 +1,10 @@ +package dummy + +authors = "Joe Bloggs" +maintainers = "Joe Bloggs" +license = "BSD3 but see LICENSE for more information" +brief = "This is a dummy package." +readme = "README.md" + +modules = Dummy +opts = "--no-color --console-width 0" diff --git a/tests/templates/with-ipkg/expected b/tests/templates/with-ipkg/expected new file mode 100644 index 000000000..41b9984a2 --- /dev/null +++ b/tests/templates/with-ipkg/expected @@ -0,0 +1 @@ +1/1: Building Dummy (Dummy.idr) diff --git a/tests/templates/with-ipkg/notes.md b/tests/templates/with-ipkg/notes.md new file mode 100644 index 000000000..b15926fc4 --- /dev/null +++ b/tests/templates/with-ipkg/notes.md @@ -0,0 +1,17 @@ +## Description + +Template for tests that requires a package file. + +### Mandatory steps +* Create a new subdirectory for the tests. Try to adhere to the naming scheme of existing tests. +* Update the `tests/Main.idr`, adding the new subdirectory to the lists of tests. +* In the `ipkg` always keep the `--no-color --console-width 0` flags in the `opts` field to avoid system dependent +differences. +* In the `run` script, keep the `rm -rf build` line as keeping build files can +lead unexpected differences in the output, due to compiler logs and not errors. +* If the tests open a REPL session, remember to put a quit command, `:q`in the input file. +* The files named `run`, `expected`, `output` are reserved by the test runner, do not overwrite them by running the test. + +### Optional steps +* The expected file can be updated for the first time manually, or by running the test, after updating `tests/Main.idr`, +with `make test only="testdir/testname000"` (substitute the only arguments with the subdirectory of the test). diff --git a/tests/templates/with-ipkg/run b/tests/templates/with-ipkg/run new file mode 100755 index 000000000..0da437ff2 --- /dev/null +++ b/tests/templates/with-ipkg/run @@ -0,0 +1,3 @@ +$1 --build dummy.ipkg + +rm -rf build diff --git a/tests/typedd-book/chapter11/ArithCmdDo.idr b/tests/typedd-book/chapter11/ArithCmdDo.idr index 5956d0af7..7ce3725a3 100644 --- a/tests/typedd-book/chapter11/ArithCmdDo.idr +++ b/tests/typedd-book/chapter11/ArithCmdDo.idr @@ -2,7 +2,7 @@ import Data.Primitives.Views import Data.Strings import System --- %default total +%default total export data Command : Type -> Type where