diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright the disco project and contributors +SPDX-License-Identifier: BSD-3-Clause + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Disco team nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,108 @@ +[![Build Status](https://travis-ci.org/disco-lang/disco.svg?branch=master)](https://travis-ci.org/disco-lang/disco) +[![Contributor Covenant](https://img.shields.io/badge/Contributor%20Covenant-v2.0%20adopted-ff69b4.svg)](CODE_OF_CONDUCT.md) + +Disco is a programming language intended to teach basic functional +programming principles in the context of a discrete mathematics +course. + +Installation +------------ + +If you just want to *use* disco (*i.e.* if you are a student), follow +these instructions. If you want to *contribute* to disco development, +you should skip to the instructions below about building with stack. + +- Follow the instructions to [install + ghcup](https://www.haskell.org/ghcup/) by opening a terminal or + command prompt and copy-pasting the given installation command. You + can just accept all the defaults. If you don't have [Windows + Subsystem for Linux](https://docs.microsoft.com/en-us/windows/wsl/) + (if you don't know what that is, then you don't have it), see the + [instructions here](https://www.haskell.org/ghcup/install/) for a + PowerShell command to run. +- Now run `cabal install disco` at a command prompt. +- If it works, you should be able to now type `disco` at a command + prompt, which should display a message like this: + + ``` + Welcome to Disco! + + A language for programming discrete mathematics. + + Disco> + ``` + +If you encounter any difficulties, please let me know --- either come +talk to me or [open a GitHub +issue](https://github.com/disco-lang/disco/issues/new). These +instructions will be kept up-to-date with whatever helpful tips or +workarounds I learn. So even if you encounter a difficulty but figure +out the solution youself, let me know --- that way I can include the +problem and solution here so others can benefit! + +Design principles +----------------- + +* Includes those features, and *only* those features, useful in the + context of a discrete math course. This is *not* intended to be a + general-purpose language. +* Syntax is as close to standard *mathematical* practice as possible, + to make it easier for mathematicians to pick up, and to reduce as + much as possible the incongruity between the language and the + mathematics being explored and modeled. +* Tooling, error messages, etc. are very important---the language + needs to be accessible to undergrads with no prior programming + experience. (However, this principle is, as of yet, only + that---there is no tooling or nice error messages to speak of.) + +Feel free to look around, ask questions, etc. You can also +[contribute](CONTRIBUTING.md)---collaborators are most welcome. + +Community +--------- + +Check out the disco IRC channel, `#disco-lang` on Libera.Chat. If +you're not familiar with IRC, you can connect via [this web client](https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest?#disco-lang). + +Documentation +------------- + +Documentation is [hosted on +readthedocs.io](http://disco-lang.readthedocs.io/en/latest/). + +Contributing +------------ + +If you'd like to contribute to disco development, check out +[CONTRIBUTING.md](CONTRIBUTING.md). + +Building with stack +------------------- + +First, make sure you have +[the `stack` tool](https://docs.haskellstack.org/en/stable/README/) +(the easiest way to install it is via [ghcup](https://www.haskell.org/ghcup/)). +Then open a command prompt, navigate to the root directory of this +repository, and execute + +``` +stack build +``` + +After this completes, you should be able to + +``` +stack exec disco +``` + +to run the Disco command-line REPL. + +While developing, you may want to use a command like + +``` +stack test --fast --file-watch --ghc-options='-Wall' +``` + +which will turn on warnings, turn off optimizations for a faster +edit-compile-test cycle, and automatically recompile and run the test +suite every time a source file changes. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/disco.cabal b/disco.cabal new file mode 100644 --- /dev/null +++ b/disco.cabal @@ -0,0 +1,515 @@ +cabal-version: 2.4 +name: disco +version: 0.1.0.0 +synopsis: Functional programming language for teaching discrete math. +description: Disco is a simple functional programming language for use in + teaching discrete math. Its syntax is designed to be close + to standard mathematical practice. +license: BSD-3-Clause +license-file: LICENSE +author: Disco team +maintainer: byorgey@gmail.com +copyright: Disco team 2016 (see LICENSE) +category: Language + +tested-with: GHC == 8.10.4 + +data-dir: lib + +data-files: *.disco + +extra-source-files: README.md, stack.yaml, example/*.disco, repl/*.hs + docs/tutorial/example/*.disco + --- TEST FILES BEGIN (updated automatically by add-test-files.hs) --- + test/README.md + test/Tests.hs + test/arith-basic-bin/expected + test/arith-basic-bin/input + test/arith-basic-un/expected + test/arith-basic-un/input + test/arith-count/expected + test/arith-count/input + test/arith-numthry/expected + test/arith-numthry/input + test/arith-prim/arith-prim.disco + test/arith-prim/expected + test/arith-prim/input + test/arith-round/expected + test/arith-round/input + test/case-arith/case-arith.disco + test/case-arith/expected + test/case-arith/input + test/case-basic/case-basic.disco + test/case-basic/expected + test/case-basic/input + test/case-let/case-let.disco + test/case-let/expected + test/case-let/input + test/compile-cons/expected + test/compile-cons/input + test/compile-misc/expected + test/compile-misc/input + test/containers-cmp/expected + test/containers-cmp/input + test/containers-comp/expected + test/containers-comp/input + test/containers-convert/expected + test/containers-convert/input + test/containers-each/expected + test/containers-each/input + test/containers-ellipsis/expected + test/containers-ellipsis/input + test/containers-filter/expected + test/containers-filter/input + test/containers-join/expected + test/containers-join/input + test/containers-merge/expected + test/containers-merge/input + test/containers-ops/expected + test/containers-ops/input + test/containers-reduce/containers-reduce.disco + test/containers-reduce/expected + test/containers-reduce/input + test/error-ambiguous/a.disco + test/error-ambiguous/ambiguous.disco + test/error-ambiguous/b.disco + test/error-ambiguous/expected + test/error-ambiguous/input + test/error-cyclic/cyclic.disco + test/error-cyclic/expected + test/error-cyclic/input + test/error-duplicatedecls/dupdecls.disco + test/error-duplicatedecls/expected + test/error-duplicatedecls/input + test/error-duplicatedefns/dupdefns.disco + test/error-duplicatedefns/expected + test/error-duplicatedefns/input + test/error-duplicatetydefns/duptydefns.disco + test/error-duplicatetydefns/expected + test/error-duplicatetydefns/input + test/error-emptycase/expected + test/error-emptycase/input + test/error-names/expected + test/error-names/input + test/error-notcon/expected + test/error-notcon/input + test/error-notype/expected + test/error-notype/input + test/error-numpatterns/expected + test/error-numpatterns/input + test/error-numpatterns/numpatterns.disco + test/error-pattype/expected + test/error-pattype/input + test/error-polyrec/expected + test/error-polyrec/input + test/error-polyrec/polyrec.disco + test/error-qualskolem/expected + test/error-qualskolem/input + test/error-qualskolem/qualskolem.disco + test/error-tyargs/error-tyargs.disco + test/error-tyargs/expected + test/error-tyargs/input + test/error-unboundtyvar/expected + test/error-unboundtyvar/input + test/error-unboundtyvar/unboundtyvar.disco + test/error-unqual-base/expected + test/error-unqual-base/input + test/error-unqual-base/unqualbase.disco + test/error-unqual/expected + test/error-unqual/input + test/error-wildcard/expected + test/error-wildcard/input + test/graphs-basic/expected + test/graphs-basic/input + test/graphs-equality/expected + test/graphs-equality/input + test/interp-loop/expected + test/interp-loop/input + test/interp-strictmatch/bomb.disco + test/interp-strictmatch/expected + test/interp-strictmatch/input + test/lib-oeis/expected + test/lib-oeis/input + test/list-comp/expected + test/list-comp/input + test/list-poly/expected + test/list-poly/input + test/logic-bools/expected + test/logic-bools/input + test/logic-cmp/expected + test/logic-cmp/input + test/map-basic/expected + test/map-basic/input + test/map-compare/expected + test/map-compare/input + test/module-basic/a.disco + test/module-basic/b.disco + test/module-basic/c.disco + test/module-basic/e.disco + test/module-basic/expected + test/module-basic/input + test/module-basic/subdir/d.disco + test/module-cycle/cyclic1.disco + test/module-cycle/cyclic2.disco + test/module-cycle/expected + test/module-cycle/input + test/module-notfound/expected + test/module-notfound/input + test/parse-245/expected + test/parse-245/input + test/parse-280/capitalvars.disco + test/parse-280/expected + test/parse-280/input + test/parse-case-expr/expected + test/parse-case-expr/input + test/parse-nested-list/expected + test/parse-nested-list/input + test/parse-quantifiers/expected + test/parse-quantifiers/input + test/parse-top-term/expected + test/parse-top-term/input + test/parse-top-term/parse-top-term.disco + test/poly-bad/expected + test/poly-bad/input + test/poly-infer-sort/expected + test/poly-infer-sort/input + test/poly-instantiate/expected + test/poly-instantiate/input + test/poly-instantiate/poly-instantiate.disco + test/poly-rectype/expected + test/poly-rectype/input + test/poly-rectype/poly-rectype.disco + test/pretty-defn/expected + test/pretty-defn/input + test/pretty-functions/expected + test/pretty-functions/input + test/pretty-issue258/expected + test/pretty-issue258/input + test/pretty-lit/expected + test/pretty-lit/input + test/pretty-ops/expected + test/pretty-ops/input + test/pretty-pattern/expected + test/pretty-pattern/input + test/pretty-torture/expected + test/pretty-torture/input + test/pretty-type/expected + test/pretty-type/input + test/pretty-whnf/expected + test/pretty-whnf/input + test/prim-crash/expected + test/prim-crash/input + test/prim-frac/expected + test/prim-frac/input + test/prim-sum/expected + test/prim-sum/input + test/prop-basic/expected + test/prop-basic/input + test/prop-basic/prop-basic.disco + test/prop-cmp/expected + test/prop-cmp/input + test/prop-fail/bad-tests.disco + test/prop-fail/expected + test/prop-fail/input + test/prop-fairness/expected + test/prop-fairness/input + test/prop-higher-order/expected + test/prop-higher-order/higher-order.disco + test/prop-higher-order/input + test/prop-holds/expected + test/prop-holds/input + test/prop-impredicative/expected + test/prop-impredicative/input + test/prop-impredicative/prop-impredicative.disco + test/prop-tests/expected + test/prop-tests/input + test/prop-tests/prop-tests.disco + test/prop-type/expected + test/prop-type/input + test/repl-ann/expected + test/repl-ann/input + test/repl-compile/expected + test/repl-compile/input + test/repl-defn/expected + test/repl-defn/input + test/repl-defns/expected + test/repl-defns/input + test/repl-desugar/expected + test/repl-desugar/input + test/repl-doc/doc.disco + test/repl-doc/expected + test/repl-doc/input + test/repl-eval-tydef-import/a.disco + test/repl-eval-tydef-import/b.disco + test/repl-eval-tydef-import/expected + test/repl-eval-tydef-import/input + test/repl-help/expected + test/repl-help/input + test/repl-import/expected + test/repl-import/input + test/repl-names/expected + test/repl-names/input + test/repl-names/logic.disco + test/repl-names/other.disco + test/repl-proptest/expected + test/repl-proptest/input + test/solver-issue112/diag-iso-bad.disco + test/solver-issue112/expected + test/solver-issue112/input + test/syntax-chain/expected + test/syntax-chain/inRange.disco + test/syntax-chain/input + test/syntax-clause/clauses.disco + test/syntax-clause/expected + test/syntax-clause/input + test/syntax-comment/expected + test/syntax-comment/fib.disco + test/syntax-comment/input + test/syntax-containers/expected + test/syntax-containers/input + test/syntax-decimals/expected + test/syntax-decimals/input + test/syntax-doc/expected + test/syntax-doc/input + test/syntax-doc/syntax-doc.disco + test/syntax-exts/expected + test/syntax-exts/input + test/syntax-exts/syntax-exts.disco + test/syntax-juxt-app/expected + test/syntax-juxt-app/input + test/syntax-juxt-app/juxt-app.disco + test/syntax-juxt-mul/expected + test/syntax-juxt-mul/input + test/syntax-juxt-mul/juxt-mul.disco + test/syntax-lambda-pat/expected + test/syntax-lambda-pat/input + test/syntax-lambda/expected + test/syntax-lambda/input + test/syntax-let/expected + test/syntax-let/input + test/syntax-many-args/expected + test/syntax-many-args/input + test/syntax-many-args/many-args.disco + test/syntax-many-clauses/expected + test/syntax-many-clauses/input + test/syntax-many-clauses/many-clauses.disco + test/syntax-patclause/expected + test/syntax-patclause/fact.disco + test/syntax-patclause/input + test/syntax-prims/expected + test/syntax-prims/input + test/syntax-prims/syntax-prims.disco + test/syntax-tuples/expected + test/syntax-tuples/input + test/syntax-types/expected + test/syntax-types/input + test/types-192/expected + test/types-192/input + test/types-bind/expected + test/types-bind/input + test/types-char-string/expected + test/types-char-string/input + test/types-compare/expected + test/types-compare/input + test/types-container/expected + test/types-container/input + test/types-kinds/expected + test/types-kinds/input + test/types-naked-ops/expected + test/types-naked-ops/input + test/types-numpats/expected + test/types-numpats/input + test/types-numpats/types-numpats.disco + test/types-ops/expected + test/types-ops/input + test/types-rational/expected + test/types-rational/input + test/types-rec/expected + test/types-rec/input + test/types-rec/types-rec.disco + test/types-squash/expected + test/types-squash/input + test/types-standalone-ops/expected + test/types-standalone-ops/input + test/types-toomanypats/expected + test/types-toomanypats/input + test/types-toomanypats/toomanypats.disco + test/types-tydef-bad/expected + test/types-tydef-bad/input + test/types-tydef-bad/types-tydef-bad.disco + test/types-tydef-kind/expected + test/types-tydef-kind/input + test/types-tydef-kind/types-tydef-kind.disco + test/types-tydef-param/expected + test/types-tydef-param/input + test/types-tydef-param/types-tydef-param.disco + test/types-tydefs/expected + test/types-tydefs/input + test/types-tydefs/types-tydefs.disco + --- TEST FILES END --- + +build-type: Simple + +source-repository head + type: git + location: git://github.com/disco-lang/disco.git + +common common + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wno-star-is-type + -Wpartial-fields + default-language: Haskell2010 + +library + import: common + ghc-options: -flate-specialise -fspecialise-aggressively -fplugin=Polysemy.Plugin + default-extensions: DataKinds + DeriveGeneric + FlexibleContexts + FlexibleInstances + GADTs + LambdaCase + MultiParamTypeClasses + PolyKinds + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + TypeOperators + TypeFamilies + ViewPatterns + exposed-modules: + Disco.Syntax.Operators + Disco.Syntax.Prims + Disco.Extensions + Disco.Effects.Counter + Disco.Effects.Fresh + Disco.Effects.Input + Disco.Effects.LFresh + Disco.Effects.Random + Disco.Effects.State + Disco.Effects.Store + Disco.AST.Core + Disco.AST.Desugared + Disco.AST.Generic + Disco.AST.Surface + Disco.AST.Typed + Disco.Data + Disco.Names + Disco.Context + Disco.Report + Disco.Messages + Disco.Module + Disco.Parser + Disco.Pretty + Disco.Pretty.DSL + Disco.Pretty.Prec + Disco.Property + Disco.Desugar + Disco.Compile + Disco.Enumerate + Disco.Value + Disco.Error + Disco.Eval + Disco.Interpret.CESK + Disco.Subst + Disco.Typecheck + Disco.Typecheck.Constraints + Disco.Typecheck.Erase + Disco.Typecheck.Graph + Disco.Typecheck.Util + Disco.Typecheck.Solve + Disco.Typecheck.Unify + Disco.Types + Disco.Types.Qualifiers + Disco.Types.Rules + Disco.Util + Disco.Interactive.CmdLine + Disco.Interactive.Commands + + other-modules: Paths_disco + autogen-modules: Paths_disco + + build-depends: base >=4.8 && <4.17, + filepath, + directory, + mtl >=2.2 && <2.3, + megaparsec >= 6.1.1 && < 9.3, + parser-combinators >= 1.0.0 && < 1.4, + pretty >=1.1 && <1.2, + split >= 0.2 && < 0.3, + transformers >= 0.4 && < 0.7, + containers >=0.5 && <0.7, + unbound-generics >= 0.3 && < 0.5, + polysemy >= 1.6.0.0 && < 1.8, + polysemy-plugin >= 0.4 && < 0.5, + polysemy-zoo >= 0.7 && < 0.8, + lens >= 4.14 && < 5.2, + exact-combinatorics >= 0.2 && < 0.3, + arithmoi >= 0.10 && < 0.13, + integer-logarithms >= 1.0 && < 1.1, + simple-enumeration >= 0.2 && < 0.3, + haskeline >=0.8 && <0.9, + exceptions >= 0.10 && < 0.11, + QuickCheck >= 2.9 && < 2.15, + splitmix >= 0.1 && < 0.2, + fgl >= 5.5 && < 5.8, + optparse-applicative >= 0.12 && < 0.17, + oeis >= 0.3.10, + algebraic-graphs >= 0.5, + pretty-show >= 1.10 + + hs-source-dirs: src + default-language: Haskell2010 + +executable disco + import: common + hs-source-dirs: repl + main-is: REPL.hs + build-depends: base, + disco, + directory, + filepath, + haskeline >=0.8 && <0.9, + mtl >=2.2 && <2.3, + transformers >= 0.4 && < 0.7, + megaparsec >= 6.1.1 && < 9.3, + containers >= 0.5 && < 0.7, + unbound-generics >= 0.3 && < 0.5, + lens >= 4.14 && < 5.2, + optparse-applicative >= 0.12 && < 0.17, + oeis >= 0.3.10 + + default-language: Haskell2010 + +test-suite disco-tests + import: common + type: exitcode-stdio-1.0 + main-is: Tests.hs + hs-source-dirs: test + ghc-options: -threaded + build-depends: base >= 4.7 && < 4.17, + tasty >= 0.10 && < 1.5, + tasty-golden >= 2.3 && < 2.4, + directory >= 1.2 && < 1.4, + filepath >= 1.4 && < 1.5, + process >= 1.4 && < 1.7, + bytestring >= 0.9 && < 0.12, + disco + default-language: Haskell2010 + +test-suite disco-examples + import: common + type: exitcode-stdio-1.0 + main-is: TestExamples.hs + hs-source-dirs: example + ghc-options: -threaded + build-depends: base >= 4.7 && < 4.17, + directory >= 1.2 && < 1.4, + filepath >= 1.4 && < 1.5, + process >= 1.4 && < 1.7 + default-language: Haskell2010 diff --git a/docs/tutorial/example/arith-pattern.disco b/docs/tutorial/example/arith-pattern.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/arith-pattern.disco @@ -0,0 +1,8 @@ +h : N -> N +h(0) = 1 -- matches 0 +h(2k+1) = h(k) -- matches any natural of the form 2k+1 for a natural number k +h(2k+2) = h(k+1) + h(k) -- matches any natural of the form 2k+2 + +isHalf : Q -> Bool +isHalf(s) = {? true when s is _ / 2, -- matches fractions with denominator 2 + false otherwise ?} diff --git a/docs/tutorial/example/basic-ellipsis.disco b/docs/tutorial/example/basic-ellipsis.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/basic-ellipsis.disco @@ -0,0 +1,19 @@ +-- Counting numbers from 1 to 100 +counting : List(N) +counting = [1 .. 100] + +-- Even numbers from 2 to 100 +evens : List(N) +evens = [2, 4 ..... 100] + +-- [5, 4, 3, ... -3, -4, -5] +down : List(Z) +down = [5 .. -5] + +-- 1 + 3 + 5 + 7 = 16 +s : N +s = {? a+b+c+d when [1, 3 .. 100] is (a::b::c::d::_) ?} + +-- It doesn't always have to be integers +qs : List(Q) +qs = [2/3, 7/5 .. 10] diff --git a/docs/tutorial/example/basics.disco b/docs/tutorial/example/basics.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/basics.disco @@ -0,0 +1,5 @@ +approx_pi : Rational +approx_pi = 22/7 + +increment : N -> N +increment(n) = n + 1 diff --git a/docs/tutorial/example/case-pattern.disco b/docs/tutorial/example/case-pattern.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/case-pattern.disco @@ -0,0 +1,5 @@ +g : Z*Z -> Z +g(p) = {? 0 when p is (3,_), + x + y when p is (x,y) if x > 5 or y > 20, + -100 otherwise + ?} diff --git a/docs/tutorial/example/case.disco b/docs/tutorial/example/case.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/case.disco @@ -0,0 +1,5 @@ +f : Z -> Z +f(x) = {? x + 2 if x < 0, + x^2 - 3x + 2 if 0 <= x < 10, + 5 - x otherwise + ?} diff --git a/docs/tutorial/example/comment.disco b/docs/tutorial/example/comment.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/comment.disco @@ -0,0 +1,9 @@ +-- This is a comment +approx_pi : Rational +approx_pi = 22/7 -- an OK approximation + +-- The following function is very complicated +-- and took about three weeks to write. +-- Don't laugh. +increment : N -> N +increment(n) = n + 1 -- one more than the input diff --git a/docs/tutorial/example/comprehension.disco b/docs/tutorial/example/comprehension.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/comprehension.disco @@ -0,0 +1,10 @@ +comp1 : List(N) -> List(N) -> List(N) +comp1 xs ys = [ x + y | x in xs, 2 divides x, y in ys, 2 divides y, x + y >= 50 ] + +pythagTriples : List (N*N*N) +pythagTriples = [ (a,b,c) + | a in [1 .. 20] + , b in [1 .. 20] + , c in [1 .. 20] + , a^2 + b^2 == c^2 + ] diff --git a/docs/tutorial/example/doc.disco b/docs/tutorial/example/doc.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/doc.disco @@ -0,0 +1,14 @@ +||| A reasonable approximation of pi. +approx_pi : Rational +approx_pi = 22/7 -- an OK approximation + +||| Take a natural number as input, and return the natural +||| number which is one greater. +||| +||| Should not be used while operating heavy machinery. +-- This comment will be ignored. +increment : N -> N +increment(n) = n + 1 + +fizz : N +fizz = 1 diff --git a/docs/tutorial/example/function-desugar.disco b/docs/tutorial/example/function-desugar.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/function-desugar.disco @@ -0,0 +1,8 @@ +gcd : N * N -> N +gcd(a,0) = a +gcd(a,b) = gcd(b, a mod b) + +gcd2 : N * N -> N +gcd2 = λp. {? a when p is (a,0), + gcd2(b, a mod b) when p is (a,b) + ?} diff --git a/docs/tutorial/example/function.disco b/docs/tutorial/example/function.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/function.disco @@ -0,0 +1,9 @@ +f : N -> N +f(x) = x + 7 + +g : Z -> Bool +g(n) = (n - 3) > 7 + +factorial : N -> N +factorial(0) = 1 +factorial(n) = n * factorial(n .- 1) diff --git a/docs/tutorial/example/general-ellipsis.disco b/docs/tutorial/example/general-ellipsis.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/general-ellipsis.disco @@ -0,0 +1,11 @@ +-- Some triangular numbers +triangular : List(N) +triangular = [1, 3, 6 .. 100] + +-- Some squares +squares : List(N) +squares = [1, 4, 9 .. 100] + +-- Some cubes +cubes : List(N) +cubes = [1, 8, 27, 64 .. 1000] diff --git a/docs/tutorial/example/higher-order.disco b/docs/tutorial/example/higher-order.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/higher-order.disco @@ -0,0 +1,2 @@ +thrice : (N -> N) -> (N -> N) +thrice(f)(n) = f(f(f(n))) diff --git a/docs/tutorial/example/let.disco b/docs/tutorial/example/let.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/let.disco @@ -0,0 +1,6 @@ +f : Nat -> List(Nat) +f n = + let x : Nat = n//2, + y : Nat = x + 3, + z : List(Nat) = [3,x,y] + in n :: z diff --git a/docs/tutorial/example/list.disco b/docs/tutorial/example/list.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/list.disco @@ -0,0 +1,17 @@ +emptyList : List(Bool) +emptyList = [] + +nums : List(N) +nums = [1, 3, 4, 6] + +nums2 : List(N) +nums2 = 1 :: 3 :: 4 :: 6 :: [] + + -- nums and nums2 are equal + +nested : List(List(Q)) +nested = [1, 5/2, -8] :: [[2, 4], [], [1/2]] + +sum : List(N) -> N +sum [] = 0 +sum (n :: ns) = n + sum ns diff --git a/docs/tutorial/example/multi-arg-functions.disco b/docs/tutorial/example/multi-arg-functions.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/multi-arg-functions.disco @@ -0,0 +1,9 @@ +gcd : N * N -> N +gcd(a,0) = a +gcd(a,b) = gcd(b, a mod b) + +discrim : Q * Q * Q -> Q +discrim(a,b,c) = b^2 - 4*a*c + +manhattan : (Q*Q) * (Q*Q) -> Q +manhattan ((x1,y1), (x2,y2)) = abs (x1-x2) + abs (y1-y2) diff --git a/docs/tutorial/example/pair.disco b/docs/tutorial/example/pair.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/pair.disco @@ -0,0 +1,11 @@ +pair1 : N * Q +pair1 = (3, -5/6) + +pair2 : Z × Bool +pair2 = (17 + 22, (3,5) < (4,2)) + +pair3 : Bool * (Bool * Bool) +pair3 = (true, (false, true)) + +pair4 : Bool * Bool * Bool +pair4 = (true, false, true) diff --git a/docs/tutorial/example/poly.disco b/docs/tutorial/example/poly.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/poly.disco @@ -0,0 +1,3 @@ +maplist : (a -> b) -> List(a) -> List(b) +maplist _ [] = [] +maplist f (a :: as) = f a :: (maplist f as) diff --git a/docs/tutorial/example/property.disco b/docs/tutorial/example/property.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/property.disco @@ -0,0 +1,21 @@ +!!! ∀ x:Bool. neg (neg x) == x +neg : Bool -> Bool +neg x = not x + +!!! ∀p: N + N. plusIsoR (plusIso p) == p +plusIso : N + N -> N +plusIso (left n) = 2n +plusIso (right n) = 2n + 1 + +!!! ∀n:N. plusIso (plusIsoR n) == n +plusIsoR : N -> N + N +plusIsoR n = + {? left (n // 2) if 2 divides n + , right (n // 2) otherwise + ?} + +!!! forall x:N, y:N, z:N. + f(f(x,y), z) == f(x, f(y,z)) + +f : N*N -> N +f (x,y) = x + x*y + y diff --git a/docs/tutorial/example/sum.disco b/docs/tutorial/example/sum.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/sum.disco @@ -0,0 +1,8 @@ +sum1 : N + Bool +sum1 = left(3) + +sum2 : N + Bool +sum2 = right(false) + +sum3 : N + N + N +sum3 = right(right(3)) diff --git a/docs/tutorial/example/tydefs-poly.disco b/docs/tutorial/example/tydefs-poly.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/tydefs-poly.disco @@ -0,0 +1,13 @@ +import list + +type Tree(a) = Unit + (a * Tree(a) * Tree(a)) + +treeFold : b * (a * b * b -> b) * Tree(a) -> b +treeFold (z, f, left(unit)) = z +treeFold (z, f, right (a, l, r)) = f(a, treeFold(z,f,l), treeFold(z,f,r)) + +sumTree : Tree(Nat) -> Nat +sumTree(t) = treeFold(0, \(a,l,r). a+l+r, t) + +flattenTree : Tree(a) -> List(a) +flattenTree(t) = treeFold([], \(a,l,r). append(l, append([a], r)), t) diff --git a/docs/tutorial/example/tydefs.disco b/docs/tutorial/example/tydefs.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/tydefs.disco @@ -0,0 +1,11 @@ +type Triplet = (N * N * N) + +sumTripletList : List (N * N * N) -> N +sumTripletList [] = 0 +sumTripletList ((n1, n2, n3) :: rest) = (n1 + n2 + n3 + (sumTripletList rest)) + +type Tree = Unit + (N * Tree * Tree) + +sumTree : Tree -> N +sumTree (left _) = 0 +sumTree (right (n, l, r)) = n + sumTree(l) + sumTree(r) diff --git a/docs/tutorial/example/unit-test.disco b/docs/tutorial/example/unit-test.disco new file mode 100644 --- /dev/null +++ b/docs/tutorial/example/unit-test.disco @@ -0,0 +1,8 @@ +!!! gcd(7,6) == 1 +!!! gcd(12,18) == 6 +!!! gcd(0,0) == 0 + +gcd : N * N -> N +gcd(a,0) = a +gcd(a,b) = gcd(b, a mod b) + diff --git a/example/TestExamples.hs b/example/TestExamples.hs new file mode 100644 --- /dev/null +++ b/example/TestExamples.hs @@ -0,0 +1,25 @@ +module Main where + +import System.Directory +import System.Exit +import System.FilePath +import System.Process + +import Control.Monad + +exampleDirs :: [FilePath] +exampleDirs = ["example", "docs/tutorial/example", "lib"] + +main :: IO () +main = mapM_ checkDir exampleDirs + +checkDir :: FilePath -> IO () +checkDir dir = do + examples <- filter ((== ".disco") . takeExtension) <$> getDirectoryContents dir + res <- and <$> mapM (checkExample . (dir )) examples + when (not res) $ exitFailure + +checkExample :: FilePath -> IO Bool +checkExample exampleFile = do + ex <- system ("disco --check " ++ exampleFile) + return (ex == ExitSuccess) diff --git a/example/abs.disco b/example/abs.disco new file mode 100644 --- /dev/null +++ b/example/abs.disco @@ -0,0 +1,13 @@ +||| This was an example of how you could implement an absolute value +||| function with the type Z -> N even if it is not built into the +||| language. The problem is that it is rather inefficient: since it +||| builds up the answer by adding 1 repeatedly, it takes time +||| proportional to its result. absolute value is now built into disco +||| so this is here just as a curiosity. + +abs : Z -> N +abs x = + {? abs (-x) if x < 0, + 0 when x is 0, + 1 + abs (x-1) otherwise + ?} diff --git a/example/catalan.disco b/example/catalan.disco new file mode 100644 --- /dev/null +++ b/example/catalan.disco @@ -0,0 +1,19 @@ +import list +import oeis + +-- The type of binary tree shapes: empty tree, or a pair of subtrees. +type BT = Unit + BT*BT + +-- Generate the list of all binary tree shapes of a given size. +treesOfSize : N -> List(BT) +treesOfSize(0) = [left(■)] +treesOfSize(k+1) = + [ right (l,r) | x <- [0 .. k], l <- treesOfSize(x), r <- treesOfSize(k .- x) ] + +-- Compute first few Catalan numbers by brute force. +catalan1 : List(N) +catalan1 = each(\k. length(treesOfSize(k)), [0..4]) + +-- Extend the sequence via the OEIS. +catalan : List(N) +catalan = extendSequence(catalan1) diff --git a/example/demo.disco b/example/demo.disco new file mode 100644 --- /dev/null +++ b/example/demo.disco @@ -0,0 +1,29 @@ +f : Z -> Z +f x = x - 3 + +sum : List(Z) -> Z +sum [] = 0 +sum (x::xs) = x + sum xs + +g : N -> N +g (2n) = n +g (2n+1) = n + +q : N -> N +q x = + {? 3 if x < 9 + , 17 if 10 <= x < 22 + , 99 otherwise + ?} + +type S = Unit + Char × S + +len : S -> N +len (left(unit)) = 0 +len (right(_, s)) = 1 + len s + +type P(a) = a + P(a) * P(a) + +height : P(a) -> N +height (left(_)) = 0 +height (right(l, r)) = 1 + (height l) max (height r) diff --git a/example/gcd.disco b/example/gcd.disco new file mode 100644 --- /dev/null +++ b/example/gcd.disco @@ -0,0 +1,22 @@ +||| The greatest common divisor of two natural numbers. +||| +||| If we take the word "greatest" to refer to the usual less-than +||| relation on natural numbers, then gcd(0,0) would be undefined: +||| every natural number evenly divides 0, and there is no greatest +||| natural number. However, we should instead think of the +||| divisibility relation: gcd is really the meet (greatest lower +||| bound) in the divisibility lattice on the natural numbers. That +||| is, gcd(a,b) = d if for every d' such that d' evenly divides both +||| a and b, we have that d' also evenly divides (NOT "is less than"!) +||| d. Under this definition, gcd(0,0) is perfectly well defined and +||| equal to 0. 0 is in fact the "greatest" natural number under the +||| divisibility relation, because it is divisible by every natural +||| number. + +!!! gcd(7,6) == 1 +!!! gcd(12,18) == 6 +!!! gcd(0,0) == 0 + +gcd : N * N -> N +gcd(a,0) = a +gcd(a,b) = gcd(b, a mod b) diff --git a/example/grid.disco b/example/grid.disco new file mode 100644 --- /dev/null +++ b/example/grid.disco @@ -0,0 +1,75 @@ +-- Some isomorphisms between ℕ and ℕ×ℕ. + +||| An isomorphism between ℕ and ℕ×ℕ, counting off "by squares", like this: +||| +||| 0 3 8 +||| 1 2 7 +||| 4 5 6 +||| +||| and so on, where the first column contains the square numbers. +||| sqIso' is the inverse. + +!!! ∀ n : Nat. sqIso (sqIso' n) == n + +sqIso : ℕ×ℕ → ℕ +sqIso (x,y) = + {? y^2 + x if x <= y, + (x+1)^2 .- 1 .- y otherwise + ?} + +||| Inverse direction of the square isomorphism. + +!!! ∀ p : Nat*Nat. sqIso' (sqIso p) == p + +sqIso' : ℕ → ℕ×ℕ +sqIso' n = + let r = sqrt n + in {? (n .- r^2, r) if n <= r^2 + r, + (r, (r+1)^2 .- 1 .- n) otherwise + ?} + +||| The classic "diagonal" isomorphism: +||| +||| 0 2 5 +||| 1 4 +||| 3 +||| +||| where the first column contains the triangular numbers. + +!!! ∀ n : Nat. diagIso (diagIso' n) == n + +diagIso : ℕ×ℕ → ℕ +diagIso (x,y) = (x+y)*(x+y+1)//2 + x + +diagIso' : ℕ → ℕ×ℕ +diagIso' n = + let d = (sqrt(1 + 8n) .- 1)//2 : N + in let t = d*(d+1)//2 + in (n .- t, d .- (n .- t)) + + +||| Every POSITIVE n can be decomposed into a power of two times an +||| odd number, n = 2^x (2y + 1). This creates an isomorphism n <-> +||| (x,y). This is actually an isomorphism between {n | n : ℕ, n > 0} +||| and ℕ×ℕ, but at the moment the disco type system doesn't let us +||| say that (and it likely never will). + +-- We have to be careful not to call powerIso' 0 because it gets stuck +-- in infinite recursion! One way that would work is to write the +-- test as follows: + +!!! forall n:Nat. powerIso (powerIso' (n+1)) == (n+1) + +-- Alternatively, since 'implies' is lazy (i.e. "short-circuiting"), +-- we can write + +!!! ∀ n : Nat. (n > 0) ==> powerIso (powerIso' n) == n + +powerIso : ℕ×ℕ → ℕ +powerIso (x,y) = 2^x * (2y + 1) + +powerIso' : ℕ → ℕ×ℕ +powerIso' n = + {? (0, n//2) if not (2 divides n), + (x+1,y) when powerIso' (n//2) is (x,y) + ?} diff --git a/example/lists.disco b/example/lists.disco new file mode 100644 --- /dev/null +++ b/example/lists.disco @@ -0,0 +1,12 @@ +iterateP : (a → a) → a → List(a) +iterateP f p = p :: iterateP f (f p) + +fib2_helper : ℕ×ℕ → ℕ×ℕ +fib2_helper (a,b) = (b,a+b) + +indexP : ℕ -> List(a) -> a +indexP 0 (p::_) = p +indexP (n+1) (_::l') = indexP n l' + +fib2 : ℕ → ℕ +fib2 n = {? x when (indexP n (iterateP fib2_helper (0,1))) is (x,_) ?} diff --git a/example/logic.disco b/example/logic.disco new file mode 100644 --- /dev/null +++ b/example/logic.disco @@ -0,0 +1,20 @@ +-- Basic logical operators + +lnot1 : Bool -> Bool +lnot1 true = false +lnot1 false = true + +lnot2 : Bool -> Bool +lnot2 x = + {? false if x, + true otherwise + ?} + +implication : Bool -> Bool -> Bool +implication x y = + {? false if x and not y, + true otherwise + ?} + +exor : Bool -> Bool -> Bool +exor x y = (x && not y) || (not x && y) diff --git a/example/nim.disco b/example/nim.disco new file mode 100644 --- /dev/null +++ b/example/nim.disco @@ -0,0 +1,66 @@ +import list + +I : Bool +I = true + +O : Bool +O = false + +||| Convert a natural number into a list of bits, with the *least* +||| significant bit first. + +!!! toBinary 0 == ([] : List(Bool)) +!!! toBinary 1 == ([I] : List(Bool)) +!!! toBinary 2 == ([O,I] : List(Bool)) +!!! toBinary 534 == ([O,I,I,O,I,O,O,O,O,I] : List(Bool)) +toBinary : N -> List(Bool) +toBinary 0 = [] +toBinary n = + {? O :: toBinary (n // 2) if 2 divides n + , I :: toBinary (n // 2) otherwise + ?} + +||| Convert a list of bits (with the least significant bit first) back +||| into a natural number. Left inverse of toBinary. + +!!! fromBinary [O,O,I,I] == 12 +!!! fromBinary [O,O,O,O] == 0 +!!! ∀ n : N. fromBinary (toBinary n) == n + +fromBinary : List(Bool) -> N +fromBinary [] = 0 +fromBinary (false :: b) = 2 * fromBinary b +fromBinary (true :: b) = 1 + 2 * fromBinary b + +xorB : Bool * Bool -> Bool +xorB = ~/=~ + +xor : List(Bool) * List(Bool) -> List(Bool) +xor([], bs) = bs +xor(bs, []) = bs +xor(a::as, b::bs) = (xorB(a,b)) :: xor(as, bs) + +xorN : N*N -> N +xorN(a, b) = fromBinary (xor(toBinary a, toBinary b)) + +nimSum : List(N) -> N +nimSum ns = fromBinary(reduce(xor, [], each(toBinary, ns))) + +xorPile : N -> List(N) -> List(N) +xorPile _ [] = [] +xorPile x (n :: ns) + = {? xorN(x, n) :: ns if xorN(x, n) < n + , n :: xorPile x ns otherwise + ?} + +||| Perform the optimal nim move, or report that the position is a +||| losing position. + +!!! nimMove [1,5,8] == (right [1,5,4] : Unit + List(N)) +nimMove : List(N) -> Unit + List(N) +nimMove ls = + let s = nimSum ls + , ls' = xorPile s ls + in {? left unit if ls == ls' + , right ls' otherwise + ?} diff --git a/example/prime.disco b/example/prime.disco new file mode 100644 --- /dev/null +++ b/example/prime.disco @@ -0,0 +1,53 @@ +-- Primality test +-- +-- Taken from Jan van Eijck, "The Haskell Road to Logic, Maths, and Programming", 2nd +-- Edition, pp. 4--11 + +||| ldf k n calculates the least divisor of n that is at least k and +||| at most sqrt n. If no such divisor exists, then it returns n. + +!!! ldf 2 10 == 2 +!!! ldf 3 10 == 10 +!!! ldf 2 25 == 5 +!!! ldf 5 25 == 5 +!!! ldf 6 25 == 25 +!!! forall k:N, m:N. let n = k+m in k <= ldf k n <= n +!!! forall k:N, n:N. (ldf k n) divides n + +ldf : N -> N -> N +ldf k n = + {? k if k divides n, + n if k^2 > n, + ldf (k+1) n otherwise + ?} + + +||| ld n calculates the least nontrivial divisor of n, or returns n if +||| n has no nontrivial divisors. + +!!! ld 14 == 2 +!!! ld 15 == 3 +!!! ld 16 == 2 +!!! ld 17 == 17 +!!! ld 25 == 5 +!!! forall n:N. (ld n) divides n + +ld : N -> N +ld = ldf 2 + +||| Tests whether n is prime or not. + +!!! not (isPrime 0) +!!! not (isPrime 1) +!!! isPrime 2 +!!! isPrime 3 +!!! not (isPrime 4) +!!! isPrime 5 +!!! not (isPrime 91) +!!! isPrime 113 + +isPrime : N -> Bool +isPrime n = + {? false if n <= 1, + ld n == n otherwise + ?} diff --git a/example/prog.disco b/example/prog.disco new file mode 100644 --- /dev/null +++ b/example/prog.disco @@ -0,0 +1,57 @@ +f : (N -> N) -> N * N -> N -> Z +f g (x,y) z = x + g y - z -- here g y is function application + +-- This used to be allowed, but now function application is +-- *syntactically* disambiguated from multiplication. 'g y' must be +-- function application because the left-hand term is a variable. +-- q : ℕ → ℕ×ℕ → ℕ → ℤ +-- q g (x,y) z = x + g y - z -- here g y is multiplication + + +||| A naive implementation of the fibonacci function. +!!! fib 0 == 0 +!!! fib 1 == 1 +!!! fib 2 == 1 +!!! fib 5 == 5 +!!! fib 12 == 144 +fib : Nat -> Nat -- a top-level recursive function +fib n = + {? n when + n + is 0 + , n when n is 1 -- comment + , fib (n.-1) + fib (n.-2) otherwise + -- note we can't write + -- fib (n-1) + fib (n-2) otherwise + -- since that doesn't pass the type checker: it doesn't believe + -- that (n-1) and (n-2) are natural numbers. + ?} + +-- Mutually recursive functions. The order of declarations and +-- definitions does not matter. +isEven : N -> Bool +isOdd : N -> Bool + +-- We can either write a definition explicitly using a case... +isEven n = + {? true when n is 0 + , isOdd m when n is m+1 + ?} + +-- Or we can directly define by cases like this (which is just syntax +-- sugar for something like the former). +isOdd 0 = false +isOdd (m+1) = isEven m + +-- Again, here are two equivalent definitions of fact using the two +-- different styles. + +fact : N -> N +fact n = + {? 1 when n is 0, + n * fact m when n is m+1 + ?} + +fact2 : N -> N +fact2 0 = 1 +fact2 (m+1) = (m + 1) * fact2 m diff --git a/example/prop.disco b/example/prop.disco new file mode 100644 --- /dev/null +++ b/example/prop.disco @@ -0,0 +1,4 @@ + +!!! ∀ x : N, y : N. plus x y == plus y x +plus : N -> N -> N +plus x y = x + y diff --git a/example/rsa.disco b/example/rsa.disco new file mode 100644 --- /dev/null +++ b/example/rsa.disco @@ -0,0 +1,73 @@ +import num +import list + +-- Implementation of RSA encryption algorithm. +-- Reference: https://simple.wikipedia.org/wiki/RSA_(algorithm) + +-- To use, first call `getKeys` with two prime numbers, which returns +-- two pairs. The first pair is the public key, the second is the +-- private key. These keys, along with the `encrypt` and `decrypt` +-- functions can be used to encrypt and decrypt lists of natural +-- numbers. + +encrypt : N * N -> List(N) -> List(N) +encrypt key xs = each (encrypt1 key, xs) + +decrypt : N * N -> List(N) -> List(N) +decrypt = encrypt + +-- takes two primes, returns a pair of pairs containing the RSA public/private keys +-- prime -> prime -> (public key, private key) +getKeys : N -> N -> (N * N) * (N * N) +getKeys p1 p2 = + let m = p1 * p2, + totient = (p1 .- 1)*(p2 .- 1), + e = getPubExp 2 totient + in ((m, e), (m, getPrivExp e totient)) + +-- guess -> totient -> e +getPubExp : N -> N -> N +getPubExp e totient = + {? e if gcd(e, totient) == 1 + , getPubExp (e+1) totient otherwise + ?} + +gcd : N*N -> N +gcd (a, 0) = a +gcd (a, b) = gcd (b, a mod b) + +getPrivExp : N -> N -> N +getPrivExp e totient = + let t = inverse (0,1) (totient,e) + in {? abs t if t>=0 + , abs (t+totient) otherwise + ?} + + +-- Implemented using Extended Euclidean Algorithm (reference: +-- https://en.wikipedia.org/wiki/Extended_Euclidean_algorithm#Computing_multiplicative_inverses_in_modular_structures) +inverse : (Z * Z) -> (Z * Z) -> Z +inverse (t,newt) (r,newr) = + {? t if newr==0 + , let q = r // newr in (inverse (newt, t-q*newt) (newr,r-q*newr)) otherwise + ?} + +-- encrypt1 : msg -> public key (mod,exp) -> encrypted msg +-- encrypts one single number +encrypt1 : Nat * Nat -> Nat -> Nat +encrypt1 (m, e) msg = modPower msg e m + +-- decrypts one single number +decrypt1 : Nat * Nat -> Nat -> Nat +decrypt1 = encrypt1 + +-- modPower : n -> power -> modulus -> nat +-- Exponentiating by squaring algorithm reference: +-- https://simple.wikipedia.org/wiki/Exponentiation_by_squaring +modPower : Nat -> Nat -> Nat -> Nat +modPower n p m = + {? 1 if p==0 + , n % m if p==1 + , (modPower (n^2) (p//2) m) % m if (even p) + , (n * (modPower (n^2) (p//2) m)) % m if (p>2) && (odd p) + ?} diff --git a/example/sums.disco b/example/sums.disco new file mode 100644 --- /dev/null +++ b/example/sums.disco @@ -0,0 +1,7 @@ +foo : List(N) + Bool -> N +foo x = + {? n when x is left (n :: _), + 0 when x is left [], + 1 when x is right True, + 2 when x is right False + ?} diff --git a/example/tree.disco b/example/tree.disco new file mode 100644 --- /dev/null +++ b/example/tree.disco @@ -0,0 +1,23 @@ +type Tree = Unit + N * Tree * Tree + +leaf : Tree +leaf = left(■) + +node : N * Tree * Tree -> Tree +node(x, l, r) = right(x, l, r) + +tree1 : Tree +tree1 = node(3, node(5, node(1, leaf, leaf), leaf), node(6, node(2, leaf, leaf), node(8, leaf, leaf))) + +treeFold : r * (N * r * r -> r) * Tree -> r +treeFold(x, f, left(■)) = x +treeFold(x, f, right(n,l,r)) = f(n, treeFold(x, f, l), treeFold(x, f, r)) + +treeSum : Tree -> N +treeSum(t) = treeFold(0, \(x,l,r). x + l + r, t) + +treeSize : Tree -> N +treeSize(t) = treeFold(0, \(x,l,r). 1 + l + r, t) + +treeHeight : Tree -> N +treeHeight(t) = treeFold(0, \(x,l,r). 1 + l max r, t) diff --git a/lib/container.disco b/lib/container.disco new file mode 100644 --- /dev/null +++ b/lib/container.disco @@ -0,0 +1,13 @@ +using NoStdLib + +import list +import product + +reducebag : (a × a → a) × a × Bag(a) → a +reducebag(f,z,b) = foldr(f,z,list(b)) + +reduceset : (a × a → a) × a × Set(a) → a +reduceset(f,z,s) = foldr(f,z,list(s)) + +unions : Set(Set(a)) → Set(a) +unions(ss) = foldr(~∪~, {}, list(ss)) diff --git a/lib/graph.disco b/lib/graph.disco new file mode 100644 --- /dev/null +++ b/lib/graph.disco @@ -0,0 +1,58 @@ +search : N -> Graph(N) -> N -> Bool * Set(N) +search target g pos = {? + (search' target g pos {}) if (contains g pos), + (False, {}) otherwise + ?} + +search' : N -> Graph(N) -> N -> Set(N) -> Bool * Set(N) +search' target g pos visited = {? + (True, visited union {pos}) if (pos == target && contains g pos), + (False,visited) if pos ∈ visited, + sequence target g pos (list (neighbors g pos)) (visited union {pos}) otherwise + ?} + +sequence : N -> Graph(N) -> N -> List(N) -> Set(N) -> Bool * Set(N) +sequence target g pos [] visited = (False, visited) +sequence target g pos (a::as) visited = + {? {? + (successful, v') if successful, + sequence target g pos as v' otherwise + ?} when search' target g a visited is (successful, v') + ?} + +searchDAG : N -> Graph(N) -> N -> Bool +searchDAG target g pos = (pos == target && contains g pos) || (true ∈ (each (searchDAG target g, neighbors g pos))) + +contains : Graph(N) -> N -> Bool +contains g a = {? + True when lookup (a,summary g) is right _, + False otherwise + ?} + +neighbors : Graph(N) -> N -> Set(N) +neighbors g pos = {? + s when lookup (pos, summary g) is right s, + {} otherwise + ?} + +vertices : Graph(N) -> List(N) +vertices g = each ((\(k,_). k), (list (mapToSet (summary g)))) + +topsort : Graph(N) -> Unit + List(N) * Set(N) +topsort g = downstream g (vertices g) {} {} [] + +searchFrom' : Graph(N) -> N -> Set(N) -> Set(N) -> List(N) -> Unit + List(N) * Set(N) +searchFrom' g pos visited locked stack = {? + left(unit) if pos ∈ locked, + right (stack, visited) if pos ∈ visited, + right (pos :: s', v' union {pos}) when downstream g (list (neighbors g pos)) visited (locked union {pos}) stack is right (s', v'), + left(unit) otherwise + ?} + +downstream : Graph(N) -> List(N) -> Set(N) -> Set(N) -> List(N) -> Unit + List(N) * Set(N) +downstream g [] visited locked stack = right (stack, visited) +downstream g (a::as) visited locked stack = + {? + downstream g as v' locked s' when searchFrom' g a visited locked stack is right (s',v'), + left(unit) otherwise + ?} diff --git a/lib/list.disco b/lib/list.disco new file mode 100644 --- /dev/null +++ b/lib/list.disco @@ -0,0 +1,72 @@ +using NoStdLib + +||| A right fold for lists. +||| foldr(f, z, [a,b,c]) = f(a, f(b, f(c, z))) + +!!! foldr(~+~, 0, [1,2,3]) == 6 +!!! foldr(~+~, 0, []) == 0 + +foldr : (a × b → b) × b × List(a) → b +foldr(f, z, [] ) = z +foldr(f, z, x::xs) = f(x, foldr(f, z, xs)) + +||| Append two lists into a single list. + +!!! append([], []) == [] +!!! append([1,2,3], []) == [1,2,3] +!!! append([1,2,3], [4,5,6]) == [1,2,3,4,5,6] +!!! ∀ xs : List(N). append([], xs) == xs +!!! forall xs : List(N). append(xs, []) == xs + +append : List(a) × List(a) → List(a) +append([], ys) = ys +append(x::xs, ys) = x :: append(xs, ys) + +||| Flatten a list of lists into a single list. + +!!! concat [[1,2],[3],[],[4,5,6]] == [1,2,3,4,5,6] + +concat : List(List(a)) → List(a) +concat [] = [] +concat (l::ls) = append(l, concat ls) + +||| Apply a function to each element of a list, returning a new list +||| of the results. Note, this is here just for illustration +||| purposes; it is much more efficient to use the builtin primitive +||| 'each' function (which also works on bags and sets). + +!!! eachlist(\x.x+1, [] ) == [] +!!! eachlist(\x.2, "hello" ) == [2,2,2,2,2] +!!! eachlist(\x. 5x, [2,4,1,7]) == [10,20,5,35] + +eachlist : (a → b) × List(a) → List(b) +eachlist(f, []) = [] +eachlist(f, x::xs) = f(x) :: eachlist(f, xs) + +||| Take the first n elements of a list. +!!! take(1, [true, false, true]) == [true] +!!! take(3, [true, false]) == [true, false] +!!! take(0, [true, false]) == ([] : List(Bool)) + +take : ℕ × List(a) → List(a) +take(0, _) = [] +take(_, []) = [] +take(n+1, x :: xs) = x :: take(n, xs) + +||| The length of a list. +!!! length [true, false, true] == 3 +length : List(a) → ℕ +length [] = 0 +length (_::l) = 1 + length l + +zipWith : (a × b → c) × List(a) × List(b) -> List(c) +zipWith(_, [], _) = [] +zipWith(_, _, []) = [] +zipWith(f, a::as, b::bs) = f(a, b) :: zipWith(f, as, bs) + +filterlist : (a -> Bool) × List(a) -> List(a) +filterlist(_, []) = [] +filterlist(p, a :: as) = + {? a :: filterlist(p, as) if p a + , filterlist(p, as) otherwise + ?} diff --git a/lib/num.disco b/lib/num.disco new file mode 100644 --- /dev/null +++ b/lib/num.disco @@ -0,0 +1,47 @@ +using Primitives + +||| Test whether the given natural number is prime. +!!! not (isPrime 0) +!!! not (isPrime 1) +!!! isPrime 2 +!!! isPrime 3 +!!! isPrime 1000000007 +isPrime : N -> Bool +isPrime = $isPrime + +||| Takes naturals b and n. Calculates the base b logarithm of n rounded down +!!! log (1,1) == 0 +!!! log (3,1) == 0 +!!! log (2, 1024) == 10 +!!! log (2, 1023) == 9 +!!! log (7, 11398895185373143) == 19 +log : N * N -> N +log (1,1) = 0 +log (0,_) = $crash "Log base 0 is undefined" +log (1,_) = $crash "Log base 1 is undefined for inputs other than 1" +log (_,0) = $crash "Log of Zero" +log (b, x) = {? + 0 if b > x, + 1 + log (b, x // b) otherwise + ?} + +||| Calculate the base 2 logarithm of the given natural number rounded down +!!! lg 4 == 2 +!!! lg 5 == 2 +!!! lg 7 == 2 +!!! lg 10 == 3 +!!! lg 25 == 4 +!!! lg 99887766554433221100 == 66 +!!! lg (2^100 + 1) == 100 +lg : N -> N +lg x = log (2,x) + +||| Compute the prime factorization of the given natural number. +factor : N -> Bag(N) +factor = $factor + +even : Z -> Bool +even x = 2 divides x + +odd : Z -> Bool +odd x = ¬(2 divides x) diff --git a/lib/oeis.disco b/lib/oeis.disco new file mode 100644 --- /dev/null +++ b/lib/oeis.disco @@ -0,0 +1,13 @@ +using Primitives + +||| Look up a sequence of integers using https://oeis.org +!!! lookupSequence [] == left(unit) +!!! lookupSequence [1,1,2,3] == right "https://oeis.org/A000045" +lookupSequence : List(N) -> Unit + List(Char) +lookupSequence = $lookupSequence + +||| Extend a known sequence of integers with data from https://oeis.org +!!! extendSequence [] == [] +!!! extendSequence [1,1,2,3,5] == [1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, 377, 610, 987, 1597, 2584, 4181, 6765, 10946, 17711, 28657, 46368, 75025, 121393, 196418, 317811, 514229, 832040, 1346269, 2178309, 3524578, 5702887, 9227465, 14930352, 24157817, 39088169, 63245986, 102334155] +extendSequence : List(N) -> List(N) +extendSequence = $extendSequence diff --git a/lib/prim.disco b/lib/prim.disco new file mode 100644 --- /dev/null +++ b/lib/prim.disco @@ -0,0 +1,4 @@ +using Primitives + +crash : List(Char) -> a +crash = $crash diff --git a/lib/product.disco b/lib/product.disco new file mode 100644 --- /dev/null +++ b/lib/product.disco @@ -0,0 +1,7 @@ +using NoStdLib + +fst : (a × b) → a +fst (a,_) = a + +snd : (a × b) → b +snd (_,b) = b diff --git a/lib/prop.disco b/lib/prop.disco new file mode 100644 --- /dev/null +++ b/lib/prop.disco @@ -0,0 +1,16 @@ +using Primitives + +||| Decide whether a proposition holds, *i.e.* convert it to a boolean. +||| Note, however, that for some propositions this may run forever. +||| For example, `holds (forall (x:N). x >= 0)` will run forever +||| trying to check all natural numbers to see if they are all +||| nonnegative. +||| +||| If you want to use random sampling to check whether a proposition +||| *probably* holds, the `:test` command at the REPL will give you a +||| best-effort answer. For instance, `:test (forall x:N. x >= 0)` will +||| happily report that every natural number it tried was nonnegative. + +!!! holds (true : Prop) == true +holds : Prop -> Bool +holds = $holds diff --git a/repl/REPL.hs b/repl/REPL.hs new file mode 100644 --- /dev/null +++ b/repl/REPL.hs @@ -0,0 +1,16 @@ +----------------------------------------------------------------------------- +-- | +-- Module : REPL +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A text-based REPL for disco. +-- +----------------------------------------------------------------------------- + +import Disco.Interactive.CmdLine + +main :: IO () +main = discoMain diff --git a/src/Disco/AST/Core.hs b/src/Disco/AST/Core.hs new file mode 100644 --- /dev/null +++ b/src/Disco/AST/Core.hs @@ -0,0 +1,390 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.AST.Core +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Abstract syntax trees representing the desugared, untyped core +-- language for Disco. +----------------------------------------------------------------------------- + +module Disco.AST.Core + ( -- * Core AST + RationalDisplay(..) + , Core(..) + , Op(..), opArity, substQC, substsQC + ) + where + +import Control.Lens.Plated +import Data.Data (Data) +import Data.Data.Lens (uniplate) +import qualified Data.Set as S +import GHC.Generics +import Prelude hiding ((<>)) +import qualified Prelude as P +import Unbound.Generics.LocallyNameless hiding (LFresh, lunbind) + +import Disco.Effects.LFresh +import Polysemy (Members, Sem) +import Polysemy.Reader + +import Data.Ratio +import Disco.AST.Generic (Side, selectSide) +import Disco.Names (QName) +import Disco.Pretty +import Disco.Types + +-- | A type of flags specifying whether to display a rational number +-- as a fraction or a decimal. +data RationalDisplay = Fraction | Decimal + deriving (Eq, Show, Generic, Data, Ord, Alpha) + +instance Semigroup RationalDisplay where + Decimal <> _ = Decimal + _ <> Decimal = Decimal + _ <> _ = Fraction + +-- | The 'Monoid' instance for 'RationalDisplay' corresponds to the +-- idea that the result should be displayed as a decimal if any +-- decimal literals are used in the input; otherwise, the default is +-- to display as a fraction. So the identity element is 'Fraction', +-- and 'Decimal' always wins when combining. +instance Monoid RationalDisplay where + mempty = Fraction + mappend = (P.<>) + +-- | AST for the desugared, untyped core language. +data Core where + -- | A variable. + CVar :: QName Core -> Core + -- | A rational number. + CNum :: RationalDisplay -> Rational -> Core + -- | A built-in constant. + CConst :: Op -> Core + -- | An injection into a sum type, i.e. a value together with a tag + -- indicating which element of a sum type we are in. For example, + -- false is represented by @CSum L CUnit@; @right(v)@ is + -- represented by @CSum R v@. Note we do not need to remember + -- which type the constructor came from; if the program + -- typechecked then we will never end up comparing constructors + -- from different types. + CInj :: Side -> Core -> Core + -- | A primitive case expression on a value of a sum type. + CCase :: Core -> Bind (Name Core) Core -> Bind (Name Core) Core -> Core + -- | The unit value. + CUnit :: Core + -- | A pair of values. + CPair :: Core -> Core -> Core + -- | A projection from a product type, i.e. @fst@ or @snd@. + CProj :: Side -> Core -> Core + -- | An anonymous function. + CAbs :: Bind [Name Core] Core -> Core + -- | Function application. + CApp :: Core -> Core -> Core + -- | A "test frame" under which a test case is run. Records the + -- types and legible names of the variables that should + -- be reported to the user if the test fails. + CTest :: [(String, Type, Name Core)] -> Core -> Core + -- | A type. + CType :: Type -> Core + -- | Introduction form for a lazily evaluated value of type Lazy T + -- for some type T. We can have multiple bindings to multiple + -- terms to create a simple target for compiling mutual recursion. + CDelay :: Bind [Name Core] [Core] -> Core + -- | Force evaluation of a lazy value. + CForce :: Core -> Core + deriving (Show, Generic, Data, Alpha) + +instance Plated Core where + plate = uniplate + +-- | Operators that can show up in the core language. Note that not +-- all surface language operators show up here, since some are +-- desugared into combinators of the operators here. +data Op + = -- | Addition (@+@) + OAdd + | -- | Arithmetic negation (@-@) + ONeg + | -- | Integer square root (@sqrt@) + OSqrt + | -- | Floor of fractional type (@floor@) + OFloor + | -- | Ceiling of fractional type (@ceiling@) + OCeil + | -- | Absolute value (@abs@) + OAbs + | -- | Multiplication (@*@) + OMul + | -- | Division (@/@) + ODiv + | -- | Exponentiation (@^@) + OExp + | -- | Modulo (@mod@) + OMod + | -- | Divisibility test (@|@) + ODivides + | -- | Multinomial coefficient (@choose@) + OMultinom + | -- | Factorial (@!@) + OFact + | -- | Equality test (@==@) + OEq + | -- | Less than (@<@) + OLt + | -- Type operators + + -- | Enumerate the values of a type. + OEnum + | -- | Count the values of a type. + OCount + | -- Container operations + + -- | Size of two sets (@size@) + OSize + | -- | Power set/bag of a given set/bag + -- (@power@). + OPower + | -- | Set/bag element test. + OBagElem + | -- | List element test. + OListElem + | -- | Map a function over a bag. Carries the + -- output type of the function. + OEachBag + | -- | Map a function over a set. Carries the + -- output type of the function. + OEachSet + | -- | Filter a bag. + OFilterBag + | -- | Merge two bags/sets. + OMerge + | -- | Bag join, i.e. union a bag of bags. + OBagUnions + | -- | Adjacency List of given graph + OSummary + | -- | Empty graph + OEmptyGraph + | -- | Construct a vertex with given value + OVertex + | -- | Graph overlay + OOverlay + | -- | Graph connect + OConnect + | -- | Map insert + OInsert + | -- | Map lookup + OLookup + | -- Ellipses + + -- | Continue until end, @[x, y, z .. e]@ + OUntil + | -- Container conversion + + -- | set -> list conversion (sorted order). + OSetToList + | -- | bag -> set conversion (forget duplicates). + OBagToSet + | -- | bag -> list conversion (sorted order). + OBagToList + | -- | list -> set conversion (forget order, duplicates). + OListToSet + | -- | list -> bag conversion (forget order). + OListToBag + | -- | bag -> set of counts + OBagToCounts + | -- | set of counts -> bag + OCountsToBag + | -- | Map k v -> Set (k × v) + OMapToSet + | -- | Set (k × v) -> Map k v + OSetToMap + | -- Number theory primitives + + -- | Primality test + OIsPrime + | -- | Factorization + OFactor + | -- | Turn a rational into a (num, denom) pair + OFrac + | -- Propositions + + -- | Universal quantification. Applied to a closure + -- @t1, ..., tn -> Prop@ it yields a @Prop@. + OForall [Type] + | -- | Existential quantification. Applied to a closure + -- @t1, ..., tn -> Prop@ it yields a @Prop@. + OExists [Type] + | -- | Convert Prop -> Bool via exhaustive search. + OHolds + | -- | Flip success and failure for a prop. + ONotProp + | -- | Equality assertion, @=!=@ + OShouldEq Type + | -- Other primitives + + -- | Error for non-exhaustive pattern match + OMatchErr + | -- | Crash with a user-supplied message + OCrash + | -- | No-op/identity function + OId + | -- | Lookup OEIS sequence + OLookupSeq + | -- | Extend a List via OEIS + OExtendSeq + deriving (Show, Generic, Data, Alpha, Eq, Ord) + +-- | Get the arity (desired number of arguments) of a function +-- constant. A few constants have arity 0; everything else is +-- uncurried and hence has arity 1. +opArity :: Op -> Int +opArity OEmptyGraph = 0 +opArity OMatchErr = 0 +opArity _ = 1 + +substQC :: QName Core -> Core -> Core -> Core +substQC x s = transform $ \case + CVar y + | x == y -> s + | otherwise -> CVar y + t -> t + +substsQC :: [(QName Core, Core)] -> Core -> Core +substsQC xs = transform $ \case + CVar y -> case P.lookup y xs of + Just c -> c + _ -> CVar y + t -> t + +instance Pretty Core where + pretty = \case + CVar qn -> pretty qn + CNum _ r + | denominator r == 1 -> text (show (numerator r)) + | otherwise -> text (show (numerator r)) <> "/" <> text (show (denominator r)) + CApp (CConst op) (CPair c1 c2) + | isInfix op -> parens (pretty c1 <+> text (opToStr op) <+> pretty c2) + CApp (CConst op) c + | isPrefix op -> text (opToStr op) <> pretty c + | isPostfix op -> pretty c <> text (opToStr op) + CConst op -> pretty op + CInj s c -> withPA funPA $ selectSide s "left" "right" <+> rt (pretty c) + CCase c l r -> do + lunbind l $ \(x, lc) -> do + lunbind r $ \(y, rc) -> do + "case" <+> pretty c <+> "of {" + $+$ nest 2 ( + vcat + [ withPA funPA $ "left" <+> rt (pretty x) <+> "->" <+> pretty lc + , withPA funPA $ "right" <+> rt (pretty y) <+> "->" <+> pretty rc + ]) + $+$ "}" + CUnit -> "unit" + CPair c1 c2 -> setPA initPA $ parens (pretty c1 <> ", " <> pretty c2) + CProj s c -> withPA funPA $ selectSide s "fst" "snd" <+> rt (pretty c) + CAbs lam -> withPA initPA $ do + lunbind lam $ \(xs, body) -> "λ" <> intercalate "," (map pretty xs) <> "." <+> lt (pretty body) + CApp c1 c2 -> withPA funPA $ lt (pretty c1) <+> rt (pretty c2) + CTest xs c -> "test" <+> prettyTestVars xs <+> pretty c + CType ty -> pretty ty + CDelay d -> withPA initPA $ do + lunbind d $ \(xs, bodies) -> + "delay" <+> intercalate "," (map pretty xs) <> "." <+> pretty (toTuple bodies) + CForce c -> withPA funPA $ "force" <+> rt (pretty c) + +toTuple :: [Core] -> Core +toTuple = foldr CPair CUnit + +prettyTestVars :: Members '[Reader PA, LFresh] r => [(String, Type, Name Core)] -> Sem r Doc +prettyTestVars = brackets . intercalate "," . map prettyTestVar + where + prettyTestVar (s, ty, n) = parens (intercalate "," [text s, pretty ty, pretty n]) + +isInfix, isPrefix, isPostfix :: Op -> Bool +isInfix OShouldEq{} = True +isInfix op = op `S.member` S.fromList + [ OAdd, OMul, ODiv, OExp, OMod, ODivides, OMultinom, OEq, OLt] + +isPrefix ONeg = True +isPrefix _ = False + +isPostfix OFact = True +isPostfix _ = False + +instance Pretty Op where + pretty (OForall tys) = "∀" <> intercalate "," (map pretty tys) <> "." + pretty (OExists tys) = "∃" <> intercalate "," (map pretty tys) <> "." + pretty op + | isInfix op = "~" <> text (opToStr op) <> "~" + | isPrefix op = text (opToStr op) <> "~" + | isPostfix op = "~" <> text (opToStr op) + | otherwise = text (opToStr op) + +opToStr :: Op -> String +opToStr = \case + OAdd -> "+" + ONeg -> "-" + OSqrt -> "sqrt" + OFloor -> "floor" + OCeil -> "ceil" + OAbs -> "abs" + OMul -> "*" + ODiv -> "/" + OExp -> "^" + OMod -> "mod" + ODivides -> "divides" + OMultinom -> "choose" + OFact -> "!" + OEq -> "==" + OLt -> "<" + OEnum -> "enumerate" + OCount -> "count" + OSize -> "size" + OPower -> "power" + OBagElem -> "elem_bag" + OListElem -> "elem_list" + OEachBag -> "each_bag" + OEachSet -> "each_set" + OFilterBag -> "filter_bag" + OMerge -> "merge" + OBagUnions -> "unions_bag" + OSummary -> "summary" + OEmptyGraph -> "emptyGraph" + OVertex -> "vertex" + OOverlay -> "overlay" + OConnect -> "connect" + OInsert -> "insert" + OLookup -> "lookup" + OUntil -> "until" + OSetToList -> "set2list" + OBagToSet -> "bag2set" + OBagToList -> "bag2list" + OListToSet -> "list2set" + OListToBag -> "list2bag" + OBagToCounts -> "bag2counts" + OCountsToBag -> "counts2bag" + OMapToSet -> "map2set" + OSetToMap -> "set2map" + OIsPrime -> "isPrime" + OFactor -> "factor" + OFrac -> "frac" + OHolds -> "holds" + ONotProp -> "not" + OShouldEq _ -> "=!=" + OMatchErr -> "matchErr" + OCrash -> "crash" + OId -> "id" + OLookupSeq -> "lookupSeq" + OExtendSeq -> "extendSeq" + OForall{} -> "∀" + OExists{} -> "∃" diff --git a/src/Disco/AST/Desugared.hs b/src/Disco/AST/Desugared.hs new file mode 100644 --- /dev/null +++ b/src/Disco/AST/Desugared.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE PatternSynonyms #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.AST.Desugared +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Typed abstract syntax trees representing the typechecked, desugared +-- Disco language. +-- +----------------------------------------------------------------------------- + +module Disco.AST.Desugared + ( -- * Desugared, type-annotated terms + DTerm + , pattern DTVar + , pattern DTPrim + , pattern DTUnit + , pattern DTBool + , pattern DTChar + , pattern DTNat + , pattern DTRat + , pattern DTAbs + , pattern DTApp + , pattern DTPair + , pattern DTCase + , pattern DTTyOp + , pattern DTNil + , pattern DTTest + + , Container(..) + , DBinding + , pattern DBinding + -- * Branches and guards + , DBranch + + , DGuard + , pattern DGPat + + , DPattern + , pattern DPVar + , pattern DPWild + , pattern DPUnit + , pattern DPPair + , pattern DPInj + + , DProperty + ) + where + +import GHC.Generics + +import Data.Void +import Unbound.Generics.LocallyNameless + +import Disco.AST.Generic +import Disco.Names (QName (..)) +import Disco.Syntax.Operators +import Disco.Syntax.Prims +import Disco.Types + +data DS + +type DProperty = Property_ DS + +-- | A @DTerm@ is a term which has been typechecked and desugared, so +-- it has fewer constructors and complex features than 'ATerm', but +-- still retains typing information. + +type DTerm = Term_ DS + +type instance X_Binder DS = Name DTerm + +type instance X_TVar DS = Void -- names are qualified +type instance X_TPrim DS = Type +type instance X_TLet DS = Void -- Let gets translated to lambda +type instance X_TUnit DS = () +type instance X_TBool DS = Type +type instance X_TChar DS = () +type instance X_TString DS = Void +type instance X_TNat DS = Type +type instance X_TRat DS = () +type instance X_TAbs DS = Type -- For lambas this is the function type but + -- for forall/exists it's the argument type +type instance X_TApp DS = Type +type instance X_TCase DS = Type +type instance X_TChain DS = Void -- Chains are translated into conjunctions of + -- binary comparisons +type instance X_TTyOp DS = Type +type instance X_TContainer DS = Void -- Literal containers are desugared into + -- conversion functions applied to list literals + +type instance X_TContainerComp DS = Void -- Container comprehensions are translated + -- into monadic chains + +type instance X_TAscr DS = Void -- No type ascriptions +type instance X_TTup DS = Void -- No tuples, only pairs +type instance X_TParens DS = Void -- No explicit parens + +-- Extra constructors +type instance X_Term DS = X_DTerm + +data X_DTerm + = DTPair_ Type DTerm DTerm + | DTNil_ Type + | DTTest_ [(String, Type, Name DTerm)] DTerm + | DTVar_ Type (QName DTerm) + deriving (Show, Generic) + +instance Subst Type X_DTerm +instance Alpha X_DTerm + +pattern DTVar :: Type -> QName DTerm -> DTerm +pattern DTVar ty qname = XTerm_ (DTVar_ ty qname) + +pattern DTPrim :: Type -> Prim -> DTerm +pattern DTPrim ty name = TPrim_ ty name + +pattern DTUnit :: DTerm +pattern DTUnit = TUnit_ () + +pattern DTBool :: Type -> Bool -> DTerm +pattern DTBool ty bool = TBool_ ty bool + +pattern DTNat :: Type -> Integer -> DTerm +pattern DTNat ty int = TNat_ ty int + +pattern DTRat :: Rational -> DTerm +pattern DTRat rat = TRat_ () rat + +pattern DTChar :: Char -> DTerm +pattern DTChar c = TChar_ () c + +pattern DTAbs :: Quantifier -> Type -> Bind (Name DTerm) DTerm -> DTerm +pattern DTAbs q ty lam = TAbs_ q ty lam + +pattern DTApp :: Type -> DTerm -> DTerm -> DTerm +pattern DTApp ty term1 term2 = TApp_ ty term1 term2 + +pattern DTPair :: Type -> DTerm -> DTerm -> DTerm +pattern DTPair ty t1 t2 = XTerm_ (DTPair_ ty t1 t2) + +pattern DTCase :: Type -> [DBranch] -> DTerm +pattern DTCase ty branch = TCase_ ty branch + +pattern DTTyOp :: Type -> TyOp -> Type -> DTerm +pattern DTTyOp ty1 tyop ty2 = TTyOp_ ty1 tyop ty2 + +pattern DTNil :: Type -> DTerm +pattern DTNil ty = XTerm_ (DTNil_ ty) + +-- | A test frame, recording a collection of variables with their types and +-- their original user-facing names. Used for legible reporting of test +-- failures inside the enclosed term. +pattern DTTest :: [(String, Type, Name DTerm)] -> DTerm -> DTerm +pattern DTTest ns t = XTerm_ (DTTest_ ns t) + +{-# COMPLETE DTVar, DTPrim, DTUnit, DTBool, DTChar, DTNat, DTRat, + DTAbs, DTApp, DTPair, DTCase, DTTyOp, + DTNil, DTTest #-} + +type instance X_TLink DS = Void + +type DBinding = Binding_ DS + +pattern DBinding :: Maybe (Embed PolyType) -> Name DTerm -> Embed DTerm -> DBinding +pattern DBinding m b n = Binding_ m b n + +{-# COMPLETE DBinding #-} + +type DBranch = Bind (Telescope DGuard) DTerm + +type DGuard = Guard_ DS + +type instance X_GBool DS = Void -- Boolean guards get desugared to pattern-matching +type instance X_GPat DS = () +type instance X_GLet DS = Void -- Let gets desugared to 'when' with a variable + +pattern DGPat :: Embed DTerm -> DPattern -> DGuard +pattern DGPat embedt pat = GPat_ () embedt pat + +{-# COMPLETE DGPat #-} + +type DPattern = Pattern_ DS + +type instance X_PVar DS = Embed Type +type instance X_PWild DS = Embed Type +type instance X_PAscr DS = Void +type instance X_PUnit DS = () +type instance X_PBool DS = Void +type instance X_PChar DS = Void +type instance X_PString DS = Void +type instance X_PTup DS = Void +type instance X_PInj DS = Void +type instance X_PNat DS = Void +type instance X_PCons DS = Void +type instance X_PList DS = Void +type instance X_PAdd DS = Void +type instance X_PMul DS = Void +type instance X_PSub DS = Void +type instance X_PNeg DS = Void +type instance X_PFrac DS = Void + +-- In the desugared language, constructor patterns (DPPair, DPInj) can +-- only contain variables, not nested patterns. This means that the +-- desugaring phase has to make explicit the order of matching by +-- exploding nested patterns into sequential guards, which makes the +-- interpreter simpler. + +type instance X_Pattern DS = + Either + (Embed Type, Name DTerm, Name DTerm) -- DPPair + (Embed Type, Side, Name DTerm) -- DPInj + +pattern DPVar :: Type -> Name DTerm -> DPattern +pattern DPVar ty name <- PVar_ (unembed -> ty) name + where + DPVar ty name = PVar_ (embed ty) name + +pattern DPWild :: Type -> DPattern +pattern DPWild ty <- PWild_ (unembed -> ty) + where + DPWild ty = PWild_ (embed ty) + +pattern DPUnit :: DPattern +pattern DPUnit = PUnit_ () + +pattern DPPair :: Type -> Name DTerm -> Name DTerm -> DPattern +pattern DPPair ty x1 x2 <- XPattern_ (Left (unembed -> ty, x1, x2)) + where + DPPair ty x1 x2 = XPattern_ (Left (embed ty, x1, x2)) + +pattern DPInj :: Type -> Side -> Name DTerm -> DPattern +pattern DPInj ty s x <- XPattern_ (Right (unembed -> ty, s, x)) + where + DPInj ty s x = XPattern_ (Right (embed ty, s, x)) + +{-# COMPLETE DPVar, DPWild, DPUnit, DPPair, DPInj #-} + +type instance X_QBind DS = Void +type instance X_QGuard DS = Void + +------------------------------------------------------------ +-- getType +------------------------------------------------------------ + +instance HasType DTerm where + getType (DTVar ty _) = ty + getType (DTPrim ty _) = ty + getType DTUnit = TyUnit + getType (DTBool ty _) = ty + getType (DTChar _) = TyC + getType (DTNat ty _) = ty + getType (DTRat _) = TyF + getType (DTAbs Lam ty _) = ty + getType DTAbs{} = TyProp + getType (DTApp ty _ _) = ty + getType (DTPair ty _ _) = ty + getType (DTCase ty _) = ty + getType (DTTyOp ty _ _) = ty + getType (DTNil ty) = ty + getType (DTTest _ _) = TyProp + +instance HasType DPattern where + getType (DPVar ty _) = ty + getType (DPWild ty) = ty + getType DPUnit = TyUnit + getType (DPPair ty _ _) = ty + getType (DPInj ty _ _) = ty diff --git a/src/Disco/AST/Generic.hs b/src/Disco/AST/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Disco/AST/Generic.hs @@ -0,0 +1,656 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +-- Orphan Alpha Void instance +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.AST.Generic +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- Abstract syntax trees representing the generic syntax of the Disco +-- language. Concrete AST instances may use this module as a template. +-- +-- For more detail on the approach used here, see +-- +-- Najd and Peyton Jones, "Trees that Grow". Journal of Universal +-- Computer Science, vol. 23 no. 1 (2017), 42-62. +-- +-- +-- Essentially, we define a basic generic 'Term_' type, with a type +-- index to indicate what kind of term it is, i.e. what phase the term +-- belongs to. Each constructor has a type family used to define any +-- extra data that should go in the constructor for a particular +-- phase; there is also one additional constructor which can be used +-- to store arbitrary additional information, again governed by a type +-- family. Together with the use of pattern synonyms, the result is +-- that it looks like we have a different type for each phase, each +-- with its own set of constructors, but in fact all use the same +-- underlying type. Particular instantiations of the generic +-- framework here can be found in "Disco.AST.Surface", +-- "Disco.AST.Typed", and "Disco.AST.Desugared". +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + +module Disco.AST.Generic + ( -- * Telescopes + + Telescope (..), telCons + , foldTelescope, mapTelescope + , traverseTelescope + , toTelescope, fromTelescope + + -- * Utility types + + , Side (..), selectSide, fromSide + , Container (..) + , Ellipsis (..) + + -- * Term + + , Term_ (..) + + , X_TVar + , X_TPrim + , X_TLet + , X_TParens + , X_TUnit + , X_TBool + , X_TNat + , X_TRat + , X_TChar + , X_TString + , X_TAbs + , X_TApp + , X_TTup + , X_TCase + , X_TChain + , X_TTyOp + , X_TContainer + , X_TContainerComp + , X_TAscr + , X_Term + + , ForallTerm + + -- * Link + + , Link_ (..) + , X_TLink + , ForallLink + + -- * Qual + + , Qual_ (..) + , X_QBind + , X_QGuard + , ForallQual + + -- * Binding + + , Binding_ (..) + + -- * Branch + , Branch_ + + -- * Guard + + , Guard_ (..) + , X_GBool + , X_GPat + , X_GLet + , ForallGuard + + -- * Pattern + + , Pattern_ (..) + , X_PVar + , X_PWild + , X_PAscr + , X_PUnit + , X_PBool + , X_PTup + , X_PInj + , X_PNat + , X_PChar + , X_PString + , X_PCons + , X_PList + , X_PAdd + , X_PMul + , X_PSub + , X_PNeg + , X_PFrac + , X_Pattern + , ForallPattern + + -- * Quantifiers + + , Quantifier(..) + , Binder_ + , X_Binder + + -- * Property + + , Property_ + ) + where + +import Control.Lens.Plated +import Data.Data (Data) +import Data.Data.Lens (uniplate) +import Data.Typeable +import GHC.Exts (Constraint) +import GHC.Generics (Generic) + +import Data.Void +import Unbound.Generics.LocallyNameless + +import Disco.Pretty +import Disco.Syntax.Operators +import Disco.Syntax.Prims +import Disco.Types + +------------------------------------------------------------ +-- Telescopes +------------------------------------------------------------ + +-- | A telescope is essentially a list, except that each item can bind +-- names in the rest of the list. +data Telescope b where + + -- | The empty telescope. + TelEmpty :: Telescope b + + -- | A binder of type @b@ followed by zero or more @b@'s. This @b@ + -- can bind variables in the subsequent @b@'s. + TelCons :: Rebind b (Telescope b) -> Telescope b + deriving (Show, Generic, Alpha, Subst t, Data) + +-- | Add a new item to the beginning of a 'Telescope'. +telCons :: Alpha b => b -> Telescope b -> Telescope b +telCons b tb = TelCons (rebind b tb) + +-- | Fold a telescope given a combining function and a value to use +-- for the empty telescope. Analogous to 'foldr' for lists. +foldTelescope :: Alpha b => (b -> r -> r) -> r -> Telescope b -> r +foldTelescope _ z TelEmpty = z +foldTelescope f z (TelCons (unrebind -> (b,bs))) = f b (foldTelescope f z bs) + +-- | Apply a function to every item in a telescope. +mapTelescope :: (Alpha a, Alpha b) => (a -> b) -> Telescope a -> Telescope b +mapTelescope f = toTelescope . map f . fromTelescope + +-- | Traverse over a telescope. +traverseTelescope + :: (Applicative f, Alpha a, Alpha b) + => (a -> f b) -> Telescope a -> f (Telescope b) +traverseTelescope f = foldTelescope (\a ftb -> telCons <$> f a <*> ftb) (pure TelEmpty) + +-- | Convert a list to a telescope. +toTelescope :: Alpha b => [b] -> Telescope b +toTelescope = foldr telCons TelEmpty + +-- | Convert a telescope to a list. +fromTelescope :: Alpha b => Telescope b -> [b] +fromTelescope = foldTelescope (:) [] + +------------------------------------------------------------ +-- Utility types +------------------------------------------------------------ + +-- | Injections into a sum type (@inl@ or @inr@) have a "side" (@L@ or @R@). +data Side = L | R + deriving (Show, Eq, Ord, Enum, Bounded, Generic, Data, Alpha, Subst t) + +instance Pretty Side where + pretty = \case + L -> text "left" + R -> text "right" + +-- | Use a 'Side' to select one of two arguments (the first argument +-- for 'L', and the second for 'R'). +selectSide :: Side -> a -> a -> a +selectSide L a _ = a +selectSide R _ b = b + +-- | Convert a 'Side' to a boolean. +fromSide :: Side -> Bool +fromSide s = selectSide s False True + +-- | An enumeration of the different kinds of containers in disco: +-- lists, bags, and sets. +data Container where + ListContainer :: Container + BagContainer :: Container + SetContainer :: Container + deriving (Show, Eq, Enum, Generic, Data, Alpha, Subst t) + +-- | An ellipsis is an "omitted" part of a literal container (such as +-- a list or set), of the form @.. t@. We don't have open-ended +-- ellipses since everything is evaluated eagerly and hence +-- containers must be finite. +data Ellipsis t where + -- | 'Until' represents an ellipsis with a given endpoint, as in @[3 .. 20]@. + Until :: t -> Ellipsis t -- @.. t@ + deriving (Show, Generic, Functor, Foldable, Traversable, Alpha, Subst a, Data) + +------------------------------------------------------------ +-- Terms +------------------------------------------------------------ + +type family X_TVar e +type family X_TPrim e +type family X_TLet e +type family X_TParens e +type family X_TUnit e +type family X_TBool e +type family X_TNat e +type family X_TRat e +type family X_TChar e +type family X_TString e +type family X_TAbs e +type family X_TApp e +type family X_TTup e +type family X_TCase e +type family X_TChain e +type family X_TTyOp e +type family X_TContainer e +type family X_TContainerComp e +type family X_TAscr e +type family X_Term e + +-- | The base generic AST representing terms in the disco language. +-- @e@ is a type index indicating the kind of term, i.e. the phase +-- (for example, surface, typed, or desugared). Type families like +-- 'X_TVar' and so on use the phase index to determine what extra +-- information (if any) should be stored in each constructor. For +-- example, in the typed phase many constructors store an extra +-- type, giving the type of the term. +data Term_ e where + + -- | A term variable. + TVar_ :: X_TVar e -> Name (Term_ e) -> Term_ e + + -- | A primitive, /i.e./ a constant which is interpreted specially + -- at runtime. See "Disco.Syntax.Prims". + TPrim_ :: X_TPrim e -> Prim -> Term_ e + + -- | A (non-recursive) let expression, @let x1 = t1, x2 = t2, ... in t@. + TLet_ :: X_TLet e -> Bind (Telescope (Binding_ e)) (Term_ e) -> Term_ e + + -- | Explicit parentheses. We need to keep track of these in the + -- surface syntax in order to syntactically distinguish + -- multiplication and function application. However, note that + -- these disappear after the surface syntax phase. + TParens_ :: X_TParens e -> Term_ e -> Term_ e + + -- | The unit value, (), of type Unit. + TUnit_ :: X_TUnit e -> Term_ e + + -- | A boolean value. + TBool_ :: X_TBool e -> Bool -> Term_ e + + -- | A natural number. + TNat_ :: X_TNat e -> Integer -> Term_ e + + -- | A nonnegative rational number, parsed as a decimal. (Note + -- syntax like @3/5@ does not parse as a rational, but rather as + -- the application of a division operator to two natural numbers.) + TRat_ :: X_TRat e -> Rational -> Term_ e + + -- | A literal unicode character, /e.g./ @'d'@. + TChar_ :: X_TChar e -> Char -> Term_ e + + -- | A string literal, /e.g./ @"disco"@. + TString_ :: X_TString e -> [Char] -> Term_ e + + -- | A binding abstraction, of the form @Q vars. expr@ where @Q@ is + -- a quantifier and @vars@ is a list of bound variables and + -- optional type annotations. In particular, this could be a + -- lambda abstraction, /i.e./ an anonymous function (/e.g./ @\x, + -- (y:N). 2x + y@), a universal quantifier (@forall x, (y:N). x^2 + + -- y > 0@), or an existential quantifier (@exists x, (y:N). x^2 + y + -- == 0@). + TAbs_ :: Quantifier -> X_TAbs e -> Binder_ e (Term_ e) -> Term_ e + + -- | Function application, @t1 t2@. + TApp_ :: X_TApp e -> Term_ e -> Term_ e -> Term_ e + + -- | An n-tuple, @(t1, ..., tn)@. + TTup_ :: X_TTup e -> [Term_ e] -> Term_ e + + -- | A case expression. + TCase_ :: X_TCase e -> [Branch_ e] -> Term_ e + + -- | A chained comparison, consisting of a term followed by one or + -- more "links", where each link is a comparison operator and + -- another term. + TChain_ :: X_TChain e -> Term_ e -> [Link_ e] -> Term_ e + + -- | An application of a type operator. + TTyOp_ :: X_TTyOp e -> TyOp -> Type -> Term_ e + + -- | A containter literal (set, bag, or list). + TContainer_ :: X_TContainer e -> Container -> [(Term_ e, Maybe (Term_ e))] -> Maybe (Ellipsis (Term_ e)) -> Term_ e + + -- | A container comprehension. + TContainerComp_ :: X_TContainerComp e -> Container -> Bind (Telescope (Qual_ e)) (Term_ e) -> Term_ e + + -- | Type ascription, @(Term_ e : type)@. + TAscr_ :: X_TAscr e -> Term_ e -> PolyType -> Term_ e + + -- | A data constructor with an extension descriptor that a "concrete" + -- implementation of a generic AST may use to carry extra information. + XTerm_ :: X_Term e -> Term_ e + deriving (Generic) + +-- A type that abstracts over constraints for generic data constructors. +-- This makes it easier to derive typeclass instances for generic types. +type ForallTerm (a :: * -> Constraint) e + = ( a (X_TVar e) + , a (X_TPrim e) + , a (X_TLet e) + , a (X_TParens e) + , a (X_TUnit e) + , a (X_TBool e) + , a (X_TNat e) + , a (X_TRat e) + , a (X_TChar e) + , a (X_TString e) + , a (X_TAbs e) + , a (X_TApp e) + , a (X_TCase e) + , a (X_TTup e) + , a (X_TChain e) + , a (X_TTyOp e) + , a (X_TContainer e) + , a (X_TContainerComp e) + , a (X_TAscr e) + , a (X_Term e) + , a (Qual_ e) + , a (Guard_ e) + , a (Link_ e) + , a (Binding_ e) + , a (Pattern_ e) + , a (Binder_ e (Term_ e)) + ) + +deriving instance ForallTerm Show e => Show (Term_ e) +instance + ( Typeable e + , ForallTerm (Subst Type) e + , ForallTerm Alpha e + ) + => Subst Type (Term_ e) +instance (Typeable e, ForallTerm Alpha e) => Alpha (Term_ e) +deriving instance (Data e, Typeable e, ForallTerm Data e) => Data (Term_ e) + +instance (Data e, ForallTerm Data e) => Plated (Term_ e) where + plate = uniplate + +------------------------------------------------------------ +-- Link +------------------------------------------------------------ + +type family X_TLink e + +-- | A "link" is a comparison operator and a term; a single term +-- followed by a sequence of links makes up a comparison chain, such +-- as @2 < x < y < 10@. +data Link_ e where + + -- | Note that although the type of 'TLink_' says it can hold any + -- 'BOp', it should really only hold comparison operators. + TLink_ :: X_TLink e -> BOp -> Term_ e -> Link_ e + deriving Generic + +type ForallLink (a :: * -> Constraint) e + = ( a (X_TLink e) + , a (Term_ e) + ) + +deriving instance ForallLink Show e => Show (Link_ e) +instance ForallLink (Subst Type) e => Subst Type (Link_ e) +instance (Typeable e, Show (Link_ e), ForallLink Alpha e) => Alpha (Link_ e) +deriving instance (Typeable e, Data e, ForallLink Data e) => Data (Link_ e) + +------------------------------------------------------------ +-- Qual +------------------------------------------------------------ + +type family X_QBind e +type family X_QGuard e + +-- | A container comprehension consists of a head term and then a list +-- of qualifiers. Each qualifier either binds a variable to some +-- collection or consists of a boolean guard. +data Qual_ e where + + -- | A binding qualifier (i.e. @x in t@). + QBind_ :: X_QBind e -> Name (Term_ e) -> Embed (Term_ e) -> Qual_ e + + -- | A boolean guard qualfier (i.e. @x + y > 4@). + QGuard_ :: X_QGuard e -> Embed (Term_ e) -> Qual_ e + + deriving Generic + +type ForallQual (a :: * -> Constraint) e + = ( a (X_QBind e) + , a (X_QGuard e) + , a (Term_ e) + ) + +deriving instance ForallQual Show e => Show (Qual_ e) +instance ForallQual (Subst Type) e => Subst Type (Qual_ e) +instance (Typeable e, ForallQual Alpha e) => Alpha (Qual_ e) +deriving instance (Typeable e, Data e, ForallQual Data e) => Data (Qual_ e) + +------------------------------------------------------------ +-- Binding +------------------------------------------------------------ + +-- | A binding is a name along with its definition, and optionally its +-- type. +data Binding_ e = Binding_ (Maybe (Embed PolyType)) (Name (Term_ e)) (Embed (Term_ e)) + deriving (Generic) + +deriving instance ForallTerm Show e => Show (Binding_ e) +instance Subst Type (Term_ e) => Subst Type (Binding_ e) +instance (Typeable e, Show (Binding_ e), Alpha (Term_ e)) => Alpha (Binding_ e) +deriving instance (Typeable e, Data e, ForallTerm Data e) => Data (Binding_ e) + +------------------------------------------------------------ +-- Branch +------------------------------------------------------------ + +-- | A branch of a case is a list of guards with an accompanying term. +-- The guards scope over the term. Additionally, each guard scopes +-- over subsequent guards. + +type Branch_ e = Bind (Telescope (Guard_ e)) (Term_ e) + +------------------------------------------------------------ +-- Guard +------------------------------------------------------------ + +type family X_GBool e +type family X_GPat e +type family X_GLet e + +-- | Guards in case expressions. +data Guard_ e where + + -- | Boolean guard (@if @) + GBool_ :: X_GBool e -> Embed (Term_ e) -> Guard_ e + + -- | Pattern guard (@when term = pat@) + GPat_ :: X_GPat e -> Embed (Term_ e) -> Pattern_ e -> Guard_ e + + -- | Let (@let x = term@) + GLet_ :: X_GLet e -> Binding_ e -> Guard_ e + + deriving Generic + +type ForallGuard (a :: * -> Constraint) e + = ( a (X_GBool e) + , a (X_GPat e) + , a (X_GLet e) + , a (Term_ e) + , a (Pattern_ e) + , a (Binding_ e) + ) + +deriving instance ForallGuard Show e => Show (Guard_ e) +instance ForallGuard (Subst Type) e => Subst Type (Guard_ e) +instance (Typeable e, Show (Guard_ e), ForallGuard Alpha e) => Alpha (Guard_ e) +deriving instance (Typeable e, Data e, ForallGuard Data e) => Data (Guard_ e) + +------------------------------------------------------------ +-- Pattern +------------------------------------------------------------ + +type family X_PVar e +type family X_PWild e +type family X_PAscr e +type family X_PUnit e +type family X_PBool e +type family X_PTup e +type family X_PInj e +type family X_PNat e +type family X_PChar e +type family X_PString e +type family X_PCons e +type family X_PList e +type family X_PAdd e +type family X_PMul e +type family X_PSub e +type family X_PNeg e +type family X_PFrac e +type family X_Pattern e + +-- | Patterns. +data Pattern_ e where + + -- | Variable pattern: matches anything and binds the variable. + PVar_ :: X_PVar e -> Name (Term_ e) -> Pattern_ e + + -- | Wildcard pattern @_@: matches anything. + PWild_ :: X_PWild e -> Pattern_ e + + -- | Type ascription pattern @pat : ty@. + PAscr_ :: X_PAscr e -> Pattern_ e -> Type -> Pattern_ e + + -- | Unit pattern @()@: matches @()@. + PUnit_ :: X_PUnit e -> Pattern_ e + + -- | Literal boolean pattern. + PBool_ :: X_PBool e -> Bool -> Pattern_ e + + -- | Tuple pattern @(pat1, .. , patn)@. + PTup_ :: X_PTup e -> [Pattern_ e] -> Pattern_ e + + -- | Injection pattern (@inl pat@ or @inr pat@). + PInj_ :: X_PInj e -> Side -> Pattern_ e -> Pattern_ e + + -- | Literal natural number pattern. + PNat_ :: X_PNat e -> Integer -> Pattern_ e + + -- | Unicode character pattern + PChar_ :: X_PChar e -> Char -> Pattern_ e + + -- | String pattern. + PString_ :: X_PString e -> String -> Pattern_ e + + -- | Cons pattern @p1 :: p2@. + PCons_ :: X_PCons e -> Pattern_ e -> Pattern_ e -> Pattern_ e + + -- | List pattern @[p1, .., pn]@. + PList_ :: X_PList e -> [Pattern_ e] -> Pattern_ e + + -- | Addition pattern, @p + t@ or @t + p@ + PAdd_ :: X_PAdd e -> Side -> Pattern_ e -> Term_ e -> Pattern_ e + + -- | Multiplication pattern, @p * t@ or @t * p@ + PMul_ :: X_PMul e -> Side -> Pattern_ e -> Term_ e -> Pattern_ e + + -- | Subtraction pattern, @p - t@ + PSub_ :: X_PSub e -> Pattern_ e -> Term_ e -> Pattern_ e + + -- | Negation pattern, @-p@ + PNeg_ :: X_PNeg e -> Pattern_ e -> Pattern_ e + + -- | Fraction pattern, @p1/p2@ + PFrac_ :: X_PFrac e -> Pattern_ e -> Pattern_ e -> Pattern_ e + + -- | Expansion slot. + XPattern_ :: X_Pattern e -> Pattern_ e + + deriving (Generic) + +type ForallPattern (a :: * -> Constraint) e + = ( a (X_PVar e) + , a (X_PWild e) + , a (X_PAscr e) + , a (X_PUnit e) + , a (X_PBool e) + , a (X_PNat e) + , a (X_PChar e) + , a (X_PString e) + , a (X_PTup e) + , a (X_PInj e) + , a (X_PCons e) + , a (X_PList e) + , a (X_PAdd e) + , a (X_PMul e) + , a (X_PSub e) + , a (X_PNeg e) + , a (X_PFrac e) + , a (X_Pattern e) + , a (Term_ e) + ) + +deriving instance ForallPattern Show e => Show (Pattern_ e) +instance ForallPattern (Subst Type) e => Subst Type (Pattern_ e) +instance (Typeable e, Show (Pattern_ e), ForallPattern Alpha e) => Alpha (Pattern_ e) +deriving instance (Typeable e, Data e, ForallPattern Data e) => Data (Pattern_ e) + +------------------------------------------------------------ +-- Quantifiers and binders +------------------------------------------------------------ + +-- | A type family specifying what the binder in an abstraction can be. +-- Should have at least variables in it, but how many variables and +-- what other information is carried along may vary. +type family X_Binder e + +-- | A binder represents the stuff between the quantifier and the body +-- of a lambda, ∀, or ∃ abstraction, as in @x : N, r : F@. +type Binder_ e a = Bind (X_Binder e) a + +-- | A quantifier: λ, ∀, or ∃ +data Quantifier = Lam | Ex | All + deriving (Generic, Data, Eq, Ord, Show, Alpha, Subst Type) + +------------------------------------------------------------ +-- Property +------------------------------------------------------------ + +-- | A property is just a term (of type Prop). +type Property_ e = Term_ e + +------------------------------------------------------------ +-- Orphan instances +------------------------------------------------------------ + +-- Need this if we want to put 'Void' as the type +-- of an extension slot (to kill a constructor) +instance Alpha Void diff --git a/src/Disco/AST/Surface.hs b/src/Disco/AST/Surface.hs new file mode 100644 --- /dev/null +++ b/src/Disco/AST/Surface.hs @@ -0,0 +1,654 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.AST.Surface +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Abstract syntax trees representing the surface syntax of the Disco +-- language. +-- +----------------------------------------------------------------------------- + +module Disco.AST.Surface + ( -- * Modules + Module(..), TopLevel(..) + -- ** Documentation + , Docs, DocThing(..), Property + -- ** Declarations + , TypeDecl(..), TermDefn(..), TypeDefn(..) + , Decl(..), partitionDecls, prettyTyDecl + + -- * Terms + , UD + , Term + , pattern TVar + , pattern TPrim + , pattern TUn + , pattern TBin + , pattern TLet + , pattern TParens + , pattern TUnit + , pattern TBool + , pattern TChar + , pattern TString + , pattern TNat + , pattern TRat + , pattern TAbs + , pattern TApp + , pattern TTup + , pattern TCase + , pattern TChain + , pattern TTyOp + , pattern TContainerComp + , pattern TContainer + , pattern TAscr + , pattern TWild + , pattern TList + , pattern TListComp + + , Quantifier(..) + + -- ** Telescopes + , Telescope(..), foldTelescope, mapTelescope, toTelescope, fromTelescope + -- ** Expressions + , Side(..) + + , Link + , pattern TLink + + , Binding + + -- ** Lists + , Qual + , pattern QBind + , pattern QGuard + + , Container(..) + + , Ellipsis(..) + + -- ** Case expressions and patterns + , Branch + + , Guard + , pattern GBool + , pattern GPat + , pattern GLet + + , Pattern + , pattern PVar + , pattern PWild + , pattern PAscr + , pattern PUnit + , pattern PBool + , pattern PChar + , pattern PString + , pattern PTup + , pattern PInj + , pattern PNat + , pattern PCons + , pattern PList + , pattern PAdd + , pattern PMul + , pattern PSub + , pattern PNeg + , pattern PFrac + + , pattern Binding + ) + where + +import Prelude hiding ((<>)) + +import Control.Lens (_1, _2, _3, (%~)) +import Data.Char (toLower) +import qualified Data.Map as M +import Data.Set (Set) +import Data.Void + +import Disco.Effects.LFresh +import Polysemy hiding (Embed) +import Polysemy.Reader + +import Disco.AST.Generic +import Disco.Extensions +import Disco.Pretty +import Disco.Syntax.Operators +import Disco.Syntax.Prims +import Disco.Types +import Unbound.Generics.LocallyNameless hiding (LFresh (..), lunbind) + +-- | The extension descriptor for Surface specific AST types. +data UD + +-- | A module contains all the information from one disco source file. +data Module = Module + { modExts :: Set Ext -- ^ Enabled extensions + , modImports :: [String] -- ^ Module imports + , modDecls :: [Decl] -- ^ Declarations + , modDocs :: [(Name Term, Docs)] -- ^ Documentation + , modTerms :: [Term] -- ^ Top-level (bare) terms + } +deriving instance ForallTerm Show UD => Show Module + +-- | A @TopLevel@ is either documentation (a 'DocThing') or a +-- declaration ('Decl'). +data TopLevel = TLDoc DocThing | TLDecl Decl | TLExpr Term +deriving instance ForallTerm Show UD => Show TopLevel + +-- | Convenient synonym for a list of 'DocThing's. +type Docs = [DocThing] + +-- | An item of documentation. +data DocThing + = DocString [String] -- ^ A documentation string, i.e. a block + -- of @||| text@ items + | DocProperty Property -- ^ An example/doctest/property of the + -- form @!!! forall (x1:ty1) ... . property@ +deriving instance ForallTerm Show UD => Show DocThing + +-- | A property is a universally quantified term of the form +-- @forall v1 : T1, v2 : T2. term@. +type Property = Property_ UD + +-- | A type declaration, @name : type@. +data TypeDecl = TypeDecl (Name Term) PolyType + +-- | A group of definition clauses of the form @name pat1 .. patn = term@. The +-- patterns bind variables in the term. For example, @f n (x,y) = +-- n*x + y@. +data TermDefn = TermDefn (Name Term) [Bind [Pattern] Term] + +-- | A user-defined type (potentially recursive). +-- +-- @type T arg1 arg2 ... = body +data TypeDefn = TypeDefn String [String] Type + deriving Show + +-- | A declaration is either a type declaration, a term definition, or +-- a type definition. +data Decl where + DType :: TypeDecl -> Decl + DDefn :: TermDefn -> Decl + DTyDef :: TypeDefn -> Decl + +deriving instance ForallTerm Show UD => Show TypeDecl +deriving instance ForallTerm Show UD => Show TermDefn +deriving instance ForallTerm Show UD => Show Decl + +partitionDecls :: [Decl] -> ([TypeDecl], [TermDefn], [TypeDefn]) +partitionDecls (DType tyDecl : ds) = (_1 %~ (tyDecl:)) (partitionDecls ds) +partitionDecls (DDefn def : ds) = (_2 %~ (def:)) (partitionDecls ds) +partitionDecls (DTyDef def : ds) = (_3 %~ (def:)) (partitionDecls ds) +partitionDecls [] = ([], [], []) + +------------------------------------------------------------ +-- Pretty-printing top-level declarations + +-- prettyModule :: Module -> Doc +-- prettyModule = foldr ($+$) empty . map pretty + +instance Pretty Decl where + pretty = \case + DType (TypeDecl x ty) -> pretty x <+> text ":" <+> pretty ty + DTyDef (TypeDefn x args body) -> + text "type" <+> text x <+> hsep (map text args) <+> text "=" <+> pretty body + DDefn (TermDefn x bs) -> vcat $ map (pretty . (x,)) bs + +-- | Pretty-print a single clause in a definition. +instance Pretty (Name a, Bind [Pattern] Term) where + pretty (x, b) = withPA funPA . lunbind b $ \(ps, t) -> + pretty x <> hcat (map prettyPatternP ps) <+> text "=" <+> setPA initPA (pretty t) + +-- | Pretty-print a type declaration. +prettyTyDecl :: Members '[Reader PA, LFresh] r => Name t -> Type -> Sem r Doc +prettyTyDecl x ty = hsep [pretty x, text ":", pretty ty] + +------------------------------------------------------------ +-- Terms +------------------------------------------------------------ +type Term = Term_ UD + +-- In the surface language, abstractions bind variables using a +-- (nonempty) list of patterns. Each pattern might contain any +-- number of variables, and might have type annotations on some +-- of its components. +type instance X_Binder UD = [Pattern] + +type instance X_TVar UD = () +type instance X_TPrim UD = () +type instance X_TLet UD = () +type instance X_TParens UD = () +type instance X_TUnit UD = () +type instance X_TBool UD = () +type instance X_TNat UD = () +type instance X_TRat UD = () +type instance X_TChar UD = () +type instance X_TString UD = () +type instance X_TAbs UD = () +type instance X_TApp UD = () +type instance X_TTup UD = () +type instance X_TCase UD = () +type instance X_TChain UD = () +type instance X_TTyOp UD = () +type instance X_TContainer UD = () +type instance X_TContainerComp UD = () +type instance X_TAscr UD = () +type instance X_Term UD = () -- TWild + +pattern TVar :: Name Term -> Term +pattern TVar name = TVar_ () name + +pattern TPrim :: Prim -> Term +pattern TPrim name = TPrim_ () name + +pattern TUn :: UOp -> Term -> Term +pattern TUn uop term = TApp_ () (TPrim_ () (PrimUOp uop)) term + +pattern TBin :: BOp -> Term -> Term -> Term +pattern TBin bop term1 term2 = TApp_ () (TPrim_ () (PrimBOp bop)) (TTup_ () [term1, term2]) + +pattern TLet :: Bind (Telescope Binding) Term -> Term +pattern TLet bind = TLet_ () bind + +pattern TParens :: Term -> Term +pattern TParens term = TParens_ () term + +pattern TUnit :: Term +pattern TUnit = TUnit_ () + +pattern TBool :: Bool -> Term +pattern TBool bool = TBool_ () bool + +pattern TNat :: Integer -> Term +pattern TNat int = TNat_ () int + +pattern TRat :: Rational -> Term +pattern TRat rat = TRat_ () rat + +pattern TChar :: Char -> Term +pattern TChar c = TChar_ () c + +pattern TString :: String -> Term +pattern TString s = TString_ () s + +pattern TAbs :: Quantifier -> Bind [Pattern] Term -> Term +pattern TAbs q bind = TAbs_ q () bind + +pattern TApp :: Term -> Term -> Term +pattern TApp term1 term2 = TApp_ () term1 term2 + +pattern TTup :: [Term] -> Term +pattern TTup termlist = TTup_ () termlist + +pattern TCase :: [Branch] -> Term +pattern TCase branch = TCase_ () branch + +pattern TChain :: Term -> [Link] -> Term +pattern TChain term linklist = TChain_ () term linklist + +pattern TTyOp :: TyOp -> Type -> Term +pattern TTyOp tyop ty = TTyOp_ () tyop ty + +pattern TContainer :: Container -> [(Term, Maybe Term)] -> Maybe (Ellipsis Term) -> Term +pattern TContainer c tl mets = TContainer_ () c tl mets + +pattern TContainerComp :: Container -> Bind (Telescope Qual) Term -> Term +pattern TContainerComp c b = TContainerComp_ () c b + +pattern TAscr :: Term -> PolyType -> Term +pattern TAscr term ty = TAscr_ () term ty + +-- Since we parse patterns by first parsing a term and then ensuring +-- it is a valid pattern, we have to include wildcards in the syntax +-- of terms, although they will be rejected at a later phase. +pattern TWild :: Term +pattern TWild = XTerm_ () + +{-# COMPLETE TVar, TPrim, TLet, TParens, TUnit, TBool, TNat, TRat, TChar, + TString, TAbs, TApp, TTup, TCase, TChain, TTyOp, + TContainer, TContainerComp, TAscr, TWild #-} + +pattern TList :: [Term] -> Maybe (Ellipsis Term) -> Term +pattern TList ts e <- TContainer_ () ListContainer (map fst -> ts) e + where + TList ts e = TContainer_ () ListContainer (map (,Nothing) ts) e + +pattern TListComp :: Bind (Telescope Qual) Term -> Term +pattern TListComp x = TContainerComp_ () ListContainer x + +type Link = Link_ UD + +type instance X_TLink UD = () + +pattern TLink :: BOp -> Term -> Link +pattern TLink bop term = TLink_ () bop term + +{-# COMPLETE TLink #-} + +type Qual = Qual_ UD + +type instance X_QBind UD = () +type instance X_QGuard UD = () + +pattern QBind :: Name Term -> Embed Term -> Qual +pattern QBind namet embedt = QBind_ () namet embedt + +pattern QGuard :: Embed Term -> Qual +pattern QGuard embedt = QGuard_ () embedt + +{-# COMPLETE QBind, QGuard #-} + +type Binding = Binding_ UD + +pattern Binding :: Maybe (Embed PolyType) -> Name Term -> Embed Term -> Binding +pattern Binding m b n = Binding_ m b n + +{-# COMPLETE Binding #-} + +type Branch = Branch_ UD + +type Guard = Guard_ UD + +type instance X_GBool UD = () +type instance X_GPat UD = () +type instance X_GLet UD = () + +pattern GBool :: Embed Term -> Guard +pattern GBool embedt = GBool_ () embedt + +pattern GPat :: Embed Term -> Pattern -> Guard +pattern GPat embedt pat = GPat_ () embedt pat + +pattern GLet :: Binding -> Guard +pattern GLet b = GLet_ () b + +{-# COMPLETE GBool, GPat, GLet #-} + +type Pattern = Pattern_ UD + +type instance X_PVar UD = () +type instance X_PWild UD = () +type instance X_PAscr UD = () +type instance X_PUnit UD = () +type instance X_PBool UD = () +type instance X_PTup UD = () +type instance X_PInj UD = () +type instance X_PNat UD = () +type instance X_PChar UD = () +type instance X_PString UD = () +type instance X_PCons UD = () +type instance X_PList UD = () +type instance X_PAdd UD = () +type instance X_PMul UD = () +type instance X_PSub UD = () +type instance X_PNeg UD = () +type instance X_PFrac UD = () +type instance X_Pattern UD = Void + +pattern PVar :: Name Term -> Pattern +pattern PVar name = PVar_ () name + +pattern PWild :: Pattern +pattern PWild = PWild_ () + + -- (?) TAscr uses a PolyType, but without higher rank types + -- I think we can't possibly need that here. +pattern PAscr :: Pattern -> Type -> Pattern +pattern PAscr p ty = PAscr_ () p ty + +pattern PUnit :: Pattern +pattern PUnit = PUnit_ () + +pattern PBool :: Bool -> Pattern +pattern PBool b = PBool_ () b + +pattern PChar :: Char -> Pattern +pattern PChar c = PChar_ () c + +pattern PString :: String -> Pattern +pattern PString s = PString_ () s + +pattern PTup :: [Pattern] -> Pattern +pattern PTup lp = PTup_ () lp + +pattern PInj :: Side -> Pattern -> Pattern +pattern PInj s p = PInj_ () s p + +pattern PNat :: Integer -> Pattern +pattern PNat n = PNat_ () n + +pattern PCons :: Pattern -> Pattern -> Pattern +pattern PCons p1 p2 = PCons_ () p1 p2 + +pattern PList :: [Pattern] -> Pattern +pattern PList lp = PList_ () lp + +pattern PAdd :: Side -> Pattern -> Term -> Pattern +pattern PAdd s p t = PAdd_ () s p t + +pattern PMul :: Side -> Pattern -> Term -> Pattern +pattern PMul s p t = PMul_ () s p t + +pattern PSub :: Pattern -> Term -> Pattern +pattern PSub p t = PSub_ () p t + +pattern PNeg :: Pattern -> Pattern +pattern PNeg p = PNeg_ () p + +pattern PFrac :: Pattern -> Pattern -> Pattern +pattern PFrac p1 p2 = PFrac_ () p1 p2 + +{-# COMPLETE PVar, PWild, PAscr, PUnit, PBool, PTup, PInj, PNat, + PChar, PString, PCons, PList, PAdd, PMul, PSub, PNeg, PFrac #-} + +------------------------------------------------------------ +-- Pretty-printing for surface-syntax terms +-- +-- The instances in this section are used to pretty-print surface +-- syntax, for example, when printing the source code definition of a +-- term (e.g. via the :doc REPL command). + +-- | Pretty-print a term with guaranteed parentheses. +prettyTermP :: Members '[LFresh, Reader PA] r => Term -> Sem r Doc +prettyTermP t@TTup{} = setPA initPA $ pretty t +-- prettyTermP t@TContainer{} = setPA initPA $ "" <+> prettyTerm t +prettyTermP t = withPA initPA $ pretty t + +instance Pretty Term where + pretty = \case + TVar x -> pretty x + TPrim (PrimUOp uop) -> + case M.lookup uop uopMap of + Just (OpInfo (UOpF Pre _) (syn:_) _) -> text syn <> text "~" + Just (OpInfo (UOpF Post _) (syn:_) _) -> text "~" <> text syn + _ -> error $ "pretty @Term: " ++ show uop ++ " is not in the uopMap!" + TPrim (PrimBOp bop) -> text "~" <> pretty bop <> text "~" + TPrim p -> + case M.lookup p primMap of + Just (PrimInfo _ nm True) -> text nm + Just (PrimInfo _ nm False) -> text "$" <> text nm + Nothing -> error $ "pretty @Term: Prim " ++ show p ++ " is not in the primMap!" + TParens t -> pretty t + TUnit -> text "■" + (TBool b) -> text (map toLower $ show b) + TChar c -> text (show c) + TString cs -> doubleQuotes $ text cs + TAbs q bnd -> withPA initPA $ + lunbind bnd $ \(args, body) -> + prettyQ q + <> (hsep =<< punctuate (text ",") (map pretty args)) + <> text "." + <+> lt (pretty body) + where + prettyQ Lam = text "λ" + prettyQ All = text "∀" + prettyQ Ex = text "∃" + + -- special case for fully applied unary operators + TApp (TPrim (PrimUOp uop)) t -> + case M.lookup uop uopMap of + Just (OpInfo (UOpF Post _) _ _) -> withPA (ugetPA uop) $ + lt (pretty t) <> pretty uop + Just (OpInfo (UOpF Pre _) _ _) -> withPA (ugetPA uop) $ + pretty uop <> rt (pretty t) + _ -> error $ "pretty @Term: uopMap doesn't contain " ++ show uop + + -- special case for fully applied binary operators + TApp (TPrim (PrimBOp bop)) (TTup [t1, t2]) -> withPA (getPA bop) $ + hsep + [ lt (pretty t1) + , pretty bop + , rt (pretty t2) + ] + + -- Always pretty-print function applications with parentheses + TApp t1 t2 -> withPA funPA $ + lt (pretty t1) <> prettyTermP t2 + + TTup ts -> setPA initPA $ do + ds <- punctuate (text ",") (map pretty ts) + parens (hsep ds) + TContainer c ts e -> setPA initPA $ do + ds <- punctuate (text ",") (map prettyCount ts) + let pe = case e of + Nothing -> [] + Just (Until t) -> [text "..", pretty t] + containerDelims c (hsep (ds ++ pe)) + where + prettyCount (t, Nothing) = pretty t + prettyCount (t, Just n) = lt (pretty t) <+> text "#" <+> rt (pretty n) + TContainerComp c bqst -> + lunbind bqst $ \(qs,t) -> + setPA initPA $ containerDelims c (hsep [pretty t, text "|", pretty qs]) + TNat n -> integer n + TChain t lks -> withPA (getPA Eq) . hsep $ + lt (pretty t) + : concatMap prettyLink lks + where + prettyLink (TLink op t2) = + [ pretty op + , setPA (getPA op) . rt $ pretty t2 + ] + TLet bnd -> withPA initPA $ + lunbind bnd $ \(bs, t2) -> do + ds <- punctuate (text ",") (map pretty (fromTelescope bs)) + hsep + [ text "let" + , hsep ds + , text "in" + , pretty t2 + ] + + TCase b -> withPA initPA $ + (text "{?" <+> prettyBranches b) $+$ text "?}" + TAscr t ty -> withPA ascrPA $ + lt (pretty t) <+> text ":" <+> rt (pretty ty) + TRat r -> text (prettyDecimal r) + TTyOp op ty -> withPA funPA $ + pretty op <+> pretty ty + TWild -> text "_" + +-- | Print appropriate delimiters for a container literal. +containerDelims :: Member (Reader PA) r => Container -> (Sem r Doc -> Sem r Doc) +containerDelims ListContainer = brackets +containerDelims BagContainer = bag +containerDelims SetContainer = braces + +prettyBranches :: Members '[Reader PA, LFresh] r => [Branch] -> Sem r Doc +prettyBranches = \case + [] -> error "Empty branches are disallowed." + b:bs -> + pretty b + $+$ + foldr (($+$) . (text "," <+>) . pretty) empty bs + +-- | Pretty-print a single branch in a case expression. +instance Pretty Branch where + pretty br = lunbind br $ \(gs,t) -> + pretty t <+> pretty gs + +-- | Pretty-print the guards in a single branch of a case expression. +instance Pretty (Telescope Guard) where + pretty = \case + TelEmpty -> text "otherwise" + gs -> foldr (\g r -> pretty g <+> r) (text "") (fromTelescope gs) + +instance Pretty Guard where + pretty = \case + GBool et -> text "if" <+> pretty (unembed et) + GPat et p -> text "when" <+> pretty (unembed et) <+> text "is" <+> pretty p + GLet b -> text "let" <+> pretty b + +-- | Pretty-print a binding, i.e. a pairing of a name (with optional +-- type annotation) and term. +instance Pretty Binding where + pretty = \case + Binding Nothing x (unembed -> t) -> + hsep [pretty x, text "=", pretty t] + Binding (Just (unembed -> ty)) x (unembed -> t) -> + hsep [pretty x, text ":", pretty ty, text "=", pretty t] + +-- | Pretty-print the qualifiers in a comprehension. +instance Pretty (Telescope Qual) where + pretty (fromTelescope -> qs) = do + ds <- punctuate (text ",") (map pretty qs) + hsep ds + +-- | Pretty-print a single qualifier in a comprehension. +instance Pretty Qual where + pretty = \case + QBind x (unembed -> t) -> hsep [pretty x, text "in", pretty t] + QGuard (unembed -> t) -> pretty t + +-- | Pretty-print a pattern with guaranteed parentheses. +prettyPatternP :: Members '[LFresh, Reader PA] r => Pattern -> Sem r Doc +prettyPatternP p@PTup{} = setPA initPA $ pretty p +prettyPatternP p = withPA initPA $ pretty p + +-- We could probably alternatively write a function to turn a pattern +-- back into a term, and pretty-print that instead of the below. +-- Unsure whether it would be worth it. + +instance Pretty Pattern where + pretty = \case + PVar x -> pretty x + PWild -> text "_" + PAscr p ty -> withPA ascrPA $ + lt (pretty p) <+> text ":" <+> rt (pretty ty) + PUnit -> text "■" + PBool b -> text $ map toLower $ show b + PChar c -> text (show c) + PString s -> text (show s) + PTup ts -> setPA initPA $ do + ds <- punctuate (text ",") (map pretty ts) + parens (hsep ds) + PInj s p -> withPA funPA $ + pretty s <> prettyPatternP p + PNat n -> integer n + PCons p1 p2 -> withPA (getPA Cons) $ + lt (pretty p1) <+> text "::" <+> rt (pretty p2) + PList ps -> setPA initPA $ do + ds <- punctuate (text ",") (map pretty ps) + brackets (hsep ds) + PAdd L p t -> withPA (getPA Add) $ + lt (pretty p) <+> text "+" <+> rt (pretty t) + PAdd R p t -> withPA (getPA Add) $ + lt (pretty t) <+> text "+" <+> rt (pretty p) + PMul L p t -> withPA (getPA Mul) $ + lt (pretty p) <+> text "*" <+> rt (pretty t) + PMul R p t -> withPA (getPA Mul) $ + lt (pretty t) <+> text "*" <+> rt (pretty p) + PSub p t -> withPA (getPA Sub) $ + lt (pretty p) <+> text "-" <+> rt (pretty t) + PNeg p -> withPA (ugetPA Neg) $ + text "-" <> rt (pretty p) + PFrac p1 p2 -> withPA (getPA Div) $ + lt (pretty p1) <+> text "/" <+> rt (pretty p2) + diff --git a/src/Disco/AST/Typed.hs b/src/Disco/AST/Typed.hs new file mode 100644 --- /dev/null +++ b/src/Disco/AST/Typed.hs @@ -0,0 +1,532 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PatternSynonyms #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.AST.Typed +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Typed abstract syntax trees representing the typechecked surface +-- syntax of the Disco language. Each tree node is annotated with the +-- type of its subtree. +-- +----------------------------------------------------------------------------- + +module Disco.AST.Typed + ( -- * Type-annotated terms + ATerm + , pattern ATVar + , pattern ATPrim + , pattern ATLet + , pattern ATUnit + , pattern ATBool + , pattern ATNat + , pattern ATRat + , pattern ATChar + , pattern ATString + , pattern ATAbs + , pattern ATApp + , pattern ATTup + , pattern ATCase + , pattern ATChain + , pattern ATTyOp + , pattern ATContainer + , pattern ATContainerComp + , pattern ATList + , pattern ATListComp + , pattern ATTest + + , ALink + , pattern ATLink + + , Container(..) + , ABinding + -- * Branches and guards + , ABranch + + , AGuard + , pattern AGBool + , pattern AGPat + , pattern AGLet + + , AQual + , pattern AQBind + , pattern AQGuard + + , APattern + , pattern APVar + , pattern APWild + , pattern APUnit + , pattern APBool + , pattern APTup + , pattern APInj + , pattern APNat + , pattern APChar + , pattern APString + , pattern APCons + , pattern APList + , pattern APAdd + , pattern APMul + , pattern APSub + , pattern APNeg + , pattern APFrac + + , pattern ABinding + -- * Utilities + , varsBound + , getType + , setType + , substQT + + , AProperty + ) + where + +import Unbound.Generics.LocallyNameless +import Unbound.Generics.LocallyNameless.Unsafe + +import Control.Arrow ((***)) +import Data.Coerce (coerce) +import Data.Data (Data) +import Data.Void + +import Control.Lens.Plated (transform) +import Disco.AST.Generic +import Disco.AST.Surface +import Disco.Names +import Disco.Pretty +import Disco.Syntax.Operators +import Disco.Syntax.Prims +import Disco.Types + +-- | The extension descriptor for Typed specific AST types. + +data TY + deriving Data + +type AProperty = Property_ TY + +------------------------------------------------------------ + +-- TODO: Should probably really do this with a 2-level/open recursion +-- approach, with a cofree comonad or whatever + +-- | An @ATerm@ is a typechecked term where every node in the tree has +-- been annotated with the type of the subterm rooted at that node. + +type ATerm = Term_ TY + +type instance X_Binder TY = [APattern] + +type instance X_TVar TY = Void -- Names are now qualified +type instance X_TPrim TY = Type +type instance X_TLet TY = Type +type instance X_TUnit TY = () +type instance X_TBool TY = Type +type instance X_TNat TY = Type +type instance X_TRat TY = () +type instance X_TChar TY = () +type instance X_TString TY = () +type instance X_TAbs TY = Type +type instance X_TApp TY = Type +type instance X_TCase TY = Type +type instance X_TChain TY = Type +type instance X_TTyOp TY = Type +type instance X_TContainer TY = Type +type instance X_TContainerComp TY = Type +type instance X_TAscr TY = Void -- No more type ascriptions in typechecked terms +type instance X_TTup TY = Type +type instance X_TParens TY = Void -- No more explicit parens + + -- A test frame for reporting counterexamples in a test. These don't appear + -- in source programs, but because the deugarer manipulates partly-desugared + -- terms it helps to be able to represent these in 'ATerm'. +type instance X_Term TY = Either ([(String, Type, Name ATerm)], ATerm) (Type, QName ATerm) + +pattern ATVar :: Type -> QName ATerm -> ATerm +pattern ATVar ty qname = XTerm_ (Right (ty, qname)) + +pattern ATPrim :: Type -> Prim -> ATerm +pattern ATPrim ty name = TPrim_ ty name + +pattern ATLet :: Type -> Bind (Telescope ABinding) ATerm -> ATerm +pattern ATLet ty bind = TLet_ ty bind + +pattern ATUnit :: ATerm +pattern ATUnit = TUnit_ () + +pattern ATBool :: Type -> Bool -> ATerm +pattern ATBool ty bool = TBool_ ty bool + +pattern ATNat :: Type -> Integer -> ATerm +pattern ATNat ty int = TNat_ ty int + +pattern ATRat :: Rational -> ATerm +pattern ATRat rat = TRat_ () rat + +pattern ATChar :: Char -> ATerm +pattern ATChar c = TChar_ () c + +pattern ATString :: String -> ATerm +pattern ATString s = TString_ () s + +pattern ATAbs :: Quantifier -> Type -> Bind [APattern] ATerm -> ATerm +pattern ATAbs q ty bind = TAbs_ q ty bind + +pattern ATApp :: Type -> ATerm -> ATerm -> ATerm +pattern ATApp ty term1 term2 = TApp_ ty term1 term2 + +pattern ATTup :: Type -> [ATerm] -> ATerm +pattern ATTup ty termlist = TTup_ ty termlist + +pattern ATCase :: Type -> [ABranch] -> ATerm +pattern ATCase ty branch = TCase_ ty branch + +pattern ATChain :: Type -> ATerm -> [ALink] -> ATerm +pattern ATChain ty term linklist = TChain_ ty term linklist + +pattern ATTyOp :: Type -> TyOp -> Type -> ATerm +pattern ATTyOp ty1 tyop ty2 = TTyOp_ ty1 tyop ty2 + +pattern ATContainer :: Type -> Container -> [(ATerm, Maybe ATerm)] -> Maybe (Ellipsis ATerm) -> ATerm +pattern ATContainer ty c tl mets = TContainer_ ty c tl mets + +pattern ATContainerComp :: Type -> Container -> Bind (Telescope AQual) ATerm -> ATerm +pattern ATContainerComp ty c b = TContainerComp_ ty c b + +pattern ATTest :: [(String, Type, Name ATerm)] -> ATerm -> ATerm +pattern ATTest ns t = XTerm_ (Left (ns, t)) + +{-# COMPLETE ATVar, ATPrim, ATLet, ATUnit, ATBool, ATNat, ATRat, ATChar, + ATString, ATAbs, ATApp, ATTup, ATCase, ATChain, ATTyOp, + ATContainer, ATContainerComp, ATTest #-} + +pattern ATList :: Type -> [ATerm] -> Maybe (Ellipsis ATerm) -> ATerm +pattern ATList t xs e <- ATContainer t ListContainer (map fst -> xs) e + where + ATList t xs e = ATContainer t ListContainer (map (,Nothing) xs) e + +pattern ATListComp :: Type -> Bind (Telescope AQual) ATerm -> ATerm +pattern ATListComp t b = ATContainerComp t ListContainer b + +type ALink = Link_ TY + +type instance X_TLink TY = () + +pattern ATLink :: BOp -> ATerm -> ALink +pattern ATLink bop term = TLink_ () bop term + +{-# COMPLETE ATLink #-} + + +type AQual = Qual_ TY + +type instance X_QBind TY = () +type instance X_QGuard TY = () + + +pattern AQBind :: Name ATerm -> Embed ATerm -> AQual +pattern AQBind namet embedt = QBind_ () namet embedt + +pattern AQGuard :: Embed ATerm -> AQual +pattern AQGuard embedt = QGuard_ () embedt + +{-# COMPLETE AQBind, AQGuard #-} + +type ABinding = Binding_ TY + +pattern ABinding :: Maybe (Embed PolyType) -> Name ATerm -> Embed ATerm -> ABinding +pattern ABinding m b n = Binding_ m b n + +{-# COMPLETE ABinding #-} + +type ABranch = Bind (Telescope AGuard) ATerm + +type AGuard = Guard_ TY + +type instance X_GBool TY = () +type instance X_GPat TY = () +type instance X_GLet TY = () -- ??? Type? + +pattern AGBool :: Embed ATerm -> AGuard +pattern AGBool embedt = GBool_ () embedt + +pattern AGPat :: Embed ATerm -> APattern -> AGuard +pattern AGPat embedt pat = GPat_ () embedt pat + +pattern AGLet :: ABinding -> AGuard +pattern AGLet b = GLet_ () b + +{-# COMPLETE AGBool, AGPat, AGLet #-} + +type APattern = Pattern_ TY + +-- We have to use Embed Type because we don't want any type variables +-- inside the types being treated as binders! + +type instance X_PVar TY = Embed Type +type instance X_PWild TY = Embed Type +type instance X_PAscr TY = Void -- No more ascriptions in typechecked patterns. +type instance X_PUnit TY = () +type instance X_PBool TY = () +type instance X_PChar TY = () +type instance X_PString TY = () +type instance X_PTup TY = Embed Type +type instance X_PInj TY = Embed Type +type instance X_PNat TY = Embed Type +type instance X_PCons TY = Embed Type +type instance X_PList TY = Embed Type +type instance X_PAdd TY = Embed Type +type instance X_PMul TY = Embed Type +type instance X_PSub TY = Embed Type +type instance X_PNeg TY = Embed Type +type instance X_PFrac TY = Embed Type + +type instance X_Pattern TY = () + +pattern APVar :: Type -> Name ATerm -> APattern +pattern APVar ty name <- PVar_ (unembed -> ty) name + where + APVar ty name = PVar_ (embed ty) name + +pattern APWild :: Type -> APattern +pattern APWild ty <- PWild_ (unembed -> ty) + where + APWild ty = PWild_ (embed ty) + +pattern APUnit :: APattern +pattern APUnit = PUnit_ () + +pattern APBool :: Bool -> APattern +pattern APBool b = PBool_ () b + +pattern APChar :: Char -> APattern +pattern APChar c = PChar_ () c + +pattern APString :: String -> APattern +pattern APString s = PString_ () s + +pattern APTup :: Type -> [APattern] -> APattern +pattern APTup ty lp <- PTup_ (unembed -> ty) lp + where + APTup ty lp = PTup_ (embed ty) lp + +pattern APInj :: Type -> Side -> APattern -> APattern +pattern APInj ty s p <- PInj_ (unembed -> ty) s p + where + APInj ty s p = PInj_ (embed ty) s p + +pattern APNat :: Type -> Integer -> APattern +pattern APNat ty n <- PNat_ (unembed -> ty) n + where + APNat ty n = PNat_ (embed ty) n + +pattern APCons :: Type -> APattern -> APattern -> APattern +pattern APCons ty p1 p2 <- PCons_ (unembed -> ty) p1 p2 + where + APCons ty p1 p2 = PCons_ (embed ty) p1 p2 + +pattern APList :: Type -> [APattern] -> APattern +pattern APList ty lp <- PList_ (unembed -> ty) lp + where + APList ty lp = PList_ (embed ty) lp + +pattern APAdd :: Type -> Side -> APattern -> ATerm -> APattern +pattern APAdd ty s p t <- PAdd_ (unembed -> ty) s p t + where + APAdd ty s p t = PAdd_ (embed ty) s p t + +pattern APMul :: Type -> Side -> APattern -> ATerm -> APattern +pattern APMul ty s p t <- PMul_ (unembed -> ty) s p t + where + APMul ty s p t = PMul_ (embed ty) s p t + +pattern APSub :: Type -> APattern -> ATerm -> APattern +pattern APSub ty p t <- PSub_ (unembed -> ty) p t + where + APSub ty p t = PSub_ (embed ty) p t + +pattern APNeg :: Type -> APattern -> APattern +pattern APNeg ty p <- PNeg_ (unembed -> ty) p + where + APNeg ty p = PNeg_ (embed ty) p + +pattern APFrac :: Type -> APattern -> APattern -> APattern +pattern APFrac ty p1 p2 <- PFrac_ (unembed -> ty) p1 p2 + where + APFrac ty p1 p2 = PFrac_ (embed ty) p1 p2 + +{-# COMPLETE APVar, APWild, APUnit, APBool, APChar, APString, + APTup, APInj, APNat, APCons, APList, APAdd, APMul, APSub, APNeg, APFrac #-} + +varsBound :: APattern -> [(Name ATerm, Type)] +varsBound (APVar ty n) = [(n, ty)] +varsBound (APWild _) = [] +varsBound APUnit = [] +varsBound (APBool _) = [] +varsBound (APChar _) = [] +varsBound (APString _) = [] +varsBound (APTup _ ps) = varsBound =<< ps +varsBound (APInj _ _ p) = varsBound p +varsBound (APNat _ _) = [] +varsBound (APCons _ p q) = varsBound p ++ varsBound q +varsBound (APList _ ps) = varsBound =<< ps +varsBound (APAdd _ _ p _) = varsBound p +varsBound (APMul _ _ p _) = varsBound p +varsBound (APSub _ p _) = varsBound p +varsBound (APNeg _ p) = varsBound p +varsBound (APFrac _ p q) = varsBound p ++ varsBound q + +------------------------------------------------------------ +-- getType +------------------------------------------------------------ + +instance HasType ATerm where + getType (ATVar ty _) = ty + getType (ATPrim ty _) = ty + getType ATUnit = TyUnit + getType (ATBool ty _) = ty + getType (ATNat ty _) = ty + getType (ATRat _) = TyF + getType (ATChar _) = TyC + getType (ATString _) = TyList TyC + getType (ATAbs _ ty _) = ty + getType (ATApp ty _ _) = ty + getType (ATTup ty _) = ty + getType (ATTyOp ty _ _) = ty + getType (ATChain ty _ _) = ty + getType (ATContainer ty _ _ _) = ty + getType (ATContainerComp ty _ _) = ty + getType (ATLet ty _) = ty + getType (ATCase ty _) = ty + getType (ATTest _ _ ) = TyProp + + setType ty (ATVar _ x ) = ATVar ty x + setType ty (ATPrim _ x ) = ATPrim ty x + setType _ ATUnit = ATUnit + setType ty (ATBool _ b) = ATBool ty b + setType ty (ATNat _ x ) = ATNat ty x + setType _ (ATRat r) = ATRat r + setType _ (ATChar c) = ATChar c + setType _ (ATString cs) = ATString cs + setType ty (ATAbs q _ x ) = ATAbs q ty x + setType ty (ATApp _ x y ) = ATApp ty x y + setType ty (ATTup _ x ) = ATTup ty x + setType ty (ATTyOp _ x y ) = ATTyOp ty x y + setType ty (ATChain _ x y ) = ATChain ty x y + setType ty (ATContainer _ x y z) = ATContainer ty x y z + setType ty (ATContainerComp _ x y) = ATContainerComp ty x y + setType ty (ATLet _ x ) = ATLet ty x + setType ty (ATCase _ x ) = ATCase ty x + setType _ (ATTest vs x) = ATTest vs x + +instance HasType APattern where + getType (APVar ty _) = ty + getType (APWild ty) = ty + getType APUnit = TyUnit + getType (APBool _) = TyBool + getType (APChar _) = TyC + getType (APString _) = TyList TyC + getType (APTup ty _) = ty + getType (APInj ty _ _) = ty + getType (APNat ty _) = ty + getType (APCons ty _ _) = ty + getType (APList ty _) = ty + getType (APAdd ty _ _ _) = ty + getType (APMul ty _ _ _) = ty + getType (APSub ty _ _) = ty + getType (APNeg ty _) = ty + getType (APFrac ty _ _) = ty + +instance HasType ABranch where + getType = getType . snd . unsafeUnbind + +------------------------------------------------------------ +-- subst +------------------------------------------------------------ + +substQT :: QName ATerm -> ATerm -> ATerm -> ATerm +substQT x s = transform $ \case + t@(ATVar _ y) + | x == y -> s + | otherwise -> t + t -> t + +------------------------------------------------------------ +-- Exploding a typed term into a surface term with annotations +------------------------------------------------------------ + +instance Pretty ATerm where + pretty = pretty . explode + +explode :: ATerm -> Term +explode = \case + ATVar ty x -> TAscr (TVar (coerce (qname x))) (toPolyType ty) + ATPrim ty x -> TAscr (TPrim x) (toPolyType ty) + ATLet ty tel -> TAscr (TLet (explodeTelescope explodeBinding tel)) (toPolyType ty) + ATUnit -> TUnit + ATBool _ty b -> TBool b + ATNat ty x -> TAscr (TNat x) (toPolyType ty) + ATRat r -> TRat r + ATChar c -> TChar c + ATString cs -> TString cs + ATAbs q ty a -> TAscr (TAbs q (explodeAbs a)) (toPolyType ty) + ATApp ty x y -> TAscr (TApp (explode x) (explode y)) (toPolyType ty) + ATTup ty xs -> TAscr (TTup (map explode xs)) (toPolyType ty) + ATCase ty bs -> TAscr (TCase (map explodeBranch bs)) (toPolyType ty) + ATChain ty t ls -> TAscr (TChain (explode t) (map explodeLink ls)) (toPolyType ty) + ATTyOp ty x y -> TAscr (TTyOp x y) (toPolyType ty) + ATContainer ty c ts el -> + TAscr + (TContainer c (map (explode *** fmap explode) ts) (fmap (fmap explode) el)) + (toPolyType ty) + ATContainerComp ty c b -> TAscr (TContainerComp c (explodeTelescope explodeQual b)) (toPolyType ty) + ATTest _vs x -> TAscr (explode x) (toPolyType TyProp) + +explodeTelescope + :: (Alpha a, Alpha b) + => (a -> b) -> Bind (Telescope a) ATerm -> Bind (Telescope b) Term +explodeTelescope explodeBinder (unsafeUnbind -> (xs,at)) = bind (mapTelescope explodeBinder xs) (explode at) + +explodeBinding :: ABinding -> Binding +explodeBinding (ABinding m b (unembed -> n)) = Binding m (coerce b) (embed (explode n)) + +explodeAbs :: Bind [APattern] ATerm -> Bind [Pattern] Term +explodeAbs (unsafeUnbind -> (aps, at)) = bind (map explodePattern aps) (explode at) + +explodePattern :: APattern -> Pattern +explodePattern = \case + APVar ty x -> PAscr (PVar (coerce x)) ty + APWild ty -> PAscr PWild ty + APUnit -> PUnit + APBool b -> PBool b + APChar c -> PChar c + APString s -> PString s + APTup ty ps -> PAscr (PTup (map explodePattern ps)) ty + APInj ty s p -> PAscr (PInj s (explodePattern p)) ty + APNat ty n -> PAscr (PNat n) ty + APCons ty p1 p2 -> PAscr (PCons (explodePattern p1) (explodePattern p2)) ty + APList ty ps -> PAscr (PList (map explodePattern ps)) ty + APAdd ty s p t -> PAscr (PAdd s (explodePattern p) (explode t)) ty + APMul ty s p t -> PAscr (PMul s (explodePattern p) (explode t)) ty + APSub ty p t -> PAscr (PSub (explodePattern p) (explode t)) ty + APNeg ty p -> PAscr (PNeg (explodePattern p)) ty + APFrac ty p q -> PAscr (PFrac (explodePattern p) (explodePattern q)) ty + +explodeBranch :: ABranch -> Branch +explodeBranch = explodeTelescope explodeGuard + +explodeGuard :: AGuard -> Guard +explodeGuard (AGBool (unembed -> at)) = GBool (embed (explode at)) +explodeGuard (AGPat (unembed -> at) ap) = GPat (embed (explode at)) (explodePattern ap) +explodeGuard (AGLet ab) = GLet (explodeBinding ab) + +explodeLink :: ALink -> Link +explodeLink (ATLink bop at) = TLink bop (explode at) + +explodeQual :: AQual -> Qual +explodeQual (AQBind x (unembed -> at)) = QBind (coerce x) (embed (explode at)) +explodeQual (AQGuard (unembed -> at)) = QGuard (embed (explode at)) diff --git a/src/Disco/Compile.hs b/src/Disco/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Compile.hs @@ -0,0 +1,490 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Compile +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Compiling the typechecked, desugared AST to the untyped core +-- language. +----------------------------------------------------------------------------- + +module Disco.Compile where + +import Control.Monad ((<=<)) +import Data.Bool (bool) +import Data.Coerce +import qualified Data.Map as M +import Data.Ratio +import Data.Set (Set) +import qualified Data.Set as S +import Data.Set.Lens (setOf) + +import Disco.Effects.Fresh +import Polysemy (Member, Sem, run) +import Unbound.Generics.LocallyNameless (Name, bind, string2Name, + unembed) + +import Disco.AST.Core +import Disco.AST.Desugared +import Disco.AST.Generic +import Disco.AST.Typed +import Disco.Context as Ctx +import Disco.Desugar +import Disco.Module +import Disco.Names +import Disco.Syntax.Operators +import Disco.Syntax.Prims +import qualified Disco.Typecheck.Graph as G +import Disco.Types +import Disco.Util + +------------------------------------------------------------ +-- Convenience operations +------------------------------------------------------------ + +-- | Utility function to desugar and compile a thing, given a +-- desugaring function for it. +compileThing :: (a -> Sem '[Fresh] DTerm) -> a -> Core +compileThing desugarThing = run . runFresh . (compileDTerm <=< desugarThing) + +-- | Compile a typechecked term ('ATerm') directly to a 'Core' term, +-- by desugaring and then compiling. +compileTerm :: ATerm -> Core +compileTerm = compileThing desugarTerm + +-- | Compile a typechecked property ('AProperty') directly to a 'Core' term, +-- by desugaring and then compilling. +compileProperty :: AProperty -> Core +compileProperty = compileThing desugarProperty + +------------------------------------------------------------ +-- Compiling definitions +------------------------------------------------------------ + +-- | Compile a context of typechecked definitions ('Defn') to a +-- sequence of compiled 'Core' bindings, such that the body of each +-- binding depends only on previous ones in the list. First +-- topologically sorts the definitions into mutually recursive +-- groups, then compiles recursive definitions specially in terms of +-- 'delay' and 'force'. +compileDefns :: Ctx ATerm Defn -> [(QName Core, Core)] +compileDefns defs = run . runFresh $ do + let vars = Ctx.keysSet defs + + -- Get a list of pairs of the form (y,x) where x uses y in its + -- definition. We want them in the order (y,x) since y needs to + -- be evaluated before x. These will be the edges in our + -- dependency graph. Note that some of these edges may refer to + -- things that were imported, and hence not in the set of + -- definitions; those edges will simply be dropped by G.mkGraph. + deps :: Set (QName ATerm, QName ATerm) + deps = S.unions . map (\(x, body) -> S.map (,x) (setOf (fvQ @Defn @ATerm) body)) . Ctx.assocs $ defs + + -- Do a topological sort of the condensation of the dependency + -- graph. Each SCC corresponds to a group of mutually recursive + -- definitions; each such group depends only on groups that come + -- before it in the topsort. + defnGroups :: [Set (QName ATerm)] + defnGroups = G.topsort (G.condensation (G.mkGraph vars deps)) + + concat <$> mapM (compileDefnGroup . Ctx.assocs . Ctx.restrictKeys defs) defnGroups + +-- | Compile a group of mutually recursive definitions, using @delay@ +-- to compile recursion via references to memory cells. +compileDefnGroup :: Member Fresh r => [(QName ATerm, Defn)] -> Sem r [(QName Core, Core)] +compileDefnGroup [(f, defn)] + -- Informally, a recursive definition f = body compiles to + -- + -- f = force (delay f. [force f / f] body). + -- + -- However, we have to be careful: in the informal notation above, + -- all the variables are named 'f', but in fully renamed syntax they + -- are different. Writing fT for the top-level f bound in a + -- specific module etc. and fL for a locally bound f, we really + -- have + -- + -- fT = force (delay fL. [force fL / fT] body) + | f `S.member` setOf fvQ defn = return . (:[]) $ + (fT, CForce (CProj L (CDelay (bind [qname fL] [substQC fT (CForce (CVar fL)) cdefn])))) + + -- A non-recursive definition just compiles simply. + | otherwise = + return [(fT, cdefn)] + + where + fT, fL :: QName Core + fT = coerce f + fL = localName (coerce (qname f)) + + cdefn = compileThing desugarDefn defn + +-- A group of mutually recursive definitions {f = fbody, g = gbody, ...} +-- compiles to +-- { _grp = delay fL gL ... . (forceVars fbody, forceVars gbody, ...) +-- , fT = fst (force _grp) +-- , gT = snd (force _grp) +-- , ... +-- } +-- where forceVars is the substitution [force fL / fT, force gL / gT, ...] + +compileDefnGroup defs = do + grp :: QName Core <- freshQ "__grp" + let (vars, bodies) = unzip defs + varsT, varsL :: [QName Core] + varsT = coerce vars + varsL = map (localName . qname) varsT + forceVars :: [(QName Core, Core)] + forceVars = zipWith (\t l -> (t, CForce (CVar l))) varsT varsL + bodies' :: [Core] + bodies' = map (substsQC forceVars . compileThing desugarDefn) bodies + return $ + (grp, CDelay (bind (map qname varsL) bodies')) : + zip varsT (for [0 ..] $ CForce . flip proj (CVar grp)) + where + proj :: Int -> Core -> Core + proj 0 = CProj L + proj n = proj (n -1) . CProj R + +------------------------------------------------------------ +-- Compiling terms +------------------------------------------------------------ + +-- | Compile a typechecked, desugared 'DTerm' to an untyped 'Core' +-- term. +compileDTerm :: Member Fresh r => DTerm -> Sem r Core +compileDTerm (DTVar _ x) = return $ CVar (coerce x) +compileDTerm (DTPrim ty x) = compilePrim ty x +compileDTerm DTUnit = return CUnit +compileDTerm (DTBool _ b) = return $ CInj (bool L R b) CUnit +compileDTerm (DTChar c) = return $ CNum Fraction (toInteger (fromEnum c) % 1) +compileDTerm (DTNat _ n) = return $ CNum Fraction (n % 1) -- compileNat ty n +compileDTerm (DTRat r) = return $ CNum Decimal r +compileDTerm term@(DTAbs q _ _) = do + (xs, tys, body) <- unbindDeep term + cbody <- compileDTerm body + case q of + Lam -> return $ abstract xs cbody + Ex -> return $ quantify (OExists tys) (abstract xs cbody) + All -> return $ quantify (OForall tys) (abstract xs cbody) + where + -- Gather nested abstractions with the same quantifier. + unbindDeep :: Member Fresh r => DTerm -> Sem r ([Name DTerm], [Type], DTerm) + unbindDeep (DTAbs q' ty l) | q == q' = do + (name, inner) <- unbind l + (ns, tys, body) <- unbindDeep inner + return (name : ns, ty : tys, body) + unbindDeep t = return ([], [], t) + + abstract :: [Name DTerm] -> Core -> Core + abstract xs body = CAbs (bind (map coerce xs) body) + + quantify :: Op -> Core -> Core + quantify op = CApp (CConst op) + +-- Special case for Cons, which compiles to a constructor application +-- rather than a function application. +compileDTerm (DTApp _ (DTPrim _ (PrimBOp Cons)) (DTPair _ t1 t2)) = + CInj R <$> (CPair <$> compileDTerm t1 <*> compileDTerm t2) +-- Special cases for left and right, which also compile to constructor applications. +compileDTerm (DTApp _ (DTPrim _ PrimLeft) t) = + CInj L <$> compileDTerm t +compileDTerm (DTApp _ (DTPrim _ PrimRight) t) = + CInj R <$> compileDTerm t +compileDTerm (DTApp _ t1 t2) = CApp <$> compileDTerm t1 <*> compileDTerm t2 +compileDTerm (DTPair _ t1 t2) = + CPair <$> compileDTerm t1 <*> compileDTerm t2 +compileDTerm (DTCase _ bs) = CApp <$> compileCase bs <*> pure CUnit +compileDTerm (DTTyOp _ op ty) = return $ CApp (CConst (tyOps ! op)) (CType ty) + where + tyOps = + M.fromList + [ Enumerate ==> OEnum, + Count ==> OCount + ] +compileDTerm (DTNil _) = return $ CInj L CUnit +compileDTerm (DTTest info t) = CTest (coerce info) <$> compileDTerm t + +------------------------------------------------------------ + +-- | Compile a natural number. A separate function is needed in +-- case the number is of a finite type, in which case we must +-- mod it by its type. +-- compileNat :: Member Fresh r => Type -> Integer -> Sem r Core +-- compileNat (TyFin n) x = return $ CNum Fraction ((x `mod` n) % 1) +-- compileNat _ x = return $ CNum Fraction (x % 1) + +------------------------------------------------------------ + +-- | Compile a primitive. Typically primitives turn into a +-- corresponding function constant in the core language, but +-- sometimes the particular constant it turns into may depend on the +-- type. +compilePrim :: Member Fresh r => Type -> Prim -> Sem r Core +compilePrim (argTy :->: _) (PrimUOp uop) = return $ compileUOp argTy uop +compilePrim ty p@(PrimUOp _) = compilePrimErr p ty +-- This special case for Cons only triggers if we didn't hit the case +-- for fully saturated Cons; just fall back to generating a lambda. Have to +-- do it here, not in compileBOp, since we need to generate fresh names. +compilePrim _ (PrimBOp Cons) = do + hd <- fresh (string2Name "hd") + tl <- fresh (string2Name "tl") + return $ CAbs $ bind [hd, tl] $ CInj R (CPair (CVar (localName hd)) (CVar (localName tl))) + +compilePrim _ PrimLeft = do + a <- fresh (string2Name "a") + return $ CAbs $ bind [a] $ CInj L (CVar (localName a)) + +compilePrim _ PrimRight = do + a <- fresh (string2Name "a") + return $ CAbs $ bind [a] $ CInj R (CVar (localName a)) + +compilePrim (ty1 :*: ty2 :->: resTy) (PrimBOp bop) = return $ compileBOp ty1 ty2 resTy bop +compilePrim ty p@(PrimBOp _) = compilePrimErr p ty +compilePrim _ PrimSqrt = return $ CConst OSqrt +compilePrim _ PrimFloor = return $ CConst OFloor +compilePrim _ PrimCeil = return $ CConst OCeil +compilePrim _ PrimAbs = return $ CConst OAbs +compilePrim _ PrimSize = return $ CConst OSize +compilePrim (TySet _ :->: _) PrimPower = return $ CConst OPower +compilePrim (TyBag _ :->: _) PrimPower = return $ CConst OPower +compilePrim ty PrimPower = compilePrimErr PrimPower ty +compilePrim (TySet _ :->: _) PrimList = return $ CConst OSetToList +compilePrim (TyBag _ :->: _) PrimSet = return $ CConst OBagToSet +compilePrim (TyBag _ :->: _) PrimList = return $ CConst OBagToList +compilePrim (TyList _ :->: _) PrimSet = return $ CConst OListToSet +compilePrim (TyList _ :->: _) PrimBag = return $ CConst OListToBag +compilePrim _ p | p `elem` [PrimList, PrimBag, PrimSet] = return $ CConst OId +compilePrim ty PrimList = compilePrimErr PrimList ty +compilePrim ty PrimBag = compilePrimErr PrimBag ty +compilePrim ty PrimSet = compilePrimErr PrimSet ty +compilePrim _ PrimB2C = return $ CConst OBagToCounts +compilePrim (_ :->: TyBag _) PrimC2B = return $ CConst OCountsToBag +compilePrim ty PrimC2B = compilePrimErr PrimC2B ty +compilePrim (TyMap _ _ :->: _) PrimMapToSet = return $ CConst OMapToSet +compilePrim (_ :->: TyMap _ _) PrimSetToMap = return $ CConst OSetToMap +compilePrim ty PrimMapToSet = compilePrimErr PrimMapToSet ty +compilePrim ty PrimSetToMap = compilePrimErr PrimSetToMap ty +compilePrim _ PrimSummary = return $ CConst OSummary +compilePrim (_ :->: TyGraph _) PrimVertex = return $ CConst OVertex +compilePrim (TyGraph _) PrimEmptyGraph = return $ CConst OEmptyGraph +compilePrim (_ :->: TyGraph _) PrimOverlay = return $ CConst OOverlay +compilePrim (_ :->: TyGraph _) PrimConnect = return $ CConst OConnect +compilePrim ty PrimVertex = compilePrimErr PrimVertex ty +compilePrim ty PrimEmptyGraph = compilePrimErr PrimEmptyGraph ty +compilePrim ty PrimOverlay = compilePrimErr PrimOverlay ty +compilePrim ty PrimConnect = compilePrimErr PrimConnect ty +compilePrim _ PrimInsert = return $ CConst OInsert +compilePrim _ PrimLookup = return $ CConst OLookup +compilePrim (_ :*: TyList _ :->: _) PrimEach = return $ + CVar (Named Stdlib "list" .- string2Name "eachlist") +compilePrim (_ :*: TyBag _ :->: TyBag _) PrimEach = return $ CConst OEachBag +compilePrim (_ :*: TySet _ :->: TySet _) PrimEach = return $ CConst OEachSet +compilePrim ty PrimEach = compilePrimErr PrimEach ty +compilePrim (_ :*: _ :*: TyList _ :->: _) PrimReduce = + return $ CVar (Named Stdlib "list" .- string2Name "foldr") +compilePrim (_ :*: _ :*: TyBag _ :->: _) PrimReduce = return $ + CVar (Named Stdlib "container" .- string2Name "reducebag") +compilePrim (_ :*: _ :*: TySet _ :->: _) PrimReduce = return $ + CVar (Named Stdlib "container" .- string2Name "reduceset") +compilePrim ty PrimReduce = compilePrimErr PrimReduce ty +compilePrim (_ :*: TyList _ :->: _) PrimFilter = return $ + CVar (Named Stdlib "list" .- string2Name "filterlist") +compilePrim (_ :*: TyBag _ :->: _) PrimFilter = return $ CConst OFilterBag +compilePrim (_ :*: TySet _ :->: _) PrimFilter = return $ CConst OFilterBag +compilePrim ty PrimFilter = compilePrimErr PrimFilter ty +compilePrim (_ :->: TyList _) PrimJoin = return $ + CVar (Named Stdlib "list" .- string2Name "concat") +compilePrim (_ :->: TyBag _) PrimJoin = return $ CConst OBagUnions +compilePrim (_ :->: TySet _) PrimJoin = return $ + CVar (Named Stdlib "container" .- string2Name "unions") +compilePrim ty PrimJoin = compilePrimErr PrimJoin ty + +compilePrim (_ :*: TyBag _ :*: _ :->: _) PrimMerge = return $ CConst OMerge +compilePrim (_ :*: TySet _ :*: _ :->: _) PrimMerge = return $ CConst OMerge +compilePrim ty PrimMerge = compilePrimErr PrimMerge ty + +compilePrim _ PrimIsPrime = return $ CConst OIsPrime +compilePrim _ PrimFactor = return $ CConst OFactor +compilePrim _ PrimFrac = return $ CConst OFrac +compilePrim _ PrimCrash = return $ CConst OCrash +compilePrim _ PrimUntil = return $ CConst OUntil +compilePrim _ PrimHolds = return $ CConst OHolds +compilePrim _ PrimLookupSeq = return $ CConst OLookupSeq +compilePrim _ PrimExtendSeq = return $ CConst OExtendSeq + +compilePrimErr :: Prim -> Type -> a +compilePrimErr p ty = error $ "Impossible! compilePrim " ++ show p ++ " on bad type " ++ show ty + +------------------------------------------------------------ +-- Case expressions +------------------------------------------------------------ + +-- | Compile a case expression of type τ to a core language expression +-- of type (Unit → τ), in order to delay evaluation until explicitly +-- applying it to the unit value. +compileCase :: Member Fresh r => [DBranch] -> Sem r Core +compileCase [] = return $ CAbs (bind [string2Name "_"] (CConst OMatchErr)) +-- empty case ==> λ _ . error + +compileCase (b : bs) = do + c1 <- compileBranch b + c2 <- compileCase bs + return $ CAbs (bind [string2Name "_"] (CApp c1 c2)) + +-- | Compile a branch of a case expression of type τ to a core +-- language expression of type (Unit → τ) → τ. The idea is that it +-- takes a failure continuation representing the subsequent branches +-- in the case expression. If the branch succeeds, it just returns +-- the associated expression of type τ; if it fails, it calls the +-- continuation to proceed with the case analysis. +compileBranch :: Member Fresh r => DBranch -> Sem r Core +compileBranch b = do + (gs, e) <- unbind b + c <- compileDTerm e + k <- fresh (string2Name "k") -- Fresh name for the failure continuation + bc <- compileGuards (fromTelescope gs) k c + return $ CAbs (bind [k] bc) + +-- | 'compileGuards' takes a list of guards, the name of the failure +-- continuation of type (Unit → τ), and a Core term of type τ to +-- return in the case of success, and compiles to an expression of +-- type τ which evaluates the guards in sequence, ultimately +-- returning the given expression if all guards succeed, or calling +-- the failure continuation at any point if a guard fails. +compileGuards :: Member Fresh r => [DGuard] -> Name Core -> Core -> Sem r Core +compileGuards [] _ e = return e +compileGuards (DGPat (unembed -> s) p : gs) k e = do + e' <- compileGuards gs k e + s' <- compileDTerm s + compileMatch p s' k e' + +-- | 'compileMatch' takes a pattern, the compiled scrutinee, the name +-- of the failure continuation, and a Core term representing the +-- compilation of any guards which come after this one, and returns +-- a Core expression of type τ that performs the match and either +-- calls the failure continuation in the case of failure, or the +-- rest of the guards in the case of success. +compileMatch :: Member Fresh r => DPattern -> Core -> Name Core -> Core -> Sem r Core +compileMatch (DPVar _ x) s _ e = return $ CApp (CAbs (bind [coerce x] e)) s +-- Note in the below two cases that we can't just discard s since +-- that would result in a lazy semantics. With an eager/strict +-- semantics, we have to make sure s gets evaluated even if its +-- value is then discarded. +compileMatch (DPWild _) s _ e = return $ CApp (CAbs (bind [string2Name "_"] e)) s +compileMatch DPUnit s _ e = return $ CApp (CAbs (bind [string2Name "_"] e)) s +compileMatch (DPPair _ x1 x2) s _ e = do + y <- fresh (string2Name "y") + + -- {? e when s is (x1,x2) ?} ==> (\y. (\x1.\x2. e) (fst y) (snd y)) s + return $ + CApp + ( CAbs + ( bind + [y] + ( CApp + ( CApp + (CAbs (bind [coerce x1, coerce x2] e)) + (CProj L (CVar (localName y))) + ) + (CProj R (CVar (localName y))) + ) + ) + ) + s +compileMatch (DPInj _ L x) s k e = + -- {? e when s is left(x) ?} ==> case s of {left x -> e; right _ -> k unit} + return $ CCase s (bind (coerce x) e) (bind (string2Name "_") (CApp (CVar (localName k)) CUnit)) +compileMatch (DPInj _ R x) s k e = + -- {? e when s is right(x) ?} ==> case s of {left _ -> k unit; right x -> e} + return $ CCase s (bind (string2Name "_") (CApp (CVar (localName k)) CUnit)) (bind (coerce x) e) + +------------------------------------------------------------ +-- Unary and binary operators +------------------------------------------------------------ + +-- | Compile a unary operator. +compileUOp :: + -- | Type of the operator argument + Type -> + UOp -> + Core +compileUOp _ op = CConst (coreUOps ! op) + where + -- Just look up the corresponding core operator. + coreUOps = + M.fromList + [ Neg ==> ONeg, + Fact ==> OFact + ] + +-- | Compile a binary operator. This function needs to know the types +-- of the arguments and result since some operators are overloaded +-- and compile to different code depending on their type. +-- +-- @arg1 ty -> arg2 ty -> result ty -> op -> result@ +compileBOp :: Type -> Type -> Type -> BOp -> Core +-- First, compile some operators specially for modular arithmetic. +-- Most operators on TyFun (add, mul, sub, etc.) have already been +-- desugared to an operation followed by a mod. The only operators +-- here are the ones that have a special runtime behavior for Zn that +-- can't be implemented in terms of other, existing operators: +-- +-- - Division on Zn needs to find modular inverses. +-- - Divisibility testing on Zn similarly needs to find a gcd etc. +-- - Exponentiation on Zn could in theory be implemented as a normal +-- exponentiation on naturals followed by a mod, but that would be +-- silly and inefficient. Instead we compile to a special modular +-- exponentiation operator which takes mods along the way. Also, +-- negative powers have similar requirements to division. +-- +-- We match on the type of arg1 because that is the only one which +-- will consistently be TyFin in the case of Div, Exp, and Divides. +-- compileBOp (TyFin n) _ _ op +-- | op `elem` [Div, Exp, Divides] +-- = CConst ((omOps ! op) n) +-- where +-- omOps = M.fromList +-- [ Div ==> OMDiv +-- , Exp ==> OMExp +-- , Divides ==> OMDivides +-- ] + +-- Graph operations are separate, but use the same syntax, as traditional +-- addition and multiplication. +compileBOp (TyGraph _) (TyGraph _) (TyGraph _) op + | op `elem` [Add, Mul] = + CConst (regularOps ! op) + where + regularOps = + M.fromList + [ Add ==> OOverlay, + Mul ==> OConnect + ] + +-- Some regular arithmetic operations that just translate straightforwardly. +compileBOp _ _ _ op + | op `M.member` regularOps = CConst (regularOps ! op) + where + regularOps = + M.fromList + [ Add ==> OAdd, + Mul ==> OMul, + Div ==> ODiv, + Exp ==> OExp, + Mod ==> OMod, + Divides ==> ODivides, + Choose ==> OMultinom, + Eq ==> OEq, + Lt ==> OLt + ] + +-- ShouldEq needs to know the type at which the comparison is +-- occurring, so values can be correctly pretty-printed if the test +-- fails. +compileBOp ty _ _ ShouldEq = CConst (OShouldEq ty) +compileBOp _ty (TyList _) _ Elem = CConst OListElem +compileBOp _ty _ _ Elem = CConst OBagElem +compileBOp ty1 ty2 resTy op = + error $ "Impossible! missing case in compileBOp: " ++ show (ty1, ty2, resTy, op) diff --git a/src/Disco/Context.hs b/src/Disco/Context.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Context.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE DeriveTraversable #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Context +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- A *context* is a mapping from names to other things (such as types +-- or values). This module defines a generic type of contexts which +-- is used in many different places throughout the disco codebase. +-- +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + +module Disco.Context + ( -- * Context type + Ctx + + -- * Construction + , emptyCtx + , singleCtx + , fromList + , ctxForModule + , localCtx + + -- * Insertion + , insert + , extend + , extends + + -- * Query + , null + , lookup, lookup' + , lookupNonLocal, lookupNonLocal' + , lookupAll, lookupAll' + + -- * Conversion + , names + , elems + , assocs + , keysSet + + -- * Traversal + , coerceKeys + , restrictKeys + + -- * Combination + , joinCtx + , joinCtxs + + -- * Filter + , filter + + ) where + +import Control.Monad ((<=<)) +import Data.Bifunctor (first, second) +import Data.Coerce +import Data.Map (Map) +import qualified Data.Map as M +import Data.Map.Merge.Lazy as MM +import Data.Set (Set) +import qualified Data.Set as S +import Prelude hiding (filter, lookup, null) + +import Unbound.Generics.LocallyNameless (Name) + +import Polysemy +import Polysemy.Reader + +import Disco.Names (ModuleName, + NameProvenance (..), + QName (..)) + +-- | A context maps qualified names to things. In particular a @Ctx a +-- b@ maps qualified names for @a@s to values of type @b@. +newtype Ctx a b = Ctx { getCtx :: M.Map NameProvenance (M.Map (Name a) b) } + deriving (Eq, Show, Functor, Foldable, Traversable) + + -- Note that we implement a context as a nested map from + -- NameProvenance to Name to b, rather than as a Map QName b. They + -- are isomorphic, but this way it is easier to do name resolution, + -- because given an (unqualified) Name, we can look it up in each + -- inner map corresponding to modules that are in scope. + +instance Semigroup (Ctx a b) where + (<>) = joinCtx + +instance Monoid (Ctx a b) where + mempty = emptyCtx + mappend = (<>) + +------------------------------------------------------------ +-- Construction +------------------------------------------------------------ + +-- | The empty context. +emptyCtx :: Ctx a b +emptyCtx = Ctx M.empty + +-- | A singleton context, mapping a qualified name to a thing. +singleCtx :: QName a -> b -> Ctx a b +singleCtx (QName p n) = Ctx . M.singleton p . M.singleton n + +-- | Create a context from a list of (qualified name, value) pairs. +fromList :: [(QName a, b)] -> Ctx a b +fromList = Ctx . M.fromListWith M.union . map (\(QName p n, b) -> (p, M.singleton n b)) + +-- | Create a context for bindings from a single module. +ctxForModule :: ModuleName -> [(Name a, b)] -> Ctx a b +ctxForModule m = Ctx . M.singleton (QualifiedName m) . M.fromList + +-- | Create a context with local bindings. +localCtx :: [(Name a, b)] -> Ctx a b +localCtx = Ctx . M.singleton LocalName . M.fromList + +------------------------------------------------------------ +-- Insertion +------------------------------------------------------------ + +-- | Insert a new binding into a context. The new binding shadows any +-- old binding for the same qualified name. +insert :: QName a -> b -> Ctx a b -> Ctx a b +insert (QName p n) b = Ctx . M.insertWith M.union p (M.singleton n b) . getCtx + +-- | Run a computation under a context extended with a new binding. +-- The new binding shadows any old binding for the same name. +extend :: Member (Reader (Ctx a b)) r => QName a -> b -> Sem r c -> Sem r c +extend qn b = local (insert qn b) + +-- | Run a computation in a context extended with an additional +-- context. Bindings in the additional context shadow any bindings +-- with the same names in the existing context. +extends :: Member (Reader (Ctx a b)) r => Ctx a b -> Sem r c -> Sem r c +extends = local . joinCtx + +------------------------------------------------------------ +-- Query +------------------------------------------------------------ + +-- | Check if a context is empty. +null :: Ctx a b -> Bool +null = all M.null . getCtx + +-- | Look up a qualified name in an ambient context. +lookup :: Member (Reader (Ctx a b)) r => QName a -> Sem r (Maybe b) +lookup x = lookup' x <$> ask + +-- | Look up a qualified name in a context. +lookup' :: QName a -> Ctx a b -> Maybe b +lookup' (QName p n) = (M.lookup n <=< M.lookup p) . getCtx + +-- | Look up all the non-local bindings of a name in an ambient context. +lookupNonLocal :: Member (Reader (Ctx a b)) r => Name a -> Sem r [(ModuleName, b)] +lookupNonLocal n = lookupNonLocal' n <$> ask + +-- | Look up all the non-local bindings of a name in a context. +lookupNonLocal' :: Name a -> Ctx a b -> [(ModuleName, b)] +lookupNonLocal' n = nonLocal . lookupAll' n + where + nonLocal bs = [(m,b) | (QName (QualifiedName m) _, b) <- bs] + +-- | Look up all the bindings of an (unqualified) name in an ambient context. +lookupAll :: Member (Reader (Ctx a b)) r => Name a -> Sem r [(QName a, b)] +lookupAll n = lookupAll' n <$> ask + +-- | Look up all the bindings of an (unqualified) name in a context. +lookupAll' :: Name a -> Ctx a b -> [(QName a, b)] +lookupAll' n = map (first (`QName` n)) . M.assocs . M.mapMaybe (M.lookup n) . getCtx + +------------------------------------------------------------ +-- Conversion +------------------------------------------------------------ + +-- | Return a list of the names defined by the context. +names :: Ctx a b -> [Name a] +names = concatMap M.keys . M.elems . getCtx + +-- | Return a list of all the values bound by the context. +elems :: Ctx a b -> [b] +elems = concatMap M.elems . M.elems . getCtx + +-- | Return a list of the qualified name-value associations in the +-- context. +assocs :: Ctx a b -> [(QName a, b)] +assocs = concatMap (uncurry modAssocs) . M.assocs . getCtx + where + modAssocs :: NameProvenance -> Map (Name a) b -> [(QName a, b)] + modAssocs p = map (first (QName p)) . M.assocs + +-- | Return a set of all qualified names in the context. +keysSet :: Ctx a b -> Set (QName a) +keysSet = S.unions . map (uncurry (S.map . QName) . second M.keysSet) . M.assocs . getCtx + +------------------------------------------------------------ +-- Traversal +------------------------------------------------------------ + +-- | Coerce the type of the qualified name keys in a context. +coerceKeys :: Ctx a1 b -> Ctx a2 b +coerceKeys = Ctx . M.map (M.mapKeys coerce) . getCtx + +-- | Restrict a context to only the keys in the given set. +restrictKeys :: Ctx a b -> Set (QName a) -> Ctx a b +restrictKeys ctx xs = Ctx . restrict m . getCtx $ ctx + where + restrict = MM.merge MM.dropMissing MM.dropMissing (MM.zipWithMatched (\_ ns m' -> M.restrictKeys m' ns)) + m = M.fromListWith S.union . map (\(QName p n) -> (p, S.singleton n)) . S.toList $ xs + +------------------------------------------------------------ +-- Combination +------------------------------------------------------------ + +-- | Join two contexts (left-biased, /i.e./ if the same qualified name +-- exists in both contexts, the result will use the value from the +-- first context, and throw away the value from the second.). +joinCtx :: Ctx a b -> Ctx a b -> Ctx a b +joinCtx a b = joinCtxs [a,b] + +-- | Join a list of contexts (left-biased). +joinCtxs :: [Ctx a b] -> Ctx a b +joinCtxs = Ctx . M.unionsWith M.union . map getCtx + +------------------------------------------------------------ +-- Filter +------------------------------------------------------------ + +-- | Filter a context using a predicate. +filter :: (b -> Bool) -> Ctx a b -> Ctx a b +filter p = Ctx . M.map (M.filter p) . getCtx diff --git a/src/Disco/Data.hs b/src/Disco/Data.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Data.hs @@ -0,0 +1,32 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Data +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- Some orphan 'Data' instances. +-- +----------------------------------------------------------------------------- + +module Disco.Data where + +import Unbound.Generics.LocallyNameless.Bind +import Unbound.Generics.LocallyNameless.Embed +import Unbound.Generics.LocallyNameless.Name + +import Data.Data (Data) +import Unbound.Generics.LocallyNameless.Rebind + +------------------------------------------------------------ +-- Some orphan instances +------------------------------------------------------------ + +deriving instance (Data a, Data b) => Data (Bind a b) +deriving instance Data t => Data (Embed t) +deriving instance (Data a, Data b) => Data (Rebind a b) +deriving instance Data a => Data (Name a) + diff --git a/src/Disco/Desugar.hs b/src/Disco/Desugar.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Desugar.hs @@ -0,0 +1,822 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Desugar +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Desugaring the typechecked surface language to a (still typed) +-- simpler language. +-- +----------------------------------------------------------------------------- + +module Disco.Desugar + ( -- * Running desugaring computations + runDesugar + + -- * Programs, terms, and properties + , desugarDefn, desugarTerm, desugarProperty + + -- * Case expressions and patterns + , desugarBranch, desugarGuards + ) + where + +import Control.Monad.Cont +import Data.Bool (bool) +import Data.Coerce +import Data.Maybe (fromMaybe, isJust) + +import Disco.AST.Desugared +import Disco.AST.Surface +import Disco.AST.Typed +import Disco.Module +import Disco.Names +import Disco.Syntax.Operators +import Disco.Syntax.Prims +import Disco.Typecheck (containerTy) +import Disco.Types + +import Disco.Effects.Fresh +import Polysemy (Member, Sem, run) +import Unbound.Generics.LocallyNameless (Bind, Name, bind, + embed, name2String, + string2Name, unembed, + unrebind) +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) + +------------------------------------------------------------ +-- Running desugaring computations +------------------------------------------------------------ + +-- | Run a desugaring computation. +runDesugar :: Sem '[Fresh] a -> a +runDesugar = run . runFresh1 + -- Using runFresh1 is a bit of a hack; that way we won't + -- ever pick a name with #0 (which is what is generated by default + -- by string2Name), hence won't conflict with any existing free + -- variables which came from the parser. + +------------------------------------------------------------ +-- ATerm DSL +------------------------------------------------------------ + +-- A tiny DSL for building certain ATerms, which is helpful for +-- writing desugaring rules. + +-- Make a local ATVar. +atVar :: Type -> Name ATerm -> ATerm +atVar ty x = ATVar ty (QName LocalName x) + +tapp :: ATerm -> ATerm -> ATerm +tapp t1 t2 = ATApp resTy t1 t2 + where + resTy = case getType t1 of + (_ :->: r) -> r + ty -> error $ "Impossible! Got non-function type " ++ show ty ++ " in tapp" + +mkBin :: Type -> BOp -> ATerm -> ATerm -> ATerm +mkBin resTy bop t1 t2 + = tapp (ATPrim (getType t1 :*: getType t2 :->: resTy) (PrimBOp bop)) (mkPair t1 t2) + +mkUn :: Type -> UOp -> ATerm -> ATerm +mkUn resTy uop t = tapp (ATPrim (getType t :->: resTy) (PrimUOp uop)) t + +mkPair :: ATerm -> ATerm -> ATerm +mkPair t1 t2 = mkTup [t1,t2] + +mkTup :: [ATerm] -> ATerm +mkTup ts = ATTup (foldr1 (:*:) (map getType ts)) ts + +tapps :: ATerm -> [ATerm] -> ATerm +tapps t ts = tapp t (mkTup ts) + +infixr 2 ||. +(||.) :: ATerm -> ATerm -> ATerm +(||.) = mkBin TyBool Or + +infixl 6 -., +. +(-.) :: ATerm -> ATerm -> ATerm +at1 -. at2 = mkBin (getType at1) Sub at1 at2 + +(+.) :: ATerm -> ATerm -> ATerm +at1 +. at2 = mkBin (getType at1) Add at1 at2 + +infixl 7 /. +(/.) :: ATerm -> ATerm -> ATerm +at1 /. at2 = mkBin (getType at1) Div at1 at2 + +infix 4 <., >=. +(<.) :: ATerm -> ATerm -> ATerm +(<.) = mkBin TyBool Lt + +(>=.) :: ATerm -> ATerm -> ATerm +(>=.) = mkBin TyBool Geq + +(|.) :: ATerm -> ATerm -> ATerm +(|.) = mkBin TyBool Divides + +infix 4 ==. +(==.) :: ATerm -> ATerm -> ATerm +(==.) = mkBin TyBool Eq + +tnot :: ATerm -> ATerm +tnot = tapp (ATPrim (TyBool :->: TyBool) (PrimUOp Not)) + +(<==.) :: ATerm -> [AGuard] -> ABranch +t <==. gs = bind (toTelescope gs) t + +fls :: ATerm +fls = ATBool TyBool False + +tru :: ATerm +tru = ATBool TyBool True + +tif :: ATerm -> AGuard +tif t = AGBool (embed t) + +ctrNil :: Container -> Type -> ATerm +ctrNil ctr ty = ATContainer (containerTy ctr ty) ctr [] Nothing + +ctrSingleton :: Container -> ATerm -> ATerm +ctrSingleton ctr t = ATContainer (containerTy ctr (getType t)) ctr [(t, Nothing)] Nothing + +------------------------------------------------------------ +-- Making DTerms +------------------------------------------------------------ + +dtVar :: Type -> Name DTerm -> DTerm +dtVar ty x = DTVar ty (QName LocalName x) + +dtapp :: DTerm -> DTerm -> DTerm +dtapp t1 t2 = DTApp resTy t1 t2 + where + resTy = case getType t1 of + (_ :->: r) -> r + ty -> error $ "Impossible! Got non-function type " ++ show ty ++ " in dtapp" + +dtbin :: Type -> Prim -> DTerm -> DTerm -> DTerm +dtbin resTy p dt1 dt2 + = dtapp (DTPrim (getType dt1 :*: getType dt2 :->: resTy) p) (mkDTPair dt1 dt2) + +mkDTPair :: DTerm -> DTerm -> DTerm +mkDTPair dt1 dt2 = DTPair (getType dt1 :*: getType dt2) dt1 dt2 + +------------------------------------------------------------ +-- Definition desugaring +------------------------------------------------------------ + +-- | Desugar a definition (consisting of a collection of pattern +-- clauses with bodies) into a core language term. +desugarDefn :: Member Fresh r => Defn -> Sem r DTerm +desugarDefn (Defn _ patTys bodyTy def) = + desugarAbs Lam (foldr (:->:) bodyTy patTys) def + +------------------------------------------------------------ +-- Abstraction desugaring +------------------------------------------------------------ + +-- | Desugar an abstraction -- that is, a collection of clauses +-- with their corresponding patterns. Definitions are abstractions +-- (which happen to be named), and source-level lambdas are also +-- abstractions (which happen to have only one clause). + +desugarAbs :: Member Fresh r => Quantifier -> Type -> [Clause] -> Sem r DTerm +-- Special case for compiling a single lambda with no pattern matching directly to a lambda +desugarAbs Lam ty [cl@(unsafeUnbind -> ([APVar _ _], _))] = do + (ps, at) <- unbind cl + d <- desugarTerm at + return $ DTAbs Lam ty (bind (getVar (head ps)) d) + where + getVar (APVar _ x) = coerce x +-- General case +desugarAbs quant overallTy body = do + clausePairs <- unbindClauses body + let (pats, bodies) = unzip clausePairs + let patTys = map getType (head pats) + let bodyTy = getType (head bodies) + + -- generate dummy variables for lambdas + args <- zipWithM (\_ i -> fresh (string2Name ("arg" ++ show i))) (head pats) [0 :: Int ..] + + -- Create lambdas and one big case. Recursively desugar the case to + -- deal with arithmetic patterns. + let branches = zipWith (mkBranch (zip args patTys)) bodies pats + dcase <- desugarTerm $ ATCase bodyTy branches + return $ mkAbs quant overallTy patTys (coerce args) dcase + + where + mkBranch :: [(Name ATerm, Type)] -> ATerm -> [APattern] -> ABranch + mkBranch xs b ps = bind (mkGuards xs ps) b + + mkGuards :: [(Name ATerm, Type)] -> [APattern] -> Telescope AGuard + mkGuards xs ps = toTelescope $ zipWith AGPat (map (\(x,ty) -> embed (atVar ty x)) xs) ps + + -- To make searches fairer, we lift up directly nested abstractions + -- with the same quantifier when there's only a single clause. That + -- way, we generate a chain of abstractions followed by a case, instead + -- of a bunch of alternating abstractions and cases. + unbindClauses :: Member Fresh r => [Clause] -> Sem r [([APattern], ATerm)] + unbindClauses [c] | quant `elem` [All, Ex] = do + (ps, t) <- liftClause c + return [(ps, addDbgInfo ps t)] + unbindClauses cs = mapM unbind cs + + liftClause :: Member Fresh r => Bind [APattern] ATerm -> Sem r ([APattern], ATerm) + liftClause c = unbind c >>= \case + (ps, ATAbs q _ c') | q == quant -> do + (ps', b) <- liftClause c' + return (ps ++ ps', b) + (ps, b) -> return (ps, b) + + -- Wrap a term in a test frame to report the values of all variables + -- bound in the patterns. + addDbgInfo :: [APattern] -> ATerm -> ATerm + addDbgInfo ps t = ATTest (map withName $ concatMap varsBound ps) t + where withName (n, ty) = (name2String n, ty, n) + +------------------------------------------------------------ +-- Term desugaring +------------------------------------------------------------ + +-- | Desugar a typechecked term. +desugarTerm :: Member Fresh r => ATerm -> Sem r DTerm +desugarTerm (ATVar ty x) = return $ DTVar ty (coerce x) +desugarTerm (ATPrim (ty1 :->: resTy) (PrimUOp uop)) + | uopDesugars ty1 resTy uop = desugarPrimUOp ty1 resTy uop +desugarTerm (ATPrim (ty1 :*: ty2 :->: resTy) (PrimBOp bop)) + | bopDesugars ty1 ty2 resTy bop = desugarPrimBOp ty1 ty2 resTy bop +desugarTerm (ATPrim ty@(TyList cts :->: TyBag b) PrimC2B) = do + c <- fresh (string2Name "c") + body <- desugarTerm $ + tapp (ATPrim (TyBag cts :->: TyBag b) PrimC2B) + (tapp (ATPrim (TyList cts :->: TyBag cts) PrimBag) + (atVar (TyList cts) c) + ) + return $ mkLambda ty [c] body + +desugarTerm (ATPrim ty x) = return $ DTPrim ty x +desugarTerm ATUnit = return DTUnit +desugarTerm (ATBool ty b) = return $ DTBool ty b +desugarTerm (ATChar c) = return $ DTChar c +desugarTerm (ATString cs) = + desugarContainer (TyList TyC) ListContainer (map (\c -> (ATChar c, Nothing)) cs) Nothing +desugarTerm (ATAbs q ty lam) = desugarAbs q ty [lam] + +-- Special cases for fully applied operators +desugarTerm (ATApp resTy (ATPrim _ (PrimUOp uop)) t) + | uopDesugars (getType t) resTy uop = desugarUnApp resTy uop t +desugarTerm (ATApp resTy (ATPrim _ (PrimBOp bop)) (ATTup _ [t1,t2])) + | bopDesugars (getType t1) (getType t2) resTy bop = desugarBinApp resTy bop t1 t2 + +desugarTerm (ATApp ty t1 t2) = + DTApp ty <$> desugarTerm t1 <*> desugarTerm t2 +desugarTerm (ATTup ty ts) = desugarTuples ty ts +desugarTerm (ATNat ty n) = return $ DTNat ty n +desugarTerm (ATRat r) = return $ DTRat r + +desugarTerm (ATTyOp ty op t) = return $ DTTyOp ty op t + +desugarTerm (ATChain _ t1 links) = desugarTerm $ expandChain t1 links + +desugarTerm (ATContainer ty c es mell) = desugarContainer ty c es mell + +desugarTerm (ATContainerComp _ ctr bqt) = do + (qs, t) <- unbind bqt + desugarComp ctr t qs + +desugarTerm (ATLet _ t) = do + (bs, t2) <- unbind t + desugarLet (fromTelescope bs) t2 + +desugarTerm (ATCase ty bs) = DTCase ty <$> mapM desugarBranch bs + +desugarTerm (ATTest info t) = DTTest (coerce info) <$> desugarTerm t + +-- | Desugar a property by wrapping its corresponding term in a test +-- frame to catch its exceptions & convert booleans to props. +desugarProperty :: Member Fresh r => AProperty -> Sem r DTerm +desugarProperty p = DTTest [] <$> desugarTerm p + +------------------------------------------------------------ +-- Desugaring operators +------------------------------------------------------------ + +-- | Test whether a given unary operator is one that needs to be +-- desugared, given the type of the argument and result. +uopDesugars :: Type -> Type -> UOp -> Bool +-- uopDesugars _ (TyFin _) Neg = True +uopDesugars _ _ uop = uop == Not + +desugarPrimUOp :: Member Fresh r => Type -> Type -> UOp -> Sem r DTerm +desugarPrimUOp argTy resTy op = do + x <- fresh (string2Name "arg") + body <- desugarUnApp resTy op (atVar argTy x) + return $ mkLambda (argTy :->: resTy) [x] body + +-- | Test whether a given binary operator is one that needs to be +-- desugared, given the two types of the arguments and the type of the result. +bopDesugars :: Type -> Type -> Type -> BOp -> Bool +bopDesugars _ TyN _ Choose = True +-- bopDesugars _ _ (TyFin _) bop | bop `elem` [Add, Mul] = True +bopDesugars _ _ _ bop = bop `elem` + [ And, Or, Impl + , Neq, Gt, Leq, Geq, Min, Max + , IDiv + , Sub, SSub + , Inter, Diff, Union, Subset + ] + +-- | Desugar a primitive binary operator at the given type. +desugarPrimBOp :: Member Fresh r => Type -> Type -> Type -> BOp -> Sem r DTerm +desugarPrimBOp ty1 ty2 resTy op = do + p <- fresh (string2Name "pair1") + x <- fresh (string2Name "arg1") + y <- fresh (string2Name "arg2") + let argsTy = ty1 :*: ty2 + body <- desugarBinApp resTy op (atVar ty1 x) (atVar ty2 y) + return $ mkLambda (argsTy :->: resTy) [p] $ + DTCase resTy + [ bind + (toTelescope [DGPat (embed (dtVar argsTy (coerce p))) (DPPair argsTy (coerce x) (coerce y))]) + body + ] + +-- | Desugar a saturated application of a unary operator. +-- The first argument is the type of the result. +desugarUnApp :: Member Fresh r => Type -> UOp -> ATerm -> Sem r DTerm + +-- Desugar negation on TyFin to a negation on TyZ followed by a mod. +-- See the comments below re: Add and Mul on TyFin. +-- desugarUnApp (TyFin n) Neg t = +-- desugarTerm $ mkBin (TyFin n) Mod (mkUn TyZ Neg t) (ATNat TyN n) + +-- XXX This should be turned into a standard library definition. +-- not t ==> {? false if t, true otherwise ?} +desugarUnApp _ Not t = desugarTerm $ + ATCase TyBool + [ fls <==. [AGBool (embed t)] + , tru <==. [] + ] + +desugarUnApp ty uop t = error $ "Impossible! desugarUnApp " ++ show ty ++ " " ++ show uop ++ " " ++ show t + +-- | Desugar a saturated application of a binary operator. +-- The first argument is the type of the result. +desugarBinApp :: Member Fresh r => Type -> BOp -> ATerm -> ATerm -> Sem r DTerm + +-- Implies, and, or should all be turned into a standard library +-- definition. This will require first (1) adding support for +-- modules/a standard library, including (2) the ability to define +-- infix operators. + +-- t1 and t2 ==> {? t2 if t1, false otherwise ?} +desugarBinApp _ And t1 t2 = desugarTerm $ + ATCase TyBool + [ t2 <==. [tif t1] + , fls <==. [] + ] + +-- (t1 implies t2) ==> (not t1 or t2) +desugarBinApp _ Impl t1 t2 = desugarTerm $ tnot t1 ||. t2 + +-- t1 or t2 ==> {? true if t1, t2 otherwise ?}) +desugarBinApp _ Or t1 t2 = desugarTerm $ + ATCase TyBool + [ tru <==. [tif t1] + , t2 <==. [] + ] + +desugarBinApp _ Neq t1 t2 = desugarTerm $ tnot (t1 ==. t2) +desugarBinApp _ Gt t1 t2 = desugarTerm $ t2 <. t1 +desugarBinApp _ Leq t1 t2 = desugarTerm $ tnot (t2 <. t1) +desugarBinApp _ Geq t1 t2 = desugarTerm $ tnot (t1 <. t2) + +-- XXX sharing! +desugarBinApp ty Min t1 t2 = desugarTerm $ + ATCase ty + [ t1 <==. [tif (t1 <. t2)] + , t2 <==. [] + ] + +desugarBinApp ty Max t1 t2 = desugarTerm $ + ATCase ty + [ t1 <==. [tif (t2 <. t1)] + , t2 <==. [] + ] + +-- t1 // t2 ==> floor (t1 / t2) +desugarBinApp resTy IDiv t1 t2 = desugarTerm $ + ATApp resTy (ATPrim (getType t1 :->: resTy) PrimFloor) (mkBin (getType t1) Div t1 t2) + +-- Desugar normal binomial coefficient (n choose k) to a multinomial +-- coefficient with a singleton list, (n choose [k]). +-- Note this will only be called when (getType t2 == TyN); see bopDesugars. +desugarBinApp _ Choose t1 t2 + = desugarTerm $ mkBin TyN Choose t1 (ctrSingleton ListContainer t2) + +desugarBinApp ty Sub t1 t2 = desugarTerm $ mkBin ty Add t1 (mkUn ty Neg t2) +desugarBinApp ty SSub t1 t2 = desugarTerm $ + -- t1 -. t2 ==> {? 0 if t1 < t2, t1 - t2 otherwise ?} + ATCase ty + [ ATNat ty 0 <==. [tif (t1 <. t2)] + , mkBin ty Sub t1 t2 <==. [] + -- NOTE, the above is slightly bogus since the whole point of SSub is + -- because we can't subtract naturals. However, this will + -- immediately desugar to a DTerm. When we write a linting + -- typechecker for DTerms we should allow subtraction on TyN! + ] + +-- Addition and multiplication on TyFin just desugar to the operation +-- followed by a call to mod. +-- desugarBinApp (TyFin n) op t1 t2 +-- | op `elem` [Add, Mul] = desugarTerm $ +-- mkBin (TyFin n) Mod +-- (mkBin TyN op t1 t2) +-- (ATNat TyN n) + -- Note the typing of this is a bit funny: t1 and t2 presumably + -- have type (TyFin n), and now we are saying that applying 'op' + -- to them results in TyN, then applying 'mod' results in a TyFin + -- n again. Using TyN as the intermediate result is necessary so + -- we don't fall into an infinite desugaring loop, and intuitively + -- makes sense because the idea is that we first do the operation + -- as a normal operation in "natural land" and then do a mod. + -- + -- We will have to think carefully about how the linting + -- typechecker for DTerms should treat TyN and TyFin. Probably + -- something like this will work: TyFin is a subtype of TyN, and + -- TyN can be turned into TyFin with mod. (We don't want such + -- typing rules in the surface disco language itself because + -- implicit coercions from TyFin -> N don't commute with + -- operations like addition and multiplication, e.g. 3+3 yields 1 + -- if we add them in Z5 and then coerce to Nat, but 6 if we first + -- coerce both and then add. + +-- Intersection, difference, and union all desugar to an application +-- of 'merge' with an appropriate combining operation. +desugarBinApp ty op t1 t2 + | op `elem` [Inter, Diff, Union] = + desugarTerm $ + tapps (ATPrim ((TyN :*: TyN :->: TyN) :*: ty :*: ty :->: ty) PrimMerge) + [ ATPrim (TyN :*: TyN :->: TyN) (mergeOp ty op) + , t1 + , t2 + ] + where + mergeOp _ Inter = PrimBOp Min + mergeOp _ Diff = PrimBOp SSub + mergeOp (TySet _) Union = PrimBOp Max + mergeOp (TyBag _) Union = PrimBOp Add + mergeOp _ _ = error $ "Impossible! mergeOp " ++ show ty ++ " " ++ show op + +-- A ⊆ B <==> (A ⊔ B = B) +-- where ⊔ denotes 'merge max'. +-- Note it is NOT union, since this doesn't work for bags. +-- e.g. bag [1] union bag [1,2] = bag [1,1,2] /= bag [1,2]. +desugarBinApp _ Subset t1 t2 = desugarTerm $ + tapps (ATPrim (ty :*: ty :->: TyBool) (PrimBOp Eq)) + [ tapps (ATPrim ((TyN :*: TyN :->: TyN) :*: ty :*: ty :->: ty) PrimMerge) + [ ATPrim (TyN :*: TyN :->: TyN) (PrimBOp Max) + , t1 + , t2 + ] + , t2 -- XXX sharing + ] + where + ty = getType t1 + +desugarBinApp ty bop t1 t2 = error $ "Impossible! desugarBinApp " ++ show ty ++ " " ++ show bop ++ " " ++ show t1 ++ " " ++ show t2 + +------------------------------------------------------------ +-- Desugaring other stuff +------------------------------------------------------------ + +-- | Desugar a container comprehension. First translate it into an +-- expanded ATerm and then recursively desugar that. +desugarComp :: Member Fresh r => Container -> ATerm -> Telescope AQual -> Sem r DTerm +desugarComp ctr t qs = expandComp ctr t qs >>= desugarTerm + +-- | Expand a container comprehension into an equivalent ATerm. +expandComp :: Member Fresh r => Container -> ATerm -> Telescope AQual -> Sem r ATerm + +-- [ t | ] = [ t ] +expandComp ctr t TelEmpty = return $ ctrSingleton ctr t + +-- [ t | q, qs ] = ... +expandComp ctr t (TelCons (unrebind -> (q,qs))) + = case q of + -- [ t | x in l, qs ] = join (map (\x -> [t | qs]) l) + AQBind x (unembed -> lst) -> do + tqs <- expandComp ctr t qs + let c = containerTy ctr + tTy = getType t + xTy = case getType lst of + TyContainer _ e -> e + _ -> error "Impossible! Not a container in expandComp" + joinTy = c (c tTy) :->: c tTy + mapTy = (xTy :->: c tTy) :*: c xTy :->: c (c tTy) + return $ tapp (ATPrim joinTy PrimJoin) $ + tapp + (ATPrim mapTy PrimEach) + (mkPair + (ATAbs Lam (xTy :->: c tTy) (bind [APVar xTy x] tqs)) + lst + ) + + -- [ t | g, qs ] = if g then [ t | qs ] else [] + AQGuard (unembed -> g) -> do + tqs <- expandComp ctr t qs + return $ ATCase (containerTy ctr (getType t)) + [ tqs <==. [tif g] + , ctrNil ctr (getType t) <==. [] + ] + +-- | Desugar a let into applications of a chain of nested lambdas. +-- /e.g./ +-- +-- @let x = s, y = t in q@ +-- +-- desugars to +-- +-- @(\x. (\y. q) t) s@ +desugarLet :: Member Fresh r => [ABinding] -> ATerm -> Sem r DTerm +desugarLet [] t = desugarTerm t +desugarLet ((ABinding _ x (unembed -> t1)) : ls) t = + dtapp + <$> (DTAbs Lam (getType t1 :->: getType t) + <$> (bind (coerce x) <$> desugarLet ls t) + ) + <*> desugarTerm t1 + +-- | Desugar a lambda from a list of argument names and types and the +-- desugared @DTerm@ expression for its body. It will be desugared +-- to a chain of one-argument lambdas. /e.g./ +-- +-- @\x y z. q@ +-- +-- desugars to +-- +-- @\x. \y. \z. q@ +mkLambda :: Type -> [Name ATerm] -> DTerm -> DTerm +mkLambda funty args c = go funty args + where + go _ [] = c + go ty@(_ :->: ty2) (x:xs) = DTAbs Lam ty (bind (coerce x) (go ty2 xs)) + go ty as = error $ "Impossible! mkLambda.go " ++ show ty ++ " " ++ show as + +mkQuant :: Quantifier -> [Type] -> [Name ATerm] -> DTerm -> DTerm +mkQuant q argtys args c = foldr quantify c (zip args argtys) + where + quantify (x, ty) body = DTAbs q ty (bind (coerce x) body) + +mkAbs :: Quantifier -> Type -> [Type] -> [Name ATerm] -> DTerm -> DTerm +mkAbs Lam funty _ args c = mkLambda funty args c +mkAbs q _ argtys args c = mkQuant q argtys args c + +-- | Desugar a tuple to nested pairs, /e.g./ @(a,b,c,d) ==> (a,(b,(c,d)))@.a +desugarTuples :: Member Fresh r => Type -> [ATerm] -> Sem r DTerm +desugarTuples _ [t] = desugarTerm t +desugarTuples ty@(_ :*: ty2) (t:ts) = DTPair ty <$> desugarTerm t <*> desugarTuples ty2 ts +desugarTuples ty ats + = error $ "Impossible! desugarTuples " ++ show ty ++ " " ++ show ats + +-- | Expand a chain of comparisons into a sequence of binary +-- comparisons combined with @and@. Note we only expand it into +-- another 'ATerm' (which will be recursively desugared), because +-- @and@ itself also gets desugared. +-- +-- For example, @a < b <= c > d@ becomes @a < b and b <= c and c > d@. +expandChain :: ATerm -> [ALink] -> ATerm +expandChain _ [] = error "Can't happen! expandChain _ []" +expandChain t1 [ATLink op t2] = mkBin TyBool op t1 t2 +expandChain t1 (ATLink op t2 : links) = + mkBin TyBool And + (mkBin TyBool op t1 t2) + (expandChain t2 links) + +-- | Desugar a branch of a case expression. +desugarBranch :: Member Fresh r => ABranch -> Sem r DBranch +desugarBranch b = do + (ags, at) <- unbind b + dgs <- desugarGuards ags + d <- desugarTerm at + return $ bind dgs d + +-- | Desugar the list of guards in one branch of a case expression. +-- Pattern guards essentially remain as they are; boolean guards get +-- turned into pattern guards which match against @true@. +desugarGuards :: Member Fresh r => Telescope AGuard -> Sem r (Telescope DGuard) +desugarGuards = fmap (toTelescope . concat) . mapM desugarGuard . fromTelescope + where + desugarGuard :: Member Fresh r => AGuard -> Sem r [DGuard] + + -- A Boolean guard is desugared to a pattern-match on @true = right(unit)@. + desugarGuard (AGBool (unembed -> at)) = do + dt <- desugarTerm at + desugarMatch dt (APInj TyBool R APUnit) + + -- 'let x = t' is desugared to 'when t is x'. + desugarGuard (AGLet (ABinding _ x (unembed -> at))) = do + dt <- desugarTerm at + varMatch dt (coerce x) + + -- Desugaring 'when t is p' is the most complex case; we have to + -- break down the pattern and match it incrementally. + desugarGuard (AGPat (unembed -> at) p) = do + dt <- desugarTerm at + desugarMatch dt p + + -- Desugar a guard of the form 'when dt is p'. An entire match is + -- the right unit to desugar --- as opposed to, say, writing a + -- function to desugar a pattern --- since a match may desugar to + -- multiple matches, and on recursive calls we need to know what + -- term/variable should be bound to the pattern. + -- + -- A match may desugar to multiple matches for two reasons: + -- + -- 1. Nested patterns 'explode' into a 'telescope' matching one + -- constructor at a time, for example, 'when t is (x,y,3)' + -- becomes 'when t is (x,x0) when x0 is (y,x1) when x1 is 3'. + -- This makes the order of matching explicit and enables lazy + -- matching without requiring special support from the + -- interpreter other than WHNF reduction. + -- + -- 2. Matches against arithmetic patterns desugar to a + -- combination of matching, computation, and boolean checks. + -- For example, 'when t is (y+1)' becomes 'when t is x0 if x0 >= + -- 1 let y = x0-1'. + desugarMatch :: Member Fresh r => DTerm -> APattern -> Sem r [DGuard] + desugarMatch dt (APVar ty x) = mkMatch dt (DPVar ty (coerce x)) + desugarMatch _ (APWild _) = return [] + desugarMatch dt APUnit = mkMatch dt DPUnit + desugarMatch dt (APBool b) = desugarMatch dt (APInj TyBool (bool L R b) APUnit) + desugarMatch dt (APNat ty n) = desugarMatch (dtbin TyBool (PrimBOp Eq) dt (DTNat ty n)) (APBool True) + desugarMatch dt (APChar c) = desugarMatch (dtbin TyBool (PrimBOp Eq) dt (DTChar c)) (APBool True) + desugarMatch dt (APString s) = desugarMatch dt (APList (TyList TyC) (map APChar s)) + desugarMatch dt (APTup tupTy pat) = desugarTuplePats tupTy dt pat + where + desugarTuplePats :: Member Fresh r => Type -> DTerm -> [APattern] -> Sem r [DGuard] + desugarTuplePats _ _ [] = error "Impossible! desugarTuplePats []" + desugarTuplePats _ t [p] = desugarMatch t p + desugarTuplePats ty@(_ :*: ty2) t (p:ps) = do + (x1,gs1) <- varForPat p + (x2,gs2) <- case ps of + [APVar _ px2] -> return (coerce px2, []) + _ -> do + x <- fresh (string2Name "x") + (x,) <$> desugarTuplePats ty2 (dtVar ty2 x) ps + fmap concat . sequence $ + [ mkMatch t $ DPPair ty x1 x2 + , return gs1 + , return gs2 + ] + desugarTuplePats ty _ _ + = error $ "Impossible! desugarTuplePats with non-pair type " ++ show ty + + desugarMatch dt (APInj ty s p) = do + (x,gs) <- varForPat p + fmap concat . sequence $ + [ mkMatch dt $ DPInj ty s x + , return gs + ] + + desugarMatch dt (APCons ty p1 p2) = do + y <- fresh (string2Name "y") + (x1, gs1) <- varForPat p1 + (x2, gs2) <- varForPat p2 + + let eltTy = getType p1 + unrolledTy = eltTy :*: ty + fmap concat . sequence $ + [ mkMatch dt (DPInj ty R y) + , mkMatch (dtVar unrolledTy y) (DPPair unrolledTy x1 x2) + , return gs1 + , return gs2 + ] + + desugarMatch dt (APList ty []) = desugarMatch dt (APInj ty L APUnit) + desugarMatch dt (APList ty ps) = + desugarMatch dt $ foldr (APCons ty) (APList ty []) ps + + -- when dt is (p + t) ==> when dt is x0; let v = t; [if x0 >= v]; when x0-v is p + desugarMatch dt (APAdd ty _ p t) = arithBinMatch posRestrict (-.) dt ty p t + where + posRestrict plusty + | plusty `elem` [TyN, TyF] = Just (>=.) + | otherwise = Nothing + + -- when dt is (p * t) ==> when dt is x0; let v = t; [if v divides x0]; when x0 / v is p + desugarMatch dt (APMul ty _ p t) = arithBinMatch intRestrict (/.) dt ty p t + where + intRestrict plusty + | plusty `elem` [TyN, TyZ] = Just (flip (|.)) + | otherwise = Nothing + + -- when dt is (p - t) ==> when dt is x0; let v = t; when x0 + v is p + desugarMatch dt (APSub ty p t) = arithBinMatch (const Nothing) (+.) dt ty p t + + -- when dt is (p/q) ==> when $frac(dt) is (p, q) + desugarMatch dt (APFrac _ p q) + = desugarMatch + (dtapp (DTPrim (TyQ :->: TyZ :*: TyN) PrimFrac) dt) + (APTup (TyZ :*: TyN) [p, q]) + + -- when dt is (-p) ==> when dt is x0; if x0 < 0; when -x0 is p + desugarMatch dt (APNeg ty p) = do + + -- when dt is x0 + (x0, g1) <- varFor dt + + -- if x0 < 0 + g2 <- desugarGuard $ AGBool (embed (atVar ty (coerce x0) <. ATNat ty 0)) + + -- when -x0 is p + neg <- desugarTerm $ mkUn ty Neg (atVar ty (coerce x0)) + g3 <- desugarMatch neg p + + return (g1 ++ g2 ++ g3) + + mkMatch :: Member Fresh r => DTerm -> DPattern -> Sem r [DGuard] + mkMatch dt dp = return [DGPat (embed dt) dp] + + varMatch :: Member Fresh r => DTerm -> Name DTerm -> Sem r [DGuard] + varMatch dt x = mkMatch dt (DPVar (getType dt) x) + + varFor :: Member Fresh r => DTerm -> Sem r (Name DTerm, [DGuard]) + varFor (DTVar _ (QName _ x)) = return (x, []) -- XXX return a name + provenance?? + varFor dt = do + x <- fresh (string2Name "x") + g <- varMatch dt x + return (x, g) + + varForPat :: Member Fresh r => APattern -> Sem r (Name DTerm, [DGuard]) + varForPat (APVar _ x) = return (coerce x, []) + varForPat p = do + x <- fresh (string2Name "px") -- changing this from x fixed a bug and I don't know why =( + (x,) <$> desugarMatch (dtVar (getType p) x) p + + arithBinMatch + :: Member Fresh r + => (Type -> Maybe (ATerm -> ATerm -> ATerm)) + -> (ATerm -> ATerm -> ATerm) + -> DTerm -> Type -> APattern -> ATerm -> Sem r [DGuard] + arithBinMatch restrict inverse dt ty p t = do + (x0, g1) <- varFor dt + + -- let v = t + t' <- desugarTerm t + (v, g2) <- varFor t' + + g3 <- case restrict ty of + Nothing -> return [] + + -- if x0 `cmp` v + Just cmp -> + desugarGuard $ + AGBool (embed (atVar ty (coerce x0) `cmp` atVar (getType t) (coerce v))) + + -- when x0 `inverse` v is p + inv <- desugarTerm (atVar ty (coerce x0) `inverse` atVar (getType t) (coerce v)) + g4 <- desugarMatch inv p + + return (g1 ++ g2 ++ g3 ++ g4) + +-- | Desugar a container literal such as @[1,2,3]@ or @{1,2,3}@. +desugarContainer :: Member Fresh r => Type -> Container -> [(ATerm, Maybe ATerm)] -> Maybe (Ellipsis ATerm) -> Sem r DTerm + +-- Literal list containers desugar to nested applications of cons. +desugarContainer ty ListContainer es Nothing = + foldr (dtbin ty (PrimBOp Cons)) (DTNil ty) <$> mapM (desugarTerm . fst) es + +-- A list container with an ellipsis @[x, y, z .. e]@ desugars to an +-- application of the primitive 'until' function. +desugarContainer ty@(TyList _) ListContainer es (Just (Until t)) = + dtbin ty PrimUntil + <$> desugarTerm t + <*> desugarContainer ty ListContainer es Nothing + +-- If desugaring a bag and there are any counts specified, desugar to +-- an application of bagFromCounts to a bag of pairs (with a literal +-- value of 1 filled in for missing counts as needed). +desugarContainer (TyBag eltTy) BagContainer es mell + | any (isJust . snd) es = + dtapp (DTPrim (TySet (eltTy :*: TyN) :->: TyBag eltTy) PrimC2B) + <$> desugarContainer (TyBag (eltTy :*: TyN)) BagContainer counts mell + + where + -- turn e.g. x # 3, y into (x, 3), (y, 1) + counts = [ (ATTup (eltTy :*: TyN) [t, fromMaybe (ATNat TyN 1) n], Nothing) + | (t, n) <- es + ] + +-- Other containers desugar to an application of the appropriate +-- container conversion function to the corresponding desugared list. +desugarContainer ty _ es mell = + dtapp (DTPrim (TyList eltTy :->: ty) conv) + <$> desugarContainer (TyList eltTy) ListContainer es mell + where + (conv, eltTy) = case ty of + TyBag e -> (PrimBag, e) + TySet e -> (PrimSet, e) + _ -> error $ "Impossible! Non-container type " ++ show ty ++ " in desugarContainer" diff --git a/src/Disco/Effects/Counter.hs b/src/Disco/Effects/Counter.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Effects/Counter.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TemplateHaskell #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Effects.Counter +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Polysemy effect for integer counter. +-- +----------------------------------------------------------------------------- + +module Disco.Effects.Counter where + +import Polysemy +import Polysemy.State + +data Counter m a where + + -- | Return the next integer in sequence. + Next :: Counter m Integer + +makeSem ''Counter + +-- | Dispatch a counter effect, starting the counter from the given +-- Integer. +runCounter' :: Integer -> Sem (Counter ': r) a -> Sem r a +runCounter' i + = evalState i + . reinterpret \case + Next -> do + n <- get + put (n+1) + return n + +-- | Dispatch a counter effect, starting the counter from zero. +runCounter :: Sem (Counter ': r) a -> Sem r a +runCounter = runCounter' 0 diff --git a/src/Disco/Effects/Fresh.hs b/src/Disco/Effects/Fresh.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Effects/Fresh.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Effects.Fresh +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Polysemy effect for fresh name generation, compatible with the +-- unbound-generics library. +-- +----------------------------------------------------------------------------- + +module Disco.Effects.Fresh where + +import Disco.Effects.Counter +import Disco.Names (QName, localName) +import Polysemy +import Polysemy.ConstraintAbsorber +import qualified Unbound.Generics.LocallyNameless as U +import Unbound.Generics.LocallyNameless.Name + +-- | Fresh name generation effect, supporting raw generation of fresh +-- names, and opening binders with automatic freshening. Simply +-- increments a global counter every time 'fresh' is called and +-- makes a variable with that numeric suffix. +data Fresh m a where + Fresh :: Name x -> Fresh m (Name x) + +makeSem ''Fresh + +-- | Dispatch the fresh name generation effect, starting at a given +-- integer. +runFresh' :: Integer -> Sem (Fresh ': r) a -> Sem r a +runFresh' i + = runCounter' i + . reinterpret \case + Fresh x -> case x of + Fn s _ -> Fn s <$> next + nm@Bn{} -> return nm + + -- Above code copied from + -- https://hackage.haskell.org/package/unbound-generics-0.4.1/docs/src/Unbound.Generics.LocallyNameless.Fresh.html ; + -- see instance Monad m => Fresh (FreshMT m) . + + -- It turns out to make things much simpler to reimplement the + -- Fresh effect ourselves in terms of a state effect, since then + -- we can immediately dispatch it. The alternative would be to + -- implement it in terms of (Embed U.FreshM), but then we are + -- stuck with that constraint. Given the constraint-absorbing + -- machinery below, just impementing the 'fresh' effect itself + -- means we can then reuse other things from unbound-generics that + -- depend on a Fresh constraint, such as the 'unbind' function + -- below. + +-- | Run a computation requiring fresh name generation, beginning with +-- 0 for the initial freshly generated name. +runFresh :: Sem (Fresh ': r) a -> Sem r a +runFresh = runFresh' 0 + +-- | Run a computation requiring fresh name generation, beginning with +-- 1 instead of 0 for the initial freshly generated name. +runFresh1 :: Sem (Fresh ': r) a -> Sem r a +runFresh1 = runFresh' 1 + +------------------------------------------------------------ +-- Other functions + +-- | Open a binder, automatically creating fresh names for the bound +-- variables. +unbind :: (Member Fresh r, U.Alpha p, U.Alpha t) => U.Bind p t -> Sem r (p, t) +unbind b = absorbFresh (U.unbind b) + +-- | Generate a fresh (local, free) qualified name based on a given +-- string. +freshQ :: (Member Fresh r) => String -> Sem r (QName a) +freshQ s = localName <$> fresh (string2Name s) + +------------------------------------------------------------ +-- Machinery for absorbing MTL-style constraint. +-- See https://hackage.haskell.org/package/polysemy-zoo-0.7.0.1/docs/Polysemy-ConstraintAbsorber.html +-- Used https://hackage.haskell.org/package/polysemy-zoo-0.7.0.1/docs/src/Polysemy.ConstraintAbsorber.MonadState.html#absorbState as a template. + +-- | Run a 'Sem' computation requiring a 'U.Fresh' constraint (from +-- the @unbound-generics@ library) in terms of an available 'Fresh' +-- effect. +absorbFresh :: Member Fresh r => (U.Fresh (Sem r) => Sem r a) -> Sem r a +absorbFresh = absorbWithSem @U.Fresh @Action (FreshDict fresh) (Sub Dict) +{-# INLINEABLE absorbFresh #-} + +newtype FreshDict m = FreshDict { fresh_ :: forall x. Name x -> m (Name x) } + +-- | Wrapper for a monadic action with phantom type parameter for reflection. +-- Locally defined so that the instance we are going to build with reflection +-- must be coherent, that is there cannot be orphans. +newtype Action m s' a = Action (m a) + deriving (Functor, Applicative, Monad) + +instance ( Monad m + , Reifies s' (FreshDict m) + ) => U.Fresh (Action m s') where + fresh x = Action $ fresh_ (reflect $ Proxy @s') x + {-# INLINEABLE fresh #-} diff --git a/src/Disco/Effects/Input.hs b/src/Disco/Effects/Input.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Effects/Input.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Effects.Input +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Utility functions for input effect. +-- +----------------------------------------------------------------------------- + +module Disco.Effects.Input + ( module Polysemy.Input + , inputToState + ) + where + +import Polysemy +import Polysemy.Input +import Polysemy.State + +-- | Run an input effect in terms of an ambient state effect. +inputToState :: forall s r a. Member (State s) r => Sem (Input s ': r) a -> Sem r a +inputToState = interpret (\case { Input -> get @s }) + diff --git a/src/Disco/Effects/LFresh.hs b/src/Disco/Effects/LFresh.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Effects/LFresh.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Effects.LFresh +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Polysemy effect for local fresh name generation, compatible with +-- the unbound-generics library. +-- +----------------------------------------------------------------------------- + +module Disco.Effects.LFresh where + +import Data.Set (Set) +import qualified Data.Set as S +import Data.Typeable (Typeable) +import Polysemy +import Polysemy.ConstraintAbsorber +import Polysemy.Reader +import qualified Unbound.Generics.LocallyNameless as U +import Unbound.Generics.LocallyNameless.Name + +-- | Local fresh name generation effect. +data LFresh m a where + Lfresh :: Typeable a => Name a -> LFresh m (Name a) + Avoid :: [AnyName] -> m a -> LFresh m a + GetAvoids :: LFresh m (Set AnyName) + +makeSem ''LFresh + +-- | Dispatch an 'LFresh' effect via a 'Reader' effect to keep track +-- of a set of in-scope names. +runLFresh :: Sem (LFresh ': r) a -> Sem r a +runLFresh = runReader S.empty . runLFresh' + +runLFresh' :: Sem (LFresh ': r) a -> Sem (Reader (Set AnyName) ': r) a +runLFresh' + = reinterpretH @_ @(Reader (Set AnyName)) \case + Lfresh nm -> do + let s = name2String nm + used <- ask + pureT $ head (filter (\x -> not (S.member (AnyName x) used)) + (map (makeName s) [0..])) + Avoid names m -> do + m' <- runT m + raise (subsume (runLFresh' (local (S.union (S.fromList names)) m'))) + GetAvoids -> ask >>= pureT + + -- Much of the above code copied from + -- https://hackage.haskell.org/package/unbound-generics-0.4.1/docs/src/Unbound.Generics.LocallyNameless.LFresh.html + -- (see instance Monad m => LFresh (LFreshMT m)) + + -- It turns out to make things much simpler to reimplement the + -- LFresh effect ourselves in terms of a reader effect, since then + -- we can immediately dispatch it as above. The alternative would + -- be to implement it in terms of (Final U.LFreshM) (see the + -- commented code at the bottom of this file), but then we are stuck + -- with that constraint. Given the constraint-absorbing machinery + -- below, just impementing the 'LFresh' effect itself means we can + -- then reuse other things from unbound-generics that depend on a + -- Fresh constraint, such as the 'lunbind' function below. + + -- NOTE: originally, there was a single function runLFresh which + -- called reinterpretH and then immediately dispatched the Reader + -- (Set AnyName) effect. However, since runLFresh is recursive, + -- this means that the recursive calls were running with a + -- completely *separate* Reader effect that started over from the + -- empty set! This meant that LFresh basically never changed any + -- names, leading to all sorts of name clashes and crashes. + -- + -- Instead, we need to organize things as above: runLFresh' is + -- recursive, and keeps the Reader effect (using 'subsume' to squash + -- the duplicated Reader effects together). Then a top-level + -- runLFresh function finally runs the Reader effect. + +-------------------------------------------------- +-- Other functions + +-- | Open a binder, automatically freshening the names of the bound +-- variables, and providing the opened pattern and term to the +-- provided continuation. The bound variables are also added to the +-- set of in-scope variables within in the continuation. +lunbind + :: (Member LFresh r, U.Alpha p, U.Alpha t) + => U.Bind p t -> ((p,t) -> Sem r c) -> Sem r c +lunbind b k = absorbLFresh (U.lunbind b k) + +------------------------------------------------------------ +-- Machinery for absorbing MTL-style constraint. +-- See https://hackage.haskell.org/package/polysemy-zoo-0.7.0.1/docs/Polysemy-ConstraintAbsorber.html +-- Used https://hackage.haskell.org/package/polysemy-zoo-0.7.0.1/docs/src/Polysemy.ConstraintAbsorber.MonadState.html#absorbState as a template. + +absorbLFresh :: Member LFresh r => (U.LFresh (Sem r) => Sem r a) -> Sem r a +absorbLFresh = absorbWithSem @U.LFresh @Action (LFreshDict lfresh avoid getAvoids) (Sub Dict) +{-# INLINEABLE absorbLFresh #-} + +data LFreshDict m = LFreshDict + { lfresh_ :: forall a. Typeable a => Name a -> m (Name a) + , avoid_ :: forall a. [AnyName] -> m a -> m a + , getAvoids_ :: m (Set AnyName) + } + +-- | Wrapper for a monadic action with phantom type parameter for reflection. +-- Locally defined so that the instance we are going to build with reflection +-- must be coherent, that is there cannot be orphans. +newtype Action m s' a = Action (m a) + deriving (Functor, Applicative, Monad) + +instance ( Monad m + , Reifies s' (LFreshDict m) + ) => U.LFresh (Action m s') where + lfresh x = Action $ lfresh_ (reflect $ Proxy @s') x + {-# INLINEABLE lfresh #-} + avoid xs (Action m) = Action $ avoid_ (reflect $ Proxy @s') xs m + {-# INLINEABLE avoid #-} + getAvoids = Action $ getAvoids_ (reflect $ Proxy @s') + {-# INLINEABLE getAvoids #-} + +---------------------------------------------------------------------- +-- Old code I don't want to delete because I spent so much time +-- banging my head against it. It wasn't wasted, though, since I used +-- some of my hard-earned knowledge to write runLFresh' above. + +-- -- | Dispatch the local fresh name generation effect in an effect stack +-- -- containing the 'LFreshM' monad from @unbound-generics@. +-- runLFreshR :: Member (Final U.LFreshM) r => Sem (LFresh ': r) a -> Sem r a +-- runLFreshR = interpretFinal @U.LFreshM $ \case +-- Avoid xs m -> do +-- m' <- runS m +-- pure (U.avoid xs m') +-- Lunbind b k -> do +-- s <- getInitialStateS +-- k' <- bindS k +-- pure (U.lunbind b (k' . (<$ s))) + +-- -- The above code took me a long time to figure out how to write. +-- -- lunbind is a higher-order effect, so we have to use more +-- -- complicated machinery. See my Stack Overflow question, +-- -- https://stackoverflow.com/questions/68384508/how-to-incorporate-mtl-style-cps-style-higher-order-effect-into-polysemy/68397358#68397358 + +-- -- | Run a computation requiring only fresh name generation. +-- runLFresh :: Sem '[LFresh, Final U.LFreshM] a -> a +-- runLFresh = U.runLFreshM . runFinal . runLFreshR diff --git a/src/Disco/Effects/Random.hs b/src/Disco/Effects/Random.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Effects/Random.hs @@ -0,0 +1,32 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Effects.Random +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Utility functions for random effect. +-- +----------------------------------------------------------------------------- + +module Disco.Effects.Random + ( module Polysemy.Random + , runGen + ) + where + +import Polysemy +import Polysemy.Random +import qualified System.Random.SplitMix as SM +import qualified Test.QuickCheck.Gen as QC +import qualified Test.QuickCheck.Random as QCR + +import Data.Word (Word64) + +-- | Run a QuickCheck generator using a 'Random' effect. +runGen :: Member Random r => QC.Gen a -> Sem r a +runGen g = do + n <- random @_ @Int + w <- random @_ @Word64 + return $ QC.unGen g (QCR.QCGen (SM.mkSMGen w)) n diff --git a/src/Disco/Effects/State.hs b/src/Disco/Effects/State.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Effects/State.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE BlockArguments #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Effects.State +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Utility functions for state effect. +-- +----------------------------------------------------------------------------- + +module Disco.Effects.State + ( module Polysemy.State + , zoom + , use + ,(%=),(.=)) + where + +import Control.Lens (Getter, Lens', view, (%~), (.~)) + +import Polysemy +import Polysemy.State + +-- | Use a lens to zoom into a component of a state. +zoom :: forall s a r c. Member (State s) r => Lens' s a -> Sem (State a ': r) c -> Sem r c +zoom l = interpret \case + Get -> view l <$> get + Put a -> modify (l .~ a) + +use :: Member (State s) r => Getter s a -> Sem r a +use g = gets (view g) + +infix 4 .=, %= + +(.=) :: Member (State s) r => Lens' s a -> a -> Sem r () +l .= a = modify (l .~ a) + +(%=) :: Member (State s) r => Lens' s a -> (a -> a) -> Sem r () +l %= f = modify (l %~ f) diff --git a/src/Disco/Effects/Store.hs b/src/Disco/Effects/Store.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Effects/Store.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TemplateHaskell #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Effects.Store +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Polysemy effect for a memory store with integer keys. +-- +----------------------------------------------------------------------------- + +module Disco.Effects.Store where + +import qualified Data.IntMap.Lazy as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet + +import Disco.Effects.Counter +import Polysemy +import Polysemy.State + +data Store v m a where + + ClearStore :: Store v m () + New :: v -> Store v m Int + LookupStore :: Int -> Store v m (Maybe v) + InsertStore :: Int -> v -> Store v m () + MapStore :: (v -> v) -> Store v m () + AssocsStore :: Store v m [(Int, v)] + KeepKeys :: IntSet -> Store v m () + +makeSem ''Store + +-- | Dispatch a store effect. +runStore :: forall v r a. Sem (Store v ': r) a -> Sem r a +runStore + = runCounter + . evalState @(IntMap.IntMap v) IntMap.empty + . reinterpret2 \case + ClearStore -> put IntMap.empty + New v -> do + loc <- fromIntegral <$> next + modify $ IntMap.insert loc v + return loc + LookupStore k -> gets (IntMap.lookup k) + InsertStore k v -> modify (IntMap.insert k v) + MapStore f -> modify (IntMap.map f) + AssocsStore -> gets IntMap.assocs + KeepKeys ks -> modify (\m -> IntMap.withoutKeys m (IntMap.keysSet m `IntSet.difference` ks)) diff --git a/src/Disco/Enumerate.hs b/src/Disco/Enumerate.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Enumerate.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE NondecreasingIndentation #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Enumerate +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Enumerate values inhabiting Disco types. +-- +----------------------------------------------------------------------------- + +module Disco.Enumerate + ( + ValueEnumeration + -- * Base types + , enumVoid + , enumUnit + , enumBool + , enumN + , enumZ + , enumF + , enumQ + , enumC + + -- * Containers + , enumSet + -- , enumBag + , enumList + + -- * Any type + , enumType + , enumTypes + + -- * Lifted functions that return lists + , enumerateType + , enumerateTypes + ) + where + +import qualified Data.Enumeration.Invertible as E +import Disco.AST.Generic (Side (..)) +import Disco.Types +import Disco.Value + +type ValueEnumeration = E.IEnumeration Value + +-- | Enumerate all values of type @Void@ (none). +enumVoid :: ValueEnumeration +enumVoid = E.void + +-- | Enumerate all values of type @Unit@ (the single value @unit@). +enumUnit :: ValueEnumeration +enumUnit = E.singleton VUnit + +-- | Enumerate the values of type @Bool@ as @[false, true]@. +enumBool :: ValueEnumeration +enumBool = E.mapE toV fromV $ E.finiteList [L, R] + where + toV i = VInj i VUnit + fromV (VInj i VUnit) = i + fromV _ = error "enumBool.fromV: value isn't a bool" + +-- | Unsafely extract the numeric value of a @Value@ +-- (assumed to be a VNum). +valToRat :: Value -> Rational +valToRat (VNum _ r) = r +valToRat _ = error "valToRat: value isn't a number" + +ratToVal :: Rational -> Value +ratToVal = VNum mempty + +-- | Enumerate all values of type @Nat@ (0, 1, 2, ...). +enumN :: ValueEnumeration +enumN = E.mapE (ratToVal . fromInteger) (floor . valToRat) E.nat + +-- | Enumerate all values of type @Integer@ (0, 1, -1, 2, -2, ...). +enumZ :: ValueEnumeration +enumZ = E.mapE (ratToVal . fromInteger) (floor . valToRat) E.int + +-- | Enumerate all values of type @Fractional@ in the Calkin-Wilf +-- order (1, 1/2, 2, 1/3, 3/2, 2/3, 3, ...). +enumF :: ValueEnumeration +enumF = E.mapE ratToVal valToRat E.cw + +-- | Enumerate all values of type @Rational@ in the Calkin-Wilf order, +-- with negatives interleaved (0, 1, -1, 1/2, -1/2, 2, -2, ...). +enumQ :: ValueEnumeration +enumQ = E.mapE ratToVal valToRat E.rat + +-- | Enumerate all Unicode characters. +enumC :: ValueEnumeration +enumC = E.mapE toV fromV (E.boundedEnum @Char) + where + toV = ratToVal . fromIntegral . fromEnum + fromV = toEnum . floor . valToRat + +-- | Enumerate all *finite* sets over a certain element type, given an +-- enumeration of the elements. If we think of each finite set as a +-- binary string indicating which elements in the enumeration are +-- members, the sets are enumerated in order of the binary strings. +enumSet :: ValueEnumeration -> ValueEnumeration +enumSet e = E.mapE toV fromV (E.finiteSubsetOf e) + where + toV = VBag . map (,1) + fromV (VBag vs) = map fst vs + fromV _ = error "enumSet.fromV: value isn't a set" + +-- | Enumerate all *finite* lists over a certain element type, given +-- an enumeration of the elements. It is very difficult to describe +-- the order in which the lists are generated. +enumList :: ValueEnumeration -> ValueEnumeration +enumList e = E.mapE toV fromV (E.listOf e) + where + toV = foldr VCons VNil + fromV (VCons h t) = h : fromV t + fromV VNil = [] + fromV _ = error "enumList.fromV: value isn't a list" + +-- | Enumerate all functions from a finite domain, given enumerations +-- for the domain and codomain. +enumFunction :: ValueEnumeration -> ValueEnumeration -> ValueEnumeration +enumFunction xs ys = + case (E.card xs, E.card ys) of + (E.Finite 0, _) -> E.singleton (VFun $ \_ -> error "enumFunction: void function called") + (_, E.Finite 0) -> E.void + (_, E.Finite 1) -> E.singleton (VFun $ \_ -> E.select ys 0) + _ -> E.mapE toV fromV (E.functionOf xs ys) + + -- XXX TODO: better error message on functions with an infinite domain + where + toV = VFun + fromV (VFun f) = f + fromV _ = error "enumFunction.fromV: value isn't a VFun" + +-- | Enumerate all values of a product type, given enumerations of the +-- two component types. Uses a fair interleaving for infinite +-- component types. +enumProd :: ValueEnumeration -> ValueEnumeration -> ValueEnumeration +enumProd xs ys = E.mapE toV fromV $ (E.><) xs ys + where + toV (x, y) = VPair x y + fromV (VPair x y) = (x, y) + fromV _ = error "enumProd.fromV: value isn't a pair" + +-- | Enumerate all values of a sum type, given enumerations of the two +-- component types. +enumSum :: ValueEnumeration -> ValueEnumeration -> ValueEnumeration +enumSum xs ys = E.mapE toV fromV $ (E.<+>) xs ys + where + toV (Left x) = VInj L x + toV (Right y) = VInj R y + fromV (VInj L x) = Left x + fromV (VInj R y) = Right y + fromV _ = error "enumSum.fromV: value isn't a sum" + +-- | Enumerate the values of a given type. +enumType :: Type -> ValueEnumeration +enumType TyVoid = enumVoid +enumType TyUnit = enumUnit +enumType TyBool = enumBool +enumType TyN = enumN +enumType TyZ = enumZ +enumType TyF = enumF +enumType TyQ = enumQ +enumType TyC = enumC +enumType (TySet t) = enumSet (enumType t) +enumType (TyList t) = enumList (enumType t) +enumType (a :*: b) = enumProd (enumType a) (enumType b) +enumType (a :+: b) = enumSum (enumType a) (enumType b) +enumType (a :->: b) = enumFunction (enumType a) (enumType b) +enumType ty = error $ "enumType: can't enumerate " ++ show ty + +-- | Enumerate a finite product of types. +enumTypes :: [Type] -> E.IEnumeration [Value] +enumTypes [] = E.singleton [] +enumTypes (t:ts) = E.mapE toL fromL $ (E.><) (enumType t) (enumTypes ts) + where + toL (x, xs) = x:xs + fromL (x:xs) = (x, xs) + fromL [] = error "enumTypes.fromL: empty list not in enumeration range" + +-- | Produce an actual list of the values of a type. +enumerateType :: Type -> [Value] +enumerateType = E.enumerate . enumType + +-- | Produce an actual list of values enumerated from a finite product +-- of types. +enumerateTypes :: [Type] -> [[Value]] +enumerateTypes = E.enumerate . enumTypes diff --git a/src/Disco/Error.hs b/src/Disco/Error.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Error.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Error +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Type for collecting all potential Disco errors at the top level, +-- and a type for runtime errors. +-- +----------------------------------------------------------------------------- + +module Disco.Error (DiscoError(..), EvalError(..), panic, outputDiscoErrors) where + +import Prelude hiding ((<>)) + +import Text.Megaparsec (ParseErrorBundle, + errorBundlePretty) +import Unbound.Generics.LocallyNameless (Name) + +import Disco.Effects.LFresh +import Polysemy +import Polysemy.Error +import Polysemy.Output +import Polysemy.Reader + +import Disco.Messages +import Disco.Names (ModuleName) +import Disco.Parser (DiscoParseError) +import Disco.Pretty +import Disco.Typecheck.Solve +import Disco.Typecheck.Util (TCError (..)) +import Disco.Types +import Disco.Types.Qualifiers + +-- | Top-level error type for Disco. +data DiscoError where + + -- | Module not found. + ModuleNotFound :: String -> DiscoError + + -- | Cyclic import encountered. + CyclicImport :: [ModuleName] -> DiscoError + + -- | Error encountered during typechecking. + TypeCheckErr :: TCError -> DiscoError + + -- | Error encountered during parsing. + ParseErr :: ParseErrorBundle String DiscoParseError -> DiscoError + + -- | Error encountered at runtime. + EvalErr :: EvalError -> DiscoError + + -- | Something that shouldn't happen; indicates the presence of a + -- bug. + Panic :: String -> DiscoError + + deriving Show + +-- | Errors that can be generated at runtime. +data EvalError where + + -- | An unbound name. This shouldn't happen. + UnboundError :: Name core -> EvalError + + -- | Division by zero. + DivByZero :: EvalError + + -- | Overflow, e.g. (2^66)! + Overflow :: EvalError + + -- | Non-exhaustive case analysis. + NonExhaustive :: EvalError + + -- | Infinite loop detected via black hole. + InfiniteLoop :: EvalError + + -- | User-generated crash. + Crash :: String -> EvalError + +deriving instance Show EvalError + +panic :: Member (Error DiscoError) r => String -> Sem r a +panic = throw . Panic + +outputDiscoErrors :: Member (Output Message) r => Sem (Error DiscoError ': r) () -> Sem r () +outputDiscoErrors m = do + e <- runError m + either (err . pretty') return e + +instance Pretty DiscoError where + pretty = \case + ModuleNotFound m -> "Error: couldn't find a module named '" <> text m <> "'." + CyclicImport ms -> cyclicImportError ms + TypeCheckErr te -> prettyTCError te + ParseErr pe -> text (errorBundlePretty pe) + EvalErr ee -> prettyEvalError ee + Panic s -> + hcat + [ "Bug! " <> text s + , "Please report this as a bug at https://github.com/disco-lang/disco/issues/ ." + ] + +rtd :: String -> Sem r Doc +rtd page = "https://disco-lang.readthedocs.io/en/latest/reference/" <> text page <> ".html" + +cyclicImportError + :: Members '[Reader PA, LFresh] r + => [ModuleName] -> Sem r Doc +cyclicImportError ms = + vcat + [ "Error: module imports form a cycle:" + , nest 2 $ intercalate " ->" (map pretty ms) + ] + +prettyEvalError :: Members '[Reader PA, LFresh] r => EvalError -> Sem r Doc +prettyEvalError = \case + UnboundError x -> + ("Bug! No variable found named" <+> pretty' x <> ".") + $+$ + "Please report this as a bug at https://github.com/disco-lang/disco/issues/ ." + DivByZero -> "Error: division by zero." + Overflow -> "Error: that number would not even fit in the universe!" + NonExhaustive -> "Error: value did not match any of the branches in a case expression." + InfiniteLoop -> "Error: infinite loop detected!" + Crash s -> "User crash:" <+> text s + +-- [X] Step 1: nice error messages, make sure all are tested +-- [ ] Step 2: link to wiki/website with more info on errors! +-- [ ] Step 3: improve error messages according to notes below +-- [ ] Step 4: get it to return multiple error messages +-- [ ] Step 5: save parse locations, display with errors +prettyTCError :: Members '[Reader PA, LFresh] r => TCError -> Sem r Doc +prettyTCError = \case + + -- XXX include some potential misspellings along with Unbound + Unbound x -> vcat + [ "Error: there is nothing named" <+> pretty' x <> "." + , rtd "unbound" + ] + + Ambiguous x ms -> vcat + [ "Error: the name" <+> pretty' x <+> "is ambiguous. It could refer to:" + , nest 2 (vcat . map (\m -> pretty' m <> "." <> pretty' x) $ ms) + , rtd "ambiguous" + ] + + NoType x -> vcat + [ "Error: the definition of" <+> pretty' x <+> "must have an accompanying type signature." + , "Try writing something like '" <> pretty' x <+> ": Int' (or whatever the type of" + <+> pretty' x <+> "should be) first." + , rtd "missingtype" + ] + + NotCon c t ty -> vcat + [ "Error: the expression" + , nest 2 $ pretty' t + , "must have both a" <+> conWord c <+> "type and also the incompatible type" + , nest 2 $ pretty' ty <> "." + , rtd "notcon" + ] + + EmptyCase -> vcat + [ "Error: empty case expressions {? ?} are not allowed." + , rtd "empty-case" + ] + + PatternType c pat ty -> vcat + [ "Error: the pattern" + , nest 2 $ pretty' pat + , "is supposed to have type" + , nest 2 $ pretty' ty <> "," + , "but instead it has a" <+> conWord c <+> "type." + , rtd "pattern-type" + ] + + DuplicateDecls x -> vcat + [ "Error: duplicate type signature for" <+> pretty' x <> "." + , rtd "dup-sig" + ] + + DuplicateDefns x -> vcat + [ "Error: duplicate definition for" <+> pretty' x <> "." + , rtd "dup-def" + ] + + DuplicateTyDefns s -> vcat + [ "Error: duplicate definition for type" <+> text s <> "." + , rtd "dup-tydef" + ] + + -- XXX include all types involved in the cycle. + CyclicTyDef s -> vcat + [ "Error: cyclic type definition for" <+> text s <> "." + , rtd "cyc-ty" + ] + + -- XXX lots more info! & Split into several different errors. + NumPatterns -> vcat + [ "Error: number of arguments does not match." + , rtd "num-args" + ] + + NoSearch ty -> + vcat + [ "Error: the type" + , nest 2 $ pretty' ty + , "is not searchable (i.e. it cannot be used in a forall)." + , rtd "no-search" + ] + + Unsolvable solveErr -> prettySolveError solveErr + + -- XXX maybe include close edit-distance alternatives? + NotTyDef s -> vcat + [ "Error: there is no built-in or user-defined type named '" <> text s <> "'." + , rtd "no-tydef" + ] + + NoTWild -> vcat + [ "Error: wildcards (_) are not allowed in expressions." + , rtd "wildcard-expr" + ] + + -- XXX say how many are expected, how many there were, what the actual arguments were? + -- XXX distinguish between built-in and user-supplied type constructors in the error + -- message? + NotEnoughArgs con -> vcat + [ "Error: not enough arguments for the type '" <> pretty' con <> "'." + , rtd "num-args-type" + ] + + TooManyArgs con -> vcat + [ "Error: too many arguments for the type '" <> pretty' con <> "'." + , rtd "num-args-type" + ] + + -- XXX Mention the definition in which it was found, suggest adding the variable + -- as a parameter + UnboundTyVar v -> vcat + [ "Error: Unknown type variable '" <> pretty' v <> "'." + , rtd "unbound-tyvar" + ] + + NoPolyRec s ss tys -> vcat + [ "Error: in the definition of " <> text s <> parens (intercalate "," (map text ss)) <> ": recursive occurrences of" <+> text s <+> "may only have type variables as arguments." + , nest 2 ( + text s <> parens (intercalate "," (map pretty' tys)) <+> "does not follow this rule." + ) + , rtd "no-poly-rec" + ] + + NoError -> empty + +conWord :: Con -> Sem r Doc +conWord = \case + CArr -> "function" + CProd -> "product" + CSum -> "sum" + CSet -> "set" + CBag -> "bag" + CList -> "list" + CContainer _ -> "container" + CMap -> "map" + CGraph -> "graph" + CUser s -> text s + +prettySolveError :: Members '[Reader PA, LFresh] r => SolveError -> Sem r Doc +prettySolveError = \case + + -- XXX say which types! + NoWeakUnifier -> vcat + [ "Error: the shape of two types does not match." + , rtd "shape-mismatch" + ] + + -- XXX say more! XXX HIGHEST PRIORITY! + NoUnify -> vcat + [ "Error: typechecking failed." + , rtd "typecheck-fail" + ] + + UnqualBase q b -> vcat + [ "Error: values of type" <+> pretty' b <+> qualPhrase False q <> "." + , rtd "not-qual" + ] + + Unqual q ty -> vcat + [ "Error: values of type" <+> pretty' ty <+> qualPhrase False q <> "." + , rtd "not-qual" + ] + + QualSkolem q a -> vcat + [ "Error: type variable" <+> pretty' a <+> "represents any type, so we cannot assume values of that type" + , nest 2 (qualPhrase True q) <> "." + , rtd "qual-skolem" + ] + +qualPhrase :: Bool -> Qualifier -> Sem r Doc +qualPhrase b q + | q `elem` [QBool, QBasic, QSimple] = "are" <+> (if b then empty else "not") <+> qualAction q + | otherwise = "can" <> (if b then empty else "not") <+> "be" <+> qualAction q + +qualAction :: Qualifier -> Sem r Doc +qualAction = \case + QNum -> "added and multiplied" + QSub -> "subtracted" + QDiv -> "divided" + QCmp -> "compared" + QEnum -> "enumerated" + QBool -> "boolean" + QBasic -> "basic" + QSimple -> "simple" + diff --git a/src/Disco/Eval.hs b/src/Disco/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Eval.hs @@ -0,0 +1,422 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Eval +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Top-level evaluation utilities. +----------------------------------------------------------------------------- + +module Disco.Eval + ( + -- * Effects + + EvalEffects + , DiscoEffects + + -- * Top-level info record and associated lenses + + , DiscoConfig, initDiscoConfig, debugMode + , TopInfo + , replModInfo, topEnv, topModMap, lastFile, discoConfig + + -- * Running things + + , runDisco + , runTCM, runTCMWith + , inputTopEnv + , parseDiscoModule + , typecheckTop + + -- * Loading modules + + , loadDiscoModule + , loadParsedDiscoModule + , loadFile + , addToREPLModule + , setREPLModule + , loadDefsFrom + , loadDef + + ) + where + +import Control.Arrow ((&&&)) +import Control.Exception (SomeException, handle) +import Control.Lens (makeLenses, toListOf, view, (%~), + (.~), (^.)) +import Control.Monad (unless, void, when) +import Control.Monad.IO.Class (liftIO) +import Data.Bifunctor +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Set as S +import Prelude +import System.FilePath ((-<.>)) + +import qualified System.Console.Haskeline as H + +import Disco.Effects.Fresh +import Disco.Effects.Input +import Disco.Effects.LFresh +import Disco.Effects.State +import Polysemy +import Polysemy.Embed +import Polysemy.Error +import Polysemy.Fail +import Polysemy.Output +import Polysemy.Random +import Polysemy.Reader + +import Disco.AST.Core +import Disco.AST.Surface +import Disco.Compile (compileDefns) +import Disco.Context as Ctx +import Disco.Error +import Disco.Extensions +import Disco.Interpret.CESK +import Disco.Messages +import Disco.Module +import Disco.Names +import Disco.Parser +import Disco.Pretty hiding ((<>)) +import qualified Disco.Pretty as Pretty +import Disco.Typecheck (checkModule) +import Disco.Typecheck.Util +import Disco.Types +import Disco.Value + +------------------------------------------------------------ +-- Configuation options +------------------------------------------------------------ + +data DiscoConfig = DiscoConfig + { _debugMode :: Bool + } + +makeLenses ''DiscoConfig + +initDiscoConfig :: DiscoConfig +initDiscoConfig = DiscoConfig + { _debugMode = False + } + +------------------------------------------------------------ +-- Top level info record +------------------------------------------------------------ + +-- | A record of information about the current top-level environment. +data TopInfo = TopInfo + { _replModInfo :: ModuleInfo + -- ^ Info about the top-level module collecting stuff entered at + -- the REPL. + + , _topEnv :: Env + -- ^ Top-level environment mapping names to values. Set by + -- 'loadDefs'. + + , _topModMap :: Map ModuleName ModuleInfo + -- ^ Mapping from loaded module names to their 'ModuleInfo' + -- records. + + , _lastFile :: Maybe FilePath + -- ^ The most recent file which was :loaded by the user. + + , _discoConfig :: DiscoConfig + } + +-- | The initial (empty) record of top-level info. +initTopInfo :: DiscoConfig -> TopInfo +initTopInfo cfg = TopInfo + { _replModInfo = emptyModuleInfo + , _topEnv = emptyCtx + , _topModMap = M.empty + , _lastFile = Nothing + , _discoConfig = cfg + } + +makeLenses ''TopInfo + +------------------------------------------------------------ +-- Top-level effects +------------------------------------------------------------ + +-- | Append two effect rows. +type family AppendEffects (r :: EffectRow) (s :: EffectRow) :: EffectRow where + AppendEffects '[] s = s + AppendEffects (e ': r) s = e ': AppendEffects r s + +-- Didn't seem like this already existed in @polysemy@, though I +-- might have missed it. Of course we could also use a polymorphic +-- version from somewhere --- it is just type-level list append. +-- However, just manually implementing it here seems easier. + +-- | Effects needed at the top level. +type TopEffects = '[Error DiscoError, State TopInfo, Output Message, Embed IO, Final (H.InputT IO)] + +-- | Effects needed for evaluation. +type EvalEffects = [Error EvalError, Random, LFresh, Output Message, State Mem] + -- XXX write about order. + -- memory, counter etc. should not be reset by errors. + +-- | All effects needed for the top level + evaluation. +type DiscoEffects = AppendEffects EvalEffects TopEffects + +------------------------------------------------------------ +-- Running top-level Disco computations +------------------------------------------------------------ + +-- | Settings for running the 'InputT' monad from @haskeline@. Just +-- uses the defaults and sets the history file to @.disco_history@. +inputSettings :: H.Settings IO +inputSettings = + H.defaultSettings + { H.historyFile = Just ".disco_history" + } + +-- | Run a top-level computation. +runDisco :: DiscoConfig -> (forall r. Members DiscoEffects r => Sem r ()) -> IO () +runDisco cfg m = + void + . H.runInputT inputSettings + . runFinal @(H.InputT IO) + . embedToFinal + . runEmbedded @_ @(H.InputT IO) liftIO + . runOutputSem (handleMsg msgFilter) -- Handle Output Message via printing to console + . stateToIO (initTopInfo cfg) -- Run State TopInfo via an IORef + . inputToState -- Dispatch Input TopInfo effect via State effect + . runState emptyMem -- Start with empty memory + . outputDiscoErrors -- Output any top-level errors + . runLFresh -- Generate locally fresh names + . runRandomIO -- Generate randomness via IO + . mapError EvalErr -- Embed runtime errors into top-level error type + . failToError Panic -- Turn pattern-match failures into a Panic error + . runReader emptyCtx -- Keep track of current Env + $ m + where + msgFilter + | cfg ^. debugMode = const True + | otherwise = (/= Debug) . view messageType + +------------------------------------------------------------ +-- Environment utilities +------------------------------------------------------------ + +-- XXX change name to inputREPLEnv, modify to actually get the Env +-- from the REPL module info? + +-- | Run a computation that needs an input environment, grabbing the +-- current top-level environment from the 'TopInfo' records. +inputTopEnv :: Member (Input TopInfo) r => Sem (Input Env ': r) a -> Sem r a +inputTopEnv m = do + e <- inputs (view topEnv) + runInputConst e m + +------------------------------------------------------------ +-- High-level disco phases +------------------------------------------------------------ + +-------------------------------------------------- +-- Parsing + +-- | Parse a module from a file, re-throwing a parse error if it +-- fails. +parseDiscoModule :: Members '[Error DiscoError, Embed IO] r => FilePath -> Sem r Module +parseDiscoModule file = do + str <- liftIO $ readFile file + fromEither . first ParseErr $ runParser (wholeModule Standalone) file str + +-------------------------------------------------- +-- Type checking + +-- | Run a typechecking computation, providing it with local +-- (initially empty) contexts for variable types and type +-- definitions. +runTCM :: + Member (Error DiscoError) r => + Sem (Reader TyCtx ': Reader TyDefCtx ': Fresh ': Error TCError ': r) a -> + Sem r a +runTCM = runTCMWith emptyCtx M.empty + +-- | Run a typechecking computation, providing it with local contexts +-- (initialized to the provided arguments) for variable types and +-- type definitions. +runTCMWith :: + Member (Error DiscoError) r => + TyCtx -> + TyDefCtx -> + Sem (Reader TyCtx ': Reader TyDefCtx ': Fresh ': Error TCError ': r) a -> + Sem r a +runTCMWith tyCtx tyDefCtx = + mapError TypeCheckErr + . runFresh + . runReader @TyDefCtx tyDefCtx + . runReader @TyCtx tyCtx + +-- | Run a typechecking computation in the context of the top-level +-- REPL module, re-throwing a wrapped error if it fails. +typecheckTop + :: Members '[Input TopInfo, Error DiscoError] r + => Sem (Reader TyCtx ': Reader TyDefCtx ': Fresh ': Error TCError ': r) a + -> Sem r a +typecheckTop tcm = do + tyctx <- inputs (view (replModInfo . miTys)) + imptyctx <- inputs (toListOf (replModInfo . miImports . traverse . miTys)) + tydefs <- inputs (view (replModInfo . miTydefs)) + imptydefs <- inputs (toListOf (replModInfo . miImports . traverse . miTydefs)) + runTCMWith (tyctx <> mconcat imptyctx) (tydefs <> mconcat imptydefs) tcm + +-------------------------------------------------- +-- Loading + +-- | Recursively loads a given module by first recursively loading and +-- typechecking its imported modules, adding the obtained +-- 'ModuleInfo' records to a map from module names to info records, +-- and then typechecking the parent module in an environment with +-- access to this map. This is really just a depth-first search. +-- +-- The 'Resolver' argument specifies where to look for imported +-- modules. +loadDiscoModule + :: Members '[State TopInfo, Output Message, Random, State Mem, Error DiscoError, Embed IO] r + => Bool -> Resolver -> FilePath -> Sem r ModuleInfo +loadDiscoModule quiet resolver = + loadDiscoModule' quiet resolver [] + +-- | Like 'loadDiscoModule', but start with an already parsed 'Module' +-- instead of loading a module from disk by name. Also, check it in +-- a context that includes the current top-level context (unlike a +-- module loaded from disk). Used for e.g. blocks/modules entered +-- at the REPL prompt. +loadParsedDiscoModule + :: Members '[State TopInfo, Output Message, Random, State Mem, Error DiscoError, Embed IO] r + => Bool -> Resolver -> ModuleName -> Module -> Sem r ModuleInfo +loadParsedDiscoModule quiet resolver = + loadParsedDiscoModule' quiet REPL resolver [] + +-- | Recursively load a Disco module while keeping track of an extra +-- Map from module names to 'ModuleInfo' records, to avoid loading +-- any imported module more than once. Resolve the module, load and +-- parse it, then call 'loadParsedDiscoModule''. +loadDiscoModule' + :: Members '[State TopInfo, Output Message, Random, State Mem, Error DiscoError, Embed IO] r + => Bool -> Resolver -> [ModuleName] -> FilePath + -> Sem r ModuleInfo +loadDiscoModule' quiet resolver inProcess modPath = do + (resolvedPath, prov) <- resolveModule resolver modPath + >>= maybe (throw $ ModuleNotFound modPath) return + let name = Named prov modPath + when (name `elem` inProcess) (throw $ CyclicImport (name:inProcess)) + modMap <- use @TopInfo topModMap + case M.lookup name modMap of + Just mi -> return mi + Nothing -> do + unless quiet $ info $ "Loading" <+> text (modPath -<.> "disco") Pretty.<> "..." + cm <- parseDiscoModule resolvedPath + loadParsedDiscoModule' quiet Standalone resolver (name : inProcess) name cm + +-- | A list of standard library module names, which should always be +-- loaded implicitly. +stdLib :: [String] +stdLib = ["list", "container"] + +-- | Recursively load an already-parsed Disco module while keeping +-- track of an extra Map from module names to 'ModuleInfo' records, +-- to avoid loading any imported module more than once. Typecheck +-- it in the context of the top-level type context iff the +-- 'LoadingMode' parameter is 'REPL'. Recursively load all its +-- imports, then typecheck it. +loadParsedDiscoModule' + :: Members '[State TopInfo, Output Message, Random, State Mem, Error DiscoError, Embed IO] r + => Bool -> LoadingMode -> Resolver -> [ModuleName] -> ModuleName -> Module -> Sem r ModuleInfo +loadParsedDiscoModule' quiet mode resolver inProcess name cm@(Module _ mns _ _ _) = do + + -- Recursively load any modules imported by this one, plus standard + -- library modules (unless NoStdLib is enabled), and build a map with the results. + mis <- mapM (loadDiscoModule' quiet (withStdlib resolver) inProcess) mns + stdmis <- case NoStdLib `S.member` modExts cm of + True -> return [] + False -> mapM (loadDiscoModule' True FromStdlib inProcess) stdLib + let modImps = M.fromList (map (view miName &&& id) (mis ++ stdmis)) + + -- Get context and type definitions from the REPL, in case we are in REPL mode. + topImports <- use (replModInfo . miImports) + topTyCtx <- use (replModInfo . miTys) + topTyDefns <- use (replModInfo . miTydefs) + + -- Choose the contexts to use based on mode: if we are loading a + -- standalone module, we should start it in an empty context. If we + -- are loading something entered at the REPL, we need to include any + -- existing top-level REPL context. + let importMap = case mode of { Standalone -> modImps; REPL -> topImports <> modImps } + tyctx = case mode of { Standalone -> emptyCtx ; REPL -> topTyCtx } + tydefns = case mode of { Standalone -> M.empty ; REPL -> topTyDefns } + + -- Typecheck (and resolve names in) the module. + m <- runTCMWith tyctx tydefns $ checkModule name importMap cm + + -- Evaluate all the module definitions and add them to the topEnv. + mapError EvalErr $ loadDefsFrom m + + -- Record the ModuleInfo record in the top-level map. + modify (topModMap %~ M.insert name m) + return m + +-- | Try loading the contents of a file from the filesystem, emitting +-- an error if it's not found. +loadFile :: Members '[Output Message, Embed IO] r => FilePath -> Sem r (Maybe String) +loadFile file = do + res <- liftIO $ handle @SomeException (return . Left) (Right <$> readFile file) + case res of + Left _ -> info ("File not found:" <+> text file) >> return Nothing + Right s -> return (Just s) + +-- | Add things from the given module to the set of currently loaded +-- things. +addToREPLModule + :: Members '[Error DiscoError, State TopInfo, Random, State Mem, Output Message] r + => ModuleInfo -> Sem r () +addToREPLModule mi = do + curMI <- use @TopInfo replModInfo + mi' <- mapError TypeCheckErr $ combineModuleInfo [curMI, mi] + modify @TopInfo $ replModInfo .~ mi' + +-- | Set the given 'ModuleInfo' record as the currently loaded +-- module. This also includes updating the top-level state with new +-- term definitions, documentation, types, and type definitions. +-- Replaces any previously loaded module. +setREPLModule + :: Members '[State TopInfo, Random, Error EvalError, State Mem, Output Message] r + => ModuleInfo -> Sem r () +setREPLModule mi = do + modify @TopInfo $ replModInfo .~ mi + +-- | Populate various pieces of the top-level info record (docs, type +-- context, type and term definitions) from the 'ModuleInfo' record +-- corresponding to the currently loaded module, and load all the +-- definitions into the current top-level environment. +loadDefsFrom :: + Members '[State TopInfo, Random, Error EvalError, State Mem] r => + ModuleInfo -> + Sem r () +loadDefsFrom mi = do + + -- Note that the compiled definitions we get back from compileDefns + -- are topologically sorted by mutually recursive group. Each + -- definition needs to be evaluated in an environment containing the + -- previous ones. + + mapM_ (uncurry loadDef) (compileDefns (mi ^. miTermdefs)) + +loadDef :: + Members '[State TopInfo, Random, Error EvalError, State Mem] r => + QName Core -> Core -> Sem r () +loadDef x body = do + v <- inputToState @TopInfo . inputTopEnv $ eval body + modify @TopInfo $ topEnv %~ Ctx.insert x v diff --git a/src/Disco/Extensions.hs b/src/Disco/Extensions.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Extensions.hs @@ -0,0 +1,48 @@ +-- | +-- Module : Disco.Extensions +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Optional extensions to the disco language. +module Disco.Extensions + ( Ext (..), + ExtSet, + defaultExts, + allExts, + allExtsList, + addExtension, + ) +where + +import Data.Set (Set) +import qualified Data.Set as S + +type ExtSet = Set Ext + +-- | Enumeration of optional language extensions. +data Ext + = -- | Allow primitives, i.e. @$prim@ + Primitives + | -- | Don't automatically import standard library modules + NoStdLib + | -- | Allow randomness. This is not implemented yet. + Randomness + deriving (Eq, Ord, Show, Read, Enum, Bounded) + +-- | The default set of language extensions (currently, the empty set). +defaultExts :: ExtSet +defaultExts = S.empty + +-- | A set of all possible language extensions, provided for convenience. +allExts :: ExtSet +allExts = S.fromList allExtsList + +-- | All possible language extensions in the form of a list. +allExtsList :: [Ext] +allExtsList = [minBound .. maxBound] + +-- | Add an extension to an extension set. +addExtension :: Ext -> ExtSet -> ExtSet +addExtension = S.insert diff --git a/src/Disco/Interactive/CmdLine.hs b/src/Disco/Interactive/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Interactive/CmdLine.hs @@ -0,0 +1,193 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Interactive.CmdLine +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Definition of the command-line REPL interface for Disco. +-- +----------------------------------------------------------------------------- + +module Disco.Interactive.CmdLine + ( -- * Command-line options record + + DiscoOpts(..) + + -- * optparse-applicative command line parsers + , discoOpts, discoInfo + + -- * main + + , discoMain + + ) where + +import Control.Lens hiding (use) +import Control.Monad (unless) +import qualified Control.Monad.Catch as CMC +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Foldable (forM_) +import Data.List (isPrefixOf) +import Data.Maybe (isJust) +import System.Exit (exitFailure, + exitSuccess) + +import qualified Options.Applicative as O +import System.Console.Haskeline as H + +import Disco.Error +import Disco.Eval +import Disco.Interactive.Commands +import Disco.Messages +import Disco.Module (miExts) +import Disco.Pretty + +import Disco.Effects.State +import Polysemy +import Polysemy.ConstraintAbsorber.MonadCatch +import Polysemy.Error + +------------------------------------------------------------ +-- Command-line options parser +------------------------------------------------------------ + +-- | Command-line options for disco. +data DiscoOpts = DiscoOpts + { evaluate :: Maybe String -- ^ A single expression to evaluate + , cmdFile :: Maybe String -- ^ Execute the commands in a given file + , checkFile :: Maybe String -- ^ Check a file and then exit + , debugFlag :: Bool + } + +discoOpts :: O.Parser DiscoOpts +discoOpts = DiscoOpts + <$> O.optional ( + O.strOption (mconcat + [ O.long "evaluate" + , O.short 'e' + , O.help "evaluate an expression" + , O.metavar "TERM" + ]) + ) + <*> O.optional ( + O.strOption (mconcat + [ O.long "file" + , O.short 'f' + , O.help "execute the commands in a file" + , O.metavar "FILE" + ]) + ) + <*> O.optional ( + O.strOption (mconcat + [ O.long "check" + , O.help "check a file without starting the interactive REPL" + , O.metavar "FILE" + ]) + ) + <*> O.switch ( + mconcat + [ O.long "debug" + , O.help "print debugging information" + , O.short 'd' + ] + ) + +discoInfo :: O.ParserInfo DiscoOpts +discoInfo = O.info (O.helper <*> discoOpts) $ mconcat + [ O.fullDesc + , O.progDesc "Command-line interface for Disco, a programming language for discrete mathematics." + , O.header "disco v0.1" + ] + +optsToCfg :: DiscoOpts -> DiscoConfig +optsToCfg opts = initDiscoConfig & debugMode .~ debugFlag opts + +------------------------------------------------------------ +-- Command-line interface +------------------------------------------------------------ + +banner :: String +banner = "Welcome to Disco!\n\nA language for programming discrete mathematics.\n\n" + +discoMain :: IO () +discoMain = do + opts <- O.execParser discoInfo + + let batch = any isJust [evaluate opts, cmdFile opts, checkFile opts] + unless batch $ putStr banner + runDisco (optsToCfg opts) $ do + case checkFile opts of + Just file -> do + res <- handleLoad file + liftIO $ if res then exitSuccess else exitFailure + Nothing -> return () + case cmdFile opts of + Just file -> do + mcmds <- loadFile file + case mcmds of + Nothing -> return () + Just cmds -> mapM_ handleCMD (lines cmds) + Nothing -> return () + forM_ (evaluate opts) handleCMD + unless batch loop + + where + + -- These types used to involve InputT Disco, but we now use Final + -- (InputT IO) in the list of effects. see + -- https://github.com/polysemy-research/polysemy/issues/395 for + -- inspiration. + + ctrlC :: MonadIO m => m a -> SomeException -> m a + ctrlC act e = do + liftIO $ print e + act + + withCtrlC :: (MonadIO m, CMC.MonadCatch m) => m a -> m a -> m a + withCtrlC resume act = CMC.catch act (ctrlC resume) + + loop :: Members DiscoEffects r => Sem r () + loop = do + minput <- embedFinal $ withCtrlC (return $ Just "") (getInputLine "Disco> ") + case minput of + Nothing -> return () + Just input + | ":q" `isPrefixOf` input && input `isPrefixOf` ":quit" -> do + liftIO $ putStrLn "Goodbye!" + return () + | ":{" `isPrefixOf` input -> do + multiLineLoop [] + loop + | otherwise -> do + mapError @_ @DiscoError (Panic . show) $ + absorbMonadCatch $ + withCtrlC (return ()) $ + handleCMD input + loop + + multiLineLoop :: Members DiscoEffects r => [String] -> Sem r () + multiLineLoop ls = do + minput <- embedFinal $ withCtrlC (return Nothing) (getInputLine "Disco| ") + case minput of + Nothing -> return () + Just input + | ":}" `isPrefixOf` input -> do + mapError @_ @DiscoError (Panic . show) $ + absorbMonadCatch $ + withCtrlC (return ()) $ + handleCMD (unlines (reverse ls)) + | otherwise -> do + multiLineLoop (input:ls) + +-- | Parse and run the command corresponding to some REPL input. +handleCMD :: Members DiscoEffects r => String -> Sem r () +handleCMD "" = return () +handleCMD s = do + exts <- use @TopInfo (replModInfo . miExts) + case parseLine discoCommands exts s of + Left m -> info (text m) + Right l -> catch @DiscoError (dispatch discoCommands l) (info . pretty') + -- The above has to be catch, not outputErrors, because + -- the latter won't resume afterwards. diff --git a/src/Disco/Interactive/Commands.hs b/src/Disco/Interactive/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Interactive/Commands.hs @@ -0,0 +1,785 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Interactive.Commands +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Defining and dispatching all commands/functionality available at +-- the REPL prompt. +----------------------------------------------------------------------------- + +module Disco.Interactive.Commands + ( dispatch, + discoCommands, + handleLoad, + loadFile, + parseLine + ) where + +import Control.Arrow ((&&&)) +import Control.Lens (to, view, (%~), (.~), (?~), + (^.)) +import Control.Monad.Except +import Data.Char (isSpace) +import Data.Coerce +import Data.List (find, isPrefixOf, sortBy) +import Data.Map ((!)) +import qualified Data.Map as M +import Data.Typeable +import Prelude as P +import System.FilePath (splitFileName) + +import Text.Megaparsec hiding (State, runParser) +import qualified Text.Megaparsec.Char as C +import Unbound.Generics.LocallyNameless (Name, name2String, + string2Name) + +import Disco.Effects.Input +import Disco.Effects.LFresh +import Disco.Effects.State +import Polysemy +import Polysemy.Error hiding (try) +import Polysemy.Output +import Polysemy.Reader + +import Data.Maybe (maybeToList) +import Disco.AST.Surface +import Disco.AST.Typed +import Disco.Compile +import Disco.Context as Ctx +import Disco.Desugar +import Disco.Error +import Disco.Eval +import Disco.Extensions +import Disco.Interpret.CESK +import Disco.Messages +import Disco.Module +import Disco.Names +import Disco.Parser (Parser, ident, reservedOp, + runParser, sc, symbol, term, + wholeModule, withExts) +import Disco.Pretty hiding (empty, (<>)) +import qualified Disco.Pretty as Pretty +import Disco.Syntax.Operators +import Disco.Syntax.Prims (Prim (PrimBOp, PrimUOp), + primDoc, primReference, + toPrim) +import Disco.Typecheck +import Disco.Typecheck.Erase +import Disco.Types (toPolyType) +import Disco.Value + +------------------------------------------------------------ +-- REPL expression type +------------------------------------------------------------ + +-- | Data type to represent things typed at the Disco REPL. Each +-- constructor has a singleton type to facilitate dispatch. +data REPLExpr :: CmdTag -> * where + TypeCheck :: Term -> REPLExpr 'CTypeCheck -- Typecheck a term + Eval :: Module -> REPLExpr 'CEval -- Evaluate a block + TestProp :: Term -> REPLExpr 'CTestProp -- Run a property test + ShowDefn :: Name Term -> REPLExpr 'CShowDefn -- Show a variable's definition + Parse :: Term -> REPLExpr 'CParse -- Show the parsed AST + Pretty :: Term -> REPLExpr 'CPretty -- Pretty-print a term + Ann :: Term -> REPLExpr 'CAnn -- Show type-annotated term + Desugar :: Term -> REPLExpr 'CDesugar -- Show a desugared term + Compile :: Term -> REPLExpr 'CCompile -- Show a compiled term + Load :: FilePath -> REPLExpr 'CLoad -- Load a file. + Reload :: REPLExpr 'CReload -- Reloads the most recently + -- loaded file. + Doc :: Either (Name Term) Prim -> REPLExpr 'CDoc -- Show documentation. + Nop :: REPLExpr 'CNop -- No-op, e.g. if the user + -- just enters a comment + Help :: REPLExpr 'CHelp -- Show help + Names :: REPLExpr 'CNames -- Show bound names + +deriving instance Show (REPLExpr c) + +-- | An existential wrapper around any REPL expression. +data SomeREPLExpr where + SomeREPL :: Typeable c => REPLExpr c -> SomeREPLExpr + +------------------------------------------------------------ +-- REPL command types +------------------------------------------------------------ + +data REPLCommandCategory + = -- | REPL commands for everyday users + User + | -- | REPL commands for developers working on Disco + Dev + deriving (Eq, Show) + +data REPLCommandType + = -- | Things that don't start with a colon: eval and nop + BuiltIn + | -- | Things that start with a colon, e.g. :help, :names, :load... + ColonCmd + deriving (Eq, Show) + +-- | Tags used at the type level to denote each REPL command. +data CmdTag + = CTypeCheck + | CEval + | CShowDefn + | CParse + | CPretty + | CAnn + | CDesugar + | CCompile + | CLoad + | CReload + | CDoc + | CNop + | CHelp + | CNames + | CTestProp + deriving (Show, Eq, Typeable) + +------------------------------------------------------------ +-- REPL command info record +------------------------------------------------------------ + +-- | Data type to represent all the information about a single REPL +-- command. +data REPLCommand (c :: CmdTag) = REPLCommand + { -- | Name of the command + name :: String, + -- | Help text showing how to use the command, e.g. ":ann " + helpcmd :: String, + -- | Short free-form text explaining the command. + -- We could also consider adding long help text as well. + shortHelp :: String, + -- | Is the command for users or devs? + category :: REPLCommandCategory, + -- | Is it a built-in command or colon command? + cmdtype :: REPLCommandType, + -- | The action to execute, + -- given the input to the + -- command. + action :: REPLExpr c -> (forall r. Members DiscoEffects r => Sem r ()), + -- | Parser for the command argument(s). + parser :: Parser (REPLExpr c) + } + +-- | An existential wrapper around any REPL command info record. +data SomeREPLCommand where + SomeCmd :: Typeable c => REPLCommand c -> SomeREPLCommand + +------------------------------------------------------------ +-- REPL command lists +------------------------------------------------------------ + +type REPLCommands = [SomeREPLCommand] + +-- | Keep only commands of a certain type. +byCmdType :: REPLCommandType -> REPLCommands -> REPLCommands +byCmdType ty = P.filter (\(SomeCmd rc) -> cmdtype rc == ty) + +-- | Given a list of REPL commands and something typed at the REPL, +-- pick the first command with a matching type-level tag and run its +-- associated action. +dispatch :: Members DiscoEffects r => REPLCommands -> SomeREPLExpr -> Sem r () +dispatch [] _ = return () +dispatch (SomeCmd c : cs) r@(SomeREPL e) = case gcast e of + Just e' -> outputDiscoErrors $ action c e' + Nothing -> dispatch cs r + +-- | The list of all commands that can be used at the REPL. +-- Resolution of REPL commands searches this list /in order/, which +-- means ambiguous command prefixes (e.g. :t for :type) are resolved +-- to the first matching command. +discoCommands :: REPLCommands +discoCommands = + [ SomeCmd annCmd, + SomeCmd compileCmd, + SomeCmd desugarCmd, + SomeCmd docCmd, + SomeCmd evalCmd, + SomeCmd helpCmd, + SomeCmd loadCmd, + SomeCmd namesCmd, + SomeCmd nopCmd, + SomeCmd parseCmd, + SomeCmd prettyCmd, + SomeCmd reloadCmd, + SomeCmd showDefnCmd, + SomeCmd typeCheckCmd, + SomeCmd testPropCmd + ] + +------------------------------------------------------------ +-- Parsing +------------------------------------------------------------ + +builtinCommandParser :: REPLCommands -> Parser SomeREPLExpr +builtinCommandParser = + foldr ((<|>) . (\(SomeCmd rc) -> SomeREPL <$> try (parser rc))) empty + . byCmdType BuiltIn + +-- | Parse one of the colon commands in the given list of commands. +commandParser :: REPLCommands -> Parser SomeREPLExpr +commandParser allCommands = + (symbol ":" *> many C.lowerChar) >>= parseCommandArgs allCommands + +-- | Given a list of available commands and a string seen after a +-- colon, return a parser for its arguments. +parseCommandArgs :: REPLCommands -> String -> Parser SomeREPLExpr +parseCommandArgs allCommands cmd = maybe badCmd snd $ find ((cmd `isPrefixOf`) . fst) parsers + where + badCmd = fail $ "Command \":" ++ cmd ++ "\" is unrecognized." + + parsers = + map (\(SomeCmd rc) -> (name rc, SomeREPL <$> parser rc)) $ + byCmdType ColonCmd allCommands + +-- | Parse a file name. +fileParser :: Parser FilePath +fileParser = many C.spaceChar *> many (satisfy (not . isSpace)) + +-- | A parser for something entered at the REPL prompt. +lineParser :: REPLCommands -> Parser SomeREPLExpr +lineParser allCommands = + builtinCommandParser allCommands + <|> commandParser allCommands + +-- | Given a list of available REPL commands and the currently enabled +-- extensions, parse a string entered at the REPL prompt, returning +-- either a parse error message or a parsed REPL expression. +parseLine :: REPLCommands -> ExtSet -> String -> Either String SomeREPLExpr +parseLine allCommands exts s = + case runParser (withExts exts (lineParser allCommands)) "" s of + Left e -> Left $ errorBundlePretty e + Right l -> Right l + +-------------------------------------------------------------------------------- +-- The commands! +-------------------------------------------------------------------------------- + +------------------------------------------------------------ +-- :ann + +annCmd :: REPLCommand 'CAnn +annCmd = + REPLCommand + { name = "ann", + helpcmd = ":ann", + shortHelp = "Show type-annotated typechecked term", + category = Dev, + cmdtype = ColonCmd, + action = \x -> inputToState @TopInfo . handleAnn $ x, + parser = Ann <$> term + } + +handleAnn :: + Members '[Error DiscoError, Input TopInfo, Output Message] r => + REPLExpr 'CAnn -> + Sem r () +handleAnn (Ann t) = do + (at, _) <- typecheckTop $ inferTop t + infoPretty at + +------------------------------------------------------------ +-- :compile + +compileCmd :: REPLCommand 'CCompile +compileCmd = + REPLCommand + { name = "compile", + helpcmd = ":compile", + shortHelp = "Show a compiled term", + category = Dev, + cmdtype = ColonCmd, + action = \x -> inputToState @TopInfo . handleCompile $ x, + parser = Compile <$> term + } + +handleCompile :: + Members '[Error DiscoError, Input TopInfo, Output Message] r => + REPLExpr 'CCompile -> + Sem r () +handleCompile (Compile t) = do + (at, _) <- typecheckTop $ inferTop t + infoPretty . compileTerm $ at + +------------------------------------------------------------ +-- :desugar + +desugarCmd :: REPLCommand 'CDesugar +desugarCmd = + REPLCommand + { name = "desugar", + helpcmd = ":desugar", + shortHelp = "Show a desugared term", + category = Dev, + cmdtype = ColonCmd, + action = \x -> inputToState @TopInfo . handleDesugar $ x, + parser = Desugar <$> term + } + +handleDesugar :: + Members '[Error DiscoError, Input TopInfo, LFresh, Output Message] r => + REPLExpr 'CDesugar -> + Sem r () +handleDesugar (Desugar t) = do + (at, _) <- typecheckTop $ inferTop t + info $ pretty' . eraseDTerm . runDesugar . desugarTerm $ at + +------------------------------------------------------------ +-- :doc + +docCmd :: REPLCommand 'CDoc +docCmd = + REPLCommand + { name = "doc", + helpcmd = ":doc ", + shortHelp = "Show documentation", + category = User, + cmdtype = ColonCmd, + action = \x -> inputToState @TopInfo . handleDoc $ x, + parser = Doc <$> parseDoc + } + +parseDoc :: Parser (Either (Name Term) Prim) +parseDoc = + try (Left <$> (sc *> ident)) + <|> (Right <$> (parseNakedOpPrim "operator")) + +handleDoc :: + Members '[Error DiscoError, Input TopInfo, LFresh, Output Message] r => + REPLExpr 'CDoc -> + Sem r () +handleDoc (Doc (Left x)) = do + ctx <- inputs @TopInfo (view (replModInfo . miTys)) + tydefs <- inputs @TopInfo (view (replModInfo . miTydefs)) + docs <- inputs @TopInfo (view (replModInfo . miDocs)) + + debug $ text . show $ docs + + case (Ctx.lookupAll' x ctx, M.lookup (name2String x) tydefs) of + ([], Nothing) -> + -- Maybe the variable name entered by the user is actually a prim. + case toPrim (name2String x) of + (prim:_) -> handleDoc (Doc (Right prim)) + _ -> err $ "No documentation found for" <+> pretty' x <> "." + (binds, def) -> + mapM_ (showDoc docs) (map Left binds ++ map Right (maybeToList def)) + + where + showDoc docMap (Left (qn, ty)) = info $ + hsep [pretty' x, ":", pretty' ty] + $+$ + case Ctx.lookup' qn docMap of + Just (DocString ss : _) -> vcat (text "" : map text ss ++ [text ""]) + _ -> Pretty.empty + showDoc docMap (Right tdBody) = info $ + pretty' (name2String x, tdBody) + $+$ + case Ctx.lookupAll' x docMap of + ((_, DocString ss : _) : _) -> vcat (text "" : map text ss ++ [text ""]) + _ -> Pretty.empty +handleDoc (Doc (Right prim)) = do + handleTypeCheck (TypeCheck (TPrim prim)) + info $ vcat + [ case prim of + PrimUOp u -> describeAlts (f == Post) (f == Pre) syns + where + OpInfo (UOpF f _) syns _ = uopMap ! u + PrimBOp b -> describeAlts True True (opSyns $ bopMap ! b) + _ -> Pretty.empty + , case prim of + PrimUOp u -> describePrec (uPrec u) + PrimBOp b -> describePrec (bPrec b) <> describeFixity (assoc b) + _ -> Pretty.empty + ] + case (M.lookup prim primDoc, M.lookup prim primReference) of + (Nothing, Nothing) -> return () + (Nothing, Just p) -> info $ mkReference p + (Just d, mp) -> + info $ "" $+$ text d $+$ "" $+$ maybe Pretty.empty (\p -> mkReference p $+$ "") mp + where + describePrec p = "precedence level" <+> text (show p) + describeFixity In = Pretty.empty + describeFixity InL = ", left associative" + describeFixity InR = ", right associative" + describeAlts _ _ [] = Pretty.empty + describeAlts _ _ [_] = Pretty.empty + describeAlts pre post (_:alts) = "Alternative syntax:" <+> intercalate "," (map showOp alts) + where + showOp op = hcat + [ if pre then "~" else Pretty.empty + , text op + , if post then "~" else Pretty.empty] + + + mkReference p = + "https://disco-lang.readthedocs.io/en/latest/reference/" <> text p <> ".html" + +------------------------------------------------------------ +-- eval + +evalCmd :: REPLCommand 'CEval +evalCmd = REPLCommand + { name = "eval" + , helpcmd = "" + , shortHelp = "Evaluate a block of code" + , category = User + , cmdtype = BuiltIn + , action = \x -> handleEval x + , parser = Eval <$> wholeModule REPL + } + +handleEval + :: Members (Error DiscoError ': State TopInfo ': Output Message ': Embed IO ': EvalEffects) r + => REPLExpr 'CEval -> Sem r () +handleEval (Eval m) = do + mi <- inputToState @TopInfo $ loadParsedDiscoModule False FromCwdOrStdlib REPLModule m + addToREPLModule mi + forM_ (mi ^. miTerms) (mapError EvalErr . evalTerm . fst) + -- garbageCollect? + +evalTerm :: Members (Error EvalError ': State TopInfo ': Output Message ': EvalEffects) r => ATerm -> Sem r Value +evalTerm at = do + env <- use @TopInfo topEnv + v <- runInputConst env $ eval (compileTerm at) + + tydefs <- use @TopInfo (replModInfo . to allTydefs) + info $ runInputConst tydefs $ prettyValue' ty v + + modify @TopInfo $ + (replModInfo . miTys %~ Ctx.insert (QName (QualifiedName REPLModule) (string2Name "it")) (toPolyType ty)) . + (topEnv %~ Ctx.insert (QName (QualifiedName REPLModule) (string2Name "it")) v) + return v + where + ty = getType at + +------------------------------------------------------------ +-- :help + +helpCmd :: REPLCommand 'CHelp +helpCmd = + REPLCommand + { name = "help", + helpcmd = ":help", + shortHelp = "Show help", + category = User, + cmdtype = ColonCmd, + action = \x -> handleHelp x, + parser = return Help + } + +handleHelp :: Member (Output Message) r => REPLExpr 'CHelp -> Sem r () +handleHelp Help = + info $ + vcat + [ "Commands available from the prompt:" + , text "" + , vcat (map (\(SomeCmd c) -> showCmd c) $ sortedList discoCommands) + , text "" + ] + where + maxlen = longestCmd discoCommands + sortedList cmds = + sortBy (\(SomeCmd x) (SomeCmd y) -> compare (name x) (name y)) $ filteredCommands cmds + -- don't show dev-only commands by default + filteredCommands cmds = P.filter (\(SomeCmd c) -> category c == User) cmds + showCmd c = text (padRight (helpcmd c) maxlen ++ " " ++ shortHelp c) + longestCmd cmds = maximum $ map (\(SomeCmd c) -> length $ helpcmd c) cmds + padRight s maxsize = take maxsize (s ++ repeat ' ') + +------------------------------------------------------------ +-- :load + +loadCmd :: REPLCommand 'CLoad +loadCmd = + REPLCommand + { name = "load", + helpcmd = ":load ", + shortHelp = "Load a file", + category = User, + cmdtype = ColonCmd, + action = \x -> handleLoadWrapper x, + parser = Load <$> fileParser + } + +-- | Parses, typechecks, and loads a module by first recursively loading any imported +-- modules by calling loadDiscoModule. If no errors are thrown, any tests present +-- in the parent module are executed. +-- Disco.Interactive.CmdLine uses a version of this function that returns a Bool. +handleLoadWrapper :: + Members (Error DiscoError ': State TopInfo ': Output Message ': Embed IO ': EvalEffects) r => + REPLExpr 'CLoad -> + Sem r () +handleLoadWrapper (Load fp) = void (handleLoad fp) + +handleLoad :: + Members (Error DiscoError ': State TopInfo ': Output Message ': Embed IO ': EvalEffects) r => + FilePath -> + Sem r Bool +handleLoad fp = do + let (directory, modName) = splitFileName fp + + -- Reset top-level module map and context to empty, so we start + -- fresh and pick up any changes to imported modules etc. + modify @TopInfo $ topModMap .~ M.empty + modify @TopInfo $ topEnv .~ Ctx.emptyCtx + + -- Load the module. + m <- inputToState @TopInfo $ loadDiscoModule False (FromDir directory) modName + setREPLModule m + + -- Now run any tests + t <- inputToState $ runAllTests (m ^. miProps) + + -- Remember which was the most recently loaded file, so we can :reload + modify @TopInfo (lastFile ?~ fp) + info "Loaded." + return t + +-- XXX Return a structured summary of the results, not a Bool; +-- separate out results generation and pretty-printing, & move this +-- somewhere else. +runAllTests :: Members (Output Message ': Input TopInfo ': EvalEffects) r => Ctx ATerm [AProperty] -> Sem r Bool -- (Ctx ATerm [TestResult]) +runAllTests aprops + | Ctx.null aprops = return True + | otherwise = do + info "Running tests..." + and <$> mapM (uncurry runTests) (Ctx.assocs aprops) + + where + numSamples :: Int + numSamples = 50 -- XXX make this configurable somehow + + runTests :: Members (Output Message ': Input TopInfo ': EvalEffects) r => QName ATerm -> [AProperty] -> Sem r Bool + runTests (QName _ n) props = do + results <- inputTopEnv $ traverse (sequenceA . (id &&& runTest numSamples)) props + let failures = P.filter (not . testIsOk . snd) results + hdr = pretty' n <> ":" + + case P.null failures of + True -> info $ nest 2 $ hdr <+> "OK" + False -> do + tydefs <- inputs @TopInfo (view (replModInfo . to allTydefs)) + let prettyFailures = + runInputConst tydefs . runReader initPA . runLFresh $ + bulletList "-" $ map (uncurry prettyTestFailure) failures + info $ nest 2 $ hdr $+$ prettyFailures + return (P.null failures) + +------------------------------------------------------------ +-- :names + +namesCmd :: REPLCommand 'CNames +namesCmd = + REPLCommand + { name = "names", + helpcmd = ":names", + shortHelp = "Show all names in current scope", + category = User, + cmdtype = ColonCmd, + action = \x -> inputToState . handleNames $ x, + parser = return Names + } + +-- | Show names and types for each item in the top-level context. +handleNames :: + Members '[Input TopInfo, LFresh, Output Message] r => + REPLExpr 'CNames -> + Sem r () +handleNames Names = do + tyDef <- inputs @TopInfo (view (replModInfo . miTydefs)) + ctx <- inputs @TopInfo (view (replModInfo . miTys)) + info $ + vcat (map pretty' (M.assocs tyDef)) + $+$ + vcat (map showFn (Ctx.assocs ctx)) + where + showFn (QName _ x, ty) = hsep [pretty' x, text ":", pretty' ty] + +------------------------------------------------------------ +-- nop + +nopCmd :: REPLCommand 'CNop +nopCmd = + REPLCommand + { name = "nop", + helpcmd = "", + shortHelp = "No-op, e.g. if the user just enters a comment", + category = Dev, + cmdtype = BuiltIn, + action = \x -> handleNop x, + parser = Nop <$ (sc <* eof) + } + +handleNop :: REPLExpr 'CNop -> Sem r () +handleNop Nop = pure () + +------------------------------------------------------------ +-- :parse + +parseCmd :: REPLCommand 'CParse +parseCmd = + REPLCommand + { name = "parse", + helpcmd = ":parse ", + shortHelp = "Show the parsed AST", + category = Dev, + cmdtype = ColonCmd, + action = \x -> handleParse x, + parser = Parse <$> term + } + +handleParse :: Member (Output Message) r => REPLExpr 'CParse -> Sem r () +handleParse (Parse t) = info (text (show t)) + +------------------------------------------------------------ +-- :pretty + +prettyCmd :: REPLCommand 'CPretty +prettyCmd = + REPLCommand + { name = "pretty", + helpcmd = ":pretty ", + shortHelp = "Pretty-print a term", + category = Dev, + cmdtype = ColonCmd, + action = \x -> handlePretty x, + parser = Pretty <$> term + } + +handlePretty :: Members '[LFresh, Output Message] r => REPLExpr 'CPretty -> Sem r () +handlePretty (Pretty t) = info $ pretty' t + +------------------------------------------------------------ +-- :reload + +reloadCmd :: REPLCommand 'CReload +reloadCmd = + REPLCommand + { name = "reload", + helpcmd = ":reload", + shortHelp = "Reloads the most recently loaded file", + category = User, + cmdtype = ColonCmd, + action = \x -> handleReload x, + parser = return Reload + } + +handleReload :: + Members (Error DiscoError ': State TopInfo ': Output Message ': Embed IO ': EvalEffects) r => + REPLExpr 'CReload -> + Sem r () +handleReload Reload = do + file <- use lastFile + case file of + Nothing -> info "No file to reload." + Just f -> void (handleLoad f) + +------------------------------------------------------------ +-- :defn + +showDefnCmd :: REPLCommand 'CShowDefn +showDefnCmd = + REPLCommand + { name = "defn", + helpcmd = ":defn ", + shortHelp = "Show a variable's definition", + category = User, + cmdtype = ColonCmd, + action = \x -> inputToState @TopInfo . handleShowDefn $ x, + parser = ShowDefn <$> (sc *> ident) + } + +handleShowDefn :: + Members '[Input TopInfo, LFresh, Output Message] r => + REPLExpr 'CShowDefn -> + Sem r () +handleShowDefn (ShowDefn x) = do + let name2s = name2String x + defns <- inputs @TopInfo (view (replModInfo . miTermdefs)) + tyDefns <- inputs @TopInfo (view (replModInfo . miTydefs)) + + let xdefs = Ctx.lookupAll' (coerce x) defns + mtydef = M.lookup name2s tyDefns + + info $ do + let ds = map (pretty' . snd) xdefs ++ maybe [] (pure . pretty' . (name2s,)) mtydef + case ds of + [] -> text "No definition for" <+> pretty' x + _ -> vcat ds + +------------------------------------------------------------ +-- :test + +testPropCmd :: REPLCommand 'CTestProp +testPropCmd = + REPLCommand + { name = "test", + helpcmd = ":test ", + shortHelp = "Test a property using random examples", + category = User, + cmdtype = ColonCmd, + action = \x -> handleTest x, + parser = TestProp <$> term + } + +handleTest :: + Members (Error DiscoError ': State TopInfo ': Output Message ': EvalEffects) r => + REPLExpr 'CTestProp -> + Sem r () +handleTest (TestProp t) = do + at <- inputToState . typecheckTop $ checkProperty t + tydefs <- use @TopInfo (replModInfo . to allTydefs) + inputToState . inputTopEnv $ do + r <- runTest 100 at -- XXX make configurable + info $ runInputConst tydefs . runReader initPA $ nest 2 $ "-" <+> prettyTestResult at r + +------------------------------------------------------------ +-- :type + +typeCheckCmd :: REPLCommand 'CTypeCheck +typeCheckCmd = + REPLCommand + { name = "type", + helpcmd = ":type ", + shortHelp = "Typecheck a term", + category = Dev, + cmdtype = ColonCmd, + action = \x -> inputToState @TopInfo . handleTypeCheck $ x, + parser = parseTypeCheck + } + +handleTypeCheck :: + Members '[Error DiscoError, Input TopInfo, LFresh, Output Message] r => + REPLExpr 'CTypeCheck -> + Sem r () +handleTypeCheck (TypeCheck t) = do + (_, sig) <- typecheckTop $ inferTop t + info $ pretty' t <+> text ":" <+> pretty' sig + +parseTypeCheck :: Parser (REPLExpr 'CTypeCheck) +parseTypeCheck = + TypeCheck + <$> ( (try term "expression") + <|> (parseNakedOp "operator") + ) + +-- In a :type or :doc command, allow naked operators, as in :type + , +-- even though + by itself is not a syntactically valid term. +-- However, this seems like it may be a common thing for a student to +-- ask and there is no reason we can't have this as a special case. +parseNakedOp :: Parser Term +parseNakedOp = TPrim <$> parseNakedOpPrim + +parseNakedOpPrim :: Parser Prim +parseNakedOpPrim = sc *> choice (map mkOpParser (concat opTable)) + where + mkOpParser :: OpInfo -> Parser Prim + mkOpParser (OpInfo (UOpF _ op) syns _) = choice (map ((PrimUOp op <$) . reservedOp) syns) + mkOpParser (OpInfo (BOpF _ op) syns _) = choice (map ((PrimBOp op <$) . reservedOp) syns) diff --git a/src/Disco/Interpret/CESK.hs b/src/Disco/Interpret/CESK.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Interpret/CESK.hs @@ -0,0 +1,790 @@ +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fmax-pmcheck-models=200 #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Interpret.CESK +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- CESK machine interpreter for Disco. +----------------------------------------------------------------------------- + +module Disco.Interpret.CESK + ( CESK, + runCESK, + step, + eval, + runTest, + ) +where + +import Text.Show.Pretty (ppShow) + +import Unbound.Generics.LocallyNameless (Bind, Name) + +import Algebra.Graph +import qualified Algebra.Graph.AdjacencyMap as AdjMap +import Control.Arrow ((***), (>>>)) +import Control.Monad ((>=>)) +import Data.Bifunctor (first, second) +import Data.List (find) +import qualified Data.Map as M +import Data.Maybe (isJust) +import Data.Ratio +import Disco.AST.Core +import Disco.AST.Generic (Ellipsis (..), Side (..), + selectSide) +import Disco.AST.Typed (AProperty) +import Disco.Compile +import Disco.Context as Ctx +import Disco.Enumerate +import Disco.Error +import Disco.Names +import Disco.Property +import Disco.Types hiding (V) +import Disco.Value +import Math.Combinatorics.Exact.Binomial (choose) +import Math.Combinatorics.Exact.Factorial (factorial) +import Math.NumberTheory.Primes (factorise, unPrime) +import Math.NumberTheory.Primes.Testing (isPrime) +import Math.OEIS (catalogNums, + extendSequence, + lookupSequence) + +import Disco.Effects.Fresh +import Disco.Effects.Input +import Disco.Effects.Random +import Polysemy +import Polysemy.Error +import Polysemy.State + +------------------------------------------------------------ +-- Utilities +------------------------------------------------------------ + +------------------------------------------------------------ +-- Frames and continuations +------------------------------------------------------------ + +-- The CESK machine carries a current continuation explaining what to +-- do with the value of the currently focused expression, once it has +-- been fully evaluated. + +-- | A continuation is just a stack of frames. +type Cont = [Frame] + +-- | A frame represents a single step of the context, explaining what +-- to do with a value in that context (ultimately transforming it +-- into another value, which may in turn be handed to the next frame +-- in the continuation stack, and so on). +-- +-- As an invariant, any 'Frame' containing unevaluated 'Core' +-- expressions must also carry an 'Env' in which to evaluate them. +data Frame + = -- | Inject the value into a sum type. + FInj Side + | -- | Do a case analysis on the value. + FCase Env (Bind (Name Core) Core) (Bind (Name Core) Core) + | -- | Evaluate the right-hand value of a pair once we have finished + -- evaluating the left-hand side. + FPairR Env Core + | -- | Put the value into the right-hand side of a pair together with + -- this previously evaluated left-hand side. + FPairL Value + | -- | Project one or the other side of a pair. + FProj Side + | -- | Evaluate the argument of an application once we have finished + -- evaluating the function. + FArg Env Core + | -- | Apply an evaluated function to this already-evaluated argument. + FArgV Value + | -- | Apply a previously evaluated function to the value. + FApp Value + | -- | Force evaluation of the contents of a memory cell. + FForce + | -- | Update the contents of a memory cell with its evaluation. + FUpdate Int + | -- | Record the results of a test. + FTest TestVars Env + deriving (Show) + +------------------------------------------------------------ +-- The CESK machine +------------------------------------------------------------ + +-- | The CESK machine has two basic kinds of states. +data CESK + = -- | The 'In' constructor represents the state when we are recursing + -- "into" a term. There is a currently focused expression which + -- is to be evaluated in the given context. Generally, evaluation + -- proceeds by pattern-matching on the focused expression and + -- either immediately turning it into a value (if it is simple), + -- or focusing on a subexpression and pushing a new frame on the + -- continuation stack indicating how to continue evaluating the + -- whole expression once finished with the subexpression. + In Core Env Cont + | -- | The 'Out' constructor represents the state when we have + -- completed evaluating an expression and are now on our way back + -- "out" of the recursion. Generally, evaluation proceeds by + -- pattern-matching on the top frame of the continuation stack + -- (and sometimes on the value as well), to see what is to be done + -- with the value. + Out Value Cont + | -- | There is also an 'Up' constructor representing an exception + -- that is propagating up the continuation stack. Disco does + -- not have user-level exceptions or try/catch blocks etc., but + -- exceptions may be caught by test frames and turned into a + -- test result rather than crashing the entire computation. + Up EvalError Cont + deriving (Show) + +-- | Is the CESK machine in a final state? +isFinal :: CESK -> Maybe (Either EvalError Value) +isFinal (Up e []) = Just (Left e) +isFinal (Out v []) = Just (Right v) +isFinal _ = Nothing + +-- | Run a CESK machine to completion. +runCESK :: Members '[Fresh, Random, State Mem] r => CESK -> Sem r (Either EvalError Value) +runCESK cesk = case isFinal cesk of + Just res -> return res + Nothing -> step cesk >>= runCESK + +(!!!) :: (Show a, Show b) => Ctx a b -> QName a -> b +ctx !!! x = case Ctx.lookup' x ctx of + Nothing -> error $ "variable " ++ show x ++ " not found in environment\n" + ++ ppShow (Ctx.keysSet ctx) + Just v -> v + +-- | Advance the CESK machine by one step. +step :: Members '[Fresh, Random, State Mem] r => CESK -> Sem r CESK +step cesk = case cesk of + (In (CVar x) e k) -> return $ Out (e !!! x) k + (In (CNum d r) _ k) -> return $ Out (VNum d r) k + (In (CConst OMatchErr) _ k) -> return $ Up NonExhaustive k + (In (CConst OEmptyGraph) _ k) -> return $ Out (VGraph empty) k + (In (CConst op) _ k) -> return $ Out (VConst op) k + (In (CInj s c) e k) -> return $ In c e (FInj s : k) + (In (CCase c b1 b2) e k) -> return $ In c e (FCase e b1 b2 : k) + (In CUnit _ k) -> return $ Out VUnit k + (In (CPair c1 c2) e k) -> return $ In c1 e (FPairR e c2 : k) + (In (CProj s c) e k) -> return $ In c e (FProj s : k) + (In (CAbs b) e k) -> do + (xs, body) <- unbind b + return $ Out (VClo e xs body) k + (In (CApp c1 c2) e k) -> return $ In c1 e (FArg e c2 : k) + (In (CType ty) _ k) -> return $ Out (VType ty) k + (In (CDelay b) e k) -> do + (xs, cs) <- unbind b + locs <- allocateRec e (zip (map localName xs) cs) + return $ Out (foldr (VPair . VRef) VUnit locs) k + (In (CForce c) e k) -> return $ In c e (FForce : k) + (In (CTest vars c) e k) -> return $ In c e (FTest (TestVars vars) e : k) + + (Out v (FInj s : k)) -> return $ Out (VInj s v) k + (Out (VInj L v) (FCase e b1 _ : k)) -> do + (x, c1) <- unbind b1 + return $ In c1 (Ctx.insert (localName x) v e) k + (Out (VInj R v) (FCase e _ b2 : k)) -> do + (x, c2) <- unbind b2 + return $ In c2 (Ctx.insert (localName x) v e) k + (Out v1 (FPairR e c2 : k)) -> return $ In c2 e (FPairL v1 : k) + (Out v2 (FPairL v1 : k)) -> return $ Out (VPair v1 v2) k + (Out (VPair v1 v2) (FProj s : k)) -> return $ Out (selectSide s v1 v2) k + (Out v (FArg e c2 : k)) -> return $ In c2 e (FApp v : k) + (Out v2 (FApp (VClo e [x] b) : k)) -> return $ In b (Ctx.insert (localName x) v2 e) k + (Out v2 (FApp (VClo e (x : xs) b) : k)) -> return $ Out (VClo (Ctx.insert (localName x) v2 e) xs b) k + (Out v2 (FApp (VConst op) : k)) -> appConst k op v2 + (Out v2 (FApp (VFun f) : k)) -> return $ Out (f v2) k + -- Annoying to repeat this code, not sure of a better way. + -- The usual evaluation order (function then argument) doesn't work when + -- we're applying a test function to randomly generated values. + (Out (VClo e [x] b) (FArgV v : k)) -> return $ In b (Ctx.insert (localName x) v e) k + (Out (VClo e (x : xs) b) (FArgV v : k)) -> return $ Out (VClo (Ctx.insert (localName x) v e) xs b) k + (Out (VConst op) (FArgV v : k)) -> appConst k op v + (Out (VFun f) (FArgV v : k)) -> return $ Out (f v) k + + (Out (VRef n) (FForce : k)) -> do + cell <- lkup n + case cell of + Nothing -> error $ "impossible: location " ++ show n ++ " not found in memory" + Just (V v) -> return $ Out v k + Just (E e t) -> do + set n Blackhole + return $ In t e (FUpdate n : k) + Just Blackhole -> return $ Up InfiniteLoop k + (Out v (FUpdate n : k)) -> do + set n (V v) + return $ Out v k + + (Up err (f@FTest{} : k)) -> + return $ Out (VProp (VPDone (TestResult False (TestRuntimeError err) emptyTestEnv))) (f : k) + (Up err (_ : ks)) -> return $ Up err ks + + (Out v (FTest vs e : k)) -> do + let result = ensureProp v + res = getTestEnv vs e + case res of + Left err -> return $ Up err k + Right e' -> return $ Out (VProp $ extendPropEnv e' result) k + + _ -> error "Impossible! Bad CESK machine state" + +------------------------------------------------------------ +-- Interpreting constants +------------------------------------------------------------ + +arity2 :: (Value -> Value -> a) -> Value -> a +arity2 f (VPair x y) = f x y +arity2 _f _v = error "arity2 on a non-pair!" + +arity3 :: (Value -> Value -> Value -> a) -> Value -> a +arity3 f (VPair x (VPair y z)) = f x y z +arity3 _f _v = error "arity3 on a non-triple!" + +appConst + :: Members '[Random, State Mem] r + => Cont -> Op -> Value -> Sem r CESK +appConst k = \case + -------------------------------------------------- + -- Basics + + OCrash -> up . Crash . vlist vchar + OId -> out + -------------------------------------------------- + -- Arithmetic + + OAdd -> numOp2 (+) >=> out + ONeg -> numOp1 negate >=> out + OSqrt -> numOp1 integerSqrt >=> out + OFloor -> numOp1 ((% 1) . floor) >=> out + OCeil -> numOp1 ((% 1) . ceiling) >=> out + OAbs -> numOp1 abs >=> out + OMul -> numOp2 (*) >=> out + ODiv -> numOp2' divOp >>> outWithErr + where + divOp :: Member (Error EvalError) r => Rational -> Rational -> Sem r Value + divOp _ 0 = throw DivByZero + divOp m n = return $ ratv (m / n) + OExp -> numOp2 (\m n -> m ^^ numerator n) >=> out + OMod -> numOp2' modOp >>> outWithErr + where + modOp :: Member (Error EvalError) r => Rational -> Rational -> Sem r Value + modOp m n + | n == 0 = throw DivByZero + | otherwise = return $ intv (numerator m `mod` numerator n) + ODivides -> numOp2' (\m n -> return (enumv $ divides m n)) >=> out + where + divides 0 0 = True + divides 0 _ = False + divides x y = denominator (y / x) == 1 + + -------------------------------------------------- + -- Number theory + + OIsPrime -> intOp1 (enumv . isPrime) >=> out + OFactor -> intOp1' primFactor >>> outWithErr + where + -- Semantics of the @$factor@ prim: turn a natural number into its + -- bag of prime factors. Crash if called on 0, which does not have + -- a prime factorization. + primFactor :: Member (Error EvalError) r => Integer -> Sem r Value + primFactor 0 = throw (Crash "0 has no prime factorization!") + primFactor n = return . VBag $ map ((intv . unPrime) *** fromIntegral) (factorise n) + OFrac -> numOp1' (return . primFrac) >=> out + where + -- Semantics of the @$frac@ prim: turn a rational number into a pair + -- of its numerator and denominator. + primFrac :: Rational -> Value + primFrac r = VPair (intv (numerator r)) (intv (denominator r)) + + -------------------------------------------------- + -- Combinatorics + + OMultinom -> arity2 multinomOp >=> out + where + multinomOp :: Value -> Value -> Sem r Value + multinomOp (vint -> n0) (vlist vint -> ks0) = return . intv $ multinomial n0 ks0 + where + multinomial :: Integer -> [Integer] -> Integer + multinomial _ [] = 1 + multinomial n (k' : ks) + | k' > n = 0 + | otherwise = choose n k' * multinomial (n - k') ks + OFact -> numOp1' factOp >>> outWithErr + where + factOp :: Member (Error EvalError) r => Rational -> Sem r Value + factOp (numerator -> n) + | n > fromIntegral (maxBound :: Int) = throw Overflow + | otherwise = return . intv $ factorial (fromIntegral n) + OEnum -> out . enumOp + where + enumOp :: Value -> Value + enumOp (VType ty) = listv id (enumerateType ty) + enumOp v = error $ "Impossible! enumOp on non-type " ++ show v + OCount -> out . countOp + where + countOp :: Value -> Value + countOp (VType ty) = case countType ty of + Just num -> VInj R (intv num) + Nothing -> VNil + countOp v = error $ "Impossible! countOp on non-type " ++ show v + + -------------------------------------------------- + -- Sequences + + OUntil -> arity2 $ \v1 -> out . ellipsis (Until v1) + OLookupSeq -> out . oeisLookup + OExtendSeq -> out . oeisExtend + -------------------------------------------------- + -- Comparison + + OEq -> arity2 $ \v1 v2 -> out $ enumv (valEq v1 v2) + OLt -> arity2 $ \v1 v2 -> out $ enumv (valLt v1 v2) + -------------------------------------------------- + -- Container operations + + OSize -> withBag OSize $ out . intv . sum . map snd + OPower -> withBag OPower $ out . VBag . sortNCount . map (first VBag) . choices + where + choices :: [(Value, Integer)] -> [([(Value, Integer)], Integer)] + choices [] = [([], 1)] + choices ((x, n) : xs) = xs' ++ concatMap (\k' -> map (cons n (x, k')) xs') [1 .. n] + where + xs' = choices xs + cons n (x, k') (zs, m) = ((x, k') : zs, choose n k' * m) + OBagElem -> arity2 $ \x -> withBag OBagElem $ + out . enumv . isJust . find (valEq x) . map fst + OListElem -> arity2 $ \x -> out . enumv . isJust . find (valEq x) . vlist id + + OEachSet -> arity2 $ \f -> withBag OEachSet $ + outWithErr . fmap (VBag . countValues) . mapM (evalApp f . (:[]) . fst) + + OEachBag -> arity2 $ \f -> withBag OEachBag $ + outWithErr . fmap (VBag . sortNCount) . mapM (\(x,n) -> (,n) <$> evalApp f [x]) + + OFilterBag -> arity2 $ \f -> withBag OFilterBag $ \xs -> + outWithErr $ do + bs <- mapM (evalApp f . (:[]) . fst) xs + return . VBag . map snd . Prelude.filter (isTrue . fst) $ zip bs xs + where + isTrue (VInj R VUnit) = True + isTrue _ = False + + OMerge -> arity3 $ \f bxs bys -> + case (bxs, bys) of + (VBag xs, VBag ys) -> outWithErr (VBag <$> mergeM f xs ys) + (VBag _, _) -> error $ "Impossible! OMerge on non-VBag " ++ show bys + _ -> error $ "Impossible! OMerge on non-VBag " ++ show bxs + + OBagUnions -> withBag OBagUnions $ \cts -> + out . VBag $ sortNCount [(x, m*n) | (VBag xs, n) <- cts, (x,m) <- xs] + + -------------------------------------------------- + -- Container conversions + + OBagToSet -> withBag OBagToSet $ out . VBag . (map . second) (const 1) + OSetToList -> withBag OSetToList $ out . listv id . map fst + OBagToList -> withBag OBagToList $ out . listv id . concatMap (uncurry (flip (replicate . fromIntegral))) + OListToSet -> out . VBag . (map . fmap) (const 1) . countValues . vlist id + OListToBag -> out . VBag . countValues . vlist id + OBagToCounts -> withBag OBagToCounts $ out . VBag . map ((,1) . pairv id intv) + -- Bag (a, N) -> Bag a + -- Notionally this takes a set of pairs instead of a bag, but operationally we need to + -- be prepared for a bag, because of the way literal bags desugar, e.g. + -- + -- Disco> :desugar let x = 3 in ⟅ 'a' # (2 + x), 'b', 'b' ⟆ + -- (λx. bagFromCounts(bag(('a', 2 + x) :: ('b', 1) :: ('b', 1) :: [])))(3) + + OCountsToBag -> withBag OCountsToBag $ + out . VBag . sortNCount . map (second (uncurry (*)) . assoc . first (vpair id vint)) + where + assoc ((a, b), c) = (a, (b, c)) + + -------------------------------------------------- + -- Maps + + OMapToSet -> withMap OMapToSet $ + out . VBag . map (\(k',v) -> (VPair (fromSimpleValue k') v, 1)) . M.assocs + + OSetToMap -> withBag OSetToMap $ + out . VMap . M.fromList . map (convertAssoc . fst) + where + convertAssoc (VPair k' v) = (toSimpleValue k', v) + convertAssoc v = error $ "Impossible! convertAssoc on non-VPair " ++ show v + + OInsert -> arity3 $ \k' v -> withMap OInsert $ + out . VMap . M.insert (toSimpleValue k') v + + OLookup -> arity2 $ \k' -> withMap OLookup $ + out . toMaybe . M.lookup (toSimpleValue k') + where + toMaybe = maybe (VInj L VUnit) (VInj R) + + -------------------------------------------------- + -- Graph operations + + OVertex -> out . VGraph . Vertex . toSimpleValue + OOverlay -> arity2 $ withGraph2 OOverlay $ \g1 g2 -> + out $ VGraph (Overlay g1 g2) + OConnect -> arity2 $ withGraph2 OConnect $ \g1 g2 -> + out $ VGraph (Connect g1 g2) + OSummary -> withGraph OSummary $ out . graphSummary + + -------------------------------------------------- + -- Propositions + + OForall tys -> out . (\v -> VProp (VPSearch SMForall tys v emptyTestEnv )) + OExists tys -> out . (\v -> VProp (VPSearch SMExists tys v emptyTestEnv )) + OHolds -> testProperty Exhaustive >=> resultToBool >>> outWithErr + ONotProp -> out . VProp . notProp . ensureProp + OShouldEq ty -> arity2 $ \v1 v2 -> + out $ VProp (VPDone (TestResult (valEq v1 v2) (TestEqual ty v1 v2) emptyTestEnv)) + + c -> error $ "Unimplemented: appConst " ++ show c + where + outWithErr :: Sem (Error EvalError ': r) Value -> Sem r CESK + outWithErr m = either (`Up` k) (`Out` k) <$> runError m + out v = return $ Out v k + up e = return $ Up e k + + withBag :: Op -> ([(Value,Integer)] -> Sem r a) -> Value -> Sem r a + withBag op f = \case + VBag xs -> f xs + v -> error $ "Impossible! " ++ show op ++ " on non-VBag " ++ show v + + withMap :: Op -> (M.Map SimpleValue Value -> Sem r a) -> Value -> Sem r a + withMap op f = \case + VMap m -> f m + v -> error $ "Impossible! " ++ show op ++ " on non-VMap " ++ show v + + withGraph :: Op -> (Graph SimpleValue -> Sem r a) -> Value -> Sem r a + withGraph op f = \case + VGraph g -> f g + v -> error $ "Impossible! " ++ show op ++ " on non-VGraph " ++ show v + + withGraph2 :: Op -> (Graph SimpleValue -> Graph SimpleValue -> Sem r a) -> Value -> Value -> Sem r a + withGraph2 op f v1 v2 = case (v1, v2) of + (VGraph g1, VGraph g2) -> f g1 g2 + (_, VGraph _) -> error $ "Impossible! " ++ show op ++ " on non-VGraph " ++ show v1 + _ -> error $ "Impossible! " ++ show op ++ " on non-VGraph " ++ show v2 + +-------------------------------------------------- +-- Arithmetic + +intOp1 :: (Integer -> Value) -> Value -> Sem r Value +intOp1 f = intOp1' (return . f) + +intOp1' :: (Integer -> Sem r Value) -> Value -> Sem r Value +intOp1' f = f . vint + +numOp1 :: (Rational -> Rational) -> Value -> Sem r Value +numOp1 f = numOp1' $ return . ratv . f + +numOp1' :: (Rational -> Sem r Value) -> Value -> Sem r Value +numOp1' f (VNum _ m) = f m +numOp1' _ v = error $ "Impossible! numOp1' on non-VNum " ++ show v + +numOp2 :: (Rational -> Rational -> Rational) -> Value -> Sem r Value +numOp2 (#) = numOp2' $ \m n -> return (ratv (m # n)) + +numOp2' :: (Rational -> Rational -> Sem r Value) -> Value -> Sem r Value +numOp2' (#) = + arity2 $ \v1 v2 -> case (v1, v2) of + (VNum d1 n1, VNum d2 n2) -> do + res <- n1 # n2 + case res of + VNum _ r -> return $ VNum (d1 <> d2) r + _ -> return res + (VNum{}, _) -> error $ "Impossible! numOp2' on non-VNum " ++ show v2 + _ -> error $ "Impossible! numOp2' on non-VNum " ++ show v1 + +-- | Perform a square root operation. If the program typechecks, +-- then the argument and output will really be Natural. +integerSqrt :: Rational -> Rational +integerSqrt n = integerSqrt' (numerator n) % 1 + +-- | implementation of `integerSqrt'` taken from the Haskell wiki: +-- https://wiki.haskell.org/Generic_number_type#squareRoot +integerSqrt' :: Integer -> Integer +integerSqrt' 0 = 0 +integerSqrt' 1 = 1 +integerSqrt' n = + let twopows = iterate (^! 2) 2 + (lowerRoot, lowerN) = + last $ takeWhile ((n >=) . snd) $ zip (1 : twopows) twopows + newtonStep x = div (x + div n x) 2 + iters = iterate newtonStep (integerSqrt' (div n lowerN) * lowerRoot) + isRoot r = r ^! 2 <= n && n < (r + 1) ^! 2 + in head $ dropWhile (not . isRoot) iters + +-- this operator is used for `integerSqrt'` +(^!) :: Num a => a -> Int -> a +(^!) x n = x ^ n + +------------------------------------------------------------ +-- Comparison +------------------------------------------------------------ + +valEq :: Value -> Value -> Bool +valEq v1 v2 = valCmp v1 v2 == EQ + +valLt :: Value -> Value -> Bool +valLt v1 v2 = valCmp v1 v2 == LT + +valCmp :: Value -> Value -> Ordering +valCmp (VNum _ r1) (VNum _ r2) = compare r1 r2 +valCmp (VInj L _) (VInj R _) = LT +valCmp (VInj R _) (VInj L _) = GT +valCmp (VInj L v1) (VInj L v2) = valCmp v1 v2 +valCmp (VInj R v1) (VInj R v2) = valCmp v1 v2 +valCmp VUnit VUnit = EQ +valCmp (VPair v11 v12) (VPair v21 v22) = valCmp v11 v21 <> valCmp v12 v22 +valCmp (VType ty1) (VType ty2) = compare ty1 ty2 +valCmp (VBag cs1) (VBag cs2) = compareBags cs1 cs2 +valCmp (VMap m1) (VMap m2) = compareMaps (M.assocs m1) (M.assocs m2) +valCmp (VGraph g1) (VGraph g2) = valCmp (graphSummary g1) (graphSummary g2) +valCmp v1 v2 = error $ "valCmp " ++ show v1 ++ " " ++ show v2 + +compareBags :: [(Value, Integer)] -> [(Value, Integer)] -> Ordering +compareBags [] [] = EQ +compareBags [] _ = LT +compareBags _ [] = GT +compareBags ((x, xn) : xs) ((y, yn) : ys) + = valCmp x y <> compare xn yn <> compareBags xs ys + +compareMaps :: [(SimpleValue, Value)] -> [(SimpleValue, Value)] -> Ordering +compareMaps [] [] = EQ +compareMaps [] _ = LT +compareMaps _ [] = GT +compareMaps ((k1, v1) : as1) ((k2, v2) : as2) + = valCmp (fromSimpleValue k1) (fromSimpleValue k2) <> valCmp v1 v2 <> compareMaps as1 as2 + +------------------------------------------------------------ +-- Polynomial sequences [a,b,c,d .. e] +------------------------------------------------------------ + +ellipsis :: Ellipsis Value -> Value -> Value +ellipsis (fmap vrat -> end) (vlist vrat -> rs) = listv ratv $ enumEllipsis rs end + +enumEllipsis :: (Enum a, Num a, Ord a) => [a] -> Ellipsis a -> [a] +enumEllipsis [] _ = error "Impossible! Disco.Interpret.CESK.enumEllipsis []" +enumEllipsis [x] (Until y) + | x <= y = [x .. y] + | otherwise = [x, pred x .. y] +enumEllipsis xs (Until y) + | d > 0 = takeWhile (<= y) nums + | d < 0 = takeWhile (>= y) nums + | otherwise = nums + where + d = constdiff xs + nums = babbage xs + +-- | Extend a sequence infinitely by interpolating it as a polynomial +-- sequence, via forward differences. Essentially the same +-- algorithm used by Babbage's famous Difference Engine. +babbage :: Num a => [a] -> [a] +babbage [] = [] +babbage [x] = repeat x +babbage (x : xs) = scanl (+) x (babbage (diff (x : xs))) + +-- | Compute the forward difference of the given sequence, that is, +-- differences of consecutive pairs of elements. +diff :: Num a => [a] -> [a] +diff xs = zipWith (-) (tail xs) xs + +-- | Take forward differences until the result is constant, and return +-- the constant. The sign of the constant difference tells us the +-- limiting behavior of the sequence. +constdiff :: (Eq a, Num a) => [a] -> a +constdiff [] = error "Impossible! Disco.Interpret.Core.constdiff []" +constdiff (x : xs) + | all (== x) xs = x + | otherwise = constdiff (diff (x : xs)) + +------------------------------------------------------------ +-- OEIS +------------------------------------------------------------ + +-- | Looks up a sequence of integers in OEIS. +-- Returns 'left()' if the sequence is unknown in OEIS, +-- otherwise 'right "https://oeis.org/"' +oeisLookup :: Value -> Value +oeisLookup (vlist vint -> ns) = maybe VNil parseResult (lookupSequence ns) + where + parseResult r = VInj R (listv charv ("https://oeis.org/" ++ seqNum r)) + seqNum = getCatalogNum . catalogNums + + getCatalogNum [] = error "No catalog info" + getCatalogNum (n : _) = n + +-- | Extends a Disco integer list with data from a known OEIS +-- sequence. Returns a list of integers upon success, otherwise the +-- original list (unmodified). +oeisExtend :: Value -> Value +oeisExtend = listv intv . extendSequence . vlist vint + +------------------------------------------------------------ +-- Normalizing bags/sets +------------------------------------------------------------ + +-- | Given a list of disco values, sort and collate them into a list +-- pairing each unique value with its count. Used to +-- construct/normalize bags and sets. Prerequisite: the values must +-- be comparable. +countValues :: [Value] -> [(Value, Integer)] +countValues = sortNCount . map (,1) + +-- | Normalize a list of values where each value is paired with a +-- count, but there could be duplicate values. This function uses +-- merge sort to sort the values, adding the counts of multiple +-- instances of the same value. Prerequisite: the values must be +-- comparable. +sortNCount :: [(Value, Integer)] -> [(Value, Integer)] +sortNCount [] = [] +sortNCount [x] = [x] +sortNCount xs = merge (+) (sortNCount firstHalf) (sortNCount secondHalf) + where + (firstHalf, secondHalf) = splitAt (length xs `div` 2) xs + +-- | Generic function for merging two sorted, count-annotated lists of +-- type @[(a,Integer)]@ a la merge sort, using the given comparison +-- function, and using the provided count combining function to +-- decide what count to assign to each element of the output. For +-- example, @(+)@ corresponds to bag union; @min@ corresponds to +-- intersection; and so on. +merge :: + (Integer -> Integer -> Integer) -> + [(Value, Integer)] -> + [(Value, Integer)] -> + [(Value, Integer)] +merge g = go + where + go [] [] = [] + go [] ((y, n) : ys) = mergeCons y 0 n (go [] ys) + go ((x, n) : xs) [] = mergeCons x n 0 (go xs []) + go ((x, n1) : xs) ((y, n2) : ys) = case valCmp x y of + LT -> mergeCons x n1 0 (go xs ((y, n2) : ys)) + EQ -> mergeCons x n1 n2 (go xs ys) + GT -> mergeCons y 0 n2 (go ((x, n1) : xs) ys) + + mergeCons a m1 m2 zs = case g m1 m2 of + 0 -> zs + n -> (a, n) : zs + +mergeM :: + Members '[Random, Error EvalError, State Mem] r => + Value -> + [(Value, Integer)] -> + [(Value, Integer)] -> + Sem r [(Value, Integer)] +mergeM g = go + where + go [] [] = return [] + go [] ((y, n) : ys) = mergeCons y 0 n =<< go [] ys + go ((x, n) : xs) [] = mergeCons x n 0 =<< go xs [] + go ((x, n1) : xs) ((y, n2) : ys) = case valCmp x y of + LT -> mergeCons x n1 0 =<< go xs ((y, n2) : ys) + EQ -> mergeCons x n1 n2 =<< go xs ys + GT -> mergeCons y 0 n2 =<< go ((x, n1) : xs) ys + + mergeCons a m1 m2 zs = do + nm <- evalApp g [VPair (intv m1) (intv m2)] + return $ case nm of + VNum _ 0 -> zs + VNum _ n -> (a, numerator n) : zs + v -> error $ "Impossible! merge function in mergeM returned non-VNum " ++ show v + +------------------------------------------------------------ +-- Graphs +------------------------------------------------------------ + +graphSummary :: Graph SimpleValue -> Value +graphSummary = toDiscoAdjMap . reifyGraph + where + reifyGraph :: Graph SimpleValue -> [(SimpleValue, [SimpleValue])] + reifyGraph = + AdjMap.adjacencyList . foldg AdjMap.empty AdjMap.vertex AdjMap.overlay AdjMap.connect + + toDiscoAdjMap :: [(SimpleValue, [SimpleValue])] -> Value + toDiscoAdjMap = + VMap . M.fromList . map (second (VBag . countValues . map fromSimpleValue)) + +------------------------------------------------------------ +-- Propositions / tests +------------------------------------------------------------ + +resultToBool :: Member (Error EvalError) r => TestResult -> Sem r Value +resultToBool (TestResult _ (TestRuntimeError e) _) = throw e +resultToBool (TestResult b _ _) = return $ enumv b + +notProp :: ValProp -> ValProp +notProp (VPDone r) = VPDone (invertPropResult r) +notProp (VPSearch sm tys p e) = VPSearch (invertMotive sm) tys p e + +-- | Convert a @Value@ to a @ValProp@, embedding booleans if necessary. +ensureProp :: Value -> ValProp +ensureProp (VProp p) = p +ensureProp (VInj L _) = VPDone (TestResult False TestBool emptyTestEnv) +ensureProp (VInj R _) = VPDone (TestResult True TestBool emptyTestEnv) +ensureProp _ = error "ensureProp: non-prop value" + +testProperty + :: Members '[Random, State Mem] r + => SearchType -> Value -> Sem r TestResult +testProperty initialSt = checkProp . ensureProp + where + checkProp + :: Members '[Random, State Mem] r + => ValProp -> Sem r TestResult + checkProp (VPDone r) = return r + checkProp (VPSearch sm tys f e) = + extendResultEnv e <$> (generateSamples initialSt vals >>= go) + where + vals = enumTypes tys + (SearchMotive (whenFound, wantsSuccess)) = sm + + go + :: Members '[Random, State Mem] r + => ([[Value]], SearchType) -> Sem r TestResult + go ([], st) = return $ TestResult (not whenFound) (TestNotFound st) emptyTestEnv + go (x:xs, st) = do + mprop <- runError (ensureProp <$> evalApp f x) + case mprop of + Left err -> return $ TestResult False (TestRuntimeError err) emptyTestEnv + Right (VPDone r) -> continue st xs r + Right prop -> checkProp prop >>= continue st xs + + continue + :: Members '[Random, State Mem] r + => SearchType -> [[Value]] -> TestResult -> Sem r TestResult + continue st xs r@(TestResult _ _ e') + | testIsError r = return r + | testIsOk r == wantsSuccess = + return $ TestResult whenFound (TestFound r) e' + | otherwise = go (xs, st) + +evalApp + :: Members '[Random, Error EvalError, State Mem] r + => Value -> [Value] -> Sem r Value +evalApp f xs = + runFresh (runCESK (Out f (map FArgV xs))) >>= either throw return + +runTest + :: Members '[Random, Error EvalError, Input Env, State Mem] r + => Int -> AProperty -> Sem r TestResult +runTest n p = testProperty (Randomized n' n') =<< eval (compileProperty p) + where + n' = fromIntegral (n `div` 2) + +------------------------------------------------------------ +-- Top-level evaluation +------------------------------------------------------------ + +eval :: Members '[Random, Error EvalError, Input Env, State Mem] r => Core -> Sem r Value +eval c = do + e <- input @Env + runFresh (runCESK (In c e [])) >>= either throw return diff --git a/src/Disco/Messages.hs b/src/Disco/Messages.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Messages.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TemplateHaskell #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Messages +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Message logging framework (e.g. for errors, warnings, etc.) for +-- disco. +-- +----------------------------------------------------------------------------- + +module Disco.Messages where + +import Control.Lens +import Control.Monad (when) +import Polysemy +import Polysemy.Output + +import Disco.Pretty (Doc, Pretty, pretty', renderDoc') + +data MessageType + = Info + | Warning + | ErrMsg + | Debug + deriving (Show, Read, Eq, Ord, Enum, Bounded) + +data Message = Message {_messageType :: MessageType, _message :: Doc} + deriving (Show) + +makeLenses ''Message + +handleMsg :: Member (Embed IO) r => (Message -> Bool) -> Message -> Sem r () +handleMsg p m = when (p m) $ printMsg m + +printMsg :: Member (Embed IO) r => Message -> Sem r () +printMsg (Message _ m) = embed $ putStrLn (renderDoc' m) + +msg :: Member (Output Message) r => MessageType -> Sem r Doc -> Sem r () +msg typ m = m >>= output . Message typ + +info :: Member (Output Message) r => Sem r Doc -> Sem r () +info = msg Info + +infoPretty :: (Member (Output Message) r, Pretty t) => t -> Sem r () +infoPretty = info . pretty' + +warn :: Member (Output Message) r => Sem r Doc -> Sem r () +warn = msg Warning + +debug :: Member (Output Message) r => Sem r Doc -> Sem r () +debug = msg Debug + +debugPretty :: (Member (Output Message) r, Pretty t) => t -> Sem r () +debugPretty = debug . pretty' + +err :: Member (Output Message) r => Sem r Doc -> Sem r () +err = msg ErrMsg diff --git a/src/Disco/Module.hs b/src/Disco/Module.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Module.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Module +-- Copyright : (c) 2019 disco team (see LICENSE) +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- The 'ModuleInfo' record representing a disco module, and functions +-- to resolve the location of a module on disk. +----------------------------------------------------------------------------- + +module Disco.Module where + +import Data.Data (Data) +import GHC.Generics (Generic) + +import Control.Lens (Getting, foldOf, + makeLenses, view) +import Control.Monad (filterM, foldM) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Bifunctor (first) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (listToMaybe) +import qualified Data.Set as S +import System.Directory (doesFileExist) +import System.FilePath (replaceExtension, + ()) + +import Unbound.Generics.LocallyNameless (Alpha, Bind, Name, + Subst, bind) +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) + +import Polysemy +import Polysemy.Error + +import Disco.AST.Surface +import Disco.AST.Typed +import Disco.Context +import Disco.Extensions +import Disco.Names +import Disco.Pretty hiding ((<>)) +import Disco.Typecheck.Erase (erase, erasePattern) +import Disco.Typecheck.Util (TCError (..), TyCtx) +import Disco.Types + +import Paths_disco + +------------------------------------------------------------ +-- ModuleInfo and related types +------------------------------------------------------------ + +-- | When loading a module, we could be loading it from code entered +-- at the REPL, or from a standalone file. The two modes have +-- slightly different behavior. +data LoadingMode = REPL | Standalone + +-- | A definition consists of a name being defined, the types of any +-- pattern arguments (each clause must have the same number of +-- patterns), the type of the body of each clause, and a list of +-- clauses. For example, +-- +-- @ +-- f x (0,z) = 3*x + z > 5 +-- f x (y,z) = z == 9 +-- @ +-- +-- might look like @Defn f [Z, Z*Z] B [clause 1 ..., clause 2 ...]@ +data Defn = Defn (Name ATerm) [Type] Type [Clause] + deriving (Show, Generic, Alpha, Data, Subst Type) + +instance Pretty Defn where + pretty (Defn x patTys ty clauses) = vcat $ + prettyTyDecl x (foldr (:->:) ty patTys) + : + map (pretty . (x,) . eraseClause) clauses + +-- | A clause in a definition consists of a list of patterns (the LHS +-- of the =) and a term (the RHS). For example, given the concrete +-- syntax @f n (x,y) = n*x + y@, the corresponding 'Clause' would be +-- something like @[n, (x,y)] (n*x + y)@. +type Clause = Bind [APattern] ATerm + +eraseClause :: Clause -> Bind [Pattern] Term +eraseClause b = bind (map erasePattern ps) (erase t) + where (ps, t) = unsafeUnbind b + +-- | Type checking a module yields a value of type ModuleInfo which contains +-- mapping from terms to their relavent documenation, a mapping from terms to +-- properties, and a mapping from terms to their types. +data ModuleInfo = ModuleInfo + { _miName :: ModuleName + , _miImports :: Map ModuleName ModuleInfo + , _miDocs :: Ctx Term Docs + , _miProps :: Ctx ATerm [AProperty] + , _miTys :: TyCtx + , _miTydefs :: TyDefCtx + , _miTermdefs :: Ctx ATerm Defn + , _miTerms :: [(ATerm, PolyType)] + , _miExts :: ExtSet + } + deriving (Show) + +makeLenses ''ModuleInfo + +-- | Get something from a module and its direct imports. +withImports :: Monoid a => Getting a ModuleInfo a -> ModuleInfo -> a +withImports l = view l <> foldOf (miImports . traverse . l) + +-- | Get the types of all names bound in a module and its direct imports. +allTys :: ModuleInfo -> TyCtx +allTys = withImports miTys + +-- | Get all type definitions from a module and its direct imports. +allTydefs :: ModuleInfo -> TyDefCtx +allTydefs = withImports miTydefs + +-- | The empty module info record. +emptyModuleInfo :: ModuleInfo +emptyModuleInfo = ModuleInfo REPLModule M.empty emptyCtx emptyCtx emptyCtx M.empty emptyCtx [] S.empty + +-- | Merges a list of ModuleInfos into one ModuleInfo. Two ModuleInfos +-- are merged by joining their doc, type, type definition, and term +-- contexts. The property context of the new module is the one +-- obtained from the second module. The name of the new module is +-- taken from the first. Definitions from later modules override +-- earlier ones. Note that this function should really only be used +-- for the special top-level REPL module. +combineModuleInfo :: Member (Error TCError) r => [ModuleInfo] -> Sem r ModuleInfo +combineModuleInfo = foldM combineMods emptyModuleInfo + where + combineMods :: Member (Error TCError) r => ModuleInfo -> ModuleInfo -> Sem r ModuleInfo + combineMods + (ModuleInfo n1 is1 d1 _ ty1 tyd1 tm1 tms1 es1) + (ModuleInfo _ is2 d2 p2 ty2 tyd2 tm2 tms2 es2) = + return $ + ModuleInfo + n1 + (is1 <> is2) + (d2 <> d1) + p2 + (ty2 <> ty1) + (tyd2 <> tyd1) + (tm2 <> tm1) + (tms1 <> tms2) + (es1 <> es2) + +------------------------------------------------------------ +-- Module resolution +------------------------------------------------------------ + +-- | A data type indicating where we should look for Disco modules to +-- be loaded. +data Resolver + = -- | Load only from the stdlib (standard lib modules) + FromStdlib + | -- | Load only from a specific directory (:load) + FromDir FilePath + | -- | Load from current working dir or stdlib (import at REPL) + FromCwdOrStdlib + | -- | Load from specific dir or stdlib (import in file) + FromDirOrStdlib FilePath + +-- | Add the possibility of loading imports from the stdlib. For +-- example, this is what we want to do after a user loads a specific +-- file using `:load` (for which we will NOT look in the stdlib), +-- but then we need to recursively load modules which it imports +-- (which may either be in the stdlib, or the same directory as the +-- `:load`ed module). +withStdlib :: Resolver -> Resolver +withStdlib (FromDir fp) = FromDirOrStdlib fp +withStdlib r = r + +-- | Given a module resolution mode and a raw module name, relavent +-- directories are searched for the file containing the provided +-- module name. Returns Nothing if no module with the given name +-- could be found. +resolveModule :: Member (Embed IO) r => Resolver -> String -> Sem r (Maybe (FilePath, ModuleProvenance)) +resolveModule resolver modname = do + datadir <- liftIO getDataDir + let searchPath = + case resolver of + FromStdlib -> [(datadir, Stdlib)] + FromDir dir -> [(dir, Dir dir)] + FromCwdOrStdlib -> [(datadir, Stdlib), (".", Dir ".")] + FromDirOrStdlib dir -> [(datadir, Stdlib), (dir, Dir dir)] + let fps = map (first ( replaceExtension modname "disco")) searchPath + fexists <- liftIO $ filterM (doesFileExist . fst) fps + return $ listToMaybe fexists diff --git a/src/Disco/Names.hs b/src/Disco/Names.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Names.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Names +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- Names for modules and identifiers. +-- +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + +module Disco.Names + ( -- * Modules and their provenance + ModuleProvenance(..), ModuleName(..) + -- * Names and their provenance + , NameProvenance(..), QName(..), isFree, localName, (.-) + -- * Name-related utilities + , fvQ, substQ, substsQ + ) where + +import Control.Lens (Traversal', filtered) +import Data.Data (Data) +import Data.Data.Lens (template) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Prelude hiding ((<>)) +import System.FilePath (dropExtension) +import Unbound.Generics.LocallyNameless + +import Disco.Pretty +import Disco.Types + +------------------------------------------------------------ +-- Modules +------------------------------------------------------------ + +-- | Where did a module come from? +data ModuleProvenance + = Dir FilePath -- ^ From a particular directory (relative to cwd) + | Stdlib -- ^ From the standard library + deriving (Eq, Ord, Show, Generic, Data, Alpha, Subst Type) + +-- | The name of a module. +data ModuleName + = REPLModule -- ^ The special top-level "module" consisting of + -- what has been entered at the REPL. + | Named ModuleProvenance String + -- ^ A named module, with its name and provenance. + deriving (Eq, Ord, Show, Generic, Data, Alpha, Subst Type) + +------------------------------------------------------------ +-- Names +------------------------------------------------------------ + +-- | Where did a name come from? +data NameProvenance + = LocalName -- ^ The name is locally bound + | QualifiedName ModuleName -- ^ The name is exported by the given module + deriving (Eq, Ord, Show, Generic, Data, Alpha, Subst Type) + +-- | A @QName@, or qualified name, is a 'Name' paired with its +-- 'NameProvenance'. +data QName a = QName { qnameProvenance :: NameProvenance, qname :: Name a } + deriving (Eq, Ord, Show, Generic, Data, Alpha, Subst Type) + +-- | Does this name correspond to a free variable? +isFree :: QName a -> Bool +isFree (QName (QualifiedName _) _) = True +isFree (QName LocalName n) = isFreeName n + +-- | Create a locally bound qualified name. +localName :: Name a -> QName a +localName = QName LocalName + +-- | Create a module-bound qualified name. +(.-) :: ModuleName -> Name a -> QName a +m .- x = QName (QualifiedName m) x + +------------------------------------------------------------ +-- Free variables and substitution +------------------------------------------------------------ + +-- | The @unbound-generics@ library gives us free variables for free. +-- But when dealing with typed and desugared ASTs, we want all the +-- free 'QName's instead of just 'Name's. +fvQ :: (Data t, Typeable e) => Traversal' t (QName e) +fvQ = template . filtered isFree + +substQ :: Subst b a => QName b -> b -> a -> a +substQ = undefined + +substsQ :: Subst b a => [(QName b, b)] -> a -> a +substsQ = undefined + +------------------------------------------------------------ +-- Pretty-printing +------------------------------------------------------------ + +instance Pretty ModuleName where + pretty REPLModule = "REPL" + pretty (Named (Dir _) s) = text (dropExtension s) + pretty (Named Stdlib s) = text (dropExtension s) + +instance Pretty (QName a) where + pretty (QName LocalName x) = pretty x + pretty (QName (QualifiedName mn) x) = pretty mn <> "." <> pretty x diff --git a/src/Disco/Parser.hs b/src/Disco/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Parser.hs @@ -0,0 +1,1048 @@ +{-# LANGUAGE TemplateHaskell #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Parser +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Parser to convert concrete Disco syntax into an (untyped, surface +-- language) AST. +-- +----------------------------------------------------------------------------- + +module Disco.Parser + ( -- * Parser type and utilities + DiscoParseError(..), Parser, runParser, withExts, indented, thenIndented + + -- * Lexer + + -- ** Basic lexemes + , sc, lexeme, symbol, reservedOp + , natural, reserved, reservedWords, ident + + -- ** Punctuation + , parens, braces, angles, brackets + , semi, comma, colon, dot, pipe + , lambda + + -- * Disco parser + + -- ** Modules + , wholeModule, parseModule, parseExtName, parseTopLevel, parseDecl + , parseImport, parseModuleName + + -- ** Terms + , term, parseTerm, parseTerm', parseExpr, parseAtom + , parseContainer, parseEllipsis, parseContainerComp, parseQual + , parseLet, parseTypeOp + + -- ** Case and patterns + , parseCase, parseBranch, parseGuards, parseGuard + , parsePattern, parseAtomicPattern + + -- ** Types + , parseType, parseAtomicType + , parsePolyTy + ) + where + +import Unbound.Generics.LocallyNameless (Name, bind, embed, + fvAny, string2Name) +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) + +import Control.Monad.Combinators.Expr +import Text.Megaparsec hiding (runParser) +import qualified Text.Megaparsec as MP +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L + +import Control.Lens (makeLenses, toListOf, + use, (%=), (%~), (&), + (.=)) +import Control.Monad.State +import Data.Char (isDigit) +import Data.Foldable (asum) +import Data.List (find, intercalate) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Ratio +import Data.Set (Set) +import qualified Data.Set as S + +import Disco.AST.Surface +import Disco.Extensions +import Disco.Module +import Disco.Syntax.Operators +import Disco.Syntax.Prims +import Disco.Types + +------------------------------------------------------------ +-- Lexer + +-- Some of the basic setup code for the parser taken from +-- https://markkarpov.com/megaparsec/parsing-simple-imperative-language.html + +-- | Currently required indent level. +data IndentMode where + NoIndent :: IndentMode -- ^ Don't require indent. + ThenIndent :: IndentMode -- ^ Parse one token without + -- indent, then switch to @Indent@. + Indent :: IndentMode -- ^ Require everything to be indented at + -- least one space. + +-- | Extra custom state for the parser. +data ParserState = ParserState + { _indentMode :: IndentMode -- ^ Currently required level of indentation. + , _enabledExts :: Set Ext -- ^ Set of enabled language extensions + -- (some of which may affect parsing). + } + +makeLenses ''ParserState + +initParserState :: ParserState +initParserState = ParserState NoIndent S.empty + +data DiscoParseError + = ReservedVarName String + deriving (Show, Eq, Ord) + +instance ShowErrorComponent DiscoParseError where + showErrorComponent (ReservedVarName x) = "keyword \"" ++ x ++ "\" cannot be used as a variable name" + errorComponentLen (ReservedVarName x) = length x + +-- | A parser is a megaparsec parser of strings, with an extra layer +-- of state to keep track of the current indentation level and +-- language extensions, and some custom error messages. +type Parser = StateT ParserState (MP.Parsec DiscoParseError String) + +-- | Run a parser from the initial state. +runParser :: Parser a -> FilePath -> String -> Either (ParseErrorBundle String DiscoParseError) a +runParser = MP.runParser . flip evalStateT initParserState + +-- | Run a parser under a specified 'IndentMode'. +withIndentMode :: IndentMode -> Parser a -> Parser a +withIndentMode m p = do + indentMode .= m + res <- p + indentMode .= NoIndent + return res + +-- | @indented p@ is just like @p@, except that every token must not +-- start in the first column. +indented :: Parser a -> Parser a +indented = withIndentMode Indent + +-- | @indented p@ is just like @p@, except that every token after the +-- first must not start in the first column. +thenIndented :: Parser a -> Parser a +thenIndented = withIndentMode ThenIndent + +-- | @requireIndent p@ possibly requires @p@ to be indented, depending +-- on the current '_indentMode'. Used in the definition of +-- 'lexeme' and 'symbol'. +requireIndent :: Parser a -> Parser a +requireIndent p = do + l <- use indentMode + case l of + ThenIndent -> do + a <- p + indentMode .= Indent + return a + Indent -> L.indentGuard sc GT pos1 >> p + NoIndent -> p + +-- | Locally set the enabled extensions within a subparser. +withExts :: Set Ext -> Parser a -> Parser a +withExts exts p = do + oldExts <- use enabledExts + enabledExts .= exts + a <- p + enabledExts .= oldExts + return a + +-- | Locally enable some additional extensions within a subparser. +withAdditionalExts :: Set Ext -> Parser a -> Parser a +withAdditionalExts exts p = do + oldExts <- use enabledExts + enabledExts %= S.union exts + a <- p + enabledExts .= oldExts + return a + +-- | Ensure that a specific extension is enabled, fail if not. +ensureEnabled :: Ext -> Parser () +ensureEnabled e = do + exts <- use enabledExts + guard $ e `S.member` exts + +-- | Generically consume whitespace, including comments. +sc :: Parser () +sc = L.space space1 lineComment empty {- no block comments in disco -} + where + lineComment = L.skipLineComment "--" + +-- | Parse a lexeme, that is, a parser followed by consuming +-- whitespace. +lexeme :: Parser a -> Parser a +lexeme p = requireIndent $ L.lexeme sc p + +-- | Parse a given string as a lexeme. +symbol :: String -> Parser String +symbol s = requireIndent $ L.symbol sc s + +-- | Parse a reserved operator. +reservedOp :: String -> Parser () +reservedOp s = (lexeme . try) (string s *> notFollowedBy (oneOf opChar)) + +-- | Characters that can occur in an operator symbol. +opChar :: [Char] +opChar = "~!@#$%^&*-+=|<>?/\\." + +parens, braces, angles, brackets, bagdelims, fbrack, cbrack :: Parser a -> Parser a +parens = between (symbol "(") (symbol ")") +braces = between (symbol "{") (symbol "}") +angles = between (symbol "<") (symbol ">") +brackets = between (symbol "[") (symbol "]") +bagdelims = between (symbol "⟅") (symbol "⟆") +fbrack = between (symbol "⌊") (symbol "⌋") +cbrack = between (symbol "⌈") (symbol "⌉") + +semi, comma, colon, dot, pipe, hash :: Parser String +semi = symbol ";" +comma = symbol "," +colon = symbol ":" +dot = symbol "." +pipe = symbol "|" +hash = symbol "#" + +-- | A literal ellipsis of two or more dots, @..@ +ellipsis :: Parser String +ellipsis = label "ellipsis (..)" $ concat <$> ((:) <$> dot <*> some dot) + +-- | The symbol that starts an anonymous function (either a backslash +-- or a Greek λ). +lambda :: Parser String +lambda = symbol "\\" <|> symbol "λ" + +forall :: Parser () +forall = () <$ symbol "∀" <|> reserved "forall" + +exists :: Parser () +exists = () <$ symbol "∃" <|> reserved "exists" + +-- | Parse a natural number. +natural :: Parser Integer +natural = lexeme L.decimal "natural number" + +-- | Parse a nonnegative decimal of the form @xxx.yyyy[zzz]@, where +-- the @y@s and bracketed @z@s are both optional as long as the +-- other is present. (In other words, there must be something after +-- the period.) For example, this parser accepts all of the +-- following: +-- +-- > 2.0 +-- > 2.333 +-- > 2.33[45] +-- > 2.[45] +-- +-- The idea is that brackets surround an infinitely repeating +-- sequence of digits. +-- +-- We used to accept @2.@ with no trailing digits, but no longer do. +-- See https://github.com/disco-lang/disco/issues/245 and Note +-- [Trailing period]. +decimal :: Parser Rational +decimal = lexeme (readDecimal <$> some digit <* char '.' + <*> fractionalPart + ) + where + digit = satisfy isDigit + fractionalPart = + -- either some digits optionally followed by bracketed digits... + (,) <$> some digit <*> optional (brackets (some digit)) + -- ...or just bracketed digits. + <|> ([],) <$> (Just <$> brackets (some digit)) + + readDecimal a (b, mrep) + = read a % 1 -- integer part + + -- next part is just b/10^n + + (if null b then 0 else read b) % (10^length b) + + -- repeating part + + readRep (length b) mrep + + readRep _ Nothing = 0 + readRep offset (Just rep) = read rep % (10^offset * (10^length rep - 1)) + -- If s = 0.[rep] then 10^(length rep) * s = rep.[rep], so + -- 10^(length rep) * s - s = rep, so + -- + -- s = rep/(10^(length rep) - 1). + -- + -- We also have to divide by 10^(length b) to shift it over + -- past any non-repeating prefix. + +-- ~~~~ Note [Trailing period] +-- +-- We used to accept numbers with nothing after the trailing period, +-- such as @2.@. However, this caused some problems with parsing: +-- +-- - First, https://github.com/disco-lang/disco/issues/99 which we +-- solved by making sure there was not another period after the +-- trailing period. +-- - Next, https://github.com/disco-lang/disco/issues/245. +-- +-- I first tried solving #245 by disallowing *any* operator character +-- after the trailing period, but then some tests in the test suite +-- started failing, where we had written things like @1./(10^5)@. The +-- problem is that when a period is followed by another operator +-- symbol, sometimes we might want them to be parsed as an operator +-- (as in @2.-4@, #245), and sometimes we might not (as in +-- @1./(10^5)@). So in the end it seems simpler and cleaner to +-- require at least a 0 digit after the period --- just like pretty +-- much every other programming language and just like standard +-- mathematical practice. + +-- | Parse a reserved word. +reserved :: String -> Parser () +reserved w = (lexeme . try) $ string w *> notFollowedBy alphaNumChar + +-- | The list of all reserved words. +reservedWords :: [String] +reservedWords = + [ "unit", "true", "false", "True", "False", "let", "in", "is" + , "if", "when" + , "otherwise", "and", "or", "mod", "choose", "implies" + , "min", "max" + , "union", "∪", "intersect", "∩", "subset", "⊆", "elem", "∈" + , "enumerate", "count", "divides" + , "Void", "Unit", "Bool", "Boolean", "Proposition", "Prop", "Char" + , "Nat", "Natural", "Int", "Integer", "Frac", "Fractional", "Rational", "Fin" + , "List", "Bag", "Set", "Graph", "Map" + , "N", "Z", "F", "Q", "ℕ", "ℤ", "𝔽", "ℚ" + , "∀", "forall", "∃", "exists", "type" + , "import", "using" + ] + +-- | Parse an identifier, i.e. any non-reserved string beginning with +-- a given type of character and continuing with alphanumerics, +-- underscores, and apostrophes. +identifier :: Parser Char -> Parser String +identifier begin = (lexeme . try) (p >>= check) "variable name" + where + p = (:) <$> begin <*> many identChar + identChar = alphaNumChar <|> oneOf "_'" + check x + | x `elem` reservedWords = do + -- back up to beginning of bad token to report correct position + updateParserState (\s -> s { stateOffset = stateOffset s - length x }) + customFailure $ ReservedVarName x + | otherwise = return x + +-- | Parse an 'identifier' and turn it into a 'Name'. +ident :: Parser (Name Term) +ident = string2Name <$> identifier letterChar + +------------------------------------------------------------ +-- Parser + +-- | Results from parsing a block of top-level things. +data TLResults = TLResults + { _tlDecls :: [Decl] + , _tlDocs :: [(Name Term, [DocThing])] + , _tlTerms :: [Term] + } + +emptyTLResults :: TLResults +emptyTLResults = TLResults [] [] [] + +makeLenses ''TLResults + +-- | Parse the entire input as a module (with leading whitespace and +-- no leftovers). +wholeModule :: LoadingMode -> Parser Module +wholeModule = between sc eof . parseModule + +-- | Parse an entire module (a list of declarations ended by +-- semicolons). The 'LoadingMode' parameter tells us whether to +-- include or replace any language extensions enabled at the top +-- level. We include them when parsing a module entered at the +-- REPL, and replace them when parsing a standalone module. +parseModule :: LoadingMode -> Parser Module +parseModule mode = do + exts <- S.fromList <$> many parseExtension + let extFun = case mode of + Standalone -> withExts + REPL -> withAdditionalExts + + extFun exts $ do + imports <- many parseImport + topLevel <- many parseTopLevel + let theMod = mkModule exts imports topLevel + return theMod + where + groupTLs :: [DocThing] -> [TopLevel] -> TLResults + groupTLs _ [] = emptyTLResults + groupTLs revDocs (TLDoc doc : rest) + = groupTLs (doc : revDocs) rest + groupTLs revDocs (TLDecl decl@(DType (TypeDecl x _)) : rest) + = groupTLs [] rest + & tlDecls %~ (decl :) + & tlDocs %~ ((x, reverse revDocs) :) + groupTLs revDocs (TLDecl decl@(DTyDef (TypeDefn x _ _)) : rest) + = groupTLs [] rest + & tlDecls %~ (decl :) + & tlDocs %~ ((string2Name x, reverse revDocs) :) + groupTLs _ (TLDecl defn : rest) + = groupTLs [] rest + & tlDecls %~ (defn :) + groupTLs _ (TLExpr t : rest) + = groupTLs [] rest & tlTerms %~ (t:) + + defnGroups :: [Decl] -> [Decl] + defnGroups [] = [] + defnGroups (d@DType{} : ds) = d : defnGroups ds + defnGroups (d@DTyDef{} : ds) = d : defnGroups ds + defnGroups (DDefn (TermDefn x bs) : ds) = DDefn (TermDefn x (bs ++ concatMap (\(TermDefn _ cs) -> cs) grp)) : defnGroups rest + where + (grp, rest) = matchDefn ds + matchDefn :: [Decl] -> ([TermDefn], [Decl]) + matchDefn (DDefn t@(TermDefn x' _) : ds2) | x == x' = (t:ts, ds2') + where + (ts, ds2') = matchDefn ds2 + matchDefn ds2 = ([], ds2) + + mkModule exts imps tls = Module exts imps (defnGroups decls) docs terms + where + TLResults decls docs terms = groupTLs [] tls + +-- | Parse an extension. +parseExtension :: Parser Ext +parseExtension = L.nonIndented sc $ + reserved "using" *> parseExtName + +-- | Parse the name of a language extension (case-insensitive). +parseExtName :: Parser Ext +parseExtName = choice (map parseOneExt allExtsList) "language extension name" + where + parseOneExt ext = ext <$ lexeme (string' (show ext) :: Parser String) + +-- | Parse an import, of the form @import @. +parseImport :: Parser String +parseImport = L.nonIndented sc $ + reserved "import" *> parseModuleName + +-- | Parse the name of a module. +parseModuleName :: Parser String +parseModuleName = lexeme $ + intercalate "/" <$> (some (alphaNumChar <|> oneOf "_-") `sepBy` char '/') <* optional (string ".disco") + +-- | Parse a top level item (either documentation or a declaration), +-- which must start at the left margin. +parseTopLevel :: Parser TopLevel +parseTopLevel = L.nonIndented sc $ + TLDoc <$> parseDocThing + <|> TLDecl <$> try parseDecl + <|> TLExpr <$> thenIndented parseTerm + +-- | Parse a documentation item: either a group of lines beginning +-- with @|||@ (text documentation), or a group beginning with @!!!@ +-- (checked examples/properties). +parseDocThing :: Parser DocThing +parseDocThing + = DocString <$> some parseDocString + <|> DocProperty <$> parseProperty + +-- | Parse one line of documentation beginning with @|||@. +parseDocString :: Parser String +parseDocString = label "documentation" $ L.nonIndented sc $ + string "|||" + *> takeWhileP Nothing (`elem` " \t") + *> takeWhileP Nothing (`notElem` "\r\n") <* sc + + -- Note we use string "|||" rather than symbol "|||" because we + -- don't want it to consume whitespace afterwards (in particular a + -- line with ||| by itself would cause symbol "|||" to consume the + -- newline). + +-- | Parse a top-level property/unit test, of the form +-- +-- @!!! forall x1 : ty1, ..., xn : tyn. term@. +-- +-- The forall is optional. +parseProperty :: Parser Term +parseProperty = label "property" $ L.nonIndented sc $ do + _ <- symbol "!!!" + indented parseTerm + +-- | Parse a single top-level declaration (either a type declaration +-- or single definition clause). +parseDecl :: Parser Decl +parseDecl = try (DType <$> parseTyDecl) <|> DDefn <$> parseDefn <|> DTyDef <$> parseTyDefn + +-- | Parse a top-level type declaration of the form @x : ty@. +parseTyDecl :: Parser TypeDecl +parseTyDecl = label "type declaration" $ + TypeDecl <$> ident <*> indented (colon *> parsePolyTy) + +-- | Parse a definition of the form @x pat1 .. patn = t@. +parseDefn :: Parser TermDefn +parseDefn = label "definition" $ + TermDefn + <$> ident + <*> indented ((:[]) <$> (bind <$> many parseAtomicPattern <*> (symbol "=" *> parseTerm))) + +-- | Parse the definition of a user-defined algebraic data type. +parseTyDefn :: Parser TypeDefn +parseTyDefn = label "type defintion" $ do + reserved "type" + indented $ do + name <- parseTyDef + args <- fromMaybe [] <$> optional (parens $ parseTyVarName `sepBy1` comma) + _ <- symbol "=" + TypeDefn name args <$> parseType + +-- | Parse the entire input as a term (with leading whitespace and +-- no leftovers). +term :: Parser Term +term = between sc eof parseTerm + +-- | Parse a term, consisting of a @parseTerm'@ optionally +-- followed by an ascription. +parseTerm :: Parser Term +parseTerm = -- trace "parseTerm" $ + ascribe <$> parseTerm' <*> optional (label "type annotation" $ colon *> parsePolyTy) + where + ascribe t Nothing = t + ascribe t (Just ty) = TAscr t ty + +-- | Parse a non-atomic, non-ascribed term. +parseTerm' :: Parser Term +parseTerm' = label "expression" $ + parseQuantified + <|> parseLet + <|> parseExpr + <|> parseAtom + +-- | Parse an atomic term. +parseAtom :: Parser Term +parseAtom = label "expression" $ + parseUnit + <|> TBool True <$ (reserved "true" <|> reserved "True") + <|> TBool False <$ (reserved "false" <|> reserved "False") + <|> TChar <$> lexeme (between (char '\'') (char '\'') L.charLiteral) + <|> TString <$> lexeme (char '"' >> manyTill L.charLiteral (char '"')) + <|> TWild <$ try parseWild + <|> TPrim <$> try parseStandaloneOp + + -- Note primitives are NOT reserved words, so they are just parsed + -- as identifiers. This means that it is possible to shadow a + -- primitive in a local context, as it should be. Vars are turned + -- into prims at scope-checking time: if a var is not in scope but + -- there is a prim of that name then it becomes a TPrim. See the + -- 'typecheck Infer (TVar x)' case in Disco.Typecheck. + <|> TVar <$> ident + <|> TPrim <$> (ensureEnabled Primitives *> parsePrim) + <|> TRat <$> try decimal + <|> TNat <$> natural + <|> parseTypeOp + <|> TApp (TPrim PrimFloor) . TParens <$> fbrack parseTerm + <|> TApp (TPrim PrimCeil) . TParens <$> cbrack parseTerm + <|> parseCase + <|> try parseAbs + <|> bagdelims (parseContainer BagContainer) + <|> braces (parseContainer SetContainer) + <|> brackets (parseContainer ListContainer) + <|> tuple <$> parens (parseTerm `sepBy1` comma) + +parseAbs :: Parser Term +parseAbs = TApp (TPrim PrimAbs) <$> (pipe *> parseTerm <* pipe) + +parseUnit :: Parser Term +parseUnit = TUnit <$ (reserved "unit" <|> void (symbol "■")) + +-- | Parse a wildcard, which is an underscore that isn't the start of +-- an identifier. +parseWild :: Parser () +parseWild = (lexeme . try . void) $ + string "_" <* notFollowedBy (alphaNumChar <|> oneOf "_'") + +-- | Parse a standalone operator name with tildes indicating argument +-- slots, e.g. ~+~ for the addition operator. +parseStandaloneOp :: Parser Prim +parseStandaloneOp = asum $ concatMap mkStandaloneOpParsers (concat opTable) + where + mkStandaloneOpParsers :: OpInfo -> [Parser Prim] + mkStandaloneOpParsers (OpInfo (UOpF Pre uop) syns _) + = map (\syn -> PrimUOp uop <$ try (lexeme (string syn >> char '~'))) syns + mkStandaloneOpParsers (OpInfo (UOpF Post uop) syns _) + = map (\syn -> PrimUOp uop <$ try (lexeme (char '~' >> string syn))) syns + mkStandaloneOpParsers (OpInfo (BOpF _ bop) syns _) + = map (\syn -> PrimBOp bop <$ try (lexeme (char '~' >> string syn >> char '~'))) syns + + -- XXX TODO: improve the above so it first tries to parse a ~, + -- then parses any postfix or infix thing; or else it looks for + -- a prefix thing followed by a ~. This will get rid of the + -- need for 'try' and also potentially improve error messages. + -- The below may come in useful. + + -- flatOpTable = concat opTable + + -- prefixOps = [ (uop, syns) | (OpInfo (UOpF Pre uop) syns _) <- flatOpTable ] + -- postfixOps = [ (uop, syns) | (OpInfo (UOpF Post uop) syns _) <- flatOpTable ] + -- infixOps = [ (bop, syns) | (OpInfo (BOpF _ bop) syns _) <- flatOpTable ] + +-- | Parse a primitive name starting with a $. +parsePrim :: Parser Prim +parsePrim = do + void (char '$') + x <- identifier letterChar + case find ((==x) . primSyntax) primTable of + Just (PrimInfo p _ _) -> return p + Nothing -> fail ("Unrecognized primitive $" ++ x) + +-- | Parse a container, like a literal list, set, bag, or a +-- comprehension (not including the square or curly brackets). +-- +-- @ +-- +-- ::= '[' ']' +-- | '{' '}' +-- +-- +-- ::= empty | +-- +-- +-- ::= [ ] +-- | +-- +-- +-- ::= '|' +-- | ',' [ (',' )* ] [ ] +-- +-- ::= [ ',' ]* +-- +-- +-- ::= 'in' +-- | +-- +-- ::= '..' [ ] +-- @ + +parseContainer :: Container -> Parser Term +parseContainer c = nonEmptyContainer <|> return (TContainer c [] Nothing) + -- Careful to do this without backtracking, since backtracking can + -- lead to bad performance in certain pathological cases (for + -- example, a very deeply nested list). + + where + -- Any non-empty container starts with a term, followed by some + -- remainder (which could either be the rest of a literal + -- container, or a container comprehension). If there is no + -- remainder just return a singleton container, optionally with an + -- ellipsis. + nonEmptyContainer = do + t <- parseRepTerm + + containerRemainder t <|> singletonContainer t + + parseRepTerm = do + t <- parseTerm + n <- optional $ do + guard (c == BagContainer) + void hash + parseTerm + return (t, n) + + singletonContainer t = TContainer c [t] <$> optional parseEllipsis + + -- The remainder of a container after the first term starts with + -- either a pipe (for a comprehension) or a comma (for a literal + -- container). + containerRemainder :: (Term, Maybe Term) -> Parser Term + containerRemainder (t,n) = do + s <- pipe <|> comma + case (s, n) of + ("|", Nothing) -> parseContainerComp c t + ("|", Just _) -> fail "no comprehension with bag repetition syntax" + (",", _) -> do + -- Parse the rest of the terms in a literal container after + -- the first, then an optional ellipsis, and return + -- everything together. + ts <- parseRepTerm `sepBy` comma + e <- optional parseEllipsis + + return $ TContainer c ((t,n):ts) e + _ -> error "Impossible, got a symbol other than '|' or ',' in containerRemainder" + +-- | Parse an ellipsis at the end of a literal list, of the form +-- @.. t@. Any number > 1 of dots may be used, just for fun. +parseEllipsis :: Parser (Ellipsis Term) +parseEllipsis = do + _ <- ellipsis + Until <$> parseTerm + +-- | Parse the part of a list comprehension after the | (without +-- square brackets), i.e. a list of qualifiers. +-- +-- @q [,q]*@ +parseContainerComp :: Container -> Term -> Parser Term +parseContainerComp c t = do + qs <- toTelescope <$> (parseQual `sepBy` comma) + return (TContainerComp c $ bind qs t) + +-- | Parse a qualifier in a comprehension: either a binder @x in t@ or +-- a guard @t@. +parseQual :: Parser Qual +parseQual = try parseSelection <|> parseQualGuard + where + parseSelection = label "membership expression (x in ...)" $ + QBind <$> ident <*> (selector *> (embed <$> parseTerm)) + selector = reservedOp "<-" <|> reserved "in" + + parseQualGuard = label "boolean expression" $ + QGuard . embed <$> parseTerm + +-- | Turn a parenthesized list of zero or more terms into the +-- appropriate syntax node: one term @(t)@ is just the term itself +-- (but we record the fact that it was parenthesized, in order to +-- correctly turn juxtaposition into multiplication); two or more +-- terms @(t1,t2,...)@ are a tuple. +tuple :: [Term] -> Term +tuple [x] = TParens x +tuple t = TTup t + +-- | Parse a quantified abstraction (λ, ∀, ∃). +parseQuantified :: Parser Term +parseQuantified = + TAbs <$> parseQuantifier + <*> (bind <$> parsePattern `sepBy` comma <*> (dot *> parseTerm)) + +-- | Parse a quantifier symbol (lambda, forall, or exists). +parseQuantifier :: Parser Quantifier +parseQuantifier = + Lam <$ lambda + <|> All <$ forall + <|> Ex <$ exists + +-- | Parse a let expression (@let x1 = t1, x2 = t2, ... in t@). +parseLet :: Parser Term +parseLet = + TLet <$> + (reserved "let" *> + (bind + <$> (toTelescope <$> (parseBinding `sepBy` comma)) + <*> (reserved "in" *> parseTerm))) + +-- | Parse a single binding (@x [ : ty ] = t@). +parseBinding :: Parser Binding +parseBinding = do + x <- ident + mty <- optional (colon *> parsePolyTy) + t <- symbol "=" *> (embed <$> parseTerm) + return $ Binding (embed <$> mty) x t + +-- | Parse a case expression. +parseCase :: Parser Term +parseCase = between (symbol "{?") (symbol "?}") $ + TCase <$> parseBranch `sepBy` comma + +-- | Parse one branch of a case expression. +parseBranch :: Parser Branch +parseBranch = flip bind <$> parseTerm <*> parseGuards + +-- | Parse the list of guards in a branch. @otherwise@ can be used +-- interchangeably with an empty list of guards. +parseGuards :: Parser (Telescope Guard) +parseGuards = (TelEmpty <$ reserved "otherwise") <|> (toTelescope <$> many parseGuard) + +-- | Parse a single guard (either @if@ or @when@) +parseGuard :: Parser Guard +parseGuard = parseGBool <|> parseGPat <|> parseGLet + where + parseGBool = GBool <$> (embed <$> (reserved "if" *> parseTerm)) + parseGPat = GPat <$> (embed <$> (reserved "when" *> parseTerm)) + <*> (reserved "is" *> parsePattern) + parseGLet = GLet <$> (reserved "let" *> parseBinding) + +-- | Parse an atomic pattern, by parsing a term and then attempting to +-- convert it to a pattern. +parseAtomicPattern :: Parser Pattern +parseAtomicPattern = label "pattern" $ do + t <- parseAtom + case termToPattern t of + Nothing -> fail $ "Invalid pattern: " ++ show t + Just p -> return p + +-- | Parse a pattern, by parsing a term and then attempting to convert +-- it to a pattern. +parsePattern :: Parser Pattern +parsePattern = label "pattern" $ do + t <- parseTerm + case termToPattern t of + Nothing -> fail $ "Invalid pattern: " ++ show t + Just p -> return p + +-- | Attempt converting a term to a pattern. +termToPattern :: Term -> Maybe Pattern +termToPattern TWild = Just PWild +termToPattern (TVar x) = Just $ PVar x +termToPattern (TParens t) = termToPattern t +termToPattern TUnit = Just PUnit +termToPattern (TBool b) = Just $ PBool b +termToPattern (TNat n) = Just $ PNat n +termToPattern (TChar c) = Just $ PChar c +termToPattern (TString s) = Just $ PString s +termToPattern (TTup ts) = PTup <$> mapM termToPattern ts +termToPattern (TApp (TVar i) t) + | i == string2Name "left" = PInj L <$> termToPattern t + | i == string2Name "right" = PInj R <$> termToPattern t +-- termToPattern (TInj s t) = PInj s <$> termToPattern t + +termToPattern (TAscr t s) = case s of + Forall (unsafeUnbind -> ([], s')) -> PAscr <$> termToPattern t <*> pure s' + _ -> Nothing + +termToPattern (TBin Cons t1 t2) + = PCons <$> termToPattern t1 <*> termToPattern t2 + +termToPattern (TBin Add t1 t2) + = case (termToPattern t1, termToPattern t2) of + (Just p, _) + | length (toListOf fvAny p) == 1 + && null (toListOf fvAny t2) + -> Just $ PAdd L p t2 + (_, Just p) + | length (toListOf fvAny p) == 1 + && null (toListOf fvAny t1) + -> Just $ PAdd R p t1 + _ -> Nothing + -- If t1 is a pattern binding one variable, and t2 has no fvs, + -- this can be a PAdd L. Also vice versa for PAdd R. + +termToPattern (TBin Mul t1 t2) + = case (termToPattern t1, termToPattern t2) of + (Just p, _) + | length (toListOf fvAny p) == 1 + && null (toListOf fvAny t2) + -> Just $ PMul L p t2 + (_, Just p) + | length (toListOf fvAny p) == 1 + && null (toListOf fvAny t1) + -> Just $ PMul R p t1 + _ -> Nothing + -- If t1 is a pattern binding one variable, and t2 has no fvs, + -- this can be a PMul L. Also vice versa for PMul R. + +termToPattern (TBin Sub t1 t2) + = case termToPattern t1 of + Just p + | length (toListOf fvAny p) == 1 + && null (toListOf fvAny t2) + -> Just $ PSub p t2 + _ -> Nothing + -- If t1 is a pattern binding one variable, and t2 has no fvs, + -- this can be a PSub. + + -- For now we don't handle the case of t - p, since it seems + -- less useful (and desugaring it would require extra code since + -- subtraction is not commutative). + +termToPattern (TBin Div t1 t2) + = PFrac <$> termToPattern t1 <*> termToPattern t2 + +termToPattern (TUn Neg t) = PNeg <$> termToPattern t + +termToPattern (TContainer ListContainer ts Nothing) + = PList <$> mapM (termToPattern . fst) ts + +termToPattern _ = Nothing + +-- | Parse an expression built out of unary and binary operators. +parseExpr :: Parser Term +parseExpr = fixJuxtMul . fixChains <$> (makeExprParser parseAtom table "expression") + where + table + -- Special case for function application, with highest + -- precedence. Note that we parse all juxtaposition as + -- function application first; we later go through and turn + -- some into multiplication (fixing up the precedence + -- appropriately) based on a syntactic analysis. + = [ InfixL (TApp <$ string "") ] + + -- get all other operators from the opTable + : (map . concatMap) mkOpParser opTable + + mkOpParser :: OpInfo -> [Operator Parser Term] + mkOpParser (OpInfo op syns _) = map (withOpFixity op) syns + + withOpFixity (UOpF fx op) syn + = ufxParser fx ((reservedOp syn "operator") >> return (TUn op)) + + withOpFixity (BOpF fx op) syn + = bfxParser fx ((reservedOp syn "operator") >> return (TBin op)) + + ufxParser Pre = Prefix + ufxParser Post = Postfix + + bfxParser InL = InfixL + bfxParser InR = InfixR + bfxParser In = InfixN + + isChainable op = op `elem` [Eq, Neq, Lt, Gt, Leq, Geq, Divides] + + -- Comparison chains like 3 < x < 5 first get parsed as 3 < (x < + -- 5), which does not make sense. This function looks for such + -- nested comparison operators and turns them into a TChain. + fixChains (TUn op t) = TUn op (fixChains t) + fixChains (TBin op t1 (TBin op' t21 t22)) + | isChainable op && isChainable op' = TChain t1 (TLink op t21 : getLinks op' t22) + fixChains (TBin op t1 t2) = TBin op (fixChains t1) (fixChains t2) + fixChains (TApp t1 t2) = TApp (fixChains t1) (fixChains t2) + + -- Only recurse as long as we see TUn, TBin, or TApp which could + -- have been generated by the expression parser. If we see + -- anything else we can stop. + fixChains e = e + + getLinks op (TBin op' t1 t2) + | isChainable op' = TLink op t1 : getLinks op' t2 + getLinks op e = [TLink op (fixChains e)] + + -- Find juxtapositions (parsed as function application) which + -- syntactically have either a literal Nat or a parenthesized + -- expression containing an operator as the LHS, and turn them + -- into multiplications. Then fix up the parse tree by rotating + -- newly created multiplications up until their precedence is + -- higher than the thing above them. + + fixJuxtMul :: Term -> Term + + -- Just recurse through TUn or TBin and fix precedence on the way back up. + fixJuxtMul (TUn op t) = fixPrec $ TUn op (fixJuxtMul t) + fixJuxtMul (TBin op t1 t2) = fixPrec $ TBin op (fixJuxtMul t1) (fixJuxtMul t2) + + -- Possibly turn a TApp into a multiplication, if the LHS looks + -- like a multiplicative term. However, we must be sure to + -- *first* recursively fix the subterms (particularly the + -- left-hand one) *before* doing this analysis. See + -- . + fixJuxtMul (TApp t1 t2) + | isMultiplicativeTerm t1' = fixPrec $ TBin Mul t1' t2' + | otherwise = fixPrec $ TApp t1' t2' + where + t1' = fixJuxtMul t1 + t2' = fixJuxtMul t2 + + -- Otherwise we can stop recursing, since anything other than TUn, + -- TBin, or TApp could not have been produced by the expression + -- parser. + fixJuxtMul t = t + + -- A multiplicative term is one that looks like either a natural + -- number literal, or a unary or binary operation (optionally + -- parenthesized). For example, 3, (-2), and (x + 5) are all + -- multiplicative terms, so 3x, (-2)x, and (x + 5)x all get parsed + -- as multiplication. On the other hand, (x y) is always parsed + -- as function application, even if x and y both turn out to have + -- numeric types; a variable like x does not count as a + -- multiplicative term. Likewise, (x y) z is parsed as function + -- application, since (x y) is not a multiplicative term: it is + -- parenthezised, but contains a TApp rather than a TBin or TUn. + isMultiplicativeTerm :: Term -> Bool + isMultiplicativeTerm (TNat _) = True + isMultiplicativeTerm TUn{} = True + isMultiplicativeTerm TBin{} = True + isMultiplicativeTerm (TParens t) = isMultiplicativeTerm t + isMultiplicativeTerm _ = False + + -- Fix precedence by bubbling up any new TBin terms whose + -- precedence is less than that of the operator above them. We + -- don't worry at all about fixing associativity, just precedence. + + fixPrec :: Term -> Term + + -- e.g. 2y! --> (2@y)! --> fixup --> 2 * (y!) + fixPrec (TUn uop (TBin bop t1 t2)) + | bPrec bop < uPrec uop = case uopMap M.! uop of + OpInfo (UOpF Pre _) _ _ -> TBin bop (TUn uop t1) t2 + OpInfo (UOpF Post _) _ _ -> TBin bop t1 (TUn uop t2) + _ -> error "Impossible! In fixPrec, uopMap contained OpInfo (BOpF ...)" + + fixPrec (TBin bop1 (TBin bop2 t1 t2) t3) + | bPrec bop2 < bPrec bop1 = TBin bop2 t1 (fixPrec $ TBin bop1 t2 t3) + + -- e.g. x^2y --> x^(2@y) --> x^(2*y) --> (x^2) * y + fixPrec (TBin bop1 t1 (TBin bop2 t2 t3)) + | bPrec bop2 < bPrec bop1 = TBin bop2 (fixPrec $ TBin bop1 t1 t2) t3 + + fixPrec t = t + +-- | Parse an atomic type. +parseAtomicType :: Parser Type +parseAtomicType = label "type" $ + TyVoid <$ reserved "Void" + <|> TyUnit <$ reserved "Unit" + <|> TyBool <$ (reserved "Boolean" <|> reserved "Bool") + <|> TyProp <$ (reserved "Proposition" <|> reserved "Prop") + <|> TyC <$ reserved "Char" + -- <|> try parseTyFin + <|> TyN <$ (reserved "Natural" <|> reserved "Nat" <|> reserved "N" <|> reserved "ℕ") + <|> TyZ <$ (reserved "Integer" <|> reserved "Int" <|> reserved "Z" <|> reserved "ℤ") + <|> TyF <$ (reserved "Fractional" <|> reserved "Frac" <|> reserved "F" <|> reserved "𝔽") + <|> TyQ <$ (reserved "Rational" <|> reserved "Q" <|> reserved "ℚ") + <|> TyCon <$> parseCon <*> (fromMaybe [] <$> optional (parens (parseType `sepBy1` comma))) + <|> TyVar <$> parseTyVar + <|> parens parseType + +-- parseTyFin :: Parser Type +-- parseTyFin = TyFin <$> (reserved "Fin" *> natural) +-- <|> TyFin <$> (lexeme (string "Z" <|> string "ℤ") *> natural) + +parseCon :: Parser Con +parseCon = + CList <$ reserved "List" + <|> CBag <$ reserved "Bag" + <|> CSet <$ reserved "Set" + <|> CGraph <$ reserved "Graph" + <|> CMap <$ reserved "Map" + <|> CUser <$> parseTyDef + +parseTyDef :: Parser String +parseTyDef = identifier upperChar + +parseTyVarName :: Parser String +parseTyVarName = identifier lowerChar + +parseTyVar :: Parser (Name Type) +parseTyVar = string2Name <$> parseTyVarName + +parsePolyTy :: Parser PolyType +parsePolyTy = closeType <$> parseType + +-- | Parse a type expression built out of binary operators. +parseType :: Parser Type +parseType = makeExprParser parseAtomicType table + where + table = [ [ infixR "*" (:*:) + , infixR "×" (:*:) ] + , [ infixR "+" (:+:) + , infixR "⊎" (:+:) + ] + , [ infixR "->" (:->:) + , infixR "→" (:->:) + ] + ] + + infixR name fun = InfixR (reservedOp name >> return fun) + +parseTyOp :: Parser TyOp +parseTyOp = + Enumerate <$ reserved "enumerate" + <|> Count <$ reserved "count" + +parseTypeOp :: Parser Term +parseTypeOp = TTyOp <$> parseTyOp <*> parseAtomicType diff --git a/src/Disco/Pretty.hs b/src/Disco/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Pretty.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Pretty +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Various pretty-printing facilities for disco. +-- +----------------------------------------------------------------------------- + +-- TODO: the calls to 'error' should be replaced with logging/error capabilities. + +module Disco.Pretty + ( module Disco.Pretty.DSL + , module Disco.Pretty + , module Disco.Pretty.Prec + , Doc + ) + where + +import Prelude hiding ((<>)) + +import Data.Bifunctor +import Data.Char (isAlpha) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Ratio +import Data.Set (Set) +import qualified Data.Set as S + +import Disco.Effects.LFresh +import Polysemy + +import Polysemy.Reader + +import Text.PrettyPrint (Doc) +import Unbound.Generics.LocallyNameless (Name) + +import Disco.Pretty.DSL +import Disco.Pretty.Prec +import Disco.Syntax.Operators + +------------------------------------------------------------ +-- Utilities for handling precedence and associativity + +-- | Convenience function combining 'setPA' and 'mparens', since we +-- often want to simultaneously indicate what the precedence and +-- associativity of a term is, and optionally surround it with +-- parentheses depending on the precedence and associativity of its +-- parent. +withPA :: Member (Reader PA) r => PA -> Sem r Doc -> Sem r Doc +withPA pa = mparens pa . setPA pa + +-- | Locally set the precedence and associativity within a +-- subcomputation. +setPA :: Member (Reader PA) r => PA -> Sem r a -> Sem r a +setPA = local . const + +-- | Mark a subcomputation as pretty-printing a term on the left of an +-- operator (so parentheses can be inserted appropriately, depending +-- on the associativity). +lt :: Member (Reader PA) r => Sem r Doc -> Sem r Doc +lt = local (\(PA p _) -> PA p InL) + +-- | Mark a subcomputation as pretty-printing a term on the right of +-- an operator (so parentheses can be inserted appropriately, +-- depending on the associativity). +rt :: Member (Reader PA) r => Sem r Doc -> Sem r Doc +rt = local (\(PA p _) -> PA p InR) + +-- | Optionally surround a pretty-printed term with parentheses, +-- depending on its precedence and associativity (given as the 'PA' +-- argument) and that of its context (given by the ambient 'Reader +-- PA' effect). +mparens :: Member (Reader PA) r => PA -> Sem r Doc -> Sem r Doc +mparens pa doc = do + parentPA <- ask + (if pa < parentPA then parens else id) doc + +------------------------------------------------------------ +-- Pretty type class + +class Pretty t where + pretty :: Members '[Reader PA, LFresh] r => t -> Sem r Doc + +prettyStr :: Pretty t => t -> Sem r String +prettyStr = renderDoc . runLFresh . pretty + +pretty' :: Pretty t => t -> Sem r Doc +pretty' = runReader initPA . runLFresh . pretty + +------------------------------------------------------------ +-- Some standard instances + +instance Pretty a => Pretty [a] where + pretty = brackets . intercalate "," . map pretty + +instance (Pretty k, Pretty v) => Pretty (Map k v) where + pretty m = do + let es = map (\(k,v) -> pretty k <+> "->" <+> pretty v) (M.assocs m) + ds <- setPA initPA $ punctuate "," es + braces (hsep ds) + +instance Pretty a => Pretty (Set a) where + pretty = braces . intercalate "," . map pretty . S.toList + +------------------------------------------------------------ +-- Some Disco instances + +instance Pretty (Name a) where + pretty = text . show + +instance Pretty TyOp where + pretty = \case + Enumerate -> text "enumerate" + Count -> text "count" + +-- | Pretty-print a unary operator, by looking up its concrete syntax +-- in the 'uopMap'. +instance Pretty UOp where + pretty op = case M.lookup op uopMap of + Just (OpInfo _ (syn:_) _) -> + text $ syn ++ (if all isAlpha syn then " " else "") + _ -> error $ "UOp " ++ show op ++ " not in uopMap!" + +-- | Pretty-print a binary operator, by looking up its concrete syntax +-- in the 'bopMap'. +instance Pretty BOp where + pretty op = case M.lookup op bopMap of + Just (OpInfo _ (syn:_) _) -> text syn + _ -> error $ "BOp " ++ show op ++ " not in bopMap!" + +-------------------------------------------------- +-- Pretty-printing decimals + +-- | Pretty-print a rational number using its decimal expansion, in +-- the format @nnn.prefix[rep]...@, with any repeating digits enclosed +-- in square brackets. +prettyDecimal :: Rational -> String +prettyDecimal r = printedDecimal + where + (n,d) = properFraction r :: (Integer, Rational) + (expan, len) = digitalExpansion 10 (numerator d) (denominator d) + printedDecimal + | length first102 > 101 || length first102 == 101 && last first102 /= 0 + = show n ++ "." ++ concatMap show (take 100 expan) ++ "..." + | rep == [0] + = show n ++ "." ++ (if null pre then "0" else concatMap show pre) + | otherwise + = show n ++ "." ++ concatMap show pre ++ "[" ++ concatMap show rep ++ "]" + where + (pre, rep) = splitAt len expan + first102 = take 102 expan + +-- Given a list, find the indices of the list giving the first and +-- second occurrence of the first element to repeat, or Nothing if +-- there are no repeats. +findRep :: Ord a => [a] -> ([a], Int) +findRep = findRep' M.empty 0 + +findRep' :: Ord a => M.Map a Int -> Int -> [a] -> ([a], Int) +findRep' _ _ [] = error "Impossible. Empty list in findRep'" +findRep' prevs ix (x:xs) + | x `M.member` prevs = ([], prevs M.! x) + | otherwise = first (x:) $ findRep' (M.insert x ix prevs) (ix+1) xs + +-- | @digitalExpansion b n d@ takes the numerator and denominator of a +-- fraction n/d between 0 and 1, and returns a pair of (1) a list of +-- digits @ds@, and (2) a nonnegative integer k such that @splitAt k +-- ds = (prefix, rep)@, where the infinite base-b expansion of +-- n/d is 0.@(prefix ++ cycle rep)@. For example, +-- +-- > digitalExpansion 10 1 4 = ([2,5,0], 2) +-- > digitalExpansion 10 1 7 = ([1,4,2,8,5,7], 0) +-- > digitalExpansion 10 3 28 = ([1,0,7,1,4,2,8,5], 2) +-- > digitalExpansion 2 1 5 = ([0,0,1,1], 0) +-- +-- It works by performing the standard long division algorithm, and +-- looking for the first time that the remainder repeats. +digitalExpansion :: Integer -> Integer -> Integer -> ([Integer], Int) +digitalExpansion b n d = digits + where + longDivStep (_, r) = (b*r) `divMod` d + res = tail $ iterate longDivStep (0,n) + digits = first (map fst) (findRep res) diff --git a/src/Disco/Pretty/DSL.hs b/src/Disco/Pretty/DSL.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Pretty/DSL.hs @@ -0,0 +1,107 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Pretty.DSL +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Adapter DSL on top of Text.PrettyPrint for Applicative pretty-printing. +-- +----------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Disco.Pretty.DSL where + +import Control.Applicative hiding (empty) +import Data.String (IsString (..)) +import Prelude hiding ((<>)) + +import Polysemy +import Polysemy.Reader + +import Text.PrettyPrint (Doc) +import qualified Text.PrettyPrint as PP + +import Disco.Pretty.Prec + +instance IsString (Sem r Doc) where + fromString = text + +------------------------------------------------------------ +-- Adapter DSL +-- +-- Each combinator here mirrors one from Text.PrettyPrint, but +-- operates over a generic functor/monad. + +vcat :: Applicative f => [f Doc] -> f Doc +vcat ds = PP.vcat <$> sequenceA ds + +hcat :: Applicative f => [f Doc] -> f Doc +hcat ds = PP.hcat <$> sequenceA ds + +hsep :: Applicative f => [f Doc] -> f Doc +hsep ds = PP.hsep <$> sequenceA ds + +parens :: Functor f => f Doc -> f Doc +parens = fmap PP.parens + +brackets :: Functor f => f Doc -> f Doc +brackets = fmap PP.brackets + +braces :: Functor f => f Doc -> f Doc +braces = fmap PP.braces + +bag :: Applicative f => f Doc -> f Doc +bag p = text "⟅" <> p <> text "⟆" + +quotes :: Functor f => f Doc -> f Doc +quotes = fmap PP.quotes + +doubleQuotes :: Functor f => f Doc -> f Doc +doubleQuotes = fmap PP.doubleQuotes + +text :: Applicative m => String -> m Doc +text = pure . PP.text + +integer :: Applicative m => Integer -> m Doc +integer = pure . PP.integer + +nest :: Functor f => Int -> f Doc -> f Doc +nest n d = PP.nest n <$> d + +hang :: Applicative f => f Doc -> Int -> f Doc -> f Doc +hang d1 n d2 = PP.hang <$> d1 <*> pure n <*> d2 + +empty :: Applicative m => m Doc +empty = pure PP.empty + +(<+>) :: Applicative f => f Doc -> f Doc -> f Doc +(<+>) = liftA2 (PP.<+>) + +(<>) :: Applicative f => f Doc -> f Doc -> f Doc +(<>) = liftA2 (PP.<>) + +($+$) :: Applicative f => f Doc -> f Doc -> f Doc +($+$) = liftA2 (PP.$+$) + +punctuate :: Applicative f => f Doc -> [f Doc] -> f [f Doc] +punctuate p ds = map pure <$> (PP.punctuate <$> p <*> sequenceA ds) + +intercalate :: Monad f => f Doc -> [f Doc] -> f Doc +intercalate p ds = do + ds' <- punctuate p ds + hsep ds' + +bulletList :: Applicative f => f Doc -> [f Doc] -> f Doc +bulletList bullet = vcat . map (hang bullet 2) + +------------------------------------------------------------ +-- Running a pretty-printer + +renderDoc :: Sem (Reader PA ': r) Doc -> Sem r String +renderDoc = fmap PP.render . runReader initPA + +renderDoc' :: Doc -> String +renderDoc' = PP.render diff --git a/src/Disco/Pretty/Prec.hs b/src/Disco/Pretty/Prec.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Pretty/Prec.hs @@ -0,0 +1,53 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Pretty.Prec +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Precedence and associativity for pretty-printing. +-- +----------------------------------------------------------------------------- + +module Disco.Pretty.Prec where + +import Disco.Syntax.Operators + +-- Types for storing precedence + associativity together + +type Prec = Int + +data PA = PA Prec BFixity + deriving (Show, Eq) + +instance Ord PA where + compare (PA p1 a1) (PA p2 a2) = compare p1 p2 `mappend` (if a1 == a2 then EQ else LT) + +-- Standard precedence levels + +initPA :: PA +initPA = PA 0 InL + +ascrPA :: PA +ascrPA = PA 1 InL + +funPA :: PA +funPA = PA funPrec InL + +rPA :: Int -> PA +rPA n = PA n InR + +tarrPA, taddPA, tmulPA, tfunPA :: PA +tarrPA = rPA 1 +taddPA = rPA 6 +tmulPA = rPA 7 +tfunPA = PA 9 InL + +-- Converting UOp and BOp + +ugetPA :: UOp -> PA +ugetPA op = PA (uPrec op) In + +getPA :: BOp -> PA +getPA op = PA (bPrec op) (assoc op) diff --git a/src/Disco/Property.hs b/src/Disco/Property.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Property.hs @@ -0,0 +1,53 @@ + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Property +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Properties of disco functions. +-- +----------------------------------------------------------------------------- + +module Disco.Property + where + +import qualified Data.Enumeration.Invertible as E +import qualified Test.QuickCheck as QC + +import Disco.Effects.Random +import Polysemy + +import Disco.Value + +-- | Toggles which outcome (finding or not finding the thing being +-- searched for) qualifies as success, without changing the thing +-- being searched for. +invertMotive :: SearchMotive -> SearchMotive +invertMotive (SearchMotive (a, b)) = SearchMotive (not a, b) + +-- | Flips the success or failure status of a @PropResult@, leaving +-- the explanation unchanged. +invertPropResult :: TestResult -> TestResult +invertPropResult res@(TestResult b r env) + | TestRuntimeError _ <- r = res + | otherwise = TestResult (not b) r env + +-- | Select samples from an enumeration according to a search type. Also returns +-- a 'SearchType' describing the results, which may be 'Exhaustive' if the +-- enumeration is no larger than the number of samples requested. +generateSamples :: Member Random r => SearchType -> E.IEnumeration a -> Sem r ([a], SearchType) +generateSamples Exhaustive e = return (E.enumerate e, Exhaustive) +generateSamples (Randomized n m) e + | E.Finite k <- E.card e, k <= n + m = return (E.enumerate e, Exhaustive) + | otherwise = do + let small = [0 .. n] + rs <- runGen . mapM sizedNat $ [n .. n + m] + let samples = map (E.select e) $ small ++ rs + return (samples, Randomized n m) + where + sizedNat k = QC.resize (fromIntegral k) QC.arbitrarySizedNatural + +-- XXX do shrinking for randomly generated test cases? diff --git a/src/Disco/Report.hs b/src/Disco/Report.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Report.hs @@ -0,0 +1,55 @@ + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Report +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- XXX +-- +----------------------------------------------------------------------------- + +-- The benefit of having our own deeply-embedded type for pretty +-- printing things would be so we can render it in different backend +-- formats later (text, LaTeX, HTML, ...) so at some point it may be +-- worth doing it. The idea would be to mostly replicate the +-- interface of the pretty-printing library currently being used, so +-- that a lot of code could just be kept unchanged. + +module Disco.Report where + +import Data.List (intersperse) + +data Report + = RTxt String + | RSeq [Report] + | RVSeq [Report] + | RList [Report] + | RNest Report + deriving (Show) + +text :: String -> Report +text = RTxt + +hcat :: [Report] -> Report +hcat = RSeq + +hsep :: [Report] -> Report +hsep = hcat . intersperse (text " ") + +vcat :: [Report] -> Report +vcat = RVSeq + +vsep :: [Report] -> Report +vsep = vcat . intersperse (text "") + +list :: [Report] -> Report +list = RList + +nest :: Report -> Report +nest = RNest + +------------------------------------------------------------ + diff --git a/src/Disco/Subst.hs b/src/Disco/Subst.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Subst.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Subst +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- The "Disco.Subst" module defines a generic type of substitutions +-- that map variable names to values. +-- +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + +module Disco.Subst + ( -- * Substitutions + + Substitution(..), dom + + -- ** Constructing/destructing substitutions + + , idS, (|->), fromList, toList + + -- ** Substitution operations + + , (@@), compose, applySubst, lookup + + ) + where + +import Prelude hiding (lookup) + +import Unbound.Generics.LocallyNameless (Name, Subst, substs) + +import Data.Coerce + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) + +import Disco.Effects.LFresh +import Disco.Pretty +import Polysemy +import Polysemy.Reader + +-- | A value of type @Substitution a@ is a substitution which maps some set of +-- names (the /domain/, see 'dom') to values of type @a@. +-- Substitutions can be /applied/ to certain terms (see +-- 'applySubst'), replacing any free occurrences of names in the +-- domain with their corresponding values. Thus, substitutions can +-- be thought of as functions of type @Term -> Term@ (for suitable +-- @Term@s that contain names and values of the right type). +-- +-- Concretely, substitutions are stored using a @Map@. +-- +-- See also "Disco.Types", which defines 'S' as an alias for +-- substitutions on types (the most common kind in the disco +-- codebase). +newtype Substitution a = Substitution { getSubst :: Map (Name a) a } + deriving (Eq, Ord, Show) + +instance Functor Substitution where + fmap f (Substitution m) = Substitution (M.mapKeys coerce . M.map f $ m) + +instance Pretty a => Pretty (Substitution a) where + pretty (Substitution s) = do + let es = map (uncurry prettyMapping) (M.assocs s) + ds <- punctuate "," es + braces (hsep ds) + +prettyMapping :: (Pretty a, Members '[Reader PA, LFresh] r) => Name a -> a -> Sem r Doc +prettyMapping x a = pretty x <+> "->" <+> pretty a + +-- | The domain of a substitution is the set of names for which the +-- substitution is defined. +dom :: Substitution a -> Set (Name a) +dom = M.keysSet . getSubst + +-- | The identity substitution, /i.e./ the unique substitution with an +-- empty domain, which acts as the identity function on terms. +idS :: Substitution a +idS = Substitution M.empty + +-- | Construct a singleton substitution, which maps the given name to +-- the given value. +(|->) :: Name a -> a -> Substitution a +x |-> t = Substitution (M.singleton x t) + +-- | Compose two substitutions. Applying @s1 \@\@ s2@ is the same as +-- applying first @s2@, then @s1@; that is, semantically, +-- composition of substitutions corresponds exactly to function +-- composition when they are considered as functions on terms. +-- +-- As one would expect, composition is associative and has 'idS' as +-- its identity. +(@@) :: Subst a a => Substitution a -> Substitution a -> Substitution a +(Substitution s1) @@ (Substitution s2) = Substitution ((M.map (applySubst (Substitution s1))) s2 `M.union` s1) + +-- | Compose a whole container of substitutions. For example, +-- @compose [s1, s2, s3] = s1 \@\@ s2 \@\@ s3@. +compose :: (Subst a a, Foldable t) => t (Substitution a) -> Substitution a +compose = foldr (@@) idS + +-- | Apply a substitution to a term, resulting in a new term in which +-- any free variables in the domain of the substitution have been +-- replaced by their corresponding values. Note this requires a +-- @Subst b a@ constraint, which intuitively means that values of +-- type @a@ contain variables of type @b@ we can substitute for. +applySubst :: Subst b a => Substitution b -> a -> a +applySubst (Substitution s) = substs (M.assocs s) + +-- | Create a substitution from an association list of names and +-- values. +fromList :: [(Name a, a)] -> Substitution a +fromList = Substitution . M.fromList + +-- | Convert a substitution into an association list. +toList :: Substitution a -> [(Name a, a)] +toList (Substitution m) = M.assocs m + +-- | Look up the value a particular name maps to under the given +-- substitution; or return @Nothing@ if the name being looked up is +-- not in the domain. +lookup :: Name a -> Substitution a -> Maybe a +lookup x (Substitution m) = M.lookup x m diff --git a/src/Disco/Syntax/Operators.hs b/src/Disco/Syntax/Operators.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Syntax/Operators.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Syntax.Operators +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- Unary and binary operators along with information like precedence, +-- fixity, and concrete syntax. +-- +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + +module Disco.Syntax.Operators + ( -- * Operators + UOp(..), BOp(..), TyOp(..) + + -- * Operator info + , UFixity(..), BFixity(..), OpFixity(..), OpInfo(..) + + -- * Operator tables and lookup + , opTable, uopMap, bopMap + , uPrec, bPrec, assoc, funPrec + + ) where + +import Data.Data (Data) +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless + +import Data.Map (Map, (!)) +import qualified Data.Map as M + +------------------------------------------------------------ +-- Operators +------------------------------------------------------------ + +-- | Unary operators. +data UOp = Neg -- ^ Arithmetic negation (@-@) + | Not -- ^ Logical negation (@not@) + | Fact -- ^ Factorial (@!@) + deriving (Show, Read, Eq, Ord, Generic, Data, Alpha, Subst t) + +-- | Binary operators. +data BOp = Add -- ^ Addition (@+@) + | Sub -- ^ Subtraction (@-@) + | SSub -- ^ Saturating Subtraction (@.-@ / @∸@) + | Mul -- ^ Multiplication (@*@) + | Div -- ^ Division (@/@) + | Exp -- ^ Exponentiation (@^@) + | IDiv -- ^ Integer division (@//@) + | Eq -- ^ Equality test (@==@) + | Neq -- ^ Not-equal (@/=@) + | Lt -- ^ Less than (@<@) + | Gt -- ^ Greater than (@>@) + | Leq -- ^ Less than or equal (@<=@) + | Geq -- ^ Greater than or equal (@>=@) + | Min -- ^ Minimum (@min@) + | Max -- ^ Maximum (@max@) + | And -- ^ Logical and (@&&@ / @and@) + | Or -- ^ Logical or (@||@ / @or@) + | Impl -- ^ Logical implies (@==>@ / @implies@) + | Mod -- ^ Modulo (@mod@) + | Divides -- ^ Divisibility test (@|@) + | Choose -- ^ Binomial and multinomial coefficients (@choose@) + | Cons -- ^ List cons (@::@) + | Union -- ^ Union of two sets (@union@ / @∪@) + | Inter -- ^ Intersection of two sets (@intersect@ / @∩@) + | Diff -- ^ Difference between two sets (@\@) + | Elem -- ^ Element test (@∈@) + | Subset -- ^ Subset test (@⊆@) + | ShouldEq -- ^ Equality assertion (@=!=@) + deriving (Show, Read, Eq, Ord, Generic, Data, Alpha, Subst t) + +-- | Type operators. +data TyOp = Enumerate -- ^ List all values of a type + | Count -- ^ Count how many values there are of a type + deriving (Show, Eq, Ord, Generic, Data, Alpha, Subst t) + +------------------------------------------------------------ +-- Operator info +------------------------------------------------------------ + +-- | Fixities of unary operators (either pre- or postfix). +data UFixity + = Pre -- ^ Unary prefix. + | Post -- ^ Unary postfix. + deriving (Eq, Ord, Enum, Bounded, Show, Generic) + +-- | Fixity/associativity of infix binary operators (either left, +-- right, or non-associative). +data BFixity + = InL -- ^ Left-associative infix. + | InR -- ^ Right-associative infix. + | In -- ^ Infix. + deriving (Eq, Ord, Enum, Bounded, Show, Generic) + +-- | Operators together with their fixity. +data OpFixity = + UOpF UFixity UOp + | BOpF BFixity BOp + deriving (Eq, Show, Generic) + +-- | An @OpInfo@ record contains information about an operator, such +-- as the operator itself, its fixity, a list of concrete syntax +-- representations, and a numeric precedence level. +data OpInfo = + OpInfo + { opFixity :: OpFixity + , opSyns :: [String] + , opPrec :: Int + } + deriving Show + +------------------------------------------------------------ +-- Operator table +------------------------------------------------------------ + +-- | The @opTable@ lists all the operators in the language, in order +-- of precedence (highest precedence first). Operators in the same +-- list have the same precedence. This table is used by both the +-- parser and the pretty-printer. +opTable :: [[OpInfo]] +opTable = + assignPrecLevels + [ [ uopInfo Pre Not ["not", "¬"] + ] + , [ uopInfo Post Fact ["!"] + ] + , [ bopInfo InR Exp ["^"] + ] + , [ uopInfo Pre Neg ["-"] + ] + , [ bopInfo In Choose ["choose"] + ] + , [ bopInfo InL Union ["union", "∪"] + , bopInfo InL Inter ["intersect", "∩"] + , bopInfo InL Diff ["\\"] + ] + , [ bopInfo InL Min ["min"] + , bopInfo InL Max ["max"] + ] + , [ bopInfo InL Mul ["*"] + , bopInfo InL Div ["/"] + , bopInfo InL Mod ["%"] + , bopInfo InL Mod ["mod"] + , bopInfo InL IDiv ["//"] + ] + , [ bopInfo InL Add ["+"] + , bopInfo InL Sub ["-"] + , bopInfo InL SSub [".-", "∸"] + ] + , [ bopInfo InR Cons ["::"] + ] + , [ bopInfo InR Eq ["=="] + , bopInfo InR ShouldEq ["=!="] + , bopInfo InR Neq ["/=", "≠"] + , bopInfo InR Lt ["<"] + , bopInfo InR Gt [">"] + , bopInfo InR Leq ["<=", "≤"] + , bopInfo InR Geq [">=", "≥"] + , bopInfo InR Divides ["divides"] + , bopInfo InL Subset ["subset", "⊆"] + , bopInfo InL Elem ["elem", "∈"] + ] + , [ bopInfo InR And ["and", "∧", "&&"] + ] + , [ bopInfo InR Or ["or", "∨", "||"] + ] + , [ bopInfo InR Impl ["==>", "implies"] + ] + ] + where + uopInfo fx op syns = OpInfo (UOpF fx op) syns (-1) + bopInfo fx op syns = OpInfo (BOpF fx op) syns (-1) + + -- Start at precedence level 2 so we can give level 1 to ascription, and level 0 + -- to the ambient context + parentheses etc. + assignPrecLevels table = zipWith assignPrecs (reverse [2 .. length table+1]) table + assignPrecs p ops = map (assignPrec p) ops + assignPrec p op = op { opPrec = p } + +-- | A map from all unary operators to their associated 'OpInfo' records. +uopMap :: Map UOp OpInfo +uopMap = M.fromList $ + [ (op, info) | opLevel <- opTable, info@(OpInfo (UOpF _ op) _ _) <- opLevel ] + +-- | A map from all binary operators to their associatied 'OpInfo' records. +bopMap :: Map BOp OpInfo +bopMap = M.fromList $ + [ (op, info) | opLevel <- opTable, info@(OpInfo (BOpF _ op) _ _) <- opLevel ] + +-- | A convenient function for looking up the precedence of a unary operator. +uPrec :: UOp -> Int +uPrec = opPrec . (uopMap !) + +-- | A convenient function for looking up the precedence of a binary operator. +bPrec :: BOp -> Int +bPrec = opPrec . (bopMap !) + +-- | Look up the \"fixity\" (/i.e./ associativity) of a binary operator. +assoc :: BOp -> BFixity +assoc op = + case M.lookup op bopMap of + Just (OpInfo (BOpF fx _) _ _) -> fx + _ -> error $ "BOp " ++ show op ++ " not in bopMap!" + +-- | The precedence level of function application (higher than any +-- other precedence level). +funPrec :: Int +funPrec = length opTable+1 diff --git a/src/Disco/Syntax/Prims.hs b/src/Disco/Syntax/Prims.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Syntax/Prims.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Syntax.Prims +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- Concrete syntax for the prims (i.e. built-in constants) supported +-- by the language. +-- +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + +module Disco.Syntax.Prims + ( Prim(..) + , PrimInfo(..), primTable, toPrim, primMap, primDoc, primReference + ) where + +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless + +import Data.Map (Map) +import qualified Data.Map as M + +import Data.Data (Data) +import Disco.Syntax.Operators +import Disco.Util ((==>)) + +------------------------------------------------------------ +-- Prims +------------------------------------------------------------ + +-- | Primitives, /i.e./ built-in constants. +data Prim where + PrimUOp :: UOp -> Prim -- ^ Unary operator + PrimBOp :: BOp -> Prim -- ^ Binary operator + + PrimLeft :: Prim -- ^ Left injection into a sum type. + PrimRight :: Prim -- ^ Right injection into a sum type. + + PrimSqrt :: Prim -- ^ Integer square root (@sqrt@) + PrimFloor :: Prim -- ^ Floor of fractional type (@floor@) + PrimCeil :: Prim -- ^ Ceiling of fractional type (@ceiling@) + PrimAbs :: Prim -- ^ Absolute value (@abs@) + + PrimSize :: Prim -- ^ Size of a set (XXX should be in library) + PrimPower :: Prim -- ^ Power set (XXX or bag?) + + PrimList :: Prim -- ^ Container -> list conversion + PrimBag :: Prim -- ^ Container -> bag conversion + PrimSet :: Prim -- ^ Container -> set conversion + + PrimB2C :: Prim -- ^ bag -> set of counts conversion + PrimC2B :: Prim -- ^ set of counts -> bag conversion + PrimMapToSet :: Prim -- ^ Map k v -> Set (k × v) + PrimSetToMap :: Prim -- ^ Set (k × v) -> Map k v + + PrimSummary :: Prim -- ^ Get Adjacency list of Graph + PrimVertex :: Prim -- ^ Construct a graph Vertex + PrimEmptyGraph :: Prim -- ^ Empty graph + PrimOverlay :: Prim -- ^ Overlay two Graphs + PrimConnect :: Prim -- ^ Connect Graph to another with directed edges + + PrimInsert :: Prim -- ^ Insert into map + PrimLookup :: Prim -- ^ Get value associated with key in map + + PrimEach :: Prim -- ^ Each operation for containers + PrimReduce :: Prim -- ^ Reduce operation for containers + PrimFilter :: Prim -- ^ Filter operation for containers + PrimJoin :: Prim -- ^ Monadic join for containers + PrimMerge :: Prim -- ^ Generic merge operation for bags/sets + + PrimIsPrime :: Prim -- ^ Efficient primality test + PrimFactor :: Prim -- ^ Factorization + PrimFrac :: Prim -- ^ Turn a rational into a pair (num, denom) + + PrimCrash :: Prim -- ^ Crash + + PrimUntil :: Prim -- ^ @[x, y, z .. e]@ + + PrimHolds :: Prim -- ^ Test whether a proposition holds + + PrimLookupSeq :: Prim -- ^ Lookup OEIS sequence + PrimExtendSeq :: Prim -- ^ Extend OEIS sequence + deriving (Show, Read, Eq, Ord, Generic, Alpha, Subst t, Data) + +------------------------------------------------------------ +-- Concrete syntax for prims +------------------------------------------------------------ + +-- | An info record for a single primitive name, containing the +-- primitive itself, its concrete syntax, and whether it is +-- "exposed", /i.e./ available to be used in the surface syntax of +-- the basic language. Unexposed prims can only be referenced by +-- enabling the Primitives language extension and prefixing their +-- name by @$@. +data PrimInfo = + PrimInfo + { thePrim :: Prim + , primSyntax :: String + , primExposed :: Bool + -- Is the prim available in the normal syntax of the language? + -- + -- primExposed = True means that the bare primSyntax can be used + -- in the surface syntax, and the prim will be pretty-printed as + -- the primSyntax. + -- + -- primExposed = False means that the only way to enter it is to + -- enable the Primitives language extension and write a $ + -- followed by the primSyntax. The prim will be pretty-printed with a $ + -- prefix. + -- + -- In no case is a prim a reserved word. + } + +-- | A table containing a 'PrimInfo' record for every non-operator +-- 'Prim' recognized by the language. +primTable :: [PrimInfo] +primTable = + [ PrimInfo PrimLeft "left" True + , PrimInfo PrimRight "right" True + + , PrimInfo (PrimUOp Not) "not" True + , PrimInfo PrimSqrt "sqrt" True + , PrimInfo PrimFloor "floor" True + , PrimInfo PrimCeil "ceiling" True + , PrimInfo PrimAbs "abs" True + + , PrimInfo PrimSize "size" True + , PrimInfo PrimPower "power" True + + , PrimInfo PrimList "list" True + , PrimInfo PrimBag "bag" True + , PrimInfo PrimSet "set" True + + , PrimInfo PrimB2C "bagCounts" True + , PrimInfo PrimC2B "bagFromCounts" True + , PrimInfo PrimMapToSet "mapToSet" True + , PrimInfo PrimSetToMap "map" True + + , PrimInfo PrimSummary "summary" True + , PrimInfo PrimVertex "vertex" True + , PrimInfo PrimEmptyGraph "emptyGraph" True + , PrimInfo PrimOverlay "overlay" True + , PrimInfo PrimConnect "connect" True + + , PrimInfo PrimInsert "insert" True + , PrimInfo PrimLookup "lookup" True + + , PrimInfo PrimEach "each" True + , PrimInfo PrimReduce "reduce" True + , PrimInfo PrimFilter "filter" True + , PrimInfo PrimJoin "join" False + , PrimInfo PrimMerge "merge" False + + , PrimInfo PrimIsPrime "isPrime" False + , PrimInfo PrimFactor "factor" False + , PrimInfo PrimFrac "frac" False + + , PrimInfo PrimCrash "crash" False + + , PrimInfo PrimUntil "until" False + + , PrimInfo PrimHolds "holds" True + + , PrimInfo PrimLookupSeq "lookupSequence" False + , PrimInfo PrimExtendSeq "extendSequence" False + ] + +-- | Find any exposed prims with the given name. +toPrim :: String -> [Prim] +toPrim x = [ p | PrimInfo p syn True <- primTable, syn == x ] + +-- | A convenient map from each 'Prim' to its info record. +primMap :: Map Prim PrimInfo +primMap = M.fromList $ + [ (p, pinfo) | pinfo@(PrimInfo p _ _) <- primTable ] + +-- | A map from some primitives to a short descriptive string, +-- to be shown by the :doc command. +primDoc :: Map Prim String +primDoc = M.fromList + [ PrimUOp Neg ==> "Arithmetic negation." + , PrimBOp Add ==> "The sum of two numbers, types, or graphs." + , PrimBOp Sub ==> "The difference of two numbers." + , PrimBOp SSub ==> "The difference of two numbers, with a lower bound of 0." + , PrimBOp Mul ==> "The product of two numbers, types, or graphs." + , PrimBOp Div ==> "Divide two numbers." + , PrimBOp IDiv ==> "The integer quotient of two numbers, rounded down." + , PrimBOp Mod ==> "a mod b is the remainder when a is divided by b." + , PrimBOp Exp ==> "Exponentiation. a ^ b is a raised to the b power." + , PrimUOp Fact ==> "n! computes the factorial of n, that is, 1 * 2 * ... * n." + , PrimFloor ==> "floor(x) is the largest integer which is <= x." + , PrimCeil ==> "ceiling(x) is the smallest integer which is >= x." + , PrimAbs ==> "abs(x) is the absolute value of x. Also written |x|." + , PrimUOp Not ==> "Logical negation: ¬true = false and ¬false = true. Also written 'not'." + , PrimBOp And ==> "Logical conjunction (and): true and true = true; otherwise x and y = false." + , PrimBOp Or ==> "Logical disjunction (or): false or false = false; otherwise x or y = true." + , PrimBOp Impl ==> "Logical implication (implies): true ==> false = false; otherwise x ==> y = true." + , PrimBOp Eq ==> "Equality test. x == y is true if x and y are equal." + , PrimBOp Neq ==> "Inequality test. x /= y is true if x and y are unequal." + , PrimBOp Lt ==> "Less-than test. x < y is true if x is less than (but not equal to) y." + , PrimBOp Gt ==> "Greater-than test. x > y is true if x is greater than (but not equal to) y." + , PrimBOp Leq ==> "Less-than-or-equal test. x <= y is true if x is less than or equal to y." + , PrimBOp Geq ==> "Greater-than-or-equal test. x >= y is true if x is greater than or equal to y." + + ] + +-- | A map from some primitives to their corresponding page in the +-- Disco language reference +-- (https://disco-lang.readthedocs.io/en/latest/reference/index.html). +primReference :: Map Prim String +primReference = M.fromList + [ PrimBOp Add ==> "addition" + , PrimBOp Sub ==> "subtraction" + , PrimBOp SSub ==> "subtraction" + , PrimBOp Mul ==> "multiplication" + , PrimBOp Div ==> "division" + , PrimBOp IDiv ==> "integerdiv" + , PrimBOp Mod ==> "mod" + , PrimBOp Exp ==> "exponentiation" + , PrimUOp Fact ==> "factorial" + , PrimFloor ==> "round" + , PrimCeil ==> "round" + , PrimAbs ==> "abs" + , PrimUOp Not ==> "not" + ] diff --git a/src/Disco/Typecheck.hs b/src/Disco/Typecheck.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Typecheck.hs @@ -0,0 +1,1604 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Typecheck +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Typecheck the Disco surface language and transform it into a +-- type-annotated AST. +-- +----------------------------------------------------------------------------- + +module Disco.Typecheck where + +import Control.Arrow ((&&&)) +import Control.Lens ((^..)) +import Control.Monad.Except +import Control.Monad.Trans.Maybe +import Data.Bifunctor (first) +import Data.Coerce +import qualified Data.Foldable as F +import Data.List (group, sort) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (isJust) +import Data.Set (Set) +import qualified Data.Set as S +import Prelude as P hiding (lookup) + +import Unbound.Generics.LocallyNameless (Alpha, Bind, Name, + bind, embed, + name2String, + string2Name, substs, + unembed) +import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) + +import Disco.Effects.Fresh +import Polysemy hiding (embed) +import Polysemy.Error +import Polysemy.Output +import Polysemy.Reader +import Polysemy.Writer + +import Disco.AST.Surface +import Disco.AST.Typed +import Disco.Context hiding (filter) +import qualified Disco.Context as Ctx +import Disco.Messages +import Disco.Module +import Disco.Names +import Disco.Subst (applySubst) +import qualified Disco.Subst as Subst +import Disco.Syntax.Operators +import Disco.Syntax.Prims +import Disco.Typecheck.Constraints +import Disco.Typecheck.Util +import Disco.Types +import Disco.Types.Rules + +------------------------------------------------------------ +-- Container utilities +------------------------------------------------------------ + +containerTy :: Container -> Type -> Type +containerTy c ty = TyCon (containerToCon c) [ty] + +containerToCon :: Container -> Con +containerToCon ListContainer = CList +containerToCon BagContainer = CBag +containerToCon SetContainer = CSet + +------------------------------------------------------------ +-- Telescopes +------------------------------------------------------------ + +-- | Infer the type of a telescope, given a way to infer the type of +-- each item along with a context of variables it binds; each such +-- context is then added to the overall context when inferring +-- subsequent items in the telescope. +inferTelescope + :: (Alpha b, Alpha tyb, Member (Reader TyCtx) r) + => (b -> Sem r (tyb, TyCtx)) -> Telescope b -> Sem r (Telescope tyb, TyCtx) +inferTelescope inferOne tel = do + (tel1, ctx) <- go (fromTelescope tel) + return (toTelescope tel1, ctx) + where + go [] = return ([], emptyCtx) + go (b:bs) = do + (tyb, ctx) <- inferOne b + extends ctx $ do + (tybs, ctx') <- go bs + return (tyb:tybs, ctx <> ctx') + +------------------------------------------------------------ +-- Modules +------------------------------------------------------------ + +-- | Check all the types and extract all relevant info (docs, +-- properties, types) from a module, returning a 'ModuleInfo' record +-- on success. This function does not handle imports at all; any +-- imports should already be checked and passed in as the second +-- argument. +checkModule + :: Members '[Output Message, Reader TyCtx, Reader TyDefCtx, Error TCError, Fresh] r + => ModuleName -> Map ModuleName ModuleInfo -> Module -> Sem r ModuleInfo +checkModule name imports (Module es _ m docs terms) = do + let (typeDecls, defns, tydefs) = partitionDecls m + importTyCtx = mconcat (imports ^.. traverse . miTys) + -- XXX this isn't right, if multiple modules define the same type synonyms. + -- Need to use a normal Ctx for tydefs too. + importTyDefnCtx = M.unions (imports ^.. traverse . miTydefs) + tyDefnCtx <- makeTyDefnCtx tydefs + withTyDefns (tyDefnCtx `M.union` importTyDefnCtx) $ do + tyCtx <- makeTyCtx name typeDecls + extends importTyCtx $ extends tyCtx $ do + mapM_ checkTyDefn tydefs + adefns <- mapM (checkDefn name) defns + let defnCtx = ctxForModule name (map (getDefnName &&& id) adefns) + docCtx = ctxForModule name docs + dups = filterDups . map getDefnName $ adefns + case dups of + (x:_) -> throw $ DuplicateDefns (coerce x) + [] -> do + aprops <- checkProperties docCtx + aterms <- mapM inferTop terms + return $ ModuleInfo name imports docCtx aprops tyCtx tyDefnCtx defnCtx aterms es + where getDefnName :: Defn -> Name ATerm + getDefnName (Defn n _ _ _) = n + +-------------------------------------------------- +-- Type definitions + +-- | Turn a list of type definitions into a 'TyDefCtx', checking +-- for duplicate names among the definitions and also any type +-- definitions already in the context. +makeTyDefnCtx :: Members '[Reader TyDefCtx, Error TCError] r => [TypeDefn] -> Sem r TyDefCtx +makeTyDefnCtx tydefs = do + oldTyDefs <- ask @TyDefCtx + let oldNames = M.keys oldTyDefs + newNames = map (\(TypeDefn x _ _) -> x) tydefs + dups = filterDups $ newNames ++ oldNames + + let convert (TypeDefn x args body) + = (x, TyDefBody args (flip substs body . zip (map string2Name args))) + + case dups of + (x:_) -> throw (DuplicateTyDefns x) + [] -> return . M.fromList $ map convert tydefs + +-- | Check the validity of a type definition. +checkTyDefn :: Members '[Reader TyDefCtx, Error TCError] r => TypeDefn -> Sem r () +checkTyDefn defn@(TypeDefn x args body) = do + + -- First, make sure the body is a valid type, i.e. everything inside + -- it is well-kinded. + checkTypeValid body + + -- Now make sure it is not directly cyclic (i.e. ensure it is a + -- "productive" definition). + _ <- checkCyclicTy (TyUser x (map (TyVar . string2Name) args)) S.empty + + -- Make sure it does not use any unbound type variables or undefined + -- types. + checkUnboundVars defn + + -- Make sure it does not use any polymorphic recursion (polymorphic + -- recursion isn't allowed at the moment since it can make the + -- subtyping checker diverge). + checkPolyRec defn + +-- | Check if a given type is cyclic. A type 'ty' is cyclic if: +-- +-- 1. 'ty' is the name of a user-defined type. +-- 2. Repeated expansions of the type yield nothing but other user-defined types. +-- 3. An expansion of one of those types yields another type that has +-- been previously encountered. +-- +-- In other words, repeatedly expanding the definition can get us +-- back to exactly where we started. +-- +-- The function returns the set of TyDefs encountered during +-- expansion if the TyDef is not cyclic. +checkCyclicTy :: Members '[Reader TyDefCtx, Error TCError] r => Type -> Set String -> Sem r (Set String) +checkCyclicTy (TyUser name args) set = do + case S.member name set of + True -> throw $ CyclicTyDef name + False -> do + ty <- lookupTyDefn name args + checkCyclicTy ty (S.insert name set) + +checkCyclicTy _ set = return set + +-- | Ensure that a type definition does not use any unbound type +-- variables or undefined types. +checkUnboundVars :: Members '[Reader TyDefCtx, Error TCError] r => TypeDefn -> Sem r () +checkUnboundVars (TypeDefn _ args body) = go body + where + go (TyAtom (AVar (U x))) + | name2String x `elem` args = return () + | otherwise = throw $ UnboundTyVar x + go (TyAtom _) = return () + go (TyUser name tys) = lookupTyDefn name tys >> mapM_ go tys + go (TyCon _ tys) = mapM_ go tys + +-- | Check for polymorphic recursion: starting from a user-defined +-- type, keep expanding its definition recursively, ensuring that +-- any recursive references to the defined type have only type variables +-- as arguments. +checkPolyRec :: Member (Error TCError) r => TypeDefn -> Sem r () +checkPolyRec (TypeDefn name args body) = go body + where + go (TyCon (CUser x) tys) + | x == name && not (all isTyVar tys) = + throw $ NoPolyRec name args tys + | otherwise = return () + go (TyCon _ tys) = mapM_ go tys + go _ = return () + +-- | Keep only the duplicate elements from a list. +-- +-- >>> filterDups [1,3,2,1,1,4,2] +-- [1,2] +filterDups :: Ord a => [a] -> [a] +filterDups = map head . filter ((>1) . length) . group . sort + +-------------------------------------------------- +-- Type declarations + +-- | Given a list of type declarations from a module, first check that +-- there are no duplicate type declarations, and that the types are +-- well-formed; then create a type context containing the given +-- declarations. +makeTyCtx :: Members '[Reader TyDefCtx, Error TCError] r => ModuleName -> [TypeDecl] -> Sem r TyCtx +makeTyCtx name decls = do + let dups = filterDups . map (\(TypeDecl x _) -> x) $ decls + case dups of + (x:_) -> throw (DuplicateDecls x) + [] -> do + checkCtx declCtx + return declCtx + where + declCtx = ctxForModule name $ map (\(TypeDecl x ty) -> (x,ty)) decls + +-- | Check that all the types in a context are valid. +checkCtx :: Members '[Reader TyDefCtx, Error TCError] r => TyCtx -> Sem r () +checkCtx = mapM_ checkPolyTyValid . Ctx.elems + +-------------------------------------------------- +-- Top-level definitions + +-- | Type check a top-level definition in the given module. +checkDefn + :: Members '[Reader TyCtx, Reader TyDefCtx, Error TCError, Fresh, Output Message] r + => ModuleName -> TermDefn -> Sem r Defn +checkDefn name (TermDefn x clauses) = do + + -- Check that all clauses have the same number of patterns + checkNumPats clauses + + -- Get the declared type signature of x + Forall sig <- lookup (name .- x) >>= maybe (throw $ NoType x) return + -- If x isn't in the context, it's because no type was declared for it, so + -- throw an error. + (nms, ty) <- unbind sig + + -- Try to decompose the type into a chain of arrows like pty1 -> + -- pty2 -> pty3 -> ... -> bodyTy, according to the number of + -- patterns, and lazily unrolling type definitions along the way. + (patTys, bodyTy) <- decomposeDefnTy (numPats (head clauses)) ty + + ((acs, _), theta) <- solve $ do + aclauses <- forAll nms $ mapM (checkClause patTys bodyTy) clauses + return (aclauses, ty) + + return $ applySubst theta (Defn (coerce x) patTys bodyTy acs) + where + numPats = length . fst . unsafeUnbind + + checkNumPats [] = return () -- This can't happen, but meh + checkNumPats [_] = return () + checkNumPats (c:cs) + | all ((==0) . numPats) (c:cs) = throw (DuplicateDefns x) + | not (all ((== numPats c) . numPats) cs) = throw NumPatterns + -- XXX more info, this error actually means # of + -- patterns don't match across different clauses + | otherwise = return () + + -- | Check a clause of a definition against a list of pattern types and a body type. + checkClause + :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => [Type] -> Type -> Bind [Pattern] Term -> Sem r Clause + checkClause patTys bodyTy clause = do + (pats, body) <- unbind clause + + -- At this point we know that every clause has the same number of patterns, + -- which is the same as the length of the list patTys. So we can just use + -- zipWithM to check all the patterns. + (ctxs, aps) <- unzip <$> zipWithM checkPattern pats patTys + at <- extends (mconcat ctxs) $ check body bodyTy + return $ bind aps at + + -- Decompose a type that must be of the form t1 -> t2 -> ... -> tn -> t{n+1}. + decomposeDefnTy :: Members '[Reader TyDefCtx, Error TCError] r => Int -> Type -> Sem r ([Type], Type) + decomposeDefnTy 0 ty = return ([], ty) + decomposeDefnTy n (TyUser tyName args) = lookupTyDefn tyName args >>= decomposeDefnTy n + decomposeDefnTy n (ty1 :->: ty2) = first (ty1:) <$> decomposeDefnTy (n-1) ty2 + decomposeDefnTy _n _ty = throw NumPatterns + -- XXX include more info. More argument patterns than arrows in the type. + +-------------------------------------------------- +-- Properties + +-- | Given a context mapping names to documentation, extract the +-- properties attached to each name and typecheck them. +checkProperties + :: Members '[Reader TyCtx, Reader TyDefCtx, Error TCError, Fresh, Output Message] r + => Ctx Term Docs -> Sem r (Ctx ATerm [AProperty]) +checkProperties docs = + Ctx.coerceKeys . Ctx.filter (not . P.null) + <$> (traverse . traverse) checkProperty properties + where + properties :: Ctx Term [Property] + properties = fmap (\ds -> [p | DocProperty p <- ds]) docs + +-- | Check the types of the terms embedded in a property. +checkProperty + :: Members '[Reader TyCtx, Reader TyDefCtx, Error TCError, Fresh, Output Message] r + => Property -> Sem r AProperty +checkProperty prop = do + (at, theta) <- solve $ check prop TyProp + -- XXX do we need to default container variables here? + return $ applySubst theta at + +------------------------------------------------------------ +-- Type checking/inference +------------------------------------------------------------ + +-------------------------------------------------- +-- Checking types/kinds +-------------------------------------------------- + +-- | Check that a sigma type is a valid type. See 'checkTypeValid'. +checkPolyTyValid :: Members '[Reader TyDefCtx, Error TCError] r => PolyType -> Sem r () +checkPolyTyValid (Forall b) = do + let (_, ty) = unsafeUnbind b + checkTypeValid ty + +-- | Disco doesn't need kinds per se, since all types must be fully +-- applied. But we do need to check that every type is applied to +-- the correct number of arguments. +checkTypeValid :: Members '[Reader TyDefCtx, Error TCError] r => Type -> Sem r () +checkTypeValid (TyAtom _) = return () +checkTypeValid (TyCon c tys) = do + k <- conArity c + if | n < k -> throw (NotEnoughArgs c) + | n > k -> throw (TooManyArgs c) + | otherwise -> mapM_ checkTypeValid tys + where + n = length tys + +conArity :: Members '[Reader TyDefCtx, Error TCError] r => Con -> Sem r Int +conArity (CContainer _) = return 1 +conArity CGraph = return 1 +conArity (CUser name) = do + d <- ask @TyDefCtx + case M.lookup name d of + Nothing -> throw (NotTyDef name) + Just (TyDefBody as _) -> return (length as) +conArity _ = return 2 -- (->, *, +, map) + +-------------------------------------------------- +-- Checking modes +-------------------------------------------------- + +-- | Typechecking can be in one of two modes: inference mode means we +-- are trying to synthesize a valid type for a term; checking mode +-- means we are trying to show that a term has a given type. +data Mode = Infer | Check Type + deriving Show + +-- | Check that a term has the given type. Either throws an error, or +-- returns the term annotated with types for all subterms. +-- +-- This function is provided for convenience; it simply calls +-- 'typecheck' with an appropriate 'Mode'. +check + :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Term -> Type -> Sem r ATerm +check t ty = typecheck (Check ty) t + +-- | Check that a term has the given polymorphic type. +checkPolyTy + :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Term -> PolyType -> Sem r ATerm +checkPolyTy t (Forall sig) = do + (as, tau) <- unbind sig + (at, cst) <- withConstraint $ check t tau + case as of + [] -> constraint cst + _ -> constraint $ CAll (bind as cst) + return at + +-- | Infer the type of a term. If it succeeds, it returns the term +-- with all subterms annotated. +-- +-- This function is provided for convenience; it simply calls +-- 'typecheck' with an appropriate 'Mode'. +infer + :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Term -> Sem r ATerm +infer = typecheck Infer + +-- | Top-level type inference algorithm: infer a (polymorphic) type +-- for a term by running type inference, solving the resulting +-- constraints, and quantifying over any remaining type variables. +inferTop + :: Members '[Output Message, Reader TyCtx, Reader TyDefCtx, Error TCError, Fresh] r + => Term -> Sem r (ATerm, PolyType) +inferTop t = do + + -- Run inference on the term and try to solve the resulting + -- constraints. + (at, theta) <- solve $ infer t + + debug "Final annotated term (before substitution and container monomorphizing):" + debugPretty at + + -- Apply the resulting substitution. + let at' = applySubst theta at + + -- Find any remaining container variables. + cvs = containerVars (getType at') + + -- Replace them all with List. + at'' = applySubst (Subst.fromList $ zip (S.toList cvs) (repeat (TyAtom (ABase CtrList)))) at' + + -- Finally, quantify over any remaining type variables and return + -- the term along with the resulting polymorphic type. + return (at'', closeType (getType at'')) + +-------------------------------------------------- +-- The typecheck function +-------------------------------------------------- + +-- | The main workhorse of the typechecker. Instead of having two +-- functions, one for inference and one for checking, 'typecheck' +-- takes a 'Mode'. This cuts down on code duplication in many +-- cases, and allows all the checking and inference code related to +-- a given AST node to be placed together. +typecheck + :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Mode -> Term -> Sem r ATerm + +-- ~~~~ Note [Pattern coverage] +-- In several places we have clauses like +-- +-- inferPrim (PrimBOp op) | op `elem` [And, Or, Impl] +-- +-- since the typing rules for all the given operators are the same. +-- The only problem is that the pattern coverage checker (sensibly) +-- doesn't look at guards in general, so it thinks that there are TBin +-- cases still uncovered. +-- +-- However, we *don't* just want to add a catch-all case at the end, +-- because the coverage checker is super helpful in alerting us when +-- there's a missing typechecking case after modifying the language in +-- some way. The (not ideal) solution for now is to add some +-- additional explicit cases that simply call 'error', which will +-- never be reached but which assure the coverage checker that we have +-- handled those cases. +-- +-- The ideal solution would be to use or-patterns, if Haskell had them +-- (see https://github.com/ghc-proposals/ghc-proposals/pull/43). + +-------------------------------------------------- +-- Defined types + +-- To check at a user-defined type, expand its definition and recurse. +-- This case has to be first, so in all other cases we know the type +-- will not be a TyUser. +typecheck (Check (TyUser name args)) t = lookupTyDefn name args >>= check t + +-------------------------------------------------- +-- Parens + +-- Recurse through parens; they are not represented explicitly in the +-- resulting ATerm. +typecheck mode (TParens t) = typecheck mode t + +-------------------------------------------------- +-- Variables + +-- Resolve variable names and infer their types. We don't need a +-- checking case; checking the type of a variable will fall through to +-- this case. +typecheck Infer (TVar x) = do + + -- Pick the first method that succeeds; if none do, throw an unbound + -- variable error. + mt <- runMaybeT . F.asum . map MaybeT $ [tryLocal, tryModule, tryPrim] + maybe (throw (Unbound x)) return mt + where + -- 1. See if the variable name is bound locally. + tryLocal = do + mty <- Ctx.lookup (localName x) + case mty of + Just (Forall sig) -> do + (_, ty) <- unbind sig + return . Just $ ATVar ty (localName (coerce x)) + Nothing -> return Nothing + + -- 2. See if the variable name is bound in some in-scope module, + -- throwing an ambiguity error if it is bound in multiple modules. + tryModule = do + bs <- Ctx.lookupNonLocal x + case bs of + [(m,Forall sig)] -> do + (_, ty) <- unbind sig + return . Just $ ATVar ty (m .- coerce x) + [] -> return Nothing + _ -> throw $ Ambiguous x (map fst bs) + + -- 3. See if we should convert it to a primitive. + tryPrim = + case toPrim (name2String x) of + (prim:_) -> Just <$> typecheck Infer (TPrim prim) + _ -> return Nothing + +-------------------------------------------------- +-- Primitives + +typecheck Infer (TPrim prim) = do + ty <- inferPrim prim + return $ ATPrim ty prim + + where + inferPrim :: Members '[Writer Constraint, Fresh] r => Prim -> Sem r Type + + ---------------------------------------- + -- Left/right + + inferPrim PrimLeft = do + a <- freshTy + b <- freshTy + return $ a :->: (a :+: b) + + inferPrim PrimRight = do + a <- freshTy + b <- freshTy + return $ b :->: (a :+: b) + + ---------------------------------------- + -- Logic + + --- XXX restore typing rules for logical operations on Props + --- once the evaluator can handle them. + + inferPrim (PrimBOp op) | op `elem` [And, Or, Impl] = do + return $ TyBool :*: TyBool :->: TyBool + -- a <- freshTy + -- constraint $ CQual (bopQual op) a + -- return $ a :*: a :->: a + + -- See Note [Pattern coverage] ----------------------------- + inferPrim (PrimBOp And) = error "inferPrim And should be unreachable" + inferPrim (PrimBOp Or) = error "inferPrim Or should be unreachable" + inferPrim (PrimBOp Impl) = error "inferPrim Impl should be unreachable" + ------------------------------------------------------------ + + inferPrim (PrimUOp Not) = do + return $ TyBool :->: TyBool + -- a <- freshTy + -- constraint $ CQual QBool a + -- return $ a :->: a + + ---------------------------------------- + -- Container conversion + + inferPrim conv | conv `elem` [PrimList, PrimBag, PrimSet] = do + c <- freshAtom -- make a unification variable for the container type + a <- freshTy -- make a unification variable for the element type + + -- converting to a set or bag requires being able to sort the elements + when (conv /= PrimList) $ constraint $ CQual QCmp a + + return $ TyContainer c a :->: primCtrCon conv a + + where + primCtrCon PrimList = TyList + primCtrCon PrimBag = TyBag + primCtrCon _ = TySet + + -- See Note [Pattern coverage] ----------------------------- + inferPrim PrimList = error "inferPrim PrimList should be unreachable" + inferPrim PrimBag = error "inferPrim PrimBag should be unreachable" + inferPrim PrimSet = error "inferPrim PrimSet should be unreachable" + ------------------------------------------------------------ + + inferPrim PrimB2C = do + a <- freshTy + return $ TyBag a :->: TySet (a :*: TyN) + + inferPrim PrimC2B = do + a <- freshTy + c <- freshAtom + constraint $ CQual QCmp a + return $ TyContainer c (a :*: TyN) :->: TyBag a + + inferPrim PrimMapToSet = do + k <- freshTy + v <- freshTy + constraint $ CQual QSimple k + return $ TyMap k v :->: TySet (k :*: v) + + inferPrim PrimSetToMap = do + k <- freshTy + v <- freshTy + constraint $ CQual QSimple k + return $ TySet (k :*: v) :->: TyMap k v + + inferPrim PrimSummary = do + a <- freshTy + constraint $ CQual QSimple a + return $ TyGraph a :->: TyMap a (TySet a) + + inferPrim PrimVertex = do + a <- freshTy + constraint $ CQual QSimple a + return $ a :->: TyGraph a + + inferPrim PrimEmptyGraph = do + a <- freshTy + constraint $ CQual QSimple a + return $ TyGraph a + + inferPrim PrimOverlay = do + a <- freshTy + constraint $ CQual QSimple a + return $ TyGraph a :*: TyGraph a :->: TyGraph a + + inferPrim PrimConnect = do + a <- freshTy + constraint $ CQual QSimple a + return $ TyGraph a :*: TyGraph a :->: TyGraph a + + inferPrim PrimInsert = do + a <- freshTy + b <- freshTy + constraint $ CQual QSimple a + return $ a :*: b :*: TyMap a b :->: TyMap a b + + inferPrim PrimLookup = do + a <- freshTy + b <- freshTy + constraint $ CQual QSimple a + return $ a :*: TyMap a b :->: (TyUnit :+: b) + ---------------------------------------- + -- Container primitives + + inferPrim (PrimBOp Cons) = do + a <- freshTy + return $ a :*: TyList a :->: TyList a + + -- XXX see https://github.com/disco-lang/disco/issues/160 + -- each : (a -> b) × c a -> c b + inferPrim PrimEach = do + c <- freshAtom + a <- freshTy + b <- freshTy + return $ (a :->: b) :*: TyContainer c a :->: TyContainer c b + + -- XXX should eventually be (a * a -> a) * c a -> a, + -- with a check that the function has the right properties. + -- reduce : (a * a -> a) * a * c a -> a + inferPrim PrimReduce = do + c <- freshAtom + a <- freshTy + return $ (a :*: a :->: a) :*: a :*: TyContainer c a :->: a + + -- filter : (a -> Bool) × c a -> c a + inferPrim PrimFilter = do + c <- freshAtom + a <- freshTy + return $ (a :->: TyBool) :*: TyContainer c a :->: TyContainer c a + + -- join : c (c a) -> c a + inferPrim PrimJoin = do + c <- freshAtom + a <- freshTy + return $ TyContainer c (TyContainer c a) :->: TyContainer c a + + -- merge : (N × N -> N) × c a × c a -> c a (c = bag or set) + inferPrim PrimMerge = do + c <- freshAtom + a <- freshTy + constraint $ COr + [ CEq (TyAtom (ABase CtrBag)) (TyAtom c) + , CEq (TyAtom (ABase CtrSet)) (TyAtom c) + ] + let ca = TyContainer c a + return $ (TyN :*: TyN :->: TyN) :*: ca :*: ca :->: ca + + inferPrim (PrimBOp setOp) | setOp `elem` [Union, Inter, Diff, Subset] = do + a <- freshTy + c <- freshAtom + constraint $ COr + [ CEq (TyAtom (ABase CtrBag)) (TyAtom c) + , CEq (TyAtom (ABase CtrSet)) (TyAtom c) + ] + let ca = TyContainer c a + let resTy = case setOp of {Subset -> TyBool; _ -> ca} + return $ ca :*: ca :->: resTy + + -- See Note [Pattern coverage] ----------------------------- + inferPrim (PrimBOp Union) = error "inferPrim Union should be unreachable" + inferPrim (PrimBOp Inter) = error "inferPrim Inter should be unreachable" + inferPrim (PrimBOp Diff) = error "inferPrim Diff should be unreachable" + inferPrim (PrimBOp Subset) = error "inferPrim Subset should be unreachable" + ------------------------------------------------------------ + + inferPrim (PrimBOp Elem) = do + a <- freshTy + c <- freshAtom + + constraint $ CQual QCmp a + + return $ a :*: TyContainer c a :->: TyBool + + ---------------------------------------- + -- Arithmetic + + inferPrim (PrimBOp IDiv) = do + a <- freshTy + resTy <- cInt a + return $ a :*: a :->: resTy + + inferPrim (PrimBOp Mod) = do + a <- freshTy + constraint $ CSub a TyZ + return $ a :*: a :->: a + + inferPrim (PrimBOp op) | op `elem` [Add, Mul, Sub, Div, SSub] = do + a <- freshTy + constraint $ CQual (bopQual op) a + return $ a :*: a :->: a + + -- See Note [Pattern coverage] ----------------------------- + inferPrim (PrimBOp Add ) = error "inferPrim Add should be unreachable" + inferPrim (PrimBOp Mul ) = error "inferPrim Mul should be unreachable" + inferPrim (PrimBOp Sub ) = error "inferPrim Sub should be unreachable" + inferPrim (PrimBOp Div ) = error "inferPrim Div should be unreachable" + inferPrim (PrimBOp SSub) = error "inferPrim SSub should be unreachable" + ------------------------------------------------------------ + + inferPrim (PrimUOp Neg) = do + a <- freshTy + constraint $ CQual QSub a + return $ a :->: a + + inferPrim (PrimBOp Exp) = do + a <- freshTy + b <- freshTy + resTy <- cExp a b + return $ a :*: b :->: resTy + + ---------------------------------------- + -- Number theory + + inferPrim PrimIsPrime = return $ TyN :->: TyBool + inferPrim PrimFactor = return $ TyN :->: TyBag TyN + + inferPrim PrimFrac = return $ TyQ :->: (TyZ :*: TyN) + + inferPrim (PrimBOp Divides) = do + a <- freshTy + constraint $ CQual QNum a + return $ a :*: a :->: TyBool + + ---------------------------------------- + -- Choose + + -- For now, a simple typing rule for multinomial coefficients that + -- requires everything to be Nat. However, they can be extended to + -- handle negative or fractional arguments. + inferPrim (PrimBOp Choose) = do + b <- freshTy + + -- b can be either Nat (a binomial coefficient) + -- or a list of Nat (a multinomial coefficient). + constraint $ COr [CEq b TyN, CEq b (TyList TyN)] + return $ TyN :*: b :->: TyN + + ---------------------------------------- + -- Ellipses + + -- Actually 'until' supports more types than this, e.g. Q instead + -- of N, but this is good enough. This case is here just for + -- completeness---in case someone enables primitives and uses it + -- directly---but typically 'until' is generated only during + -- desugaring of a container with ellipsis, after typechecking, in + -- which case it can be assigned a more appropriate type directly. + + inferPrim PrimUntil = return $ TyN :*: TyList TyN :->: TyList TyN + + ---------------------------------------- + -- Crash + + inferPrim PrimCrash = do + a <- freshTy + return $ TyString :->: a + + ---------------------------------------- + -- Propositions + + -- 'holds' converts a Prop into a Bool (but might not terminate). + inferPrim PrimHolds = return $ TyProp :->: TyBool + + -- An equality assertion =!= is just like a comparison ==, except + -- the result is a Prop. + inferPrim (PrimBOp ShouldEq) = do + ty <- freshTy + constraint $ CQual QCmp ty + return $ ty :*: ty :->: TyProp + + ---------------------------------------- + -- Comparisons + + -- Infer the type of a comparison. A comparison always has type + -- Bool, but we have to make sure the subterms have compatible + -- types. We also generate a QCmp qualifier, for two reasons: + -- one, we need to know whether e.g. a comparison was done at a + -- certain type, so we can decide whether the type is allowed to + -- be completely polymorphic or not. Also, comparison of Props is + -- not allowed. + inferPrim (PrimBOp op) | op `elem` [Eq, Neq, Lt, Gt, Leq, Geq] = do + ty <- freshTy + constraint $ CQual QCmp ty + return $ ty :*: ty :->: TyBool + + -- See Note [Pattern coverage] ----------------------------- + inferPrim (PrimBOp Eq) = error "inferPrim Eq should be unreachable" + inferPrim (PrimBOp Neq) = error "inferPrim Neq should be unreachable" + inferPrim (PrimBOp Lt) = error "inferPrim Lt should be unreachable" + inferPrim (PrimBOp Gt) = error "inferPrim Gt should be unreachable" + inferPrim (PrimBOp Leq) = error "inferPrim Leq should be unreachable" + inferPrim (PrimBOp Geq) = error "inferPrim Geq should be unreachable" + ------------------------------------------------------------ + + inferPrim (PrimBOp op) | op `elem` [Min, Max] = do + ty <- freshTy + constraint $ CQual QCmp ty + return $ ty :*: ty :->: ty + + -- See Note [Pattern coverage] ----------------------------- + inferPrim (PrimBOp Min) = error "inferPrim Min should be unreachable" + inferPrim (PrimBOp Max) = error "inferPrim Max should be unreachable" + ------------------------------------------------------------ + + ---------------------------------------- + -- Special arithmetic functions: fact, sqrt, floor, ceil, abs + + inferPrim (PrimUOp Fact) = return $ TyN :->: TyN + inferPrim PrimSqrt = return $ TyN :->: TyN + + inferPrim p | p `elem` [PrimFloor, PrimCeil] = do + argTy <- freshTy + resTy <- cInt argTy + return $ argTy :->: resTy + + -- See Note [Pattern coverage] ----------------------------- + inferPrim PrimFloor = error "inferPrim Floor should be unreachable" + inferPrim PrimCeil = error "inferPrim Ceil should be unreachable" + ------------------------------------------------------------ + + inferPrim PrimAbs = do + argTy <- freshTy + resTy <- cPos argTy + return $ argTy :->: resTy + + ---------------------------------------- + -- set size, power set/bag + + -- XXX set size should move into standard library + inferPrim PrimSize = do + a <- freshTy + return $ TySet a :->: TyN + + inferPrim PrimPower = do + a <- freshTy + c <- freshAtom + + constraint $ CQual QCmp a + constraint $ COr + [ CEq (TyAtom (ABase CtrSet)) (TyAtom c) + , CEq (TyAtom (ABase CtrBag)) (TyAtom c) + ] + + return $ TyContainer c a :->: TyContainer c (TyContainer c a) + + inferPrim PrimLookupSeq = return $ TyList TyN :->: (TyUnit :+: TyString) + inferPrim PrimExtendSeq = return $ TyList TyN :->: TyList TyN + +-------------------------------------------------- +-- Base types + +-- A few trivial cases for base types. +typecheck Infer TUnit = return ATUnit +typecheck Infer (TBool b) = return $ ATBool TyBool b +typecheck Infer (TChar c) = return $ ATChar c +typecheck Infer (TString cs) = return $ ATString cs +-- typecheck (Check (TyFin n)) (TNat x) = return $ ATNat (TyFin n) x +typecheck Infer (TNat n) = return $ ATNat TyN n +typecheck Infer (TRat r) = return $ ATRat r + +typecheck _ TWild = throw NoTWild + +-------------------------------------------------- +-- Abstractions (lambdas and quantifiers) + +-- Lambdas and quantifiers are similar enough that we can share a +-- bunch of the code, but their typing rules are a bit different. In +-- particular a lambda +-- +-- \(x1:ty1), (x2:ty2) ... . body +-- +-- is going to have a type like ty1 -> ty2 -> ... -> resTy, whereas a +-- quantifier like +-- +-- ∃(x1:ty1), (x2:ty2) ... . body +-- +-- is just going to have the type Prop. The similarity is that in +-- both cases we have to generate unification variables for any +-- binders with omitted type annotations, and typecheck the body under +-- an extended context. + +-- It's only helpful to do lambdas in checking mode, since the +-- provided function type can provide information about the types of +-- the arguments. For other quantifiers we can just fall back to +-- inference mode. +typecheck (Check checkTy) tm@(TAbs Lam body) = do + (args, t) <- unbind body + + -- First check that the given type is of the form ty1 -> ty2 -> + -- ... -> resTy, where the types ty1, ty2 ... match up with any + -- types declared for the arguments to the lambda (e.g. (x:tyA) + -- (y:tyB) -> ...). + (ctx, typedArgs, resTy) <- checkArgs args checkTy tm + + -- Then check the type of the body under a context extended with + -- types for all the arguments. + extends ctx $ + ATAbs Lam checkTy <$> (bind (coerce typedArgs) <$> check t resTy) + + where + + -- Given the patterns and their optional type annotations in the + -- head of a lambda (e.g. @x (y:Z) (f : N -> N) -> ...@), and the + -- type at which we are checking the lambda, ensure that: + -- + -- - The type is of the form @ty1 -> ty2 -> ... -> resTy@ and + -- there are enough @ty1@, @ty2@, ... to match all the arguments. + -- - Each pattern successfully checks at its corresponding type. + -- + -- If it succeeds, return a context binding variables to their + -- types (as determined by the patterns and the input types) which + -- we can use to extend when checking the body, a list of the typed + -- patterns, and the result type of the function. + checkArgs + :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => [Pattern] -> Type -> Term -> Sem r (TyCtx, [APattern], Type) + + -- If we're all out of arguments, the remaining checking type is the + -- result, and there are no variables to bind in the context. + checkArgs [] ty _ = return (emptyCtx, [], ty) + + -- Take the next pattern and its annotation; the checking type must + -- be a function type ty1 -> ty2. + checkArgs (p : args) ty term = do + + -- Ensure that ty is a function type + (ty1, ty2) <- ensureConstr2 CArr ty (Left term) + + -- Check the argument pattern against the function domain. + (pCtx, pTyped) <- checkPattern p ty1 + + -- Check the rest of the arguments under the type ty2, returning a + -- context with the rest of the arguments and the final result type. + (ctx, typedArgs, resTy) <- checkArgs args ty2 term + + -- Pass the result type through, and put the pattern-bound variables + -- in the returned context. + return (pCtx <> ctx, pTyped : typedArgs, resTy) + +-- In inference mode, we handle lambdas as well as quantifiers (∀, ∃). +typecheck Infer (TAbs q lam) = do + + -- Open it and get the argument patterns with any type annotations. + (args, t) <- unbind lam + + -- Replace any missing type annotations with fresh type variables, + -- and check each pattern at that variable to refine them, collecting + -- the types of each pattern's bound variables in a context. + tys <- mapM getAscrOrFresh args + (pCtxs, typedPats) <- unzip <$> zipWithM checkPattern args tys + + -- In the case of ∀, ∃, have to ensure that the argument types are + -- searchable. + when (q `elem` [All, Ex]) $ + -- What's the difference between this and `tys`? Nothing, after + -- the solver runs, but right now the patterns might have a + -- concrete type from annotations inside tuples. + forM_ (map getType typedPats) $ \ty -> + unless (isSearchable ty) $ + throw $ NoSearch ty + + -- Extend the context with the given arguments, and then do + -- something appropriate depending on the quantifier. + extends (mconcat pCtxs) $ do + case q of + -- For lambdas, infer the type of the body, and return an appropriate + -- function type. + Lam -> do + at <- infer t + return $ ATAbs Lam (mkFunTy tys (getType at)) (bind typedPats at) + + -- For other quantifiers, check that the body has type Prop, + -- and return Prop. + _ -> do -- ∀, ∃ + at <- check t TyProp + return $ ATAbs q TyProp (bind typedPats at) + where + getAscrOrFresh + :: Members '[Reader TyDefCtx, Error TCError, Fresh] r + => Pattern -> Sem r Type + getAscrOrFresh (PAscr _ ty) = checkTypeValid ty >> pure ty + getAscrOrFresh _ = freshTy + + -- mkFunTy [ty1, ..., tyn] out = ty1 -> (ty2 -> ... (tyn -> out)) + mkFunTy :: [Type] -> Type -> Type + mkFunTy tys out = foldr (:->:) out tys + +-------------------------------------------------- +-- Application + +-- Infer the type of a function application by inferring the function +-- type and then checking the argument type. We don't need a checking +-- case because checking mode doesn't help. +typecheck Infer (TApp t t') = do + at <- infer t + let ty = getType at + (ty1, ty2) <- ensureConstr2 CArr ty (Left t) + ATApp ty2 at <$> check t' ty1 + +-------------------------------------------------- +-- Tuples + +-- Check/infer the type of a tuple. +typecheck mode1 (TTup tup) = uncurry ATTup <$> typecheckTuple mode1 tup + where + typecheckTuple + :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Mode -> [Term] -> Sem r (Type, [ATerm]) + typecheckTuple _ [] = error "Impossible! typecheckTuple []" + typecheckTuple mode [t] = (getType &&& (:[])) <$> typecheck mode t + typecheckTuple mode (t:ts) = do + (m,ms) <- ensureConstrMode2 CProd mode (Left $ TTup (t:ts)) + at <- typecheck m t + (ty, ats) <- typecheckTuple ms ts + return (getType at :*: ty, at : ats) + +---------------------------------------- +-- Comparison chain + +typecheck Infer (TChain t ls) = + ATChain TyBool <$> infer t <*> inferChain t ls + + where + inferChain + :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Term -> [Link] -> Sem r [ALink] + inferChain _ [] = return [] + inferChain t1 (TLink op t2 : links) = do + at2 <- infer t2 + _ <- check (TBin op t1 t2) TyBool + atl <- inferChain t2 links + return $ ATLink op at2 : atl + +---------------------------------------- +-- Type operations + +typecheck Infer (TTyOp Enumerate t) = do + checkTypeValid t + return $ ATTyOp (TyList t) Enumerate t + +typecheck Infer (TTyOp Count t) = do + checkTypeValid t + return $ ATTyOp (TyUnit :+: TyN) Count t + +-------------------------------------------------- +-- Containers + +-- Literal containers, including ellipses +typecheck mode t@(TContainer c xs ell) = do + eltMode <- ensureConstrMode1 (containerToCon c) mode (Left t) + axns <- mapM (\(x,n) -> (,) <$> typecheck eltMode x <*> traverse (`check` TyN) n) xs + aell <- typecheckEllipsis eltMode ell + resTy <- case mode of + Infer -> do + let tys = [ getType at | Just (Until at) <- [aell] ] ++ map (getType . fst) axns + tyv <- freshTy + constraints $ map (`CSub` tyv) tys + return $ containerTy c tyv + Check ty -> return ty + when (isJust ell) $ do + eltTy <- getEltTy c resTy + constraint $ CQual QEnum eltTy + return $ ATContainer resTy c axns aell + + where + typecheckEllipsis + :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Mode -> Maybe (Ellipsis Term) -> Sem r (Maybe (Ellipsis ATerm)) + typecheckEllipsis _ Nothing = return Nothing + typecheckEllipsis m (Just (Until tm)) = Just . Until <$> typecheck m tm + +-- Container comprehensions +typecheck mode tcc@(TContainerComp c bqt) = do + eltMode <- ensureConstrMode1 (containerToCon c) mode (Left tcc) + (qs, t) <- unbind bqt + (aqs, cx) <- inferTelescope inferQual qs + extends cx $ do + at <- typecheck eltMode t + let resTy = case mode of + Infer -> containerTy c (getType at) + Check ty -> ty + return $ ATContainerComp resTy c (bind aqs at) + + where + inferQual + :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Qual -> Sem r (AQual, TyCtx) + inferQual (QBind x (unembed -> t)) = do + at <- infer t + ty <- ensureConstr1 (containerToCon c) (getType at) (Left t) + return (AQBind (coerce x) (embed at), singleCtx (localName x) (toPolyType ty)) + + inferQual (QGuard (unembed -> t)) = do + at <- check t TyBool + return (AQGuard (embed at), emptyCtx) + +-------------------------------------------------- +-- Let + +-- To check/infer a let expression. Note let is non-recursive. +typecheck mode (TLet l) = do + (bs, t2) <- unbind l + + -- Infer the types of all the variables bound by the let... + (as, ctx) <- inferTelescope inferBinding bs + + -- ...then check/infer the body under an extended context. + extends ctx $ do + at2 <- typecheck mode t2 + return $ ATLet (getType at2) (bind as at2) + + where + + -- Infer the type of a binding (@x [: ty] = t@), returning a + -- type-annotated binding along with a (singleton) context for the + -- bound variable. The optional type annotation on the variable + -- determines whether we use inference or checking mode for the + -- body. + inferBinding + :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Binding -> Sem r (ABinding, TyCtx) + inferBinding (Binding mty x (unembed -> t)) = do + at <- case mty of + Just (unembed -> ty) -> checkPolyTy t ty + Nothing -> infer t + return (ABinding mty (coerce x) (embed at), singleCtx (localName x) (toPolyType $ getType at)) + +-------------------------------------------------- +-- Case + +-- Check/infer a case expression. +typecheck _ (TCase []) = throw EmptyCase +typecheck mode (TCase bs) = do + bs' <- mapM typecheckBranch bs + resTy <- case mode of + Check ty -> return ty + Infer -> do + x <- freshTy + constraints $ map ((`CSub` x) . getType) bs' + return x + return $ ATCase resTy bs' + + where + typecheckBranch + :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Branch -> Sem r ABranch + typecheckBranch b = do + (gs, t) <- unbind b + (ags, ctx) <- inferTelescope inferGuard gs + extends ctx $ + bind ags <$> typecheck mode t + + -- Infer the type of a guard, returning the type-annotated guard + -- along with a context of types for any variables bound by the + -- guard. + inferGuard + :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Guard -> Sem r (AGuard, TyCtx) + inferGuard (GBool (unembed -> t)) = do + at <- check t TyBool + return (AGBool (embed at), emptyCtx) + inferGuard (GPat (unembed -> t) p) = do + at <- infer t + (ctx, apt) <- checkPattern p (getType at) + return (AGPat (embed at) apt, ctx) + inferGuard (GLet (Binding mty x (unembed -> t))) = do + at <- case mty of + Just (unembed -> ty) -> checkPolyTy t ty + Nothing -> infer t + return + ( AGLet (ABinding mty (coerce x) (embed at)) + , singleCtx (localName x) (toPolyType (getType at)) + ) + +-------------------------------------------------- +-- Type ascription + +-- Ascriptions are what let us flip from inference mode into +-- checking mode. +typecheck Infer (TAscr t ty) = checkPolyTyValid ty >> checkPolyTy t ty + +-------------------------------------------------- +-- Inference fallback + +-- Finally, to check anything else, we can fall back to inferring its +-- type and then check that the inferred type is a *subtype* of the +-- given type. We have to be careful to call 'setType' to change the +-- type at the root of the term to the requested type. +typecheck (Check ty) t = do + at <- infer t + constraint $ CSub (getType at) ty + return $ setType ty at + +------------------------------------------------------------ +-- Patterns +------------------------------------------------------------ + +-- | Check that a pattern has the given type, and return a context of +-- pattern variables bound in the pattern along with their types. +checkPattern + :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Pattern -> Type -> Sem r (TyCtx, APattern) + +checkPattern p (TyUser name args) = lookupTyDefn name args >>= checkPattern p + +checkPattern (PVar x) ty = return (singleCtx (localName x) (toPolyType ty), APVar ty (coerce x)) + +checkPattern PWild ty = return (emptyCtx, APWild ty) + +checkPattern (PAscr p ty1) ty2 = do + -- We have a pattern that promises to match ty1 and someone is asking + -- us if it can also match ty2. So we just have to ensure what we're + -- being asked for is a subtype of what we can promise to cover... + constraint $ CSub ty2 ty1 + -- ... and then make sure the pattern can actually match what it promised to. + checkPattern p ty1 + +checkPattern PUnit ty = do + ensureEq ty TyUnit + return (emptyCtx, APUnit) + +checkPattern (PBool b) ty = do + ensureEq ty TyBool + return (emptyCtx, APBool b) + +checkPattern (PChar c) ty = do + ensureEq ty TyC + return (emptyCtx, APChar c) + +checkPattern (PString s) ty = do + ensureEq ty TyString + return (emptyCtx, APString s) + +checkPattern (PTup tup) tupTy = do + listCtxtAps <- checkTuplePat tup tupTy + let (ctxs, aps) = unzip listCtxtAps + return (mconcat ctxs, APTup (foldr1 (:*:) (map getType aps)) aps) + + where + checkTuplePat + :: Members '[Reader TyCtx, Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => [Pattern] -> Type -> Sem r [(TyCtx, APattern)] + checkTuplePat [] _ = error "Impossible! checkTuplePat []" + checkTuplePat [p] ty = do -- (:[]) <$> check t ty + (ctx, apt) <- checkPattern p ty + return [(ctx, apt)] + checkTuplePat (p:ps) ty = do + (ty1, ty2) <- ensureConstr2 CProd ty (Right $ PTup (p:ps)) + (ctx, apt) <- checkPattern p ty1 + rest <- checkTuplePat ps ty2 + return ((ctx, apt) : rest) + +checkPattern p@(PInj L pat) ty = do + (ty1, ty2) <- ensureConstr2 CSum ty (Right p) + (ctx, apt) <- checkPattern pat ty1 + return (ctx, APInj (ty1 :+: ty2) L apt) +checkPattern p@(PInj R pat) ty = do + (ty1, ty2) <- ensureConstr2 CSum ty (Right p) + (ctx, apt) <- checkPattern pat ty2 + return (ctx, APInj (ty1 :+: ty2) R apt) + +-- we can match any supertype of TyN against a Nat pattern, OR +-- any TyFin. + +-- XXX this isn't quite right, what if we're checking at a type +-- variable but we need to solve it to be a TyFin? Can this ever +-- happen? We would need a COr, except we can't express the +-- constraint "exists m. ty = TyFin m" +-- +-- Yes, this can happen, and here's an example: +-- +-- > (\x. {? true when x is 3, false otherwise ?}) (2 : Z5) +-- Unsolvable NoUnify +-- > (\(x : Z5). {? true when x is 3, false otherwise ?}) (2 : Z5) +-- false + +-- checkPattern (PNat n) (TyFin m) = return (emptyCtx, APNat (TyFin m) n) +checkPattern (PNat n) ty = do + constraint $ CSub TyN ty + return (emptyCtx, APNat ty n) + +checkPattern p@(PCons p1 p2) ty = do + tyl <- ensureConstr1 CList ty (Right p) + (ctx1, ap1) <- checkPattern p1 tyl + (ctx2, ap2) <- checkPattern p2 (TyList tyl) + return (ctx1 <> ctx2, APCons (TyList tyl) ap1 ap2) + +checkPattern p@(PList ps) ty = do + tyl <- ensureConstr1 CList ty (Right p) + listCtxtAps <- mapM (`checkPattern` tyl) ps + let (ctxs, aps) = unzip listCtxtAps + return (mconcat ctxs, APList (TyList tyl) aps) + +checkPattern (PAdd s p t) ty = do + constraint $ CQual QNum ty + (ctx, apt) <- checkPattern p ty + at <- check t ty + return (ctx, APAdd ty s apt at) + +checkPattern (PMul s p t) ty = do + constraint $ CQual QNum ty + (ctx, apt) <- checkPattern p ty + at <- check t ty + return (ctx, APMul ty s apt at) + +checkPattern (PSub p t) ty = do + constraint $ CQual QNum ty + (ctx, apt) <- checkPattern p ty + at <- check t ty + return (ctx, APSub ty apt at) + +checkPattern (PNeg p) ty = do + constraint $ CQual QSub ty + tyInner <- cPos ty + (ctx, apt) <- checkPattern p tyInner + return (ctx, APNeg ty apt) + +checkPattern (PFrac p q) ty = do + constraint $ CQual QDiv ty + tyP <- cInt ty + tyQ <- cPos tyP + (ctx1, ap1) <- checkPattern p tyP + (ctx2, ap2) <- checkPattern q tyQ + return (ctx1 <> ctx2, APFrac ty ap1 ap2) + +------------------------------------------------------------ +-- Constraints for abs, floor/ceiling/idiv, and exp +------------------------------------------------------------ + +-- | Given an input type @ty@, return a type which represents the +-- output type of the absolute value function, and generate +-- appropriate constraints. +cPos :: Members '[Writer Constraint, Fresh] r => Type -> Sem r Type +cPos ty = do + constraint $ CQual QNum ty -- The input type has to be numeric. + case ty of + -- If the input type is a concrete base type, we can just + -- compute the correct output type. + TyAtom (ABase b) -> return $ TyAtom (ABase (pos b)) + + -- Otherwise, generate a fresh type variable for the output type + -- along with some constraints. + _ -> do + res <- freshTy + + -- Valid types for absolute value are Z -> N, Q -> F, or T -> T + -- (e.g. Z5 -> Z5). + constraint $ COr + [ cAnd [CSub ty TyZ, CSub TyN res] + , cAnd [CSub ty TyQ, CSub TyF res] + , CEq ty res + ] + return res + where + pos Z = N + pos Q = F + pos t = t + +-- | Given an input type @ty@, return a type which represents the +-- output type of the floor or ceiling functions, and generate +-- appropriate constraints. +cInt :: Members '[Writer Constraint, Fresh] r => Type -> Sem r Type +cInt ty = do + constraint $ CQual QNum ty + case ty of + -- If the input type is a concrete base type, we can just + -- compute the correct output type. + TyAtom (ABase b) -> return $ TyAtom (ABase (int b)) + + -- Otherwise, generate a fresh type variable for the output type + -- along with some constraints. + _ -> do + res <- freshTy + + -- Valid types for absolute value are F -> N, Q -> Z, or T -> T + -- (e.g. Z5 -> Z5). + constraint $ COr + [ cAnd [CSub ty TyF, CSub TyN res] + , cAnd [CSub ty TyQ, CSub TyZ res] + , CEq ty res + ] + return res + + where + int F = N + int Q = Z + int t = t + +-- | Given input types to the exponentiation operator, return a type +-- which represents the output type, and generate appropriate +-- constraints. +cExp :: Members '[Writer Constraint, Fresh] r => Type -> Type -> Sem r Type +cExp ty1 TyN = do + constraint $ CQual QNum ty1 + return ty1 + +-- We could include a special case for TyZ, but for that we would need +-- a function to find a supertype of a given type that satisfies QDiv. + +cExp ty1 ty2 = do + + -- Create a fresh type variable to represent the result type. The + -- base type has to be a subtype. + resTy <- freshTy + constraint $ CSub ty1 resTy + + -- Either the exponent type is N, in which case the result type has + -- to support multiplication, or else the exponent is Z, in which + -- case the result type also has to support division. + constraint $ COr + [ cAnd [CQual QNum resTy, CEq ty2 TyN] + , cAnd [CQual QDiv resTy, CEq ty2 TyZ] + ] + return resTy + +------------------------------------------------------------ +-- Decomposing type constructors +------------------------------------------------------------ + +-- | Get the argument (element) type of a (known) container type. Returns a +-- fresh variable with a suitable constraint if the given type is +-- not literally a container type. +getEltTy :: Members '[Writer Constraint, Fresh] r => Container -> Type -> Sem r Type +getEltTy _ (TyContainer _ e) = return e +getEltTy c ty = do + eltTy <- freshTy + constraint $ CEq (containerTy c eltTy) ty + return eltTy + +-- | Ensure that a type's outermost constructor matches the provided +-- constructor, returning the types within the matched constructor +-- or throwing a type error. If the type provided is a type +-- variable, appropriate constraints are generated to guarantee the +-- type variable's outermost constructor matches the provided +-- constructor, and a list of fresh type variables is returned whose +-- count matches the arity of the provided constructor. +ensureConstr + :: forall r. Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Con -> Type -> Either Term Pattern -> Sem r [Type] +ensureConstr c ty targ = matchConTy c ty + where + matchConTy :: Con -> Type -> Sem r [Type] + + -- expand type definitions lazily + matchConTy c1 (TyUser name args) = lookupTyDefn name args >>= matchConTy c1 + + matchConTy c1 (TyCon c2 tys) = do + matchCon c1 c2 + return tys + + matchConTy c1 tyv@(TyAtom (AVar (U _))) = do + tyvs <- mapM (const freshTy) (arity c1) + constraint $ CEq tyv (TyCon c1 tyvs) + return tyvs + + matchConTy _ _ = matchError + + -- | Check whether two constructors match, which could include + -- unifying container variables if we are matching two container + -- types; otherwise, simply ensure that the constructors are + -- equal. Throw a 'matchError' if they do not match. + matchCon :: Con -> Con -> Sem r () + matchCon c1 c2 | c1 == c2 = return () + matchCon (CContainer v@(AVar (U _))) (CContainer ctr2) = + constraint $ CEq (TyAtom v) (TyAtom ctr2) + matchCon (CContainer ctr1) (CContainer v@(AVar (U _))) = + constraint $ CEq (TyAtom ctr1) (TyAtom v) + matchCon _ _ = matchError + + matchError :: Sem r a + matchError = case targ of + Left term -> throw (NotCon c term ty) + Right pat -> throw (PatternType c pat ty) + +-- | A variant of ensureConstr that expects to get exactly one +-- argument type out, and throws an error if we get any other +-- number. +ensureConstr1 + :: Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Con -> Type -> Either Term Pattern -> Sem r Type +ensureConstr1 c ty targ = do + tys <- ensureConstr c ty targ + case tys of + [ty1] -> return ty1 + _ -> error $ + "Impossible! Wrong number of arg types in ensureConstr1 " ++ show c ++ " " + ++ show ty ++ ": " ++ show tys + +-- | A variant of ensureConstr that expects to get exactly two +-- argument types out, and throws an error if we get any other +-- number. +ensureConstr2 + :: Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Con -> Type -> Either Term Pattern -> Sem r (Type, Type) +ensureConstr2 c ty targ = do + tys <- ensureConstr c ty targ + case tys of + [ty1, ty2] -> return (ty1, ty2) + _ -> error $ + "Impossible! Wrong number of arg types in ensureConstr2 " ++ show c ++ " " + ++ show ty ++ ": " ++ show tys + +-- | A variant of 'ensureConstr' that works on 'Mode's instead of +-- 'Type's. Behaves similarly to 'ensureConstr' if the 'Mode' is +-- 'Check'; otherwise it generates an appropriate number of copies +-- of 'Infer'. +ensureConstrMode + :: Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Con -> Mode -> Either Term Pattern -> Sem r [Mode] +ensureConstrMode c Infer _ = return $ map (const Infer) (arity c) +ensureConstrMode c (Check ty) tp = map Check <$> ensureConstr c ty tp + +-- | A variant of 'ensureConstrMode' that expects to get a single +-- 'Mode' and throws an error if it encounters any other number. +ensureConstrMode1 + :: Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Con -> Mode -> Either Term Pattern -> Sem r Mode +ensureConstrMode1 c m targ = do + ms <- ensureConstrMode c m targ + case ms of + [m1] -> return m1 + _ -> error $ + "Impossible! Wrong number of arg types in ensureConstrMode1 " ++ show c ++ " " + ++ show m ++ ": " ++ show ms + +-- | A variant of 'ensureConstrMode' that expects to get two 'Mode's +-- and throws an error if it encounters any other number. +ensureConstrMode2 + :: Members '[Reader TyDefCtx, Writer Constraint, Error TCError, Fresh] r + => Con -> Mode -> Either Term Pattern -> Sem r (Mode, Mode) +ensureConstrMode2 c m targ = do + ms <- ensureConstrMode c m targ + case ms of + [m1, m2] -> return (m1, m2) + _ -> error $ + "Impossible! Wrong number of arg types in ensureConstrMode2 " ++ show c ++ " " + ++ show m ++ ": " ++ show ms + +-- | Ensure that two types are equal: +-- 1. Do nothing if they are literally equal +-- 2. Generate an equality constraint otherwise +ensureEq :: Member (Writer Constraint) r => Type -> Type -> Sem r () +ensureEq ty1 ty2 + | ty1 == ty2 = return () + | otherwise = constraint $ CEq ty1 ty2 diff --git a/src/Disco/Typecheck/Constraints.hs b/src/Disco/Typecheck/Constraints.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Typecheck/Constraints.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Typecheck.Constraints +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Constraints generated by type inference & checking. +-- +----------------------------------------------------------------------------- + +module Disco.Typecheck.Constraints + ( Constraint(..) + , cAnd + ) + where + +import qualified Data.List.NonEmpty as NE +import Data.Semigroup +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless hiding (lunbind) + +import Disco.Effects.LFresh + +import Disco.Pretty hiding ((<>)) +import Disco.Syntax.Operators (BFixity (In, InL, InR)) +import Disco.Types +import Disco.Types.Rules + +-- | Constraints are generated as a result of type inference and checking. +-- These constraints are accumulated during the inference and checking phase +-- and are subsequently solved by the constraint solver. +data Constraint where + CSub :: Type -> Type -> Constraint + CEq :: Type -> Type -> Constraint + CQual :: Qualifier -> Type -> Constraint + CAnd :: [Constraint] -> Constraint + CTrue :: Constraint + COr :: [Constraint] -> Constraint + CAll :: Bind [Name Type] Constraint -> Constraint + + deriving (Show, Generic, Alpha, Subst Type) + +instance Pretty Constraint where + pretty = \case + CSub ty1 ty2 -> withPA (PA 4 In) $ lt (pretty ty1) <+> "<:" <+> rt (pretty ty2) + CEq ty1 ty2 -> withPA (PA 4 In) $ lt (pretty ty1) <+> "=" <+> rt (pretty ty2) + CQual q ty -> withPA (PA 10 InL) $ lt (pretty q) <+> rt (pretty ty) + CAnd [c] -> pretty c + -- Use rt for both, since we don't need to print parens for /\ at all + CAnd (c:cs) -> withPA (PA 3 InR) $ rt (pretty c) <+> "/\\" <+> rt (pretty (CAnd cs)) + CAnd [] -> "True" + CTrue -> "True" + COr [c] -> pretty c + COr (c:cs) -> withPA (PA 2 InR) $ lt (pretty c) <+> "\\/" <+> rt (pretty (COr cs)) + COr [] -> "False" + CAll b -> lunbind b $ \(xs, c) -> + "∀" <+> intercalate "," (map pretty xs) <> "." <+> pretty c + +-- A helper function for creating a single constraint from a list of constraints. +cAnd :: [Constraint] -> Constraint +cAnd cs = case filter nontrivial cs of + [] -> CTrue + [c] -> c + cs' -> CAnd cs' + where + nontrivial CTrue = False + nontrivial _ = True + +instance Semigroup Constraint where + c1 <> c2 = cAnd [c1,c2] + sconcat = cAnd . NE.toList + stimes = stimesIdempotent + +instance Monoid Constraint where + mempty = CTrue + mappend = (<>) + mconcat = cAnd diff --git a/src/Disco/Typecheck/Erase.hs b/src/Disco/Typecheck/Erase.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Typecheck/Erase.hs @@ -0,0 +1,123 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Typecheck.Erase +-- Copyright : (c) 2016 disco team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : byorgey@gmail.com +-- +-- Typecheck the Disco surface language and transform it into a +-- type-annotated AST. +-- +----------------------------------------------------------------------------- + +module Disco.Typecheck.Erase where + +import Unbound.Generics.LocallyNameless +import Unbound.Generics.LocallyNameless.Unsafe + +import Control.Arrow ((***)) +import Data.Coerce + +import Disco.AST.Desugared +import Disco.AST.Surface +import Disco.AST.Typed +import Disco.Names (QName (..)) + +-- | Erase all the type annotations from a term. +erase :: ATerm -> Term +erase (ATVar _ (QName _ x)) = TVar (coerce x) +erase (ATPrim _ x) = TPrim x +erase (ATLet _ bs) = TLet $ bind (mapTelescope eraseBinding tel) (erase at) + where (tel,at) = unsafeUnbind bs +erase ATUnit = TUnit +erase (ATBool _ b) = TBool b +erase (ATChar c) = TChar c +erase (ATString s) = TString s +erase (ATNat _ i) = TNat i +erase (ATRat r) = TRat r +erase (ATAbs q _ b) = TAbs q $ bind (map erasePattern x) (erase at) + where (x,at) = unsafeUnbind b +erase (ATApp _ t1 t2) = TApp (erase t1) (erase t2) +erase (ATTup _ ats) = TTup (map erase ats) +erase (ATCase _ brs) = TCase (map eraseBranch brs) +erase (ATChain _ at lnks) = TChain (erase at) (map eraseLink lnks) +erase (ATTyOp _ op ty) = TTyOp op ty +erase (ATContainer _ c ats aell) = TContainer c (map (erase *** fmap erase) ats) ((fmap . fmap) erase aell) +erase (ATContainerComp _ c b) = TContainerComp c $ bind (mapTelescope eraseQual tel) (erase at) + where (tel,at) = unsafeUnbind b +erase (ATTest _ x) = erase x + +eraseBinding :: ABinding -> Binding +eraseBinding (ABinding mty x (unembed -> at)) = Binding mty (coerce x) (embed (erase at)) + +erasePattern :: APattern -> Pattern +erasePattern (APVar _ n) = PVar (coerce n) +erasePattern (APWild _) = PWild +erasePattern APUnit = PUnit +erasePattern (APBool b) = PBool b +erasePattern (APChar c) = PChar c +erasePattern (APString s) = PString s +erasePattern (APTup _ alp) = PTup $ map erasePattern alp +erasePattern (APInj _ s apt) = PInj s (erasePattern apt) +erasePattern (APNat _ n) = PNat n +erasePattern (APCons _ ap1 ap2) = PCons (erasePattern ap1) (erasePattern ap2) +erasePattern (APList _ alp) = PList $ map erasePattern alp +erasePattern (APAdd _ s p t) = PAdd s (erasePattern p) (erase t) +erasePattern (APMul _ s p t) = PMul s (erasePattern p) (erase t) +erasePattern (APSub _ p t) = PSub (erasePattern p) (erase t) +erasePattern (APNeg _ p) = PNeg (erasePattern p) +erasePattern (APFrac _ p1 p2) = PFrac (erasePattern p1) (erasePattern p2) + +eraseBranch :: ABranch -> Branch +eraseBranch b = bind (mapTelescope eraseGuard tel) (erase at) + where (tel,at) = unsafeUnbind b + +eraseGuard :: AGuard -> Guard +eraseGuard (AGBool (unembed -> at)) = GBool (embed (erase at)) +eraseGuard (AGPat (unembed -> at) p) = GPat (embed (erase at)) (erasePattern p) +eraseGuard (AGLet b) = GLet (eraseBinding b) + +eraseLink :: ALink -> Link +eraseLink (ATLink bop at) = TLink bop (erase at) + +eraseQual :: AQual -> Qual +eraseQual (AQBind x (unembed -> at)) = QBind (coerce x) (embed (erase at)) +eraseQual (AQGuard (unembed -> at)) = QGuard (embed (erase at)) + +eraseProperty :: AProperty -> Property +eraseProperty = erase + +------------------------------------------------------------ +-- DTerm erasure + +eraseDTerm :: DTerm -> Term +eraseDTerm (DTVar _ (QName _ x)) = TVar (coerce x) +eraseDTerm (DTPrim _ x) = TPrim x +eraseDTerm DTUnit = TUnit +eraseDTerm (DTBool _ b) = TBool b +eraseDTerm (DTChar c) = TChar c +eraseDTerm (DTNat _ n) = TNat n +eraseDTerm (DTRat r) = TRat r +eraseDTerm (DTAbs q _ b) = TAbs q $ bind [PVar . coerce $ x] (eraseDTerm dt) + where (x, dt) = unsafeUnbind b +eraseDTerm (DTApp _ d1 d2) = TApp (eraseDTerm d1) (eraseDTerm d2) +eraseDTerm (DTPair _ d1 d2) = TTup [eraseDTerm d1, eraseDTerm d2] +eraseDTerm (DTCase _ bs) = TCase (map eraseDBranch bs) +eraseDTerm (DTTyOp _ op ty) = TTyOp op ty +eraseDTerm (DTNil _) = TList [] Nothing +eraseDTerm (DTTest _ x) = eraseDTerm x + +eraseDBranch :: DBranch -> Branch +eraseDBranch b = bind (mapTelescope eraseDGuard tel) (eraseDTerm d) + where + (tel, d) = unsafeUnbind b + +eraseDGuard :: DGuard -> Guard +eraseDGuard (DGPat (unembed -> d) p) = GPat (embed (eraseDTerm d)) (eraseDPattern p) + +eraseDPattern :: DPattern -> Pattern +eraseDPattern (DPVar _ x) = PVar (coerce x) +eraseDPattern (DPWild _) = PWild +eraseDPattern DPUnit = PUnit +eraseDPattern (DPPair _ x1 x2) = PTup (map (PVar . coerce) [x1,x2]) +eraseDPattern (DPInj _ s x) = PInj s (PVar (coerce x)) diff --git a/src/Disco/Typecheck/Graph.hs b/src/Disco/Typecheck/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Typecheck/Graph.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Typecheck.Graph +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- A thin layer on top of graphs from the @fgl@ package, which +-- allows dealing with vertices by label instead of by integer +-- @Node@ values. +----------------------------------------------------------------------------- + +module Disco.Typecheck.Graph where + +import Prelude hiding (map, (<>)) +import qualified Prelude as P + +import Control.Arrow ((&&&)) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromJust, isJust, mapMaybe) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Tuple (swap) + +import qualified Data.Graph.Inductive.Graph as G +import Data.Graph.Inductive.PatriciaTree (Gr) +import qualified Data.Graph.Inductive.Query.DFS as G (components, + condensation, topsort') + +import Disco.Pretty +import Disco.Util ((!)) + +-- | Directed graphs, with vertices labelled by @a@ and unlabelled +-- edges. +data Graph a = G (Gr a ()) (Map a G.Node) (Map G.Node a) + deriving Show + +instance Pretty a => Pretty (Graph a) where + pretty (G g _ _) = parens (prettyVertices <> ", " <> prettyEdges) + -- (V = {(0, x), (1, N)}, E = {0 -> 1, 2 -> 3}) + where + vs = G.labNodes g + es = G.labEdges g + + prettyVertex (n,a) = parens (text (show n) <> ", " <> pretty a) + prettyVertices = "V = " <> braces (intercalate "," (P.map prettyVertex vs)) + prettyEdge (v1,v2,_) = text (show v1) <+> "->" <+> text (show v2) + prettyEdges = "E = " <> braces (intercalate "," (P.map prettyEdge es)) + +-- | Create a graph with the given set of vertices and directed edges. +-- If any edges refer to vertices that are not in the given vertex +-- set, they will simply be dropped. +mkGraph :: (Show a, Ord a) => Set a -> Set (a,a) -> Graph a +mkGraph vs es = G (G.mkGraph vs' es') a2n n2a + where + vs' = zip [0..] (S.toList vs) + n2a = M.fromList vs' + a2n = M.fromList . P.map swap $ vs' + es' = mapMaybe mkEdge (S.toList es) + mkEdge (a1,a2) = (,,) <$> M.lookup a1 a2n <*> M.lookup a2 a2n <*> pure () + +-- | Return the set of vertices (nodes) of a graph. +nodes :: Graph a -> Set a +nodes (G _ m _) = M.keysSet m + +-- | Return the set of directed edges of a graph. +edges :: Ord a => Graph a -> Set (a,a) +edges (G g _ m) = S.fromList $ P.map (\(n1,n2,()) -> (m ! n1, m ! n2)) (G.labEdges g) + +-- | Map a function over all the vertices of a graph. @Graph@ is not +-- a @Functor@ instance because of the @Ord@ constraint on @b@. +map :: Ord b => (a -> b) -> Graph a -> Graph b +map f (G g m1 m2) = G (G.nmap f g) (M.mapKeys f m1) (M.map f m2) + +-- | Delete a vertex. +delete :: (Show a, Ord a) => a -> Graph a -> Graph a +delete a (G g a2n n2a) = G (G.delNode n g) (M.delete a a2n) (M.delete n n2a) + where + n = a2n ! a + +-- | The @condensation@ of a graph is the graph of its strongly +-- connected components, /i.e./ each strongly connected component is +-- compressed to a single node, labelled by the set of vertices in +-- the component. There is an edge from component A to component B +-- in the condensed graph iff there is an edge from any vertex in +-- component A to any vertex in component B in the original graph. +condensation :: Ord a => Graph a -> Graph (Set a) +condensation (G g _ n2a) = G g' as2n n2as + where + g' = G.nmap (S.fromList . P.map (n2a !)) (G.condensation g) + vs' = G.labNodes g' + n2as = M.fromList vs' + as2n = M.fromList . P.map swap $ vs' + +-- | Get a list of the weakly connected components of a graph, +-- providing the set of vertices in each. Equivalently, return the +-- strongly connected components of the graph when considered as an +-- undirected graph. +wcc :: Ord a => Graph a -> [Set a] +wcc = P.map (S.map snd) . wccIDs + +wccIDs :: Ord a => Graph a -> [Set (G.Node, a)] +wccIDs (G g _a2n n2a) = P.map (S.fromList . P.map (id &&& (n2a !))) (G.components g) + +-- | Do a topological sort on a DAG. +topsort :: Graph a -> [a] +topsort (G g _a2n _n2a) = G.topsort' g + +-- | A miscellaneous utility function to turn a @Graph Maybe@ into a +-- @Maybe Graph@: the result is @Just@ iff all the vertices in the +-- input graph are. +sequenceGraph :: Ord a => Graph (Maybe a) -> Maybe (Graph a) +sequenceGraph g = case all isJust (nodes g) of + False -> Nothing + True -> Just $ map fromJust g + +-- | Get a list of all the /successors/ of a given node in the graph, +-- /i.e./ all the nodes reachable from the given node by a directed +-- path. Does not include the given node itself. +suc :: (Show a, Ord a) => Graph a -> a -> [a] +suc (G g a2n n2a) = P.map (n2a !) . G.suc g . (a2n !) + +-- | Get a list of all the /predecessors/ of a given node in the +-- graph, /i.e./ all the nodes from which from the given node is +-- reachable by a directed path. Does not include the given node +-- itself. +pre :: (Show a, Ord a) => Graph a -> a -> [a] +pre (G g a2n n2a) = P.map (n2a !) . G.pre g . (a2n !) + +-- | Given a graph, return two mappings: the first maps each vertex to +-- its set of successors; the second maps each vertex to its set of +-- predecessors. Equivalent to +-- +-- > (M.fromList *** M.fromList) . unzip . map (\a -> ((a, suc g a), (a, pre g a))) . nodes $ g +-- +-- but much more efficient. +cessors :: (Show a, Ord a) => Graph a -> (Map a (Set a), Map a (Set a)) +cessors g@(G gg _ _) = (succs, preds) + where + as = G.topsort' gg + succs = foldr collectSuccs M.empty as -- build successors map + collectSuccs a m = M.insert a succsSet m + where + ss = suc g a + succsSet = S.fromList ss `S.union` S.unions (P.map (m !) ss) + + preds = foldr collectPreds M.empty (reverse as) -- build predecessors map + collectPreds a m = M.insert a predsSet m + where + ss = pre g a + predsSet = S.fromList ss `S.union` S.unions (P.map (m !) ss) diff --git a/src/Disco/Typecheck/Solve.hs b/src/Disco/Typecheck/Solve.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Typecheck/Solve.hs @@ -0,0 +1,1046 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Typecheck.Solve +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Constraint solver for the constraints generated during type +-- checking/inference. +----------------------------------------------------------------------------- + +module Disco.Typecheck.Solve where + +import Unbound.Generics.LocallyNameless (Alpha, Name, Subst, fv, + name2Integer, string2Name, + substs) + +import Data.Coerce +import GHC.Generics (Generic) + +import Control.Arrow ((&&&), (***)) +import Control.Lens hiding (use, (%=), (.=)) +import Control.Monad (unless, zipWithM) +import Data.Bifunctor (first, second) +import Data.Either (partitionEithers) +import Data.List (find, foldl', intersect, + partition) +import Data.Map (Map, (!)) +import qualified Data.Map as M +import Data.Maybe (fromJust, fromMaybe, + mapMaybe) +import Data.Monoid (First (..)) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Tuple + +import Disco.Effects.Fresh +import Disco.Effects.State +import Polysemy +import Polysemy.Error +import Polysemy.Output + +import Disco.Messages +import Disco.Pretty hiding ((<>)) +import Disco.Subst +import qualified Disco.Subst as Subst +import Disco.Typecheck.Constraints +import Disco.Typecheck.Graph (Graph) +import qualified Disco.Typecheck.Graph as G +import Disco.Typecheck.Unify +import Disco.Types +import Disco.Types.Qualifiers +import Disco.Types.Rules + +-------------------------------------------------- +-- Solver errors + +-- | Type of errors which can be generated by the constraint solving +-- process. +data SolveError where + NoWeakUnifier :: SolveError + NoUnify :: SolveError + UnqualBase :: Qualifier -> BaseTy -> SolveError + Unqual :: Qualifier -> Type -> SolveError + QualSkolem :: Qualifier -> Name Type -> SolveError + deriving Show + +instance Semigroup SolveError where + e <> _ = e + +-------------------------------------------------- +-- Error utilities + +runSolve :: Sem (Fresh ': Error SolveError ': r) a -> Sem r (Either SolveError a) +runSolve = runError . runFresh + +-- | Run a list of actions, and return the results from those which do +-- not throw an error. If all of them throw an error, rethrow the +-- first one. +filterErrors :: Member (Error e) r => [Sem r a] -> Sem r [a] +filterErrors ms = do + es <- mapM try ms + case partitionEithers es of + (e:_, []) -> throw e + (_, as) -> return as + +-- | A variant of 'asum' which picks the first action that succeeds, +-- or re-throws the error of the last one if none of them +-- do. Precondition: the list must not be empty. +asum' :: Member (Error e) r => [Sem r a] -> Sem r a +asum' [] = error "Impossible: asum' []" +asum' [m] = m +asum' (m:ms) = m `catch` (\_ -> asum' ms) + +-------------------------------------------------- +-- Simple constraints + +data SimpleConstraint where + (:<:) :: Type -> Type -> SimpleConstraint + (:=:) :: Type -> Type -> SimpleConstraint + deriving (Show, Eq, Ord, Generic, Alpha, Subst Type) + +instance Pretty SimpleConstraint where + pretty = \case + ty1 :<: ty2 -> pretty ty1 <+> "<:" <+> pretty ty2 + ty1 :=: ty2 -> pretty ty1 <+> "=" <+> pretty ty2 + +-------------------------------------------------- +-- Simplifier types + +-- Uses TH to generate lenses so it has to go here before other stuff. + +--------------------------------- +-- Variable maps + +-- | Information about a particular type variable. More information +-- may be added in the future (e.g. polarity). +data TyVarInfo = TVI + { _tyVarIlk :: First Ilk -- ^ The ilk (unification or skolem) of the variable, if known + , _tyVarSort :: Sort -- ^ The sort (set of qualifiers) of the type variable. + } + deriving (Show) + +makeLenses ''TyVarInfo + +instance Pretty TyVarInfo where + pretty (TVI (First ilk) s) = maybe (pure "?") pretty ilk <> "%" <> pretty s + +-- | Create a 'TyVarInfo' given an 'Ilk' and a 'Sort'. +mkTVI :: Ilk -> Sort -> TyVarInfo +mkTVI = TVI . First . Just + +-- | We can learn different things about a type variable from +-- different places; the 'Semigroup' instance allows combining +-- information about a type variable into a single record. +instance Semigroup TyVarInfo where + TVI i1 s1 <> TVI i2 s2 = TVI (i1 <> i2) (s1 <> s2) + +-- | A 'TyVarInfoMap' records what we know about each type variable; +-- it is a mapping from type variable names to 'TyVarInfo' records. +newtype TyVarInfoMap = VM { unVM :: Map (Name Type) TyVarInfo } + deriving (Show) + +instance Pretty TyVarInfoMap where + pretty (VM m) = pretty m + +-- | Utility function for acting on a 'TyVarInfoMap' by acting on the +-- underlying 'Map'. +onVM :: + (Map (Name Type) TyVarInfo -> Map (Name Type) TyVarInfo) -> + TyVarInfoMap -> TyVarInfoMap +onVM f (VM m) = VM (f m) + +-- | Look up a given variable name in a 'TyVarInfoMap'. +lookupVM :: Name Type -> TyVarInfoMap -> Maybe TyVarInfo +lookupVM v = M.lookup v . unVM + +-- | Remove the mapping for a particular variable name (if it exists) +-- from a 'TyVarInfoMap'. +deleteVM :: Name Type -> TyVarInfoMap -> TyVarInfoMap +deleteVM = onVM . M.delete + +-- | Given a list of type variable names, add them all to the +-- 'TyVarInfoMap' as 'Skolem' variables (with a trivial sort). +addSkolems :: [Name Type] -> TyVarInfoMap -> TyVarInfoMap +addSkolems vs = onVM $ \vm -> foldl' (flip (\v -> M.insert v (mkTVI Skolem mempty))) vm vs + +-- | The @Semigroup@ instance for 'TyVarInfoMap' unions the two maps, +-- combining the info records for any variables occurring in both +-- maps. +instance Semigroup TyVarInfoMap where + VM sm1 <> VM sm2 = VM (M.unionWith (<>) sm1 sm2) + +instance Monoid TyVarInfoMap where + mempty = VM M.empty + mappend = (<>) + +-- | Get the sort of a particular variable recorded in a +-- 'TyVarInfoMap'. Returns the trivial (empty) sort for a variable +-- not in the map. +getSort :: TyVarInfoMap -> Name Type -> Sort +getSort (VM m) v = maybe topSort (view tyVarSort) (M.lookup v m) + +-- | Get the 'Ilk' of a variable recorded in a 'TyVarInfoMap'. +-- Returns @Nothing@ if the variable is not in the map, or if its +-- ilk is not known. +getIlk :: TyVarInfoMap -> Name Type -> Maybe Ilk +getIlk (VM m) v = (m ^? ix v . tyVarIlk) >>= getFirst + +-- | Extend the sort of a type variable by combining its existing sort +-- with the given one. Has no effect if the variable is not already +-- in the map. +extendSort :: Name Type -> Sort -> TyVarInfoMap -> TyVarInfoMap +extendSort x s = onVM (at x . _Just . tyVarSort %~ (`S.union` s)) + +--------------------------------- +-- Simplifier state + +-- The simplification stage maintains a mutable state consisting of +-- the current qualifier map (containing wanted qualifiers for type +-- variables), the list of remaining SimpleConstraints, and the +-- current substitution. It also keeps track of seen constraints, so +-- expansion of recursive types can stop when encountering a +-- previously seen constraint. +data SimplifyState = SS + { _ssVarMap :: TyVarInfoMap + , _ssConstraints :: [SimpleConstraint] + , _ssSubst :: S + , _ssSeen :: Set SimpleConstraint + } + +makeLenses ''SimplifyState + +lkup :: (Ord k, Show k, Show (Map k a)) => String -> Map k a -> k -> a +lkup messg m k = fromMaybe (error errMsg) (M.lookup k m) + where + errMsg = unlines + [ "Key lookup error:" + , " Key = " ++ show k + , " Map = " ++ show m + , " Location: " ++ messg + ] + +-------------------------------------------------- +-- Top-level solver algorithm + +solveConstraint + :: Members '[Fresh, Error SolveError, Output Message] r + => TyDefCtx -> Constraint -> Sem r S +solveConstraint tyDefns c = do + + -- Step 1. Open foralls (instantiating with skolem variables) and + -- collect wanted qualifiers; also expand disjunctions. Result in a + -- list of possible constraint sets; each one consists of equational + -- and subtyping constraints in addition to qualifiers. + + debug "Solving:" + debugPretty c + + debug "------------------------------" + debug "Decomposing constraints..." + + qcList <- decomposeConstraint c + + -- Now try continuing with each set and pick the first one that has + -- a solution. + asum' (map (uncurry (solveConstraintChoice tyDefns)) qcList) + +solveConstraintChoice + :: Members '[Fresh, Error SolveError, Output Message] r + => TyDefCtx -> TyVarInfoMap -> [SimpleConstraint] -> Sem r S +solveConstraintChoice tyDefns quals cs = do + + debugPretty quals + debug $ vcat (map pretty' cs) + + -- Step 2. Check for weak unification to ensure termination. (a la + -- Traytel et al). + + let toEqn (t1 :<: t2) = (t1,t2) + toEqn (t1 :=: t2) = (t1,t2) + _ <- note NoWeakUnifier $ weakUnify tyDefns (map toEqn cs) + + -- Step 3. Simplify constraints, resulting in a set of atomic + -- subtyping constraints. Also simplify/update qualifier set + -- accordingly. + + debug "------------------------------" + debug "Running simplifier..." + + (vm, atoms, theta_simp) <- simplify tyDefns quals cs + debug "Done running simplifier. Results:" + + debugPretty vm + debug $ vcat $ map (pretty' . (\(x,y) -> TyAtom x :<: TyAtom y)) atoms + debugPretty theta_simp + + -- Step 4. Turn the atomic constraints into a directed constraint + -- graph. + + debug "------------------------------" + debug "Generating constraint graph..." + + -- Some variables might have qualifiers but not participate in any + -- equality or subtyping relations (see issue #153); make sure to + -- extract them and include them in the constraint graph as isolated + -- vertices + let mkAVar (v, First (Just Skolem)) = AVar (S v) + mkAVar (v, _ ) = AVar (U v) + vars = S.fromList . map (mkAVar . second (view tyVarIlk)) . M.assocs . unVM $ vm + g = mkConstraintGraph vars atoms + + debugPretty g + + -- Step 5. + -- Check for any weakly connected components containing more + -- than one skolem, or a skolem and a base type; such components are + -- not allowed. Other WCCs with a single skolem simply unify to + -- that skolem. + + debug "------------------------------" + debug "Checking WCCs for skolems..." + + (g', theta_skolem) <- checkSkolems tyDefns vm g + debugPretty theta_skolem + + -- We don't need to ensure that theta_skolem respects sorts since + -- checkSkolems will only unify skolem vars with unsorted variables. + + + -- Step 6. Eliminate cycles from the graph, turning each strongly + -- connected component into a single node, unifying all the atoms in + -- each component. + + debug "------------------------------" + debug "Collapsing SCCs..." + + (g'', theta_cyc) <- elimCycles tyDefns g' + + debugPretty g'' + debugPretty theta_cyc + + -- Check that the resulting substitution respects sorts... + let sortOK (x, TyAtom (ABase ty)) = hasSort ty (getSort vm x) + sortOK (_, TyAtom (AVar (U _))) = True + sortOK p = error $ "Impossible! sortOK " ++ show p + unless (all sortOK (Subst.toList theta_cyc)) + $ throw NoUnify + + -- ... and update the sort map if we unified any type variables. + -- Just make sure that if theta_cyc maps x |-> y, then y picks up + -- the sort of x. + + debug "Old sort map:" + debugPretty vm + + let vm' = foldr updateVarMap vm (Subst.toList theta_cyc) + where + updateVarMap :: (Name Type, Type) -> TyVarInfoMap -> TyVarInfoMap + updateVarMap (x, TyAtom (AVar (U y))) vmm = extendSort y (getSort vmm x) vmm + updateVarMap _ vmm = vmm + + debug "Updated sort map:" + debugPretty vm + + -- Steps 7 & 8: solve the graph, iteratively finding satisfying + -- assignments for each type variable based on its successor and + -- predecessor base types in the graph; then unify all the type + -- variables in any remaining weakly connected components. + + debug "------------------------------" + debug "Solving for type variables..." + + theta_sol <- solveGraph vm' g'' + debugPretty theta_sol + + debug "------------------------------" + debug "Composing final substitution..." + + let theta_final = theta_sol @@ theta_cyc @@ theta_skolem @@ theta_simp + debugPretty theta_final + + return theta_final + + +-------------------------------------------------- +-- Step 1. Constraint decomposition. + +decomposeConstraint + :: Members '[Fresh, Error SolveError] r + => Constraint -> Sem r [(TyVarInfoMap, [SimpleConstraint])] +decomposeConstraint (CSub t1 t2) = return [(mempty, [t1 :<: t2])] +decomposeConstraint (CEq t1 t2) = return [(mempty, [t1 :=: t2])] +decomposeConstraint (CQual q ty) = (:[]) . (, []) <$> decomposeQual ty q +decomposeConstraint (CAnd cs) = map mconcat . sequence <$> mapM decomposeConstraint cs +decomposeConstraint CTrue = return [mempty] +decomposeConstraint (CAll ty) = do + (vars, c) <- unbind ty + let c' = substs (mkSkolems vars) c + (map . first . addSkolems) vars <$> decomposeConstraint c' + + where + mkSkolems :: [Name Type] -> [(Name Type, Type)] + mkSkolems = map (id &&& TySkolem) + +decomposeConstraint (COr cs) = concat <$> filterErrors (map decomposeConstraint cs) + +decomposeQual + :: Members '[Fresh, Error SolveError] r + => Type -> Qualifier -> Sem r TyVarInfoMap +decomposeQual (TyAtom a) q = checkQual q a + -- XXX Really we should be able to check by induction whether a + -- user-defined type has a certain sort. +decomposeQual ty@(TyCon (CUser _) _) q = throw $ Unqual q ty +decomposeQual ty@(TyCon c tys) q + = case qualRules c q of + Nothing -> throw $ Unqual q ty + Just qs -> mconcat <$> zipWithM (maybe (return mempty) . decomposeQual) tys qs + +checkQual + :: Members '[Fresh, Error SolveError] r + => Qualifier -> Atom -> Sem r TyVarInfoMap +checkQual q (AVar (U v)) = return . VM . M.singleton v $ mkTVI Unification (S.singleton q) +checkQual q (AVar (S v)) = throw $ QualSkolem q v +checkQual q (ABase bty) = + case hasQual bty q of + True -> return mempty + False -> throw $ UnqualBase q bty + +-------------------------------------------------- +-- Step 3. Constraint simplification. + +-- | This step does unification of equality constraints, as well as +-- structural decomposition of subtyping constraints. For example, +-- if we have a constraint (x -> y) <: (z -> Int), then we can +-- decompose it into two constraints, (z <: x) and (y <: Int); if we +-- have a constraint v <: (a,b), then we substitute v ↦ (x,y) (where +-- x and y are fresh type variables) and continue; and so on. +-- +-- After this step, the remaining constraints will all be atomic +-- constraints, that is, only of the form (v1 <: v2), (v <: b), or +-- (b <: v), where v is a type variable and b is a base type. + +simplify + :: Members '[Error SolveError, Output Message] r + => TyDefCtx -> TyVarInfoMap -> [SimpleConstraint] -> Sem r (TyVarInfoMap, [(Atom, Atom)], S) +simplify tyDefns origVM cs + = (\(SS vm' cs' s' _) -> (vm', map extractAtoms cs', s')) + -- contFreshMT :: Monad m => FreshMT m a -> Integer -> m a + -- "Run a FreshMT computation given a starting index for fresh name generation." + <$> runFresh' n (execState (SS origVM cs idS S.empty) simplify') + where + + fvNums :: Alpha a => [a] -> [Integer] + fvNums = map (name2Integer :: Name Type -> Integer) . toListOf fv + + -- Find first unused integer in constraint free vars and sort map + -- domain, and use it to start the fresh var generation, so we don't + -- generate any "fresh" names that interfere with existing names + n1 = maximum0 . fvNums $ cs + n = succ . maximum . (n1:) . fvNums . M.keys . unVM $ origVM + + maximum0 [] = 0 + maximum0 xs = maximum xs + + -- Extract the type atoms from an atomic constraint. + extractAtoms :: SimpleConstraint -> (Atom, Atom) + extractAtoms (TyAtom a1 :<: TyAtom a2) = (a1, a2) + extractAtoms c = error $ "Impossible: simplify left non-atomic or non-subtype constraint " ++ show c + + -- Iterate picking one simplifiable constraint and simplifying it + -- until none are left. + simplify' + :: Members '[State SimplifyState, Fresh, Error SolveError, Output Message] r + => Sem r () + simplify' = do + -- q <- gets fst + -- debug (pretty q) + -- debug "" + + mc <- pickSimplifiable + case mc of + Nothing -> return () + Just s -> do + + debug $ "Simplifying:" <+> pretty' s + + simplifyOne s + simplify' + + -- Pick out one simplifiable constraint, removing it from the list + -- of constraints in the state. Return Nothing if no more + -- constraints can be simplified. + pickSimplifiable + :: Members '[State SimplifyState, Fresh, Error SolveError] r + => Sem r (Maybe SimpleConstraint) + pickSimplifiable = do + curCs <- use ssConstraints + case pick simplifiable curCs of + Nothing -> return Nothing + Just (a,as) -> do + ssConstraints .= as + return (Just a) + + -- Pick the first element from a list satisfying the given + -- predicate, returning the element and the list with the element + -- removed. + pick :: (a -> Bool) -> [a] -> Maybe (a,[a]) + pick _ [] = Nothing + pick p (a:as) + | p a = Just (a,as) + | otherwise = second (a:) <$> pick p as + + -- Check if a constraint can be simplified. An equality + -- constraint can always be "simplified" via unification. A + -- subtyping constraint can be simplified if either it involves a + -- type constructor (in which case we can decompose it), or if it + -- involves two base types (in which case it can be removed if the + -- relationship holds). + simplifiable :: SimpleConstraint -> Bool + simplifiable (_ :=: _) = True + simplifiable (TyCon {} :<: TyCon {}) = True + simplifiable (TyVar {} :<: TyCon {}) = True + simplifiable (TyCon {} :<: TyVar {}) = True + simplifiable (TyCon (CUser _) _ :<: _) = True + simplifiable (_ :<: TyCon (CUser _) _) = True + simplifiable (TyAtom (ABase _) :<: TyAtom (ABase _)) = True + + simplifiable _ = False + + -- Simplify the given simplifiable constraint. If the constraint + -- has already been seen before (due to expansion of a recursive + -- type), just throw it away and stop. + simplifyOne + :: Members '[State SimplifyState, Fresh, Error SolveError] r + => SimpleConstraint -> Sem r () + simplifyOne c = do + seen <- use ssSeen + case c `S.member` seen of + True -> return () + False -> do + ssSeen %= S.insert c + simplifyOne' c + + simplifyOne' + :: Members '[State SimplifyState, Fresh, Error SolveError] r + => SimpleConstraint -> Sem r () + + -- If we have an equality constraint, run unification on it. The + -- resulting substitution is applied to the remaining constraints + -- as well as prepended to the current substitution. + + simplifyOne' (ty1 :=: ty2) = + case unify tyDefns [(ty1, ty2)] of + Nothing -> throw NoUnify + Just s' -> extendSubst s' + + -- If we see a constraint of the form (T <: a), where T is a + -- user-defined type and a is a type variable, then just turn it + -- into an equality (T = a). This is sound but probably not + -- complete. The alternative seems quite complicated, possibly + -- even undecidable. See https://github.com/disco-lang/disco/issues/207 . + simplifyOne' (ty1@(TyCon (CUser _) _) :<: ty2@TyVar{}) + = simplifyOne' (ty1 :=: ty2) + + -- Otherwise, expand the user-defined type and continue. + simplifyOne' (TyCon (CUser t) ts :<: ty2) = + case M.lookup t tyDefns of + Nothing -> error $ show t ++ " not in ty defn map!" + Just (TyDefBody _ body) -> + ssConstraints %= ((body ts :<: ty2) :) + + -- Turn a <: T into a = T. See comment above. + simplifyOne' (ty1@TyVar{} :<: ty2@(TyCon (CUser _) _)) + = simplifyOne' (ty1 :=: ty2) + + simplifyOne' (ty1 :<: TyCon (CUser t) ts) = + case M.lookup t tyDefns of + Nothing -> error $ show t ++ " not in ty defn map!" + Just (TyDefBody _ body) -> + ssConstraints %= ((ty1 :<: body ts) :) + + -- Given a subtyping constraint between two type constructors, + -- decompose it if the constructors are the same (or fail if they + -- aren't), taking into account the variance of each argument to + -- the constructor. Container types are a special case; + -- recursively generate a subtyping constraint for their + -- constructors as well. + simplifyOne' (TyCon c1@(CContainer ctr1) tys1 :<: TyCon (CContainer ctr2) tys2) = + ssConstraints %= + (( (TyAtom ctr1 :<: TyAtom ctr2) + : zipWith3 variance (arity c1) tys1 tys2 + ) + ++) + + simplifyOne' (TyCon c1 tys1 :<: TyCon c2 tys2) + | c1 /= c2 = throw NoUnify + | otherwise = + ssConstraints %= (zipWith3 variance (arity c1) tys1 tys2 ++) + + -- Given a subtyping constraint between a variable and a type + -- constructor, expand the variable into the same constructor + -- applied to fresh type variables. + simplifyOne' con@(TyVar a :<: TyCon c _) = expandStruct a c con + simplifyOne' con@(TyCon c _ :<: TyVar a ) = expandStruct a c con + + -- Given a subtyping constraint between two base types, just check + -- whether the first is indeed a subtype of the second. (Note + -- that we only pattern match here on type atoms, which could + -- include variables, but this will only ever get called if + -- 'simplifiable' was true, which checks that both are base + -- types.) + simplifyOne' (TyAtom (ABase b1) :<: TyAtom (ABase b2)) = do + case isSubB b1 b2 of + True -> return () + False -> throw NoUnify + + simplifyOne' (s :<: t) = + error $ "Impossible! simplifyOne' " ++ show s ++ " :<: " ++ show t + + expandStruct + :: Members '[State SimplifyState, Fresh, Error SolveError] r + => Name Type -> Con -> SimpleConstraint -> Sem r () + expandStruct a c con = do + as <- mapM (const (TyVar <$> fresh (string2Name "a"))) (arity c) + let s' = a |-> TyCon c as + ssConstraints %= (con:) + extendSubst s' + + -- 1. compose s' with current subst + -- 2. apply s' to constraints + -- 3. apply s' to qualifier map and decompose + extendSubst + :: Members '[State SimplifyState, Fresh, Error SolveError] r + => S -> Sem r () + extendSubst s' = do + ssSubst %= (s'@@) + ssConstraints %= applySubst s' + substVarMap s' + + substVarMap + :: Members '[State SimplifyState, Fresh, Error SolveError] r + => S -> Sem r () + substVarMap s' = do + vm <- use ssVarMap + + -- 1. Get quals for each var in domain of s' and match them with + -- the types being substituted for those vars. + + let tySorts :: [(Type, Sort)] + tySorts = map (second (view tyVarSort)) . mapMaybe (traverse (`lookupVM` vm) . swap) $ Subst.toList s' + + tyQualList :: [(Type, Qualifier)] + tyQualList = concatMap (sequenceA . second S.toList) tySorts + + -- 2. Decompose the resulting qualifier constraints + + vm' <- mconcat <$> mapM (uncurry decomposeQual) tyQualList + + -- 3. delete domain of s' from vm and merge in decomposed quals. + + ssVarMap .= vm' <> foldl' (flip deleteVM) vm (dom s') + + -- The above works even when unifying two variables. Say we have + -- the TyVarInfoMap + -- + -- a |-> {add} + -- b |-> {sub} + -- + -- and we get back theta = [a |-> b]. The domain of theta + -- consists solely of a, so we look up a in the TyVarInfoMap and get + -- {add}. We therefore generate the constraint 'add (theta a)' + -- = 'add b' which can't be decomposed at all, and hence yields + -- the TyVarInfoMap {b |-> {add}}. We then delete a from the + -- original TyVarInfoMap and merge the result with the new TyVarInfoMap, + -- yielding {b |-> {sub,add}}. + + + -- Create a subtyping constraint based on the variance of a type + -- constructor argument position: in the usual order for + -- covariant, and reversed for contravariant. + variance Co ty1 ty2 = ty1 :<: ty2 + variance Contra ty1 ty2 = ty2 :<: ty1 + +-------------------------------------------------- +-- Step 4: Build constraint graph + +-- | Given a list of atoms and atomic subtype constraints (each pair +-- @(a1,a2)@ corresponds to the constraint @a1 <: a2@) build the +-- corresponding constraint graph. +mkConstraintGraph :: (Show a, Ord a) => Set a -> [(a, a)] -> Graph a +mkConstraintGraph as cs = G.mkGraph nodes (S.fromList cs) + where + nodes = as `S.union` S.fromList (cs ^.. traverse . each) + +-------------------------------------------------- +-- Step 5: Check skolems + +-- | Check for any weakly connected components containing more than +-- one skolem, or a skolem and a base type, or a skolem and any +-- variables with nontrivial sorts; such components are not allowed. +-- If there are any WCCs with a single skolem, no base types, and +-- only unsorted variables, just unify them all with the skolem and +-- remove those components. +checkSkolems + :: Members '[Error SolveError, Output Message] r + => TyDefCtx -> TyVarInfoMap -> Graph Atom -> Sem r (Graph UAtom, S) +checkSkolems tyDefns vm graph = do + let skolemWCCs :: [Set Atom] + skolemWCCs = filter (any isSkolem) $ G.wcc graph + + ok wcc = S.size (S.filter isSkolem wcc) <= 1 + && all (\case { ABase _ -> False + ; AVar (S _) -> True + ; AVar (U v) -> maybe True (S.null . view tyVarSort) (lookupVM v vm) }) + wcc + + (good, bad) = partition ok skolemWCCs + + unless (null bad) $ throw NoUnify + + -- take all good sets and + -- (1) delete them from the graph + -- (2) unify them all with the skolem + unifyWCCs graph idS good + + where + noSkolems :: Atom -> UAtom + noSkolems (ABase b) = UB b + noSkolems (AVar (U v)) = UV v + noSkolems (AVar (S v)) = error $ "Skolem " ++ show v ++ " remaining in noSkolems" + + unifyWCCs g s [] = return (G.map noSkolems g, s) + unifyWCCs g s (u:us) = do + debug $ "Unifying" <+> pretty' (u:us) <> "..." + + let g' = foldl' (flip G.delete) g u + + ms' = unifyAtoms tyDefns (S.toList u) + case ms' of + Nothing -> throw NoUnify + Just s' -> unifyWCCs g' (atomToTypeSubst s' @@ s) us + +-------------------------------------------------- +-- Step 6: Eliminate cycles + +-- | Eliminate cycles in the constraint set by collapsing each +-- strongly connected component to a single node, (unifying all the +-- types in the SCC). A strongly connected component is a maximal +-- set of nodes where every node is reachable from every other by a +-- directed path; since we are using directed edges to indicate a +-- subtyping constraint, this means every node must be a subtype of +-- every other, and the only way this can happen is if all are in +-- fact equal. +-- +-- Of course, this step can fail if the types in a SCC are not +-- unifiable. If it succeeds, it returns the collapsed graph (which +-- is now guaranteed to be acyclic, i.e. a DAG) and a substitution. +elimCycles + :: Members '[Error SolveError] r + => TyDefCtx -> Graph UAtom -> Sem r (Graph UAtom, S) +elimCycles tyDefns = elimCyclesGen uatomToTypeSubst (unifyUAtoms tyDefns) + +elimCyclesGen + :: forall a b r. (Subst a a, Ord a, Members '[Error SolveError] r) + => (Substitution a -> Substitution b) -> ([a] -> Maybe (Substitution a)) + -> Graph a -> Sem r (Graph a, Substitution b) +elimCyclesGen genSubst genUnify g + = note NoUnify + $ (G.map fst &&& (genSubst . compose . S.map snd . G.nodes)) <$> g' + where + + g' :: Maybe (Graph (a, Substitution a)) + g' = G.sequenceGraph $ G.map unifySCC (G.condensation g) + + unifySCC :: Set a -> Maybe (a, Substitution a) + unifySCC uatoms = case S.toList uatoms of + [] -> error "Impossible! unifySCC on the empty set" + as@(a:_) -> (flip applySubst a &&& id) <$> genUnify as + +------------------------------------------------------------ +-- Steps 7 and 8: Constraint resolution +------------------------------------------------------------ + +-- | Rels stores the set of base types and variables related to a +-- given variable in the constraint graph (either predecessors or +-- successors, but not both). +data Rels = Rels + { baseRels :: Set BaseTy + , varRels :: Set (Name Type) + } + deriving (Show, Eq) + +-- | A RelMap associates each variable to its sets of base type and +-- variable predecessors and successors in the constraint graph. +newtype RelMap = RelMap { unRelMap :: Map (Name Type, Dir) Rels} + +instance Pretty RelMap where + pretty (RelMap rm) = vcat (map prettyVar byVar) + where + vars = S.map fst (M.keysSet rm) + byVar = map (\x -> (rm!(x,SubTy), x, rm!(x,SuperTy))) (S.toList vars) + + prettyVar (subs, x, sups) = hsep [prettyRel subs, "<:", pretty x, "<:", prettyRel sups] + prettyRel rs = pretty (baseRels rs) <> ", " <> pretty (varRels rs) + +-- | Modify a @RelMap@ to record the fact that we have solved for a +-- type variable. In particular, delete the variable from the +-- @RelMap@ as a key, and also update the relative sets of every +-- other variable to remove this variable and add the base type we +-- chose for it. +substRel :: Name Type -> BaseTy -> RelMap -> RelMap +substRel x ty + = RelMap + . M.delete (x,SuperTy) + . M.delete (x,SubTy) + . M.map (\r@(Rels b v) -> if x `S.member` v then Rels (S.insert ty b) (S.delete x v) else r) + . unRelMap + +-- | Essentially dirtypesBySort vm rm dir t s x finds all the +-- dir-types (sub- or super-) of t which have sort s, relative to +-- the variables in x. This is \overbar{T}_S^X (resp. \underbar...) +-- from Traytel et al. +dirtypesBySort :: TyVarInfoMap -> RelMap -> Dir -> BaseTy -> Sort -> Set (Name Type) -> [BaseTy] +dirtypesBySort vm (RelMap relMap) dir t s x + + -- Keep only those supertypes t' of t + = keep (dirtypes dir t) $ \t' -> + -- which have the right sort, and such that + hasSort t' s && + + -- for all variables beta \in x, + forAll x (\beta -> + + -- there is at least one type t'' which is a subtype of t' + -- which would be a valid solution for beta, that is, + exists (dirtypes (other dir) t') $ \t'' -> + + -- t'' has the sort beta is supposed to have, and + hasSort t'' (getSort vm beta) && + + -- t'' is a supertype of every base type predecessor of beta. + forAll (baseRels (lkup "dirtypesBySort, beta rel" relMap (beta, other dir))) + (isDirB dir t'')) + + -- The above comments are written assuming dir = Super; of course, + -- if dir = Sub then just swap "super" and "sub" everywhere. + + where + forAll, exists :: Foldable t => t a -> (a -> Bool) -> Bool + forAll = flip all + exists = flip any + keep = flip filter + +-- | Sort-aware infimum or supremum. +limBySort :: TyVarInfoMap -> RelMap -> Dir -> [BaseTy] -> Sort -> Set (Name Type) -> Maybe BaseTy +limBySort vm rm dir ts s x + = (\is -> find (\lim -> all (\u -> isDirB dir u lim) is) is) + . isects + . map (\t -> dirtypesBySort vm rm dir t s x) + $ ts + where + isects = foldr1 intersect + +lubBySort, glbBySort :: TyVarInfoMap -> RelMap -> [BaseTy] -> Sort -> Set (Name Type) -> Maybe BaseTy +lubBySort vm rm = limBySort vm rm SuperTy +glbBySort vm rm = limBySort vm rm SubTy + +-- | From the constraint graph, build the sets of sub- and super- base +-- types of each type variable, as well as the sets of sub- and +-- supertype variables. For each type variable x in turn, try to +-- find a common supertype of its base subtypes which is consistent +-- with the sort of x and with the sorts of all its sub-variables, +-- as well as symmetrically a common subtype of its supertypes, etc. +-- Assign x one of the two: if it has only successors, assign it +-- their inf; otherwise, assign it the sup of its predecessors. If +-- it has both, we have a choice of whether to assign it the sup of +-- predecessors or inf of successors; both lead to a sound & +-- complete algorithm. We choose to assign it the sup of its +-- predecessors in this case, since it seems nice to default to +-- "simpler" types lower down in the subtyping chain. +solveGraph + :: Members '[Fresh, Error SolveError, Output Message] r + => TyVarInfoMap -> Graph UAtom -> Sem r S +solveGraph vm g = atomToTypeSubst . unifyWCC <$> go topRelMap + where + unifyWCC :: Substitution BaseTy -> Substitution Atom + unifyWCC s = compose (map mkEquateSubst wccVarGroups) @@ fmap ABase s + where + wccVarGroups :: [Set (Name Type)] + wccVarGroups = map (S.map getVar) . filter (all uisVar) . applySubst s $ G.wcc g + getVar (UV v) = v + getVar (UB b) = error + $ "Impossible! Base type " ++ show b ++ " in solveGraph.getVar" + + mkEquateSubst :: Set (Name Type) -> Substitution Atom + mkEquateSubst = mkEquations . S.toList + + mkEquations (a:as) = Subst.fromList . map (\v -> (coerce v, AVar (U a))) $ as + mkEquations [] = error "Impossible! Empty set of names in mkEquateSubst" + + -- After picking concrete base types for all the type + -- variables we can, the only thing possibly remaining in + -- the graph are components containing only type variables + -- and no base types. It is sound, and simplifies the + -- generated types considerably, to simply unify any type + -- variables which are related by subtyping constraints. + -- That is, we collect all the type variables in each + -- weakly connected component and unify them. + -- + -- As an example where this final step makes a difference, + -- consider a term like @\x. (\y.y) x@. A fresh type + -- variable is generated for the type of @x@, and another + -- for the type of @y@; the application of @(\y.y)@ to @x@ + -- induces a subtyping constraint between the two type + -- variables. The most general type would be something + -- like @forall a b. (a <: b) => a -> b@, but we want to + -- avoid generating unnecessary subtyping constraints (the + -- type system might not even support subtyping qualifiers + -- like this). Instead, we unify the two type variables + -- and the resulting type is @forall a. a -> a@. + + -- Get the successor and predecessor sets for all the type variables. + topRelMap :: RelMap + topRelMap + = RelMap + . M.map (uncurry Rels . (S.fromAscList *** S.fromAscList) + . partitionEithers . map uatomToEither . S.toList) + $ M.mapKeys (,SuperTy) subMap `M.union` M.mapKeys (,SubTy) superMap + + subMap, superMap :: Map (Name Type) (Set UAtom) + (subMap, superMap) = (onlyVars *** onlyVars) $ G.cessors g + + onlyVars :: Map UAtom (Set UAtom) -> Map (Name Type) (Set UAtom) + onlyVars = M.mapKeys fromVar . M.filterWithKey (\a _ -> uisVar a) + where + fromVar (UV x) = x + fromVar _ = error "Impossible! UB but uisVar." + + go + :: Members '[Fresh, Error SolveError, Output Message] r + => RelMap -> Sem r (Substitution BaseTy) + go relMap@(RelMap rm) = debugPretty relMap >> case as of + + -- No variables left that have base type constraints. + [] -> return idS + + -- Solve one variable at a time. See below. + (a:_) -> do + debug $ "Solving for" <+> pretty' a + case solveVar a of + Nothing -> do + debug $ "Couldn't solve for" <+> pretty' a + throw NoUnify + + -- If we solved for a, delete it from the maps, apply the + -- resulting substitution to the remainder (updating the + -- relMap appropriately), and recurse. The substitution we + -- want will be the composition of the substitution for a + -- with the substitution generated by the recursive call. + -- + -- Note we don't need to delete a from the TyVarInfoMap; we + -- never use the set of keys from the TyVarInfoMap for + -- anything (indeed, some variables might not be keys if + -- they have an empty sort), so it doesn't matter if old + -- variables hang around in it. + Just s -> do + debugPretty s + (@@ s) <$> go (substRel a (fromJust $ Subst.lookup (coerce a) s) relMap) + + where + -- NOTE we can't solve a bunch in parallel! Might end up + -- assigning them conflicting solutions if some depend on + -- others. For example, consider the situation + -- + -- Z + -- | + -- a3 + -- / \ + -- a1 N + -- + -- If we try to solve in parallel we will end up assigning a1 + -- -> Z (since it only has base types as an upper bound) and + -- a3 -> N (since it has both upper and lower bounds, and by + -- default we pick the lower bound), but this is wrong since + -- we should have a1 < a3. + -- + -- If instead we solve them one at a time, we could e.g. first + -- solve a1 -> Z, and then we would find a3 -> Z as well. + -- Alternately, if we first solve a3 -> N then we will have a1 + -- -> N as well. Both are acceptable. + -- + -- In fact, this exact graph comes from (^x.x+1) which was + -- erroneously being inferred to have type Z -> N when I first + -- wrote the code. + + -- Get only the variables we can solve on this pass, which + -- have base types in their predecessor or successor set. If + -- there are no such variables, then start picking any + -- remaining variables with a sort and pick types for them + -- (disco doesn't have qualified polymorphism so we can't just + -- leave them). + asBase + = map fst + . filter (not . S.null . baseRels . lkup "solveGraph.go.as" rm) + $ M.keys rm + as = case asBase of + [] -> filter ((/= topSort) . getSort vm) . map fst $ M.keys rm + _ -> asBase + + -- Solve for a variable, failing if it has no solution, otherwise returning + -- a substitution for it. + solveVar :: Name Type -> Maybe (Substitution BaseTy) + solveVar v = + case ((v,SuperTy), (v,SubTy)) & over both (S.toList . baseRels . lkup "solveGraph.solveVar" rm) of + -- No sub- or supertypes; the only way this can happen is + -- if it has a nontrivial sort. + -- + -- Traytel et al. don't seem to have a rule saying what to + -- do in this case (see Fig. 16 on p. 16 of their long + -- version). We used to just pick a type that inhabits + -- the sort, but this is wrong; see + -- https://github.com/disco-lang/disco/issues/192. + -- + -- For now, let's assume that any situation in which we + -- have no base sub- or supertypes but we do have + -- nontrivial sorts means that we are dealing with numeric + -- types; so we can just call N a base subtype and go from there. + + ([], []) -> + -- Debug.trace (show v ++ " has no sub- or supertypes. Assuming N as a subtype.") + (coerce v |->) <$> lubBySort vm relMap [N] (getSort vm v) + (varRels (lkup "solveVar none, rels" rm (v,SubTy))) + + -- Only supertypes. Just assign a to their inf, if one exists. + (bsupers, []) -> + -- Debug.trace (show v ++ " has only supertypes (" ++ show bsupers ++ ")") $ + (coerce v |->) <$> glbBySort vm relMap bsupers (getSort vm v) + (varRels (lkup "solveVar bsupers, rels" rm (v,SuperTy))) + + -- Only subtypes. Just assign a to their sup. + ([], bsubs) -> + -- Debug.trace (show v ++ " has only subtypes (" ++ show bsubs ++ ")") $ + -- Debug.trace ("sortmap: " ++ show vm) $ + -- Debug.trace ("relmap: " ++ show relMap) $ + -- Debug.trace ("sort for " ++ show v ++ ": " ++ show (getSort vm v)) $ + -- Debug.trace ("relvars: " ++ show (varRels (relMap ! (v,SubTy)))) $ + (coerce v |->) <$> lubBySort vm relMap bsubs (getSort vm v) + (varRels (lkup "solveVar bsubs, rels" rm (v,SubTy))) + + -- Both successors and predecessors. Both must have a + -- valid bound, and the bounds must not overlap. Assign a + -- to the sup of its predecessors. + (bsupers, bsubs) -> do + ub <- glbBySort vm relMap bsupers (getSort vm v) + (varRels (rm ! (v,SuperTy))) + lb <- lubBySort vm relMap bsubs (getSort vm v) + (varRels (rm ! (v,SubTy))) + case isSubB lb ub of + True -> Just (coerce v |-> lb) + False -> Nothing diff --git a/src/Disco/Typecheck/Unify.hs b/src/Disco/Typecheck/Unify.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Typecheck/Unify.hs @@ -0,0 +1,142 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Typecheck.Unify +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Unification. +-- +----------------------------------------------------------------------------- + +module Disco.Typecheck.Unify where + +import Unbound.Generics.LocallyNameless (Name, fv) + +import Control.Lens (anyOf) +import Control.Monad.State +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S + +import Disco.Subst +import Disco.Types + +-- XXX todo: might be better if unification took sorts into account +-- directly. As it is, however, I think it works properly; +-- e.g. suppose we have a with sort {sub} and we unify it with Bool. +-- unify will just return a substitution [a |-> Bool]. But then when +-- we call extendSubst, and in particular substSortMap, the sort {sub} +-- will be applied to Bool and decomposed which will throw an error. + +-- | Given a list of equations between types, return a substitution +-- which makes all the equations satisfied (or fail if it is not +-- possible). +-- +-- This is not the most efficient way to implement unification but +-- it is simple. +unify :: TyDefCtx -> [(Type, Type)] -> Maybe S +unify = unify' (==) + +-- | Given a list of equations between types, return a substitution +-- which makes all the equations equal *up to* identifying all base +-- types. So, for example, Int = Nat weakly unifies but Int = (Int +-- -> Int) does not. This is used to check whether subtyping +-- constraints are structurally sound before doing constraint +-- simplification/solving, to ensure termination. +weakUnify :: TyDefCtx -> [(Type, Type)] -> Maybe S +weakUnify = unify' (\_ _ -> True) + +-- | Given a list of equations between types, return a substitution +-- which makes all the equations satisfied (or fail if it is not +-- possible), up to the given comparison on base types. +unify' :: (BaseTy -> BaseTy -> Bool) -> TyDefCtx + -> [(Type, Type)] -> Maybe S +unify' baseEq tyDefns eqs = evalStateT (go eqs) S.empty + where + go :: [(Type, Type)] -> StateT (Set (Type,Type)) Maybe S + go [] = return idS + go (e:es) = do + u <- unifyOne e + case u of + Left sub -> (@@ sub) <$> go (applySubst sub es) + Right newEs -> go (newEs ++ es) + + unifyOne :: (Type, Type) -> StateT (Set (Type,Type)) Maybe (Either S [(Type, Type)]) + unifyOne pair = do + seen <- get + case pair `S.member` seen of + True -> return $ Left idS + False -> unifyOne' pair + + unifyOne' :: (Type, Type) -> StateT (Set (Type,Type)) Maybe (Either S [(Type, Type)]) + + unifyOne' (ty1, ty2) + | ty1 == ty2 = return $ Left idS + + unifyOne' (TyVar x, ty2) + | occurs x ty2 = mzero + | otherwise = return $ Left (x |-> ty2) + unifyOne' (ty1, x@(TyVar _)) + = unifyOne (x, ty1) + + -- At this point we know ty2 isn't the same skolem nor a unification variable. + -- Skolems don't unify with anything. + unifyOne' (TySkolem _, _) = mzero + unifyOne' (_, TySkolem _) = mzero + + -- Unify two container types: unify the container descriptors as + -- well as the type arguments + unifyOne' p@(TyCon (CContainer ctr1) tys1, TyCon (CContainer ctr2) tys2) = do + modify (S.insert p) + return $ Right ((TyAtom ctr1, TyAtom ctr2) : zip tys1 tys2) + + -- If one of the types to be unified is a user-defined type, + -- unfold its definition before continuing the matching + unifyOne' p@(TyCon (CUser t) tys1, ty2) = do + modify (S.insert p) + case M.lookup t tyDefns of + Nothing -> mzero + Just (TyDefBody _ body) -> return $ Right [(body tys1, ty2)] + + unifyOne' p@(ty1, TyCon (CUser t) tys2) = do + modify (S.insert p) + case M.lookup t tyDefns of + Nothing -> mzero + Just (TyDefBody _ body) -> return $ Right [(ty1, body tys2)] + + -- Unify any other pair of type constructor applications: the type + -- constructors must match exactly + unifyOne' p@(TyCon c1 tys1, TyCon c2 tys2) + | c1 == c2 = do + modify (S.insert p) + return $ Right (zip tys1 tys2) + | otherwise = mzero + unifyOne' (TyAtom (ABase b1), TyAtom (ABase b2)) + | baseEq b1 b2 = return $ Left idS + | otherwise = mzero + unifyOne' _ = mzero -- Atom = Cons + + +equate :: TyDefCtx -> [Type] -> Maybe S +equate tyDefns tys = unify tyDefns eqns + where + eqns = zip tys (tail tys) + +occurs :: Name Type -> Type -> Bool +occurs x = anyOf fv (==x) + + +unifyAtoms :: TyDefCtx -> [Atom] -> Maybe (Substitution Atom) +unifyAtoms tyDefns = fmap (fmap fromTyAtom) . equate tyDefns . map TyAtom + where + fromTyAtom (TyAtom a) = a + fromTyAtom _ = error "fromTyAtom on non-TyAtom!" + +unifyUAtoms :: TyDefCtx -> [UAtom] -> Maybe (Substitution UAtom) +unifyUAtoms tyDefns = fmap (fmap fromTyAtom) . equate tyDefns . map (TyAtom . uatomToAtom) + where + fromTyAtom (TyAtom (ABase b)) = UB b + fromTyAtom (TyAtom (AVar (U v))) = UV v + fromTyAtom _ = error "fromTyAtom on wrong thing!" diff --git a/src/Disco/Typecheck/Util.hs b/src/Disco/Typecheck/Util.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Typecheck/Util.hs @@ -0,0 +1,151 @@ + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Typecheck.Util +-- Copyright : (c) 2016 disco team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : byorgey@gmail.com +-- +-- Definition of type contexts, type errors, and various utilities +-- used during type checking. +-- +----------------------------------------------------------------------------- + +module Disco.Typecheck.Util where + +import Disco.Effects.Fresh +import Polysemy +import Polysemy.Error +import Polysemy.Output +import Polysemy.Reader +import Polysemy.Writer +import Unbound.Generics.LocallyNameless (Name, bind, string2Name) + +import qualified Data.Map as M +import Data.Tuple (swap) +import Prelude hiding (lookup) + +import Disco.AST.Surface +import Disco.Context +import Disco.Messages +import Disco.Names (ModuleName) +import Disco.Typecheck.Constraints +import Disco.Typecheck.Solve +import Disco.Types + +------------------------------------------------------------ +-- Contexts +------------------------------------------------------------ + +-- | A typing context is a mapping from term names to types. +type TyCtx = Ctx Term PolyType + +------------------------------------------------------------ +-- Errors +------------------------------------------------------------ + +-- | Potential typechecking errors. +data TCError + = Unbound (Name Term) -- ^ Encountered an unbound variable + | Ambiguous (Name Term) [ModuleName] -- ^ Encountered an ambiguous name. + | NoType (Name Term) -- ^ No type is specified for a definition + | NotCon Con Term Type -- ^ The type of the term should have an + -- outermost constructor matching Con, but + -- it has type 'Type' instead + | EmptyCase -- ^ Case analyses cannot be empty. + | PatternType Con Pattern Type -- ^ The given pattern should have the type, but it doesn't. + -- instead it has a kind of type given by the Con. + | DuplicateDecls (Name Term) -- ^ Duplicate declarations. + | DuplicateDefns (Name Term) -- ^ Duplicate definitions. + | DuplicateTyDefns String -- ^ Duplicate type definitions. + | CyclicTyDef String -- ^ Cyclic type definition. + | NumPatterns -- ^ # of patterns does not match type in definition + | NoSearch Type -- ^ Type can't be quantified over. + | Unsolvable SolveError -- ^ The constraint solver couldn't find a solution. + | NotTyDef String -- ^ An undefined type name was used. + | NoTWild -- ^ Wildcards are not allowed in terms. + | NotEnoughArgs Con -- ^ Not enough arguments provided to type constructor. + | TooManyArgs Con -- ^ Too many arguments provided to type constructor. + | UnboundTyVar (Name Type) -- ^ Unbound type variable + | NoPolyRec String [String] [Type] -- ^ Polymorphic recursion is not allowed + | NoError -- ^ Not an error. The identity of the + -- @Monoid TCError@ instance. + deriving Show + +instance Semigroup TCError where + _ <> r = r + +-- | 'TCError' is a monoid where we simply discard the first error. +instance Monoid TCError where + mempty = NoError + mappend = (<>) + +------------------------------------------------------------ +-- Constraints +------------------------------------------------------------ + +-- | Emit a constraint. +constraint :: Member (Writer Constraint) r => Constraint -> Sem r () +constraint = tell + +-- | Emit a list of constraints. +constraints :: Member (Writer Constraint) r => [Constraint] -> Sem r () +constraints = constraint . cAnd + +-- | Close over the current constraint with a forall. +forAll :: Member (Writer Constraint) r => [Name Type] -> Sem r a -> Sem r a +forAll nms = censor (CAll . bind nms) + +-- | Run a computation that generates constraints, returning the +-- generated 'Constraint' along with the output. Note that this +-- locally dispatches the constraint writer effect. +-- +-- This function is somewhat low-level; typically you should use +-- 'solve' instead, which also solves the generated constraints. +withConstraint :: Sem (Writer Constraint ': r) a -> Sem r (a, Constraint) +withConstraint = fmap swap . runWriter + +-- | Run a computation and solve its generated constraint, returning +-- the resulting substitution (or failing with an error). Note that +-- this locally dispatches the constraint writer effect. +solve + :: Members '[Reader TyDefCtx, Error TCError, Output Message] r + => Sem (Writer Constraint ': r) a -> Sem r (a, S) +solve m = do + (a, c) <- withConstraint m + tds <- ask @TyDefCtx + res <- runSolve . solveConstraint tds $ c + case res of + Left e -> throw (Unsolvable e) + Right s -> return (a, s) + +------------------------------------------------------------ +-- Contexts +------------------------------------------------------------ + +-- | Look up the definition of a named type. Throw a 'NotTyDef' error +-- if it is not found. +lookupTyDefn :: + Members '[Reader TyDefCtx, Error TCError] r + => String -> [Type] -> Sem r Type +lookupTyDefn x args = do + d <- ask @TyDefCtx + case M.lookup x d of + Nothing -> throw (NotTyDef x) + Just (TyDefBody _ body) -> return $ body args + +-- | Run a subcomputation with an extended type definition context. +withTyDefns :: Member (Reader TyDefCtx) r => TyDefCtx -> Sem r a -> Sem r a +withTyDefns tyDefnCtx = local (M.union tyDefnCtx) + +------------------------------------------------------------ +-- Fresh name generation +------------------------------------------------------------ + +-- | Generate a type variable with a fresh name. +freshTy :: Member Fresh r => Sem r Type +freshTy = TyVar <$> fresh (string2Name "a") + +-- | Generate a fresh variable as an atom. +freshAtom :: Member Fresh r => Sem r Atom +freshAtom = AVar . U <$> fresh (string2Name "c") diff --git a/src/Disco/Types.hs b/src/Disco/Types.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Types.hs @@ -0,0 +1,778 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Types +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- The "Disco.Types" module defines the set of types used in the disco +-- language type system, along with various utility functions. +-- +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + +module Disco.Types + ( + -- * Disco language types + -- ** Atomic types + + BaseTy(..), isCtr, Var(..), Ilk(..), pattern U, pattern S + , Atom(..) + , isVar, isBase, isSkolem + , UAtom(..), uisVar, uatomToAtom, uatomToEither + + -- ** Type constructors + + , Con(..) + , pattern CList, pattern CBag, pattern CSet + + -- ** Types + + , Type(..) + + , pattern TyVar + , pattern TySkolem + , pattern TyVoid + , pattern TyUnit + , pattern TyBool + , pattern TyProp + , pattern TyN + , pattern TyZ + , pattern TyF + , pattern TyQ + , pattern TyC + -- , pattern TyFin + , pattern (:->:) + , pattern (:*:) + , pattern (:+:) + , pattern TyList + , pattern TyBag + , pattern TySet + , pattern TyGraph + , pattern TyMap + , pattern TyContainer + , pattern TyUser + , pattern TyString + + -- ** Quantified types + + , PolyType(..) + , toPolyType, closeType + + -- * Type predicates + + , isNumTy, isEmptyTy, isFiniteTy, isSearchable + + -- * Type substitutions + + , Substitution, atomToTypeSubst, uatomToTypeSubst + + -- * Strictness + , Strictness(..), strictness + + -- * Utilities + , isTyVar + , containerVars + , countType + , unpair + , S + , TyDefBody(..) + , TyDefCtx + + -- * HasType class + , HasType(..) + ) + where + +import Data.Coerce +import Data.Data (Data) +import Disco.Data () +import GHC.Generics (Generic) +import Unbound.Generics.LocallyNameless hiding (lunbind) + +import Control.Lens (toListOf) +import Data.List (nub) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import Data.Void +import Math.Combinatorics.Exact.Binomial (choose) + +import Disco.Effects.LFresh + +import Disco.Pretty hiding ((<>)) +import Disco.Subst (Substitution) +import Disco.Types.Qualifiers + +-------------------------------------------------- +-- Disco types +-------------------------------------------------- + +---------------------------------------- +-- Base types + +-- | Base types are the built-in types which form the basis of the +-- disco type system, out of which more complex types can be built. +data BaseTy where + + -- | The void type, with no inhabitants. + Void :: BaseTy + + -- | The unit type, with one inhabitant. + Unit :: BaseTy + + -- | Booleans. + B :: BaseTy + + -- | Propositions. + P :: BaseTy + + -- | Natural numbers. + N :: BaseTy + + -- | Integers. + Z :: BaseTy + + -- | Fractionals (i.e. nonnegative rationals). + F :: BaseTy + + -- | Rationals. + Q :: BaseTy + + -- | Unicode characters. + C :: BaseTy + + -- Finite types. The single argument is a natural number defining + -- the exact number of inhabitants. + -- Fin :: Integer -> BaseTy + + -- | Set container type. It's a bit odd putting these here since + -- they have kind * -> * and all the other base types have kind *; + -- but there's nothing fundamentally wrong with it and in + -- particular this allows us to reuse all the existing constraint + -- solving machinery for container subtyping. + CtrSet :: BaseTy + + -- | Bag container type. + CtrBag :: BaseTy + + -- | List container type. + CtrList :: BaseTy + + deriving (Show, Eq, Ord, Generic, Data, Alpha, Subst BaseTy, Subst Atom, Subst UAtom, Subst Type) + +instance Pretty BaseTy where + pretty = \case + Void -> text "Void" + Unit -> text "Unit" + B -> text "Bool" + P -> text "Prop" + N -> text "ℕ" + Z -> text "ℤ" + Q -> text "ℚ" + F -> text "𝔽" + C -> text "Char" + CtrList -> text "List" + CtrBag -> text "Bag" + CtrSet -> text "Set" + +-- | Test whether a 'BaseTy' is a container (set, bag, or list). +isCtr :: BaseTy -> Bool +isCtr = (`elem` [CtrSet, CtrBag, CtrList]) + +---------------------------------------- +-- Type variables + +-- | 'Var' represents /type variables/, that is, variables which stand +-- for some type. There are two kinds of type variables: +-- +-- * /Unification variables/ stand for an unknown type, about which +-- we might learn additional information during the typechecking +-- process. For example, given a function of type @List a -> List +-- a@, if we typecheck an application of the function to the list +-- @[1,2,3]@, we would learn that @List a@ has to be @List N@, and +-- hence that @a@ has to be @N@. +-- +-- * /Skolem variables/ stand for a fixed generic type, and are used +-- to typecheck universally quantified type signatures (/i.e./ +-- type signatures which contain type variables). For example, if +-- a function has the declared type @List a -> N@, it amounts to a +-- claim that the function will work no matter what type is +-- substituted for @a@. We check this by making up a new skolem +-- variable for @a@. Skolem variables are equal to themselves, +-- but nothing else. In contrast to a unification variable, +-- "learning something" about a skolem variable is an error: it +-- means that the function will only work for certain types, in +-- contradiction to its claim to work for any type at all. +data Ilk = Skolem | Unification + deriving (Eq, Ord, Read, Show, Generic, Data, Alpha, Subst Atom, Subst Type) + +instance Pretty Ilk where + pretty = \case + Skolem -> "S" + Unification -> "U" + +-- | 'Var' represents /type variables/, that is, variables which stand +-- for some type. +data Var where + V :: Ilk -> Name Type -> Var + deriving (Show, Eq, Ord, Generic, Data, Alpha, Subst Atom, Subst Type) + +pattern U :: Name Type -> Var +pattern U v = V Unification v + +pattern S :: Name Type -> Var +pattern S v = V Skolem v + +{-# COMPLETE U, S #-} + +---------------------------------------- +-- Atomic types + +-- | An /atomic type/ is either a base type or a type variable. The +-- alternative is a /compound type/ which is built out of type +-- constructors. The reason we split out the concept of atomic +-- types into its own data type 'Atom' is because constraints +-- involving compound types can always be simplified/translated into +-- constraints involving only atomic types. After that +-- simplification step, we want to be able to work with collections +-- of constraints that are guaranteed to contain only atomic types. +data Atom where + AVar :: Var -> Atom + ABase :: BaseTy -> Atom + deriving (Show, Eq, Ord, Generic, Data, Alpha, Subst Type) + +instance Subst Atom Atom where + isvar (AVar (U x)) = Just (SubstName (coerce x)) + isvar _ = Nothing + +instance Pretty Atom where + pretty = \case + AVar (U v) -> pretty v + AVar (S v) -> text "$" <> pretty v + ABase b -> pretty b + +-- | Is this atomic type a variable? +isVar :: Atom -> Bool +isVar (AVar _) = True +isVar _ = False + +-- | Is this atomic type a base type? +isBase :: Atom -> Bool +isBase = not . isVar + +-- | Is this atomic type a skolem variable? +isSkolem :: Atom -> Bool +isSkolem (AVar (S _)) = True +isSkolem _ = False + +-- | /Unifiable/ atomic types are the same as atomic types but without +-- skolem variables. Hence, a unifiable atomic type is either a base +-- type or a unification variable. +-- +-- Again, the reason this has its own type is that at some stage of +-- the typechecking/constraint solving process, these should be the +-- only things around; we can get rid of skolem variables because +-- either they impose no constraints, or result in an error if they +-- are related to something other than themselves. After checking +-- these things, we can just focus on base types and unification +-- variables. +data UAtom where + UB :: BaseTy -> UAtom + UV :: Name Type -> UAtom + deriving (Show, Eq, Ord, Generic, Alpha, Subst BaseTy) + +instance Subst UAtom UAtom where + isvar (UV x) = Just (SubstName (coerce x)) + isvar _ = Nothing + +instance Pretty UAtom where + pretty (UB b) = pretty b + pretty (UV n) = pretty n + +-- | Is this unifiable atomic type a (unification) variable? +uisVar :: UAtom -> Bool +uisVar (UV _) = True +uisVar _ = False + +-- | Convert a unifiable atomic type into a regular atomic type. +uatomToAtom :: UAtom -> Atom +uatomToAtom (UB b) = ABase b +uatomToAtom (UV x) = AVar (U x) + +-- | Convert a unifiable atomic type to an explicit @Either@ type. +uatomToEither :: UAtom -> Either BaseTy (Name Type) +uatomToEither (UB b) = Left b +uatomToEither (UV v) = Right v + +---------------------------------------- +-- Type constructors + +-- | /Compound types/, such as functions, product types, and sum +-- types, are an application of a /type constructor/ to one or more +-- argument types. +data Con where + -- | Function type constructor, @T1 -> T2@. + CArr :: Con + -- | Product type constructor, @T1 * T2@. + CProd :: Con + -- | Sum type constructor, @T1 + T2@. + CSum :: Con + + -- | Container type (list, bag, or set) constructor. Note this + -- looks like it could contain any 'Atom', but it will only ever + -- contain either a type variable or a 'CtrList', 'CtrBag', or + -- 'CtrSet'. + -- + -- See also 'CList', 'CBag', and 'CSet'. + CContainer :: Atom -> Con + + + -- | Key value maps, Map k v + CMap :: Con + + -- | Graph constructor, Graph a + CGraph :: Con + + -- | The name of a user defined algebraic datatype. + CUser :: String -> Con + + deriving (Show, Eq, Ord, Generic, Data, Alpha) + +instance Pretty Con where + pretty = \case + CMap -> text "Map" + CGraph -> text "Graph" + CUser s -> text s + CList -> text "List" + CBag -> text "Bag" + CSet -> text "Set" + CContainer v -> pretty v + c -> error $ "Impossible: got Con " ++ show c ++ " in pretty @Con" + +-- | 'CList' is provided for convenience; it represents a list type +-- constructor (/i.e./ @List a@). +pattern CList :: Con +pattern CList = CContainer (ABase CtrList) + +-- | 'CBag' is provided for convenience; it represents a bag type +-- constructor (/i.e./ @Bag a@). +pattern CBag :: Con +pattern CBag = CContainer (ABase CtrBag) + +-- | 'CSet' is provided for convenience; it represents a set type +-- constructor (/i.e./ @Set a@). +pattern CSet :: Con +pattern CSet = CContainer (ABase CtrSet) + +{-# COMPLETE CArr, CProd, CSum, CList, CBag, CSet, CGraph, CMap, CUser #-} + +---------------------------------------- +-- Types + +-- | The main data type for representing types in the disco language. +-- A type can be either an atomic type, or the application of a type +-- constructor to one or more type arguments. +-- +-- @Type@s are broken down into two cases (@TyAtom@ and @TyCon@) for +-- ease of implementation: there are many situations where all atoms +-- can be handled generically in one way and all type constructors +-- can be handled generically in another. However, using this +-- representation to write down specific types is tedious; for +-- example, to represent the type @N -> a@ one must write something +-- like @TyCon CArr [TyAtom (ABase N), TyAtom (AVar (U a))]@. For +-- this reason, pattern synonyms such as ':->:', 'TyN', and +-- 'TyVar' are provided so that one can use them to construct and +-- pattern-match on types when convenient. For example, using these +-- synonyms the foregoing example can be written @TyN :->: TyVar a@. +data Type where + + -- | Atomic types (variables and base types), /e.g./ @N@, @Bool@, /etc./ + TyAtom :: Atom -> Type + + -- | Application of a type constructor to type arguments, /e.g./ @N + -- -> Bool@ is the application of the arrow type constructor to the + -- arguments @N@ and @Bool@. + TyCon :: Con -> [Type] -> Type + + deriving (Show, Eq, Ord, Generic, Data, Alpha) + +instance Pretty Type where + pretty (TyAtom a) = pretty a + pretty (ty1 :->: ty2) = withPA tarrPA $ + lt (pretty ty1) <+> text "→" <+> rt (pretty ty2) + pretty (ty1 :*: ty2) = withPA tmulPA $ + lt (pretty ty1) <+> text "×" <+> rt (pretty ty2) + pretty (ty1 :+: ty2) = withPA taddPA $ + lt (pretty ty1) <+> text "+" <+> rt (pretty ty2) + pretty (TyCon c []) = pretty c + pretty (TyCon c tys) = do + ds <- setPA initPA $ punctuate (text ",") (map pretty tys) + pretty c <> parens (hsep ds) + +instance Subst Type Qualifier +instance Subst Type Rational where + subst _ _ = id + substs _ = id +instance Subst Type Void where + subst _ _ = id + substs _ = id +instance Subst Type Con where + isCoerceVar (CContainer (AVar (U x))) + = Just (SubstCoerce x substCtrTy) + where + substCtrTy (TyAtom a) = Just (CContainer a) + substCtrTy _ = Nothing + isCoerceVar _ = Nothing +instance Subst Type Type where + isvar (TyAtom (AVar (U x))) = Just (SubstName x) + isvar _ = Nothing + +pattern TyVar :: Name Type -> Type +pattern TyVar v = TyAtom (AVar (U v)) + +pattern TySkolem :: Name Type -> Type +pattern TySkolem v = TyAtom (AVar (S v)) + +pattern TyVoid :: Type +pattern TyVoid = TyAtom (ABase Void) + +pattern TyUnit :: Type +pattern TyUnit = TyAtom (ABase Unit) + +pattern TyBool :: Type +pattern TyBool = TyAtom (ABase B) + +pattern TyProp :: Type +pattern TyProp = TyAtom (ABase P) + +pattern TyN :: Type +pattern TyN = TyAtom (ABase N) + +pattern TyZ :: Type +pattern TyZ = TyAtom (ABase Z) + +pattern TyF :: Type +pattern TyF = TyAtom (ABase F) + +pattern TyQ :: Type +pattern TyQ = TyAtom (ABase Q) + +pattern TyC :: Type +pattern TyC = TyAtom (ABase C) + + +-- pattern TyFin :: Integer -> Type +-- pattern TyFin n = TyAtom (ABase (Fin n)) + +infixr 5 :->: + +pattern (:->:) :: Type -> Type -> Type +pattern (:->:) ty1 ty2 = TyCon CArr [ty1, ty2] + +infixr 7 :*: + +pattern (:*:) :: Type -> Type -> Type +pattern (:*:) ty1 ty2 = TyCon CProd [ty1, ty2] + +infixr 6 :+: + +pattern (:+:) :: Type -> Type -> Type +pattern (:+:) ty1 ty2 = TyCon CSum [ty1, ty2] + +pattern TyList :: Type -> Type +pattern TyList elTy = TyCon CList [elTy] + +pattern TyBag :: Type -> Type +pattern TyBag elTy = TyCon CBag [elTy] + +pattern TySet :: Type -> Type +pattern TySet elTy = TyCon CSet [elTy] + +pattern TyContainer :: Atom -> Type -> Type +pattern TyContainer c elTy = TyCon (CContainer c) [elTy] + +pattern TyGraph :: Type -> Type +pattern TyGraph elTy = TyCon CGraph [elTy] + +pattern TyMap :: Type -> Type -> Type +pattern TyMap tyKey tyValue = TyCon CMap [tyKey, tyValue] + +-- | An application of a user-defined type. +pattern TyUser :: String -> [Type] -> Type +pattern TyUser nm args = TyCon (CUser nm) args + +pattern TyString :: Type +pattern TyString = TyList TyC + +{-# COMPLETE + TyVar, TySkolem, TyVoid, TyUnit, TyBool, TyProp, TyN, TyZ, TyF, TyQ, TyC, + (:->:), (:*:), (:+:), TyList, TyBag, TySet, TyGraph, TyMap, TyUser #-} + +-- | Is this a type variable? +isTyVar :: Type -> Bool +isTyVar (TyAtom (AVar _)) = True +isTyVar _ = False + +-- orphans +instance (Ord a, Subst t a) => Subst t (Set a) where + subst x t = S.map (subst x t) + substs s = S.map (substs s) +instance (Ord k, Subst t a) => Subst t (Map k a) where + subst x t = M.map (subst x t) + substs s = M.map (substs s) + +-- | The definition of a user-defined type contains: +-- +-- * The actual names of the type variable arguments used in the +-- definition (we keep these around only to help with +-- pretty-printing) +-- * A function representing the body of the definition. It takes a +-- list of type arguments and returns the body of the definition +-- with the type arguments substituted. +-- +-- We represent type definitions this way (using a function, as +-- opposed to a chunk of abstract syntax) because it makes some +-- things simpler, and we don't particularly need to do anything +-- more complicated. +data TyDefBody = TyDefBody [String] ([Type] -> Type) + +instance Show TyDefBody where + show _ = "" + +-- | A 'TyDefCtx' is a mapping from type names to their corresponding +-- definitions. +type TyDefCtx = M.Map String TyDefBody + +-- | Pretty-print a type definition. +instance Pretty (String, TyDefBody) where + + pretty (tyName, TyDefBody ps body) + = "type" <+> (text tyName <> prettyArgs ps) <+> text "=" <+> pretty (body (map (TyVar . string2Name) ps)) + where + prettyArgs [] = empty + prettyArgs _ = do + ds <- punctuate (text ",") (map text ps) + parens (hsep ds) + +--------------------------------- +-- Universally quantified types + +-- | 'PolyType' represents a polymorphic type of the form @forall a1 +-- a2 ... an. ty@ (note, however, that n may be 0, that is, we can +-- have a "trivial" polytype which quantifies zero variables). +newtype PolyType = Forall (Bind [Name Type] Type) + deriving (Show, Generic, Data, Alpha, Subst Type) + +-- | Pretty-print a polytype. Note that we never explicitly print +-- @forall@; quantification is implicit, as in Haskell. +instance Pretty PolyType where + pretty (Forall bnd) = lunbind bnd $ + \(_, body) -> pretty body + +-- | Convert a monotype into a trivial polytype that does not quantify +-- over any type variables. If the type can contain free type +-- variables, use 'closeType' instead. +toPolyType :: Type -> PolyType +toPolyType ty = Forall (bind [] ty) + +-- | Convert a monotype into a polytype by quantifying over all its +-- free type variables. +closeType :: Type -> PolyType +closeType ty = Forall (bind (nub $ toListOf fv ty) ty) + +-------------------------------------------------- +-- Counting inhabitants +-------------------------------------------------- + +-- | Compute the number of inhabitants of a type. @Nothing@ means the +-- type is countably infinite. +countType :: Type -> Maybe Integer +countType TyVoid = Just 0 +countType TyUnit = Just 1 +countType TyBool = Just 2 +-- countType (TyFin n) = Just n +countType TyC = Just (17 * 2^(16 :: Integer)) +countType (ty1 :+: ty2) = (+) <$> countType ty1 <*> countType ty2 +countType (ty1 :*: ty2) + | isEmptyTy ty1 = Just 0 + | isEmptyTy ty2 = Just 0 + | otherwise = (*) <$> countType ty1 <*> countType ty2 +countType (ty1 :->: ty2) = + case (countType ty1, countType ty2) of + (Just 0, _) -> Just 1 + (_, Just 0) -> Just 0 + (_, Just 1) -> Just 1 + (c1, c2) -> (^) <$> c2 <*> c1 +countType (TyList ty) + | isEmptyTy ty = Just 1 + | otherwise = Nothing +countType (TyBag ty) + | isEmptyTy ty = Just 1 + | otherwise = Nothing +countType (TySet ty) = (2^) <$> countType ty + + -- t = number of elements in vertex type. + -- n = number of vertices in the graph. + -- For each n in [0..t], we can choose which n values to use for the + -- vertices; then for each ordered pair of vertices (u,v) + -- (including the possibility that u = v), we choose whether or + -- not there is a directed edge u -> v. + -- + -- https://oeis.org/A135748 + +countType (TyGraph ty) = + (\t -> sum $ map (\n -> (t `choose` n) * 2^(n*n)) [0 .. t]) <$> + countType ty + +countType (TyMap tyKey tyValue) + | isEmptyTy tyKey = Just 1 -- If we can't have any keys or values, + | isEmptyTy tyValue = Just 1 -- only option is empty map + | otherwise = (\k v -> (v+1) ^ k) <$> countType tyKey <*> countType tyValue + -- (v+1)^k since for each key, we can choose among v values to associate with it, + -- or we can choose to not have the key in the map. + +-- All other types are infinite. (TyN, TyZ, TyQ, TyF) +countType _ = Nothing + +-------------------------------------------------- +-- Type predicates +-------------------------------------------------- + +-- | Check whether a type is a numeric type (@N@, @Z@, @F@, @Q@, or @Zn@). +isNumTy :: Type -> Bool +-- isNumTy (TyFin _) = True +isNumTy ty = ty `elem` [TyN, TyZ, TyF, TyQ] + +-- | Decide whether a type is empty, /i.e./ uninhabited. +isEmptyTy :: Type -> Bool +isEmptyTy ty + | Just 0 <- countType ty = True + | otherwise = False + +-- | Decide whether a type is finite. +isFiniteTy :: Type -> Bool +isFiniteTy ty + | Just _ <- countType ty = True + | otherwise = False + +-- XXX coinductively check whether user-defined types are searchable +-- e.g. L = Unit + N * L ought to be searchable. +-- | Decide whether a type is searchable, i.e. effectively enumerable. +isSearchable :: Type -> Bool +isSearchable TyProp = False +isSearchable ty + | isNumTy ty = True + | isFiniteTy ty = True +isSearchable (TyList ty) = isSearchable ty +isSearchable (TySet ty) = isSearchable ty +isSearchable (ty1 :+: ty2) = isSearchable ty1 && isSearchable ty2 +isSearchable (ty1 :*: ty2) = isSearchable ty1 && isSearchable ty2 +isSearchable (ty1 :->: ty2) = isFiniteTy ty1 && isSearchable ty2 +isSearchable _ = False + +-------------------------------------------------- +-- Strictness +-------------------------------------------------- + +-- | @Strictness@ represents the strictness (either strict or lazy) of +-- a function application or let-expression. +data Strictness = Strict | Lazy + deriving (Eq, Show, Generic, Alpha) + +-- | Numeric types are strict; others are lazy. +strictness :: Type -> Strictness +strictness ty + | isNumTy ty = Strict + | otherwise = Lazy + +-------------------------------------------------- +-- Utilities +-------------------------------------------------- + +-- | Decompose a nested product @T1 * (T2 * ( ... ))@ into a list of +-- types. +unpair :: Type -> [Type] +unpair (ty1 :*: ty2) = ty1 : unpair ty2 +unpair ty = [ty] + +-- | Define @S@ as a substitution on types (the most common kind) +-- for convenience. +type S = Substitution Type + +-- | Convert a substitution on atoms into a substitution on types. +atomToTypeSubst :: Substitution Atom -> Substitution Type +atomToTypeSubst = fmap TyAtom + +-- | Convert a substitution on unifiable atoms into a substitution on +-- types. +uatomToTypeSubst :: Substitution UAtom -> Substitution Type +uatomToTypeSubst = atomToTypeSubst . fmap uatomToAtom + +-- | Return a set of all the free container variables in a type. +containerVars :: Type -> Set (Name Type) +containerVars (TyCon (CContainer (AVar (U x))) tys) + = x `S.insert` foldMap containerVars tys +containerVars (TyCon _ tys) = foldMap containerVars tys +containerVars _ = S.empty + +------------------------------------------------------------ +-- HasType class +------------------------------------------------------------ + +-- | A type class for things whose type can be extracted or set. +class HasType t where + + -- | Get the type of a thing. + getType :: t -> Type + + -- | Set the type of a thing, when that is possible; the default + -- implementation is for 'setType' to do nothing. + setType :: Type -> t -> t + setType _ = id + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/Disco/Types/Qualifiers.hs b/src/Disco/Types/Qualifiers.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Types/Qualifiers.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Types.Qualifiers +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- Type qualifiers and sorts. +-- +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + +module Disco.Types.Qualifiers where + +import GHC.Generics +import Unbound.Generics.LocallyNameless + +import Data.Set (Set) +import qualified Data.Set as S + +import Disco.Pretty +import Disco.Syntax.Operators + +------------------------------------------------------------ +-- Qualifiers +------------------------------------------------------------ + +-- | A "qualifier" is kind of like a type class in Haskell; but unlike +-- Haskell, disco users cannot define their own. Rather, there is a +-- finite fixed list of qualifiers supported by disco. For example, +-- @QSub@ denotes types which support a subtraction operation. Each +-- qualifier corresponds to a set of types which satisfy it (see +-- 'hasQual' and 'qualRules'). +-- +-- These qualifiers generally arise from uses of various operations. +-- For example, the expression @\\x y. x - y@ would be inferred to +-- have a type @a -> a -> a [subtractive a]@, that is, a function of +-- type @a -> a -> a@ where @a@ is any type that supports +-- subtraction. +-- +-- These qualifiers can appear in a 'CQual' constraint; see +-- "Disco.Typecheck.Constraint". +data Qualifier + = QNum -- ^ Numeric, i.e. a semiring supporting + and * + | QSub -- ^ Subtractive, i.e. supports - + | QDiv -- ^ Divisive, i.e. supports / + | QCmp -- ^ Comparable, i.e. supports decidable ordering/comparison (see Note [QCmp]) + | QEnum -- ^ Enumerable, i.e. supports ellipsis notation [x .. y] + | QBool -- ^ Boolean, i.e. supports and, or, not (Bool or Prop) + | QBasic -- ^ Things that do not involve Prop. + | QSimple -- ^ Things for which we can derive a *Haskell* Ord instance + deriving (Show, Eq, Ord, Generic, Alpha) + +instance Pretty Qualifier where + pretty = \case + QNum -> "num" + QSub -> "sub" + QDiv -> "div" + QCmp -> "cmp" + QEnum -> "enum" + QBool -> "bool" + QBasic -> "basic" + QSimple -> "simple" + +-- ~~~~ Note [QCmp] +-- +-- XXX edit this! I don't think we actually need type info for +-- comparisons at runtime any more, if we disallow functions from +-- being QCmp. With the switch to eager semantics + disallowing +-- function comparison, it's now the case that QCmp should mean +-- *decidable* (terminating) comparison. +-- +-- It used to be the case that every type in disco supported +-- (semi-decidable) linear ordering, so in one sense the QCmp +-- constraint was unnecessary. However, in order to do a comparison we +-- need to know the type at runtime. Currently, we use QCmp to track +-- which types have comparisons done on them, and reject any type +-- variables with a QCmp constraint (just as we reject any other type +-- variables with remaining constraints). Every type with comparisons +-- done on it must be statically known at compile time. +-- +-- However, there's now another reason: the Prop type does not support +-- comparisons at all. +-- +-- Eventually, one could imagine compiling to something like System F +-- with explicit type lambdas and applications; then the QCmp +-- constraints would tell us which type applications need to be kept +-- and which can be erased. + +-- | A helper function that returns the appropriate qualifier for a +-- binary arithmetic operation. +bopQual :: BOp -> Qualifier +bopQual Add = QNum +bopQual Mul = QNum +bopQual Div = QDiv +bopQual Sub = QSub +bopQual SSub = QNum +-- bopQual And = QBool +-- bopQual Or = QBool +-- bopQual Impl = QBool +bopQual _ = error "No qualifier for binary operation" + +------------------------------------------------------------ +-- Sorts +------------------------------------------------------------ + +-- | A 'Sort' represents a set of qualifiers, and also represents a +-- set of types (in general, the intersection of the sets +-- corresponding to the qualifiers). +type Sort = Set Qualifier + +-- | The special sort \(\top\) which includes all types. +topSort :: Sort +topSort = S.empty diff --git a/src/Disco/Types/Rules.hs b/src/Disco/Types/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Types/Rules.hs @@ -0,0 +1,270 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Types.Rules +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- "Disco.Types.Rules" defines some generic rules about arity, +-- subtyping, and sorts for disco base types. +-- +----------------------------------------------------------------------------- + +-- SPDX-License-Identifier: BSD-3-Clause + +module Disco.Types.Rules + ( -- * Arity + + Variance(..), arity + + -- * Qualifiers + , Qualifier(..), bopQual + + -- * Sorts + , Sort, topSort + + -- * Subtyping rules + + , Dir(..), other + + , isSubA, isSubB, isDirB + , supertypes, subtypes, dirtypes + + -- * Qualifier and sort rules + + , hasQual, hasSort + , qualRules, sortRules + , pickSortBaseTy + ) + where + +import Control.Monad ((>=>)) +import Data.List (foldl') +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Set as S + +import Disco.Types +import Disco.Types.Qualifiers + +------------------------------------------------------------ +-- Arity +------------------------------------------------------------ + +-- | A particular type argument can be either co- or contravariant +-- with respect to subtyping. +data Variance = Co | Contra + deriving (Show, Read, Eq, Ord) + +-- | The arity of a type constructor is a list of variances, +-- expressing both how many type arguments the constructor takes, +-- and the variance of each argument. This is used to decompose +-- subtyping constraints. +-- +-- For example, @arity CArr = [Contra, Co]@ since function arrow is +-- contravariant in its first argument and covariant in its second. +-- That is, @S1 -> T1 <: S2 -> T2@ (@<:@ means "is a subtype of") if +-- and only if @S2 <: S1@ and @T1 <: T2@. +arity :: Con -> [Variance] +arity CArr = [Contra, Co] +arity CProd = [Co, Co] +arity CSum = [Co, Co] +arity (CContainer _) = [Co] +arity CMap = [Contra, Co] +arity CGraph = [Co] +arity (CUser _) = error "Impossible! arity CUser" + -- CUsers should always be replaced by their definitions before arity + -- is called. + +------------------------------------------------------------ +-- Subtyping rules +------------------------------------------------------------ + +-- | A "direction" for the subtyping relation (either subtype or +-- supertype). +data Dir = SubTy | SuperTy + deriving (Eq, Ord, Read, Show) + +-- | Swap directions. +other :: Dir -> Dir +other SubTy = SuperTy +other SuperTy = SubTy + +-------------------------------------------------- +-- Subtype checks + +-- | Check whether one atomic type is a subtype of the other. Returns +-- @True@ if either they are equal, or if they are base types and +-- 'isSubB' returns true. +isSubA :: Atom -> Atom -> Bool +isSubA a1 a2 | a1 == a2 = True +isSubA (ABase t1) (ABase t2) = isSubB t1 t2 +isSubA _ _ = False + +-- | Check whether one base type is a subtype of another. +isSubB :: BaseTy -> BaseTy -> Bool +isSubB b1 b2 | b1 == b2 = True +isSubB N Z = True +isSubB N F = True +isSubB N Q = True +isSubB Z Q = True +isSubB F Q = True +isSubB B P = True +isSubB _ _ = False + +-- | Check whether one base type is a sub- or supertype of another. +isDirB :: Dir -> BaseTy -> BaseTy -> Bool +isDirB SubTy b1 b2 = isSubB b1 b2 +isDirB SuperTy b1 b2 = isSubB b2 b1 + +-- | List all the supertypes of a given base type. +supertypes :: BaseTy -> [BaseTy] +supertypes N = [N, Z, F, Q] +supertypes Z = [Z, Q] +supertypes F = [F, Q] +supertypes B = [B, P] +supertypes ty = [ty] + +-- | List all the subtypes of a given base type. +subtypes :: BaseTy -> [BaseTy] +subtypes Q = [Q, F, Z, N] +subtypes F = [F, N] +subtypes Z = [Z, N] +subtypes P = [P, B] +subtypes ty = [ty] + +-- | List all the sub- or supertypes of a given base type. +dirtypes :: Dir -> BaseTy -> [BaseTy] +dirtypes SubTy = subtypes +dirtypes SuperTy = supertypes + +------------------------------------------------------------ +-- Qualifier and sort rules +------------------------------------------------------------ + +-- | Check whether a given base type satisfies a qualifier. +hasQual :: BaseTy -> Qualifier -> Bool +hasQual P QCmp = False -- can't compare Props +hasQual _ QCmp = True +hasQual P QBasic = False +hasQual _ QBasic = True +hasQual P QSimple = False +hasQual _ QSimple = True +-- hasQual (Fin _) q | q `elem` [QNum, QSub, QEnum] = True +-- hasQual (Fin n) QDiv = isPrime n +hasQual b QNum = b `elem` [N, Z, F, Q] +hasQual b QSub = b `elem` [Z, Q] +hasQual b QDiv = b `elem` [F, Q] +hasQual b QEnum = b `elem` [N, Z, F, Q, C] +hasQual b QBool = b `elem` [B, P] + +-- | Check whether a base type has a certain sort, which simply +-- amounts to whether it satisfies every qualifier in the sort. +hasSort :: BaseTy -> Sort -> Bool +hasSort = all . hasQual + +-- | 'qualRulesMap' encodes some of the rules by which applications of +-- type constructors can satisfy various qualifiers. +-- +-- Each constructor maps to a set of rules. Each rule is a mapping +-- from a qualifier to the list of qualifiers needed on the type +-- constructor's arguments for the bigger type to satisfy the +-- qualifier. +-- +-- Note in Disco we can get away with any given qualifier requiring +-- /at most one/ qualifier on each type argument. Then we can +-- derive the 'sortRules' by combining 'qualRules'. In general, +-- however, you could imagine some particular qualifier requiring a +-- set of qualifiers (i.e. a general sort) on a type argument. In +-- that case one would just have to encode 'sortRules' directly. +qualRulesMap :: Map Con (Map Qualifier [Maybe Qualifier]) +qualRulesMap = M.fromList + [ CProd ==> M.fromList + [ QCmp ==> [Just QCmp, Just QCmp], + QSimple ==> [Just QSimple, Just QSimple] + ] + , CSum ==> M.fromList + [ QCmp ==> [Just QCmp, Just QCmp], + QSimple ==> [Just QSimple, Just QSimple] + ] + , CList ==> M.fromList + [ QCmp ==> [Just QCmp], + QSimple ==> [Just QSimple] + ] + , CBag ==> M.fromList + [ QCmp ==> [Just QCmp], + QSimple ==> [Just QSimple] + ] + , CSet ==> M.fromList + [ QCmp ==> [Just QCmp], + QSimple ==> [Just QSimple] + ] + , CGraph ==> M.fromList + [ QCmp ==> [Just QCmp], + QNum ==> [Nothing] + ] + , CMap ==> M.fromList + [ QCmp ==> [Just QCmp, Just QCmp] + ] + ] + where + (==>) :: a -> b -> (a,b) + (==>) = (,) + + -- We could (theoretically) make graphs and maps also be simple values if we require the map's values are also simple. + + -- Eventually we can easily imagine adding an opt-in mode where + -- numeric operations can be used on pairs and functions, then the + -- qualRules would become dependent on what language extension/mode + -- was chosen. For example we could have rules like + -- + -- [ CArr ==> M.fromList + -- [ QNum ==> [Nothing, Just QNum] -- (a -> b) can be +, * iff b can + -- , QSub ==> [Nothing, Just QSub] -- ditto for subtraction + -- , QDiv ==> [Nothing, Just QDiv] -- and division + -- ] + -- , CProd ==> M.fromList + -- [ QNum ==> [Just QNum, Just QNum] -- (a,b) can be +, * iff a and b can + -- , QSub ==> [Just QSub, Just QSub] -- etc. + -- , QDiv ==> [Just QDiv, Just QDiv] + -- ] + -- ] + +-- | Given a constructor T and a qualifier we want to hold of a type T +-- t1 t2 ..., return a list of qualifiers that need to hold of t1, +-- t2, ... +qualRules :: Con -> Qualifier -> Maybe [Maybe Qualifier] +-- T t1 t2 ... is basic (contains no Prop) iff t1, t2 ... all are. +qualRules c QBasic = Just (map (const (Just QBasic)) (arity c)) +-- Otherwise, just look up in the qualRulesMap. +qualRules c q = (M.lookup c >=> M.lookup q) qualRulesMap + +-- | @sortRules T s = [s1, ..., sn]@ means that sort @s@ holds of +-- type @(T t1 ... tn)@ if and only if @s1 t1 /\ ... /\ sn tn@. +-- For now this is just derived directly from 'qualRules'. +-- +-- This is the @arity@ function described in section 4.1 of Traytel et +-- al. +sortRules :: Con -> Sort -> Maybe [Sort] +sortRules c s = do + -- If any of the quals q in sort s are not in the map corresponding + -- to tycon c, there's no way to make c an instance of q, so fail + -- (the mapM will succeed only if all lookups succeed) + needQuals <- mapM (qualRules c) (S.toList s) + + -- Otherwise we are left with a list (corresponding to all the quals + -- in sort s) of lists (each one corresponds to the type args of c). + -- We zip them together to produce a list of sorts. + return $ foldl' (zipWith (\srt -> maybe srt (`S.insert` srt))) (repeat topSort) needQuals + +-- | Pick a base type (generally the "simplest") that satisfies a given sort. +pickSortBaseTy :: Sort -> BaseTy +pickSortBaseTy s + | QDiv `S.member` s && QSub `S.member` s = Q + | QDiv `S.member` s = F + | QSub `S.member` s = Z + | QNum `S.member` s = N + | QCmp `S.member` s = N + | QEnum `S.member` s = N + | QBool `S.member` s = B + | QSimple `S.member` s = N + | otherwise = Unit diff --git a/src/Disco/Util.hs b/src/Disco/Util.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Util.hs @@ -0,0 +1,30 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Util +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Miscellaneous utilities. +-- +----------------------------------------------------------------------------- + +module Disco.Util where + +import qualified Data.Map as M + +infixr 1 ==> + +-- | A synonym for pairing which makes convenient syntax for +-- constructing literal maps via M.fromList. +(==>) :: a -> b -> (a,b) +(==>) = (,) + +for :: [a] -> (a -> b) -> [b] +for = flip map + +(!) :: (Show k, Ord k) => M.Map k v -> k -> v +m ! k = case M.lookup k m of + Nothing -> error $ "key " ++ show k ++ " is not an element in the map" + Just v -> v diff --git a/src/Disco/Value.hs b/src/Disco/Value.hs new file mode 100644 --- /dev/null +++ b/src/Disco/Value.hs @@ -0,0 +1,574 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Disco.Value +-- Copyright : disco team and contributors +-- Maintainer : byorgey@gmail.com +-- +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Disco runtime values and environments. +-- +----------------------------------------------------------------------------- + +module Disco.Value + ( -- * Values + + Value(.., VNil, VCons, VFun) + , SimpleValue(..) + , toSimpleValue, fromSimpleValue + + -- ** Conversion + + , ratv, vrat + , intv, vint + , charv, vchar + , enumv + , pairv, vpair + , listv, vlist + + -- * Props & testing + , ValProp(..), TestResult(..), TestReason_(..), TestReason + , SearchType(..), SearchMotive(.., SMExists, SMForall) + , TestVars(..), TestEnv(..), emptyTestEnv, getTestEnv, extendPropEnv, extendResultEnv + , testIsOk, testIsError, testReason, testEnv + + -- * Environments + + , Env + + -- * Memory + , Cell(..), Mem, emptyMem, allocate, allocateRec, lkup, set + + -- * Pretty-printing + + , prettyValue', prettyValue, prettyTestFailure, prettyTestResult + ) where + +import Prelude hiding ((<>)) +import qualified Prelude as P + +import Control.Monad (forM) +import Data.Bifunctor (first) +import Data.Char (chr, ord, toLower) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM +import Data.List (foldl') +import Data.Map (Map) +import qualified Data.Map as M +import Data.Ratio + +import Algebra.Graph (Graph, foldg) + +import Disco.AST.Core +import Disco.AST.Generic (Side (..)) +import Disco.AST.Typed (AProperty) +import Disco.Context as Ctx +import Disco.Error +import Disco.Names +import Disco.Pretty +import Disco.Syntax.Operators (BOp (Add, Mul)) +import Disco.Typecheck.Erase (eraseProperty) +import Disco.Types + +import Disco.Effects.LFresh +import Polysemy +import Polysemy.Input +import Polysemy.Reader +import Polysemy.State +import Unbound.Generics.LocallyNameless (Name) + +------------------------------------------------------------ +-- Value type +------------------------------------------------------------ + +-- | Different types of values which can result from the evaluation +-- process. +data Value where + + -- | A numeric value, which also carries a flag saying how + -- fractional values should be diplayed. + VNum :: RationalDisplay -> Rational -> Value + + -- | A built-in function constant. + VConst :: Op -> Value + + -- | An injection into a sum type. + VInj :: Side -> Value -> Value + + -- | The unit value. + VUnit :: Value + + -- | A pair of values. + VPair :: Value -> Value -> Value + + -- | A closure, i.e. a function body together with its + -- environment. + VClo :: Env -> [Name Core] -> Core -> Value + + -- | A disco type can be a value. For now, there are only a very + -- limited number of places this could ever show up (in + -- particular, as an argument to @enumerate@ or @count@). + VType :: Type -> Value + + -- | A reference, i.e. a pointer to a memory cell. This is used to + -- implement (optional, user-requested) laziness as well as + -- recursion. + VRef :: Int -> Value + + -- | A literal function value. @VFun@ is only used when + -- enumerating function values in order to decide comparisons at + -- higher-order function types. For example, in order to + -- compare two values of type @(Bool -> Bool) -> Bool@ for + -- equality, we have to enumerate all functions of type @Bool -> + -- Bool@ as @VFun@ values. + -- + -- We assume that all @VFun@ values are /strict/, that is, their + -- arguments should be fully evaluated to RNF before being + -- passed to the function. + VFun_ :: ValFun -> Value + + -- | A proposition. + VProp :: ValProp -> Value + + -- | A literal bag, containing a finite list of (perhaps only + -- partially evaluated) values, each paired with a count. This is + -- also used to represent sets (with the invariant that all counts + -- are equal to 1). + VBag :: [(Value, Integer)] -> Value + + -- | A graph, stored using an algebraic repesentation. + VGraph :: Graph SimpleValue -> Value + + -- | A map from keys to values. Differs from functions because we can + -- actually construct the set of entries, while functions only have this + -- property when the key type is finite. + VMap :: Map SimpleValue Value -> Value + + deriving Show + +-- | Convenient pattern for the empty list. +pattern VNil :: Value +pattern VNil = VInj L VUnit + +-- | Convenient pattern for list cons. +pattern VCons :: Value -> Value -> Value +pattern VCons h t = VInj R (VPair h t) + +-- | Values which can be used as keys in a map, i.e. those for which a +-- Haskell Ord instance can be easily created. These should always +-- be of a type for which the QSimple qualifier can be constructed. +-- At the moment these are always fully evaluated (containing no +-- indirections) and thus don't need memory management. At some +-- point in the future constructors for simple graphs and simple +-- maps could be created, if the value type is also QSimple. The +-- only reason for actually doing this would be constructing graphs +-- of graphs or maps of maps, or the like. +data SimpleValue where + SNum :: RationalDisplay -> Rational -> SimpleValue + SUnit :: SimpleValue + SInj :: Side -> SimpleValue -> SimpleValue + SPair :: SimpleValue -> SimpleValue -> SimpleValue + SBag :: [(SimpleValue, Integer)] -> SimpleValue + SType :: Type -> SimpleValue + deriving (Show, Eq, Ord) + +toSimpleValue :: Value -> SimpleValue +toSimpleValue = \case + VNum d n -> SNum d n + VUnit -> SUnit + VInj s v1 -> SInj s (toSimpleValue v1) + VPair v1 v2 -> SPair (toSimpleValue v1) (toSimpleValue v2) + VBag bs -> SBag (map (first toSimpleValue) bs) + VType t -> SType t + t -> error $ "A non-simple value was passed as simple: " ++ show t + +fromSimpleValue :: SimpleValue -> Value +fromSimpleValue (SNum d n) = VNum d n +fromSimpleValue SUnit = VUnit +fromSimpleValue (SInj s v) = VInj s (fromSimpleValue v) +fromSimpleValue (SPair v1 v2) = VPair (fromSimpleValue v1) (fromSimpleValue v2) +fromSimpleValue (SBag bs) = VBag $ map (first fromSimpleValue) bs +fromSimpleValue (SType t) = VType t + +-- | A @ValFun@ is just a Haskell function @Value -> Value@. It is a +-- @newtype@ just so we can have a custom @Show@ instance for it and +-- then derive a @Show@ instance for the rest of the @Value@ type. +newtype ValFun = ValFun (Value -> Value) + +instance Show ValFun where + show _ = "" + +pattern VFun :: (Value -> Value) -> Value +pattern VFun f = VFun_ (ValFun f) + +------------------------------------------------------------ +-- Converting to and from Value +------------------------------------------------------------ + +-- XXX write some comments about partiality + +-- | A convenience function for creating a default @VNum@ value with a +-- default (@Fractional@) flag. +ratv :: Rational -> Value +ratv = VNum mempty + +vrat :: Value -> Rational +vrat (VNum _ r) = r +vrat v = error $ "vrat " ++ show v + +-- | A convenience function for creating a default @VNum@ value with a +-- default (@Fractional@) flag. +intv :: Integer -> Value +intv = ratv . (% 1) + +vint :: Value -> Integer +vint (VNum _ n) = numerator n +vint v = error $ "vint " ++ show v + +vchar :: Value -> Char +vchar = chr . fromIntegral . vint + +charv :: Char -> Value +charv = intv . fromIntegral . ord + +-- | Turn any instance of @Enum@ into a @Value@, by creating a +-- constructor with an index corresponding to the enum value. +enumv :: Enum e => e -> Value +enumv e = VInj (toEnum $ fromEnum e) VUnit + +pairv :: (a -> Value) -> (b -> Value) -> (a,b) -> Value +pairv av bv (a,b) = VPair (av a) (bv b) + +vpair :: (Value -> a) -> (Value -> b) -> Value -> (a,b) +vpair va vb (VPair a b) = (va a, vb b) +vpair _ _ v = error $ "vpair " ++ show v + +listv :: (a -> Value) -> [a] -> Value +listv _ [] = VNil +listv eltv (a:as) = VCons (eltv a) (listv eltv as) + +vlist :: (Value -> a) -> Value -> [a] +vlist _ VNil = [] +vlist velt (VCons v vs) = velt v : vlist velt vs +vlist _ v = error $ "vlist " ++ show v + + +------------------------------------------------------------ +-- Propositions +------------------------------------------------------------ + +data SearchType + = Exhaustive + -- ^ All possibilities were checked. + | Randomized Integer Integer + -- ^ A number of small cases were checked exhaustively and + -- then a number of additional cases were checked at random. + deriving Show + +-- | The answer (success or failure) we're searching for, and +-- the result (success or failure) we return when we find it. +-- The motive @(False, False)@ corresponds to a "forall" quantifier +-- (look for a counterexample, fail if you find it) and the motive +-- @(True, True)@ corresponds to "exists". The other values +-- arise from negations. +newtype SearchMotive = SearchMotive (Bool, Bool) + deriving Show + +pattern SMForall :: SearchMotive +pattern SMForall = SearchMotive (False, False) + +pattern SMExists :: SearchMotive +pattern SMExists = SearchMotive (True, True) + +-- | A collection of variables that might need to be reported for +-- a test, along with their types and user-legible names. +newtype TestVars = TestVars [(String, Type, Name Core)] + deriving newtype (Show, Semigroup, Monoid) + +-- | A variable assignment found during a test. +newtype TestEnv = TestEnv [(String, Type, Value)] + deriving newtype (Show, Semigroup, Monoid) + +emptyTestEnv :: TestEnv +emptyTestEnv = TestEnv [] + +getTestEnv :: TestVars -> Env -> Either EvalError TestEnv +getTestEnv (TestVars tvs) e = fmap TestEnv . forM tvs $ \(s, ty, name) -> do + let value = Ctx.lookup' (localName name) e + case value of + Just v -> return (s, ty, v) + Nothing -> Left (UnboundError name) + +-- | The possible outcomes of a property test, parametrized over +-- the type of values. A @TestReason@ explains why a proposition +-- succeeded or failed. +data TestReason_ a + = TestBool + -- ^ The prop evaluated to a boolean. + | TestEqual Type a a + -- ^ The test was an equality test. Records the values being + -- compared and also their type (which is needed for printing). + | TestNotFound SearchType + -- ^ The search didn't find any examples/counterexamples. + | TestFound TestResult + -- ^ The search found an example/counterexample. + | TestRuntimeError EvalError + -- ^ The prop failed at runtime. This is always a failure, no + -- matter which quantifiers or negations it's under. + deriving (Show, Functor, Foldable, Traversable) + +type TestReason = TestReason_ Value + +-- | The possible outcomes of a proposition. +data TestResult = TestResult Bool TestReason TestEnv + deriving Show + +-- | Whether the property test resulted in a runtime error. +testIsError :: TestResult -> Bool +testIsError (TestResult _ (TestRuntimeError _) _) = True +testIsError _ = False + +-- | Whether the property test resulted in success. +testIsOk :: TestResult -> Bool +testIsOk (TestResult b _ _) = b + +-- | The reason the property test had this result. +testReason :: TestResult -> TestReason +testReason (TestResult _ r _) = r + +testEnv :: TestResult -> TestEnv +testEnv (TestResult _ _ e) = e + +-- | A @ValProp@ is the normal form of a Disco value of type @Prop@. +data ValProp + = VPDone TestResult + -- ^ A prop that has already either succeeded or failed. + | VPSearch SearchMotive [Type] Value TestEnv + -- ^ A pending search. + deriving Show + +extendPropEnv :: TestEnv -> ValProp -> ValProp +extendPropEnv g (VPDone (TestResult b r e)) = VPDone (TestResult b r (g P.<> e)) +extendPropEnv g (VPSearch sm tys v e) = VPSearch sm tys v (g P.<> e) + +extendResultEnv :: TestEnv -> TestResult -> TestResult +extendResultEnv g (TestResult b r e) = TestResult b r (g P.<> e) + +------------------------------------------------------------ +-- Environments +------------------------------------------------------------ + +-- | An environment is a mapping from names to values. +type Env = Ctx Core Value + +------------------------------------------------------------ +-- Memory +------------------------------------------------------------ + +-- | 'Mem' represents a memory, containing 'Cell's +data Mem = Mem { next :: Int, mu :: IntMap Cell } deriving Show +data Cell = Blackhole | E Env Core | V Value deriving Show + +emptyMem :: Mem +emptyMem = Mem 0 IM.empty + +-- | Allocate a new memory cell containing an unevaluated expression +-- with the current environment. Return the index of the allocated +-- cell. +allocate :: Members '[State Mem] r => Env -> Core -> Sem r Int +allocate e t = do + Mem n m <- get + put $ Mem (n+1) (IM.insert n (E e t) m) + return n + +-- | Allocate new memory cells for a group of mutually recursive +-- bindings, and return the indices of the allocate cells. +allocateRec :: Members '[State Mem] r => Env -> [(QName Core, Core)] -> Sem r [Int] +allocateRec e bs = do + Mem n m <- get + let newRefs = zip [n ..] bs + e' = foldl' (flip (\(i,(x,_)) -> Ctx.insert x (VRef i))) e newRefs + m' = foldl' (flip (\(i,(_,c)) -> IM.insert i (E e' c))) m newRefs + n' = n + length bs + put $ Mem n' m' + return [n .. n'-1] + +-- | Look up the cell at a given index. +lkup :: Members '[State Mem] r => Int -> Sem r (Maybe Cell) +lkup n = gets (IM.lookup n . mu) + +-- | Set the cell at a given index. +set :: Members '[State Mem] r => Int -> Cell -> Sem r () +set n c = modify $ \(Mem nxt m) -> Mem nxt (IM.insert n c m) + +------------------------------------------------------------ +-- Pretty-printing values +------------------------------------------------------------ + +prettyValue' :: Member (Input TyDefCtx) r => Type -> Value -> Sem r Doc +prettyValue' ty v = runLFresh . runReader initPA $ prettyValue ty v + +prettyValue :: Members '[Input TyDefCtx, LFresh, Reader PA] r => Type -> Value -> Sem r Doc + +-- Lazily expand any user-defined types +prettyValue (TyUser x args) v = do + tydefs <- input + let (TyDefBody _ body) = tydefs M.! x -- This can't fail if typechecking succeeded + prettyValue (body args) v + +prettyValue _ VUnit = "■" +prettyValue TyProp _ = prettyPlaceholder TyProp +prettyValue TyBool (VInj s _) = text $ map toLower (show (s == R)) +prettyValue TyBool v = + error $ "Non-VInj passed with Bool type to prettyValue: " ++ show v +prettyValue TyC (vchar -> c) = text (show c) +prettyValue (TyList TyC) (vlist vchar -> cs) = doubleQuotes . text . concatMap prettyChar $ cs + where + prettyChar = drop 1 . reverse . drop 1 . reverse . show . (:[]) +prettyValue (TyList ty) (vlist id -> xs) = do + ds <- punctuate (text ",") (map (prettyValue ty) xs) + brackets (hsep ds) + +prettyValue ty@(_ :*: _) v = parens (prettyTuple ty v) + +prettyValue (ty1 :+: _) (VInj L v) = "left" <> prettyVP ty1 v +prettyValue (_ :+: ty2) (VInj R v) = "right" <> prettyVP ty2 v +prettyValue (_ :+: _) v = + error $ "Non-VInj passed with sum type to prettyValue: " ++ show v + +prettyValue _ (VNum d r) + | denominator r == 1 = text $ show (numerator r) + | otherwise = text $ case d of + Fraction -> show (numerator r) ++ "/" ++ show (denominator r) + Decimal -> prettyDecimal r + +prettyValue ty@(_ :->: _) _ = prettyPlaceholder ty + +prettyValue (TySet ty) (VBag xs) = braces $ prettySequence ty "," (map fst xs) +prettyValue (TySet _) v = + error $ "Non-VBag passed with Set type to prettyValue: " ++ show v +prettyValue (TyBag ty) (VBag xs) = prettyBag ty xs +prettyValue (TyBag _) v = + error $ "Non-VBag passed with Bag type to prettyValue: " ++ show v + +prettyValue (TyMap tyK tyV) (VMap m) = + "map" <> parens (braces (prettySequence (tyK :*: tyV) "," (assocsToValues m))) + where + assocsToValues = map (\(k,v) -> VPair (fromSimpleValue k) v) . M.assocs +prettyValue (TyMap _ _) v = + error $ "Non-map value with map type passed to prettyValue: " ++ show v + +prettyValue (TyGraph ty) (VGraph g) = + foldg + "emptyGraph" + (("vertex" <>) . prettyVP ty . fromSimpleValue) + (\l r -> withPA (getPA Add) $ lt l <+> "+" <+> rt r) + (\l r -> withPA (getPA Mul) $ lt l <+> "*" <+> rt r) + g +prettyValue (TyGraph _) v = + error $ "Non-graph value with graph type passed to prettyValue: " ++ show v + +prettyValue ty@TyAtom{} v = + error $ "Invalid atomic type passed to prettyValue: " ++ show ty ++ " " ++ show v + +prettyValue ty@TyCon{} v = + error $ "Invalid type constructor passed to prettyValue: " ++ show ty ++ " " ++ show v + +-- | Pretty-print a value with guaranteed parentheses. Do nothing for +-- tuples; add an extra set of parens for other values. +prettyVP :: Members '[Input TyDefCtx, LFresh, Reader PA] r => Type -> Value -> Sem r Doc +prettyVP ty@(_ :*: _) = prettyValue ty +prettyVP ty = parens . prettyValue ty + +prettyPlaceholder :: Members '[Reader PA, LFresh] r => Type -> Sem r Doc +prettyPlaceholder ty = "<" <> pretty ty <> ">" + +prettyTuple :: Members '[Input TyDefCtx, LFresh, Reader PA] r => Type -> Value -> Sem r Doc +prettyTuple (ty1 :*: ty2) (VPair v1 v2) = prettyValue ty1 v1 <> "," <+> prettyTuple ty2 v2 +prettyTuple ty v = prettyValue ty v + +-- | 'prettySequence' pretty-prints a lists of values separated by a delimiter. +prettySequence :: Members '[Input TyDefCtx, LFresh, Reader PA] r => Type -> Doc -> [Value] -> Sem r Doc +prettySequence ty del vs = hsep =<< punctuate (return del) (map (prettyValue ty) vs) + +-- | Pretty-print a literal bag value. +prettyBag :: Members '[Input TyDefCtx, LFresh, Reader PA] r => Type -> [(Value,Integer)] -> Sem r Doc +prettyBag _ [] = bag empty +prettyBag ty vs + | all ((==1) . snd) vs = bag $ prettySequence ty "," (map fst vs) + | otherwise = bag $ hsep =<< punctuate (return ",") (map prettyCount vs) + where + prettyCount (v,1) = prettyValue ty v + prettyCount (v,n) = prettyValue ty v <+> "#" <+> text (show n) + +------------------------------------------------------------ +-- Pretty-printing for test results +------------------------------------------------------------ + +prettyTestFailure + :: Members '[Input TyDefCtx, LFresh, Reader PA] r + => AProperty -> TestResult -> Sem r Doc +prettyTestFailure _ (TestResult True _ _) = empty +prettyTestFailure prop (TestResult False r env) = + prettyFailureReason prop r + $+$ + prettyTestEnv "Counterexample:" env + +prettyTestResult + :: Members '[Input TyDefCtx, LFresh, Reader PA] r + => AProperty -> TestResult -> Sem r Doc +prettyTestResult prop r | not (testIsOk r) = prettyTestFailure prop r +prettyTestResult prop (TestResult _ r _) = + ("Test passed:" <+> pretty (eraseProperty prop)) + $+$ + prettySuccessReason r + +prettySuccessReason + :: Members '[Input TyDefCtx, LFresh, Reader PA] r + => TestReason -> Sem r Doc +prettySuccessReason (TestFound (TestResult _ _ vs)) = prettyTestEnv "Found example:" vs +prettySuccessReason (TestNotFound Exhaustive) = "No counterexamples exist." +prettySuccessReason (TestNotFound (Randomized n m)) = + "Checked" <+> text (show (n + m)) <+> "possibilities without finding a counterexample." +prettySuccessReason _ = empty + +prettyFailureReason + :: Members '[Input TyDefCtx, LFresh, Reader PA] r + => AProperty -> TestReason -> Sem r Doc +prettyFailureReason prop TestBool = "Test is false:" <+> pretty (eraseProperty prop) +prettyFailureReason prop (TestEqual ty v1 v2) = + "Test result mismatch for:" <+> pretty (eraseProperty prop) + $+$ + bulletList "-" + [ "Left side: " <> prettyValue ty v2 + , "Right side: " <> prettyValue ty v1 + ] +prettyFailureReason prop (TestRuntimeError e) = + "Test failed:" <+> pretty (eraseProperty prop) + $+$ + text (show e) +prettyFailureReason prop (TestFound (TestResult _ r _)) = prettyFailureReason prop r +prettyFailureReason prop (TestNotFound Exhaustive) = + "No example exists:" <+> pretty (eraseProperty prop) + $+$ + "All possible values were checked." +prettyFailureReason prop (TestNotFound (Randomized n m)) = do + "No example was found:" <+> pretty (eraseProperty prop) + $+$ + ("Checked" <+> text (show (n + m)) <+> "possibilities.") + +prettyTestEnv + :: Members '[Input TyDefCtx, LFresh, Reader PA] r + => String -> TestEnv -> Sem r Doc +prettyTestEnv _ (TestEnv []) = empty +prettyTestEnv s (TestEnv vs) = text s $+$ nest 2 (vcat (map prettyBind vs)) + where + maxNameLen = maximum . map (\(n, _, _) -> length n) $ vs + prettyBind (x, ty, v) = + text x <> text (replicate (maxNameLen - length x) ' ') <+> "=" <+> prettyValue ty v diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,44 @@ +# This file was automatically generated by stack init +# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) +resolver: lts-18.13 + +# Local packages, usually specified by relative directory name +packages: + - "." + +# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) +extra-deps: + - unbound-generics-0.4.0 + - simple-enumeration-0.2 + - oeis-0.3.10 + - capability-0.4.0.0@sha256:d86d85a1691ef0165c77c47ea72eac75c99d21fb82947efe8b2f758991cf1837,3345 + - polysemy-1.6.0.0@sha256:29a73b1bf3d0049b12041016b7ee25e76bd8f6e99f9c37c2dde2b46368246697,6184 + - polysemy-plugin-0.4.0.0 + - polysemy-zoo-0.7.0.1@sha256:60c2921df95f61d43222a75adde4f330e9510320b416132838a354cd81b4bcc5,3846 + - compact-0.2.0.0@sha256:75ef98cb51201b4a0d6de95cbbb62be6237c092a3d594737346c70c5d56c2380,2413 + - constraints-0.12 # needed since polysemy-zoo hasn't updated upper bound to allow 0.13 + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] +# Control whether we use the GHC we find on the path +# system-ghc: true + +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: >= 1.0.0 + +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 + +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] + +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/test/README.md b/test/README.md new file mode 100644 --- /dev/null +++ b/test/README.md @@ -0,0 +1,48 @@ +This directory contains a regression test suite for Disco. + +Running the tests +----------------- + +To run the tests, just do `stack test`. + +Adding a new test case +---------------------- + +Adding a new test case is easy. + +1. Create a directory for the new test, with a prefix denoting the + general category of the test, a hyphen, and then an arbitrary name + describing the content of the test. + +2. In that directory, you must create two files: + + - `input` should consist of a sequence of commands or expressions + to be evaluated by the Disco REPL, one per line. + + - `expected` should consist of the expected output. + + In fact, you don't even have to create `expected` yourself. If + you know that Disco currently has the expected behavior for the + commands and expressions in `input`, simply run the test suite and + `expected` will be created automatically if it does not exist. + + You may create additional files as well, for example, one or more + `.disco` files to be `:load`ed by a command in `input`. (Be aware + that the test suite runs from the root directory of the + repository, so you will have to write something like `:load + test/category-name/foo.disco`.) + +Dealing with mass test suite breakage +------------------------------------- + +In certain cases many test cases may break all at once for a known +reason---for example, if a change in Disco's pretty-printer or +error messages causes the expected output of many tests to change. In +this case you need not manually paste in the new expected output for +each test case. + +1. Verify by inspection that all the failing test cases are in fact + producing the expected new output (by examining the `output` files). + +2. Run `stack test --test-arguments --accept`. This will overwrite + the `expected` files with the actual output. diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,83 @@ +module Main where + +import Control.Monad (filterM) +import qualified Data.ByteString as BS +import Data.Function (on) +import Data.List (groupBy, sort) +import System.Directory (doesFileExist, + getDirectoryContents) +import System.FilePath (isPathSeparator, ()) +import System.IO (hGetContents) +import System.Process (StdStream (CreatePipe), + createProcess, shell, std_out, + system) +import Text.Printf + +import Test.Tasty +import Test.Tasty.Golden.Advanced + +main :: IO () +main = do + testDirs <- getDirectoryContents "test" + >>= filterM (doesFileExist . (\d -> ("test" d "input"))) + let testDirs' + = groupBy ((==) `on` extractGroup) + . sort + . filter (\f -> f /= "." && f /= "..") + $ testDirs + let testTree = testGroup "disco" $ map mkGroup testDirs' + defaultMain testTree + where + mkGroup ds = testGroup (extractGroup (head ds)) $ map mkGolden ds + -- (head ds) is safe since mkGroup is called on testDirs', which + -- is the output of groupBy, so each element of testDirs' will + -- be a non-empty list. + +extractGroup :: FilePath -> String +extractGroup = takeWhile (/='-') + +extractName :: FilePath -> String +extractName = takeWhile (not . isPathSeparator) . drop 1 . dropWhile (/='-') + +mkGolden :: FilePath -> TestTree +mkGolden relDir = + goldenVsFileWithDiff + (extractName relDir) + (dir "expected") + (dir "output") + (system ("disco -f " ++ (dir "input") ++ " > " ++ (dir "output")) >> return ()) + where + dir = "test" relDir + +-- | A variant of goldenVsFile that prints the result of @diff@ if +-- the files are different, so we don't have to manually call @diff@ +-- every time there is a test failure. +goldenVsFileWithDiff + :: TestName -- ^ test name + -> FilePath -- ^ path to the «golden» file (the file that contains correct output) + -> FilePath -- ^ path to the output file + -> IO () -- ^ action that creates the output file + -> TestTree -- ^ the test verifies that the output file contents is the same as the golden file contents +goldenVsFileWithDiff name ref new act = + goldenTest + name + (BS.readFile ref) + (act >> BS.readFile new) + cmp + upd + where + cmp = cmpWithDiff ref new + upd = BS.writeFile ref + +cmpWithDiff :: Eq a => FilePath -> FilePath -> a -> a -> IO (Maybe String) +cmpWithDiff f1 f2 x y = do + if x == y + then return Nothing + else do + (_, Just hout, _, _) + <- createProcess (shell $ printf "diff %s %s" f1 f2) { std_out = CreatePipe } + diffStr <- hGetContents hout + return $ Just $ unlines + [ printf "Files '%s' and '%s' differ:" f1 f2 + , diffStr + ] diff --git a/test/arith-basic-bin/expected b/test/arith-basic-bin/expected new file mode 100644 --- /dev/null +++ b/test/arith-basic-bin/expected @@ -0,0 +1,24 @@ +5 +100 +-13 +3 +2 +0 +1 +0 +5 +0 +0 +0 +2 +17082135 +30 +-20 +14 +25 +4 +3/2 +65536 +256 +418993997810706159361688281193932691483730181893512293053861295116305125939798343025058571817715732115313495568327689089179808837873330310826051531440128 +592 diff --git a/test/arith-basic-bin/input b/test/arith-basic-bin/input new file mode 100644 --- /dev/null +++ b/test/arith-basic-bin/input @@ -0,0 +1,24 @@ +2+3 +10+20+30+40 +1-2-3-4-5 +1-(2-3)-(4-5) +5 .- 3 +3 ∸ 5 +-2 .- -3 +-3 .- -2 +3 .- -2 +-3 .- 2 +3 .- 3 +0 .- 2 +2 .- 0 +245*69723 +(-5)*(-6) +(4)(-5) +(2)7 +5(5) +20/5 +18/12 +2^2^2^2 +((2^2)^2)^2 +2^507 +let x = 17 in (2x+3)(x-1) diff --git a/test/arith-basic-un/expected b/test/arith-basic-un/expected new file mode 100644 --- /dev/null +++ b/test/arith-basic-un/expected @@ -0,0 +1,23 @@ +0 +1 +2 +2 +2 +4 +5254282669 +9485374212 +375828023454801203683362418972386504867736551759258677056523839782231681498337708535732725752658844333702457749526057760309227891351617765651907310968780236464694043316236562146724416478591131832593729111221580180531749232777515579969899075142213969117994877343802049421624954402214529390781647563339535024772584901607666862982567918622849636160208877365834950163790188523026247440507390382032188892386109905869706753143243921198482212075444022433366554786856559389689585638126582377224037721702239991441466026185752651502936472280911018500320375496336749951569521541850441747925844066295279671872605285792552660130702047998218334749356321677469529682551765858267502715894007887727250070780350262952377214028842297486263597879792176338220932619489509376 +0 +1 +3 +1 +2/3 +2/3 +2/3 +-6 +Error: that number would not even fit in the universe! +-9 +-~ : ℤ → ℤ +-3 : ℤ +-(3 : ℕ) : ℤ +-(3 : 𝔽) : ℚ diff --git a/test/arith-basic-un/input b/test/arith-basic-un/input new file mode 100644 --- /dev/null +++ b/test/arith-basic-un/input @@ -0,0 +1,26 @@ +sqrt 0 +sqrt 1 +sqrt 4 +sqrt 5 +sqrt 8 +sqrt 20 +sqrt 27607486371775073359 +sqrt 89972323943429722781 +sqrt (2^5000 + 1) +abs 0 +abs 1 +abs (-3) +abs (5 - 6) +abs (2/3) +abs (-2/3) +abs (2/(-3)) +-- abs (2 : Z8) +-3! +((4!)!)! +let x = 3 in -x^2 +:type -~ +:type (-~ 3) +:type (-~ (3 : N)) +:type (-~ (3 : F)) +-- :type (-~ (3 : Z5)) +-- (-~ (3 : Z5)) diff --git a/test/arith-count/expected b/test/arith-count/expected new file mode 100644 --- /dev/null +++ b/test/arith-count/expected @@ -0,0 +1,28 @@ +1 +1 +2 +6 +24 +120 +93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000 +33 +1 +1 +4 +6 +4 +1 +0 +317069614581796942069850800242662142665884971451889342180215921022256584404257764868994168981794290681466646945931721640583674582646104015150878777044819240419642695597347059228370594446663577155071679912730991740163983793762281849063963362837125 +1 +10 +45 +true +true +12600 +true +2520 +0 +3628800 +10 +30 diff --git a/test/arith-count/input b/test/arith-count/input new file mode 100644 --- /dev/null +++ b/test/arith-count/input @@ -0,0 +1,28 @@ +0! +1! +2! +3! +4! +5! +100! +1! + 2! + 3! + 4! +0 choose 0 +4 choose 0 +4 choose 1 +4 choose 2 +4 choose 3 +4 choose 4 +4 choose 5 +1000 choose 256 +10 choose [] +10 choose [1] +10 choose [2] +10 choose [2] == 10 choose 2 +10 choose [2,8] == 10 choose 2 +10 choose [2,3,4] +10 choose [2,3,2] == 10! / (2! * 3! * 2! * 3!) +10 choose [2,3,5] +10 choose [2,3,6] +10 choose [1,1,1,1,1,1,1,1,1,1] +let x = 3 in 5 choose x +let x = [1,2,2] in 5 choose x diff --git a/test/arith-numthry/expected b/test/arith-numthry/expected new file mode 100644 --- /dev/null +++ b/test/arith-numthry/expected @@ -0,0 +1,12 @@ +3 +3 +true +true +true +true +true +false +false +false +true +true diff --git a/test/arith-numthry/input b/test/arith-numthry/input new file mode 100644 --- /dev/null +++ b/test/arith-numthry/input @@ -0,0 +1,12 @@ +24 mod 7 +24 % 7 +24 mod 7 == 24 % 7 +3 divides 6 +23948723947 divides 7115869653734173619712 +(-2) divides 8 +5 divides (-25) +5 divides 24 +5 divides (-24) +0 divides 10 +10 divides 0 +0 divides 0 diff --git a/test/arith-prim/arith-prim.disco b/test/arith-prim/arith-prim.disco new file mode 100644 --- /dev/null +++ b/test/arith-prim/arith-prim.disco @@ -0,0 +1,4 @@ +import num + +ps : List(N) +ps = filter(isPrime, [1 .. 100]) diff --git a/test/arith-prim/expected b/test/arith-prim/expected new file mode 100644 --- /dev/null +++ b/test/arith-prim/expected @@ -0,0 +1,4 @@ +Loading arith-prim.disco... +Loading num.disco... +Loaded. +[2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, 79, 83, 89, 97] diff --git a/test/arith-prim/input b/test/arith-prim/input new file mode 100644 --- /dev/null +++ b/test/arith-prim/input @@ -0,0 +1,2 @@ +:load test/arith-prim/arith-prim.disco +ps diff --git a/test/arith-round/expected b/test/arith-round/expected new file mode 100644 --- /dev/null +++ b/test/arith-round/expected @@ -0,0 +1,15 @@ +0 +3 +5 +1 +1 +3 +1 +3 +3 +2 +2 +11 +2 +2 +-2 diff --git a/test/arith-round/input b/test/arith-round/input new file mode 100644 --- /dev/null +++ b/test/arith-round/input @@ -0,0 +1,16 @@ +floor (1 / 2) +floor (10 / 3) +floor 5 +floor (500 / 376) +ceiling (1 / 3) +ceiling (17 / 6) +ceiling ((floor (5 / 2)) / 28) +⌊10 / 3⌋ +⌈20 / 7⌉ +5 // 2 +37 // 13 +100 // 9 +(78 // 4) // (51 // 7) +((5 : F) // (2 : F)) : Nat +((-5 : Q) // (3 : F)) : Z +-- (5 : Z7) // (3 : Z7) diff --git a/test/case-arith/case-arith.disco b/test/case-arith/case-arith.disco new file mode 100644 --- /dev/null +++ b/test/case-arith/case-arith.disco @@ -0,0 +1,54 @@ +import list + +f1 : N -> N +f1 (x + 1) = x +f1 0 = 0 + +f2 : N -> N +f2 (3 + (x + 2)) = x +f2 y = 0 + +f3 : Z -> Z +f3 (3 + (x + 2)) = x +f3 y = 0 + +f4 : N*Z -> N*Z + N*Z +f4 (x+1,y+2) = left (x,y) +f4 (x, y+2) = right (x,y) + +h : N -> N +h(0) = 1 +h(2k+1) = h(k) +h(2k+2) = h(k+1) + h(k) + +f5 : N -> N +f5 (2x) = x +f5 (2x-1) = x + +f6 : Q -> Bool +f6 (-2/3) = True +f6 _ = False + +!!! forall x:Z. Zabs(x) >= 0 +Zabs : Z -> Z +Zabs (-x) = x +Zabs x = x + +type Tree = Unit + F * Tree * Tree + +expandTree : N -> F -> Tree +expandTree 0 _ = left(unit) +expandTree n (a/b) = right(a/b, expandTree (n .- 1) (a/(a+b)), expandTree (n .- 1) ((a+b)/b)) + +cwTree : N -> Tree +cwTree n = expandTree n 1 + +inorder : Tree -> List(F) +inorder (left(unit)) = [] +inorder (right(x,l,r)) = append(inorder(l), x :: inorder(r)) + +numerator : Q -> Z +numerator (p/q) = p + +denominator : Q -> N +denominator (p/q) = q diff --git a/test/case-arith/expected b/test/case-arith/expected new file mode 100644 --- /dev/null +++ b/test/case-arith/expected @@ -0,0 +1,37 @@ +Loading case-arith.disco... +Loading list.disco... +Running tests... + Zabs: OK +Loaded. +0 +1 +540 +0 +2 +0 +2 +-1 +left(1, -1) +right(0, -1) +1 +1 +5 +7 +3 +1/3 +200 +-1/6 +2 +2 +3 +3 +17 +17 +0 +[1/4, 1/3, 4/3, 1/2, 3/5, 3/2, 5/2, 1, 2/5, 2/3, 5/3, 2, 3/4, 3, 4] +5 +1 +2 +-2 +5 +5 diff --git a/test/case-arith/input b/test/case-arith/input new file mode 100644 --- /dev/null +++ b/test/case-arith/input @@ -0,0 +1,41 @@ +:load test/case-arith/case-arith.disco +f1 1 +f1 2 +f1 541 +f1 0 + +f2 7 +f2 4 +f3 7 +f3 4 + +f4 (2,1) +f4 (0,1) + +h(0) +h(1) +h(10) +h(22) +h(29360127) + +{? x when 5/3 is 2x+1, 200 otherwise ?} +{? x when 2/3 is 2x+1, 200 otherwise ?} +{? x when (2/3 : Q) is 2x+1, 200 otherwise ?} + +f5(3) +f5(4) +f5(5) +f5(6) + +Zabs(17) +Zabs(-17) +Zabs(0) + +inorder(cwTree(4)) + +numerator 5 +denominator 5 +numerator (2/5) +numerator (2/(-5)) +denominator (2/5) +denominator (2/(-5)) diff --git a/test/case-basic/case-basic.disco b/test/case-basic/case-basic.disco new file mode 100644 --- /dev/null +++ b/test/case-basic/case-basic.disco @@ -0,0 +1,7 @@ +foo : List(N) + Bool -> N +foo x = + {? n when x is left (n :: _), + 0 when x is left [], + 1 when x is right True, + 2 when x is right False + ?} diff --git a/test/case-basic/expected b/test/case-basic/expected new file mode 100644 --- /dev/null +++ b/test/case-basic/expected @@ -0,0 +1,7 @@ +Loading case-basic.disco... +Loaded. +0 +1 +2 +3 +4 diff --git a/test/case-basic/input b/test/case-basic/input new file mode 100644 --- /dev/null +++ b/test/case-basic/input @@ -0,0 +1,6 @@ +:load test/case-basic/case-basic.disco +foo (left []) +foo (right true) +foo (right false) +foo (left [3]) +foo (left [4,2]) diff --git a/test/case-let/case-let.disco b/test/case-let/case-let.disco new file mode 100644 --- /dev/null +++ b/test/case-let/case-let.disco @@ -0,0 +1,5 @@ +f : N -> N +f x = {? z if 2 divides x + let z = x // 2 + , x otherwise + ?} diff --git a/test/case-let/expected b/test/case-let/expected new file mode 100644 --- /dev/null +++ b/test/case-let/expected @@ -0,0 +1,4 @@ +Loading case-let.disco... +Loaded. +3 +5 diff --git a/test/case-let/input b/test/case-let/input new file mode 100644 --- /dev/null +++ b/test/case-let/input @@ -0,0 +1,3 @@ +:load test/case-let/case-let.disco +f 6 +f 5 diff --git a/test/compile-cons/expected b/test/compile-cons/expected new file mode 100644 --- /dev/null +++ b/test/compile-cons/expected @@ -0,0 +1,1 @@ +[3, 5] diff --git a/test/compile-cons/input b/test/compile-cons/input new file mode 100644 --- /dev/null +++ b/test/compile-cons/input @@ -0,0 +1,1 @@ +(\x. (\z. ~::~ (x,z))) 3 [5] diff --git a/test/compile-misc/expected b/test/compile-misc/expected new file mode 100644 --- /dev/null +++ b/test/compile-misc/expected @@ -0,0 +1,9 @@ +holds (∀ℕ. (λarg0. (λ_. (λk. (λx. test [(x, ℕ, x)] (3 < x)) arg0) (λ_1. matchErr)) unit)) +λx, y. x +(λ_. (λk. (λy. (λp, q. p) (fst y) (snd y)) (frac (2 / 3))) (λ_1. matchErr)) unit +(λ_. (λk. case (3 < 2) of { + left _1 -> k unit + right px -> (λ_2. 1) px + }) (λ_1. (λk. 17) (λ_2. matchErr))) unit +(10 choose right (5, left unit)) +5! diff --git a/test/compile-misc/input b/test/compile-misc/input new file mode 100644 --- /dev/null +++ b/test/compile-misc/input @@ -0,0 +1,6 @@ +:compile (holds (forall x : N. x > 3)) +:compile \x. \y. x +:compile {? p when 2/3 is p/q ?} +:compile {? 1 if 2 > 3, 17 otherwise ?} +:compile 10 choose 5 +:compile 5! diff --git a/test/containers-cmp/expected b/test/containers-cmp/expected new file mode 100644 --- /dev/null +++ b/test/containers-cmp/expected @@ -0,0 +1,4 @@ +{{1, 2}, {1, 3}, {2, 3}} +true +{⟅1 # 3⟆, ⟅2 # 5⟆} +true diff --git a/test/containers-cmp/input b/test/containers-cmp/input new file mode 100644 --- /dev/null +++ b/test/containers-cmp/input @@ -0,0 +1,4 @@ +{{1,2}, {2,3}, {1,3}} +{} < {1} < {1,2} < {2,3} < {4,2,3} +{ bag [1,1,1], bag [2,2,2,2,2] } +⟅⟆ < ⟅1⟆ < ⟅1,1⟆ < ⟅2⟆ < ⟅2, 2⟆ < ⟅2, 2, 3, 3⟆ < ⟅2, 2, 2, 3⟆ < ⟅2, 2, 2, 4⟆ < ⟅3⟆ diff --git a/test/containers-comp/expected b/test/containers-comp/expected new file mode 100644 --- /dev/null +++ b/test/containers-comp/expected @@ -0,0 +1,5 @@ +{1, 2, 3} +{} +{11, 13, 15, 17, 21, 23, 25, 27, 31, 33, 35, 37} +{3, 4, 5, 6} +{2, 3} diff --git a/test/containers-comp/input b/test/containers-comp/input new file mode 100644 --- /dev/null +++ b/test/containers-comp/input @@ -0,0 +1,5 @@ +{x | x in {1,2,3}} +{x | x in {1,2,3}, y in {}} +{x+y+z | z in {1,2,3}, x in {z-1,z+1}, y in {10,20,30}} +{x+y+z | x in {1,2}, y in {1,2}, z in {1,2}} +{ x | x in {1,2,3}, x > 1 } diff --git a/test/containers-convert/expected b/test/containers-convert/expected new file mode 100644 --- /dev/null +++ b/test/containers-convert/expected @@ -0,0 +1,10 @@ +[1, 2, 3, 3] +[1, 2, 3] +[1, 2, 2, 3] +⟅1, 2, 3 # 2⟆ +⟅1, 2, 3⟆ +⟅1, 2 # 2, 3⟆ +{1, 2, 3} +{1, 2, 3} +{1, 2, 3} +[1, 2, 3, 5, 6, 6] diff --git a/test/containers-convert/input b/test/containers-convert/input new file mode 100644 --- /dev/null +++ b/test/containers-convert/input @@ -0,0 +1,10 @@ +list [1,2,3,3] +list {2,3,1,2} +list ⟅2,3,1,2⟆ +bag [1,2,3,3] +bag {2,3,1,2} +bag ⟅2,3,1,2⟆ +set [1,2,3,3] +set {2,3,1,2} +set ⟅2,3,1,2⟆ +let sort : List(N) -> List(N) = \l. list (bag l) in sort [1,5,2,6,6,3] diff --git a/test/containers-each/expected b/test/containers-each/expected new file mode 100644 --- /dev/null +++ b/test/containers-each/expected @@ -0,0 +1,12 @@ +λxs. each(λx. x + 1, xs) : List(ℕ) → List(ℕ) +λxs. each(list, xs) : List(List(a)) → List(List(a)) +each(λx. x + 1, [1, 2, 3]) : List(ℕ) +each(λx. x + 1, ⟅1, 2, 3⟆) : Bag(ℕ) +each(λx. x + 1, {1, 2, 3}) : Set(ℕ) +[2, 3, 4] +⟅2, 3, 4⟆ +⟅0, 1 # 2, 4 # 2⟆ +⟅1 # 100⟆ +{2, 3, 4} +{0, 1, 4} +{1} diff --git a/test/containers-each/input b/test/containers-each/input new file mode 100644 --- /dev/null +++ b/test/containers-each/input @@ -0,0 +1,12 @@ +:type \xs. each (\x.x+1, xs) +:type \xs. each(list,xs) +:type each (\x.x+1, [1,2,3]) +:type each (\x.x+1, ⟅1,2,3⟆) +:type each (\x.x+1, {1,2,3}) +each(\x.x+1, [1,2,3]) +each(\x.x+1, ⟅1,2,3⟆) +each(\x.x^2, ⟅-2, -1, 0, 1, 2⟆) +each(\x.1, ⟅1..100⟆) +each(\x.x+1, {1,2,3}) +each(\x.x^2, {-2 .. 2}) +each(\x.1, {1..100}) diff --git a/test/containers-ellipsis/expected b/test/containers-ellipsis/expected new file mode 100644 --- /dev/null +++ b/test/containers-ellipsis/expected @@ -0,0 +1,5 @@ +{1, 2, 3, 4, 5} +{1, 3, 6, 10, 15, 21, 28, 36, 45} +⟅1, 2, 3, 4, 5⟆ +⟅1, 3, 6, 10, 15, 21, 28, 36, 45⟆ +"abcdefghijklmnopqrstuvwxyz" diff --git a/test/containers-ellipsis/input b/test/containers-ellipsis/input new file mode 100644 --- /dev/null +++ b/test/containers-ellipsis/input @@ -0,0 +1,5 @@ +{ 1 .. 5 } +{ 1, 3, 6 .. 50 } +⟅ 1 .. 5 ⟆ +⟅ 1, 3, 6 .. 50 ⟆ +[ 'a' .. 'z' ] diff --git a/test/containers-filter/expected b/test/containers-filter/expected new file mode 100644 --- /dev/null +++ b/test/containers-filter/expected @@ -0,0 +1,6 @@ +Loading list.disco... +[4, 5, 6, 7, 8, 9, 10] +⟅4, 5, 6, 7, 8, 9, 10⟆ +{4, 5, 6, 7, 8, 9, 10} +⟅2 # 2, 4⟆ +[4, 5, 6, 7, 8, 9, 10, 11, 12, 13] diff --git a/test/containers-filter/input b/test/containers-filter/input new file mode 100644 --- /dev/null +++ b/test/containers-filter/input @@ -0,0 +1,6 @@ +import list +filter(\x.x > 3, [1 .. 10]) +filter(\x.x > 3, ⟅1 .. 10⟆) +filter(\x.x > 3, {1 .. 10}) +filter(\x.x mod 2 == 0, ⟅1, 2, 1, 3, 2, 4⟆) +take(10, filter(\x.x > 3, [1 .. 1000])) diff --git a/test/containers-join/expected b/test/containers-join/expected new file mode 100644 --- /dev/null +++ b/test/containers-join/expected @@ -0,0 +1,7 @@ +[] +[1, 2, 3, 4, 5, 6, 7] +{1, 2, 3} +{1, 2, 3} +⟅1 # 4, 2 # 2, 3 # 2⟆ +⟅1 # 7, 2 # 4, 3 # 2⟆ +⟅1 # 15, 2 # 4, 3 # 6⟆ diff --git a/test/containers-join/input b/test/containers-join/input new file mode 100644 --- /dev/null +++ b/test/containers-join/input @@ -0,0 +1,8 @@ +using primitives +$join [] +$join [[1,2], [3,4,5], [6,7]] +$join {{1}, {2}, {3}} +$join {{1,2}, {2,3}, {1,3}} +$join ⟅⟅1⟆, ⟅1,2⟆, ⟅2,3⟆, ⟅1,1,3⟆⟆ +$join ⟅⟅1⟆, ⟅1⟆, ⟅1,2⟆, ⟅2,3⟆, ⟅1,2⟆, ⟅1,2⟆, ⟅1,1,3⟆⟆ +$join ($join (bag [bagFromCounts {(⟅1⟆, 2)}, bagFromCounts {(⟅1,2⟆, 3)}, bagFromCounts {(⟅2,3⟆, 1)}, bagFromCounts {(⟅1,1,3⟆, 5)}])) diff --git a/test/containers-merge/expected b/test/containers-merge/expected new file mode 100644 --- /dev/null +++ b/test/containers-merge/expected @@ -0,0 +1,8 @@ +⟅1 # 2, 2 # 5, 3 # 2⟆ +⟅1 # 2, 2⟆ +⟅2 # 2⟆ +⟅1 # 2, 2 # 3, 3 # 2⟆ +{2} +{1, 2, 3, 4} +{1, 3} +{1, 3, 4} diff --git a/test/containers-merge/input b/test/containers-merge/input new file mode 100644 --- /dev/null +++ b/test/containers-merge/input @@ -0,0 +1,9 @@ +using primitives +$merge(~+~, bag [1,1,2,2,2], bag [2,2,3,3]) +$merge(~.-~, bag [1,1,2,2,2], bag [2,2,3,3]) +$merge(~min~, bag [1,1,2,2,2], bag [2,2,3,3]) +$merge(~max~, bag [1,1,2,2,2], bag [2,2,3,3]) +$merge(~min~, {1,2,3}, {2,4}) +$merge(~max~, {1,2,3}, {2,4}) +$merge(~.-~, {1,2,3}, {2,4}) +$merge(\p. {? (x + y) mod 2 when p is (x,y) ?}, {1,2,3}, {2,4}) diff --git a/test/containers-ops/expected b/test/containers-ops/expected new file mode 100644 --- /dev/null +++ b/test/containers-ops/expected @@ -0,0 +1,60 @@ +{1, 2} +{} union {1, 2} : Set(ℕ) +{2, -3} union {1 / 2} : Set(ℚ) +{1, 2, 3} +{4} +{} +{1} +true +true +true +{{}, {1}, {1, 2}, {1, 2, 3}, {1, 3}, {2}, {2, 3}, {3}} +{{}} +{{}, {1}} +{{}, {{}}} +{{}, {{}}, {{}, {{}}}, {{{}}}} +power(power(power({}))) : Set(Set(Set(Set(ℕ)))) +{{}, {"hi"}, {"hi", "there"}, {"there"}} +⟅1, 2⟆ +⟅1, 2⟆ +bag([]) union bag([1, 2]) : Bag(ℕ) +bag([2, -3]) union bag([1 / 2]) : Bag(ℚ) +⟅1, 2 # 5, 3⟆ +⟅4⟆ +⟅⟆ +⟅2 # 2, 3, 5⟆ +⟅1⟆ +true +true +true +⟅⟅⟆⟆ +⟅⟅⟆, ⟅1⟆⟆ +⟅⟅⟆, ⟅1⟆, ⟅1, 2⟆, ⟅2⟆⟆ +⟅⟅⟆, ⟅'a'⟆, ⟅'a', 'b'⟆ # 2, ⟅'a', 'b' # 2⟆, ⟅'b'⟆ # 2, ⟅'b' # 2⟆⟆ +⟅⟅⟆, ⟅'a'⟆ # 2, ⟅'a', 'b'⟆ # 6, ⟅'a', 'b' # 2⟆ # 6, ⟅'a', 'b' # 3⟆ # 2, ⟅'a' # 2⟆, ⟅'a' # 2, 'b'⟆ # 3, ⟅'a' # 2, 'b' # 2⟆ # 3, ⟅'a' # 2, 'b' # 3⟆, ⟅'b'⟆ # 3, ⟅'b' # 2⟆ # 3, ⟅'b' # 3⟆⟆ +true +true +false +false +true +false +false +true +true +true +false +false +true +false +true +true +⟅'x' # 3, 'y' # 2⟆ +⟅'x' # 3, 'y'⟆ +⟅'x', 'y'⟆ +{(1, 3), (2, 1), (3, 2)} +⟅1 # 4, 2 # 3⟆ +⟅1 # 3, 2, 3 # 2⟆ +⟅'a' # 5, 'b' # 2⟆ +⟅'a' # 4, 'b' # 4⟆ +⟅'a' # 3, 'b' # 4⟆ +⟅'a' # 4, 'b' # 4⟆ diff --git a/test/containers-ops/input b/test/containers-ops/input new file mode 100644 --- /dev/null +++ b/test/containers-ops/input @@ -0,0 +1,60 @@ +{} union {1,2} +:type {} union {1,2} +:type {2,-3} union {1/2} +{1,2,2} union {2,2,2,3} +{3,4,5} intersect {4,2} +{3,4,5} intersect {1,6} +{1,2,3} \ {3,2} +({5,6} ⊆ {5,6,7} : Bool) +{} ⊆ {{6}} +{{6}} ⊆ {{6}} +power {1,2,3} +power {} +power {1,1,1} +power (power {}) +power (power (power {})) +:type power (power (power {})) +power {"hi", "there"} +bag [] union bag [1,2] +bag [] union bag [1,2] : Bag(N) +:type bag [] union bag [1,2] +:type bag [2,-3] union bag [1/2] +bag [1,2,2] union bag [2,2,2,3] +bag [3,4,5] intersect bag [4,2] +bag [3,4,5] intersect bag [1,6] +bag [2,2,2,3,2,4,5] intersect bag [2,3,2,5,5,6] +bag [1,2,3] \ bag [3,2] +(bag [5,6] ⊆ bag [5,6,7] : Bool) +bag [] ⊆ bag [bag [6]] +bag [bag [6]] ⊆ bag [bag [6]] +power (bag []) +power (bag [1]) +power (bag [1,2]) +power (bag ['a', 'b', 'b']) +power (bag ['a', 'b', 'a', 'b', 'b']) +2 elem {1,2,3} +2 ∈ {1,2,3} +4 elem {1,2,3} +4 elem {} +2 elem (bag [1,3,2,3,2]) +4 elem (bag [1,3,2,3,2]) +4 elem (bag []) +1 elem [1,2,3] +2 elem [1,2,3] +3 elem [1,2,3] +4 elem [1,2,3] +4 elem [] +[1,2] elem {[2,3], [1,2], [4,5]} +[1,2] elem {[2,3], [2,1], [4,5]} +{1,2} elem {{2,3}, {2,1}, {4,5}} +{} elem (power {1,2,3}) +⟅ 'x', 'x', 'y', 'y', 'x' ⟆ +⟅ 'x', 'x', 'y', 'x' ⟆ +⟅ 'y', 'x' ⟆ +bagCounts (bag [1,1,2,3,1,3]) +bagFromCounts {(1,1), (1,3), (4,0), (2,3)} +bagFromCounts (bagCounts (bag [1,1,2,3,1,3])) +let x = 3 in ⟅ 'a' # (2 + x), 'b', 'b' ⟆ +bagFromCounts [('a', 1), ('a', 1), ('a', 2), ('b', 3), ('b', 1)] +bagFromCounts {('a', 1), ('a', 1), ('a', 2), ('b', 3), ('b', 1)} +bagFromCounts ⟅('a', 1), ('a', 1), ('a', 2), ('b', 3), ('b', 1)⟆ diff --git a/test/containers-reduce/containers-reduce.disco b/test/containers-reduce/containers-reduce.disco new file mode 100644 --- /dev/null +++ b/test/containers-reduce/containers-reduce.disco @@ -0,0 +1,14 @@ +import num + +!!! ∀ x : ℕ. (x > 0) ==> reduce(~*~, 1, factor x) == x +dummy : Unit +dummy = unit + +||| The size (cardinality) of a set. +!!! setSize {} == 0 +!!! setSize {1} == 1 +!!! setSize {1..10} == 10 +!!! setSize {1,1,1,2,3} == 3 +!!! ∀ s : Set(N). setSize s == setSize (s ∪ s) +setSize : Set(N) -> N +setSize s = reduce(~+~, 0, each (\x.1, bag s)) diff --git a/test/containers-reduce/expected b/test/containers-reduce/expected new file mode 100644 --- /dev/null +++ b/test/containers-reduce/expected @@ -0,0 +1,15 @@ +Loading containers-reduce.disco... +Loading num.disco... +Running tests... + dummy: OK + setSize: OK +Loaded. +reduce : (a × a → a) × a × List(a) → a +reduce(~+~, 0, [1 .. 10]) : ℕ +55 +60 +true +2351 +6 +7 +true diff --git a/test/containers-reduce/input b/test/containers-reduce/input new file mode 100644 --- /dev/null +++ b/test/containers-reduce/input @@ -0,0 +1,10 @@ +:load test/containers-reduce/containers-reduce.disco +:type reduce +:type reduce(~+~, 0, [1 .. 10]) +reduce(~+~, 0, [1 .. 10]) +reduce(~+~, 5, [1 .. 10]) +reduce(~*~, 1, [1 .. 10]) == 10! +reduce(\p. {? d + 10*r when p is (d,r) ?}, 0, [1,5,3,2]) +reduce(~+~, 0, {1, 1, 2, 3}) +reduce(~+~, 0, ⟅1, 1, 2, 3⟆) +reduce(~*~, 1, factor 11846808) == 11846808 diff --git a/test/error-ambiguous/a.disco b/test/error-ambiguous/a.disco new file mode 100644 --- /dev/null +++ b/test/error-ambiguous/a.disco @@ -0,0 +1,2 @@ +x : Int +x = 1 diff --git a/test/error-ambiguous/ambiguous.disco b/test/error-ambiguous/ambiguous.disco new file mode 100644 --- /dev/null +++ b/test/error-ambiguous/ambiguous.disco @@ -0,0 +1,8 @@ +import a +import b + +x : Int +x = 0 + +y : Int +y = x + 1 diff --git a/test/error-ambiguous/b.disco b/test/error-ambiguous/b.disco new file mode 100644 --- /dev/null +++ b/test/error-ambiguous/b.disco @@ -0,0 +1,2 @@ +x : Int +x = 2 diff --git a/test/error-ambiguous/expected b/test/error-ambiguous/expected new file mode 100644 --- /dev/null +++ b/test/error-ambiguous/expected @@ -0,0 +1,8 @@ +Loading ambiguous.disco... +Loading a.disco... +Loading b.disco... +Error: the name x is ambiguous. It could refer to: + a.x + ambiguous.x + b.x +https://disco-lang.readthedocs.io/en/latest/reference/ambiguous.html diff --git a/test/error-ambiguous/input b/test/error-ambiguous/input new file mode 100644 --- /dev/null +++ b/test/error-ambiguous/input @@ -0,0 +1,1 @@ +:load test/error-ambiguous/ambiguous.disco diff --git a/test/error-cyclic/cyclic.disco b/test/error-cyclic/cyclic.disco new file mode 100644 --- /dev/null +++ b/test/error-cyclic/cyclic.disco @@ -0,0 +1,3 @@ +type A = B +type B = C +type C = A diff --git a/test/error-cyclic/expected b/test/error-cyclic/expected new file mode 100644 --- /dev/null +++ b/test/error-cyclic/expected @@ -0,0 +1,3 @@ +Loading cyclic.disco... +Error: cyclic type definition for A. +https://disco-lang.readthedocs.io/en/latest/reference/cyc-ty.html diff --git a/test/error-cyclic/input b/test/error-cyclic/input new file mode 100644 --- /dev/null +++ b/test/error-cyclic/input @@ -0,0 +1,1 @@ +:load test/error-cyclic/cyclic.disco diff --git a/test/error-duplicatedecls/dupdecls.disco b/test/error-duplicatedecls/dupdecls.disco new file mode 100644 --- /dev/null +++ b/test/error-duplicatedecls/dupdecls.disco @@ -0,0 +1,5 @@ +x : Z +x = 3 + +x : Z +x = 4 diff --git a/test/error-duplicatedecls/expected b/test/error-duplicatedecls/expected new file mode 100644 --- /dev/null +++ b/test/error-duplicatedecls/expected @@ -0,0 +1,3 @@ +Loading dupdecls.disco... +Error: duplicate type signature for x. +https://disco-lang.readthedocs.io/en/latest/reference/dup-sig.html diff --git a/test/error-duplicatedecls/input b/test/error-duplicatedecls/input new file mode 100644 --- /dev/null +++ b/test/error-duplicatedecls/input @@ -0,0 +1,1 @@ +:load test/error-duplicatedecls/dupdecls.disco diff --git a/test/error-duplicatedefns/dupdefns.disco b/test/error-duplicatedefns/dupdefns.disco new file mode 100644 --- /dev/null +++ b/test/error-duplicatedefns/dupdefns.disco @@ -0,0 +1,3 @@ +x : N +x = 1 +x = 2 diff --git a/test/error-duplicatedefns/expected b/test/error-duplicatedefns/expected new file mode 100644 --- /dev/null +++ b/test/error-duplicatedefns/expected @@ -0,0 +1,3 @@ +Loading dupdefns.disco... +Error: duplicate definition for x. +https://disco-lang.readthedocs.io/en/latest/reference/dup-def.html diff --git a/test/error-duplicatedefns/input b/test/error-duplicatedefns/input new file mode 100644 --- /dev/null +++ b/test/error-duplicatedefns/input @@ -0,0 +1,1 @@ +:load test/error-duplicatedefns/dupdefns.disco diff --git a/test/error-duplicatetydefns/duptydefns.disco b/test/error-duplicatetydefns/duptydefns.disco new file mode 100644 --- /dev/null +++ b/test/error-duplicatetydefns/duptydefns.disco @@ -0,0 +1,2 @@ +type XYZ = N +type XYZ = Z diff --git a/test/error-duplicatetydefns/expected b/test/error-duplicatetydefns/expected new file mode 100644 --- /dev/null +++ b/test/error-duplicatetydefns/expected @@ -0,0 +1,3 @@ +Loading duptydefns.disco... +Error: duplicate definition for type XYZ. +https://disco-lang.readthedocs.io/en/latest/reference/dup-tydef.html diff --git a/test/error-duplicatetydefns/input b/test/error-duplicatetydefns/input new file mode 100644 --- /dev/null +++ b/test/error-duplicatetydefns/input @@ -0,0 +1,1 @@ +:load test/error-duplicatetydefns/duptydefns.disco diff --git a/test/error-emptycase/expected b/test/error-emptycase/expected new file mode 100644 --- /dev/null +++ b/test/error-emptycase/expected @@ -0,0 +1,2 @@ +Error: empty case expressions {? ?} are not allowed. +https://disco-lang.readthedocs.io/en/latest/reference/empty-case.html diff --git a/test/error-emptycase/input b/test/error-emptycase/input new file mode 100644 --- /dev/null +++ b/test/error-emptycase/input @@ -0,0 +1,1 @@ +{? ?} diff --git a/test/error-names/expected b/test/error-names/expected new file mode 100644 --- /dev/null +++ b/test/error-names/expected @@ -0,0 +1,2 @@ +Error: there is nothing named x. +https://disco-lang.readthedocs.io/en/latest/reference/unbound.html diff --git a/test/error-names/input b/test/error-names/input new file mode 100644 --- /dev/null +++ b/test/error-names/input @@ -0,0 +1,1 @@ +x + 2 diff --git a/test/error-notcon/expected b/test/error-notcon/expected new file mode 100644 --- /dev/null +++ b/test/error-notcon/expected @@ -0,0 +1,5 @@ +Error: the expression + λx : ℤ. x +must have both a function type and also the incompatible type + List(ℤ). +https://disco-lang.readthedocs.io/en/latest/reference/notcon.html diff --git a/test/error-notcon/input b/test/error-notcon/input new file mode 100644 --- /dev/null +++ b/test/error-notcon/input @@ -0,0 +1,4 @@ +f : List(Int) -> List(Int) +f x = x + +f (\x:Z.x) diff --git a/test/error-notype/expected b/test/error-notype/expected new file mode 100644 --- /dev/null +++ b/test/error-notype/expected @@ -0,0 +1,3 @@ +Error: the definition of x must have an accompanying type signature. +Try writing something like 'x : Int' (or whatever the type of x should be) first. +https://disco-lang.readthedocs.io/en/latest/reference/missingtype.html diff --git a/test/error-notype/input b/test/error-notype/input new file mode 100644 --- /dev/null +++ b/test/error-notype/input @@ -0,0 +1,1 @@ +x = 3 diff --git a/test/error-numpatterns/expected b/test/error-numpatterns/expected new file mode 100644 --- /dev/null +++ b/test/error-numpatterns/expected @@ -0,0 +1,3 @@ +Loading numpatterns.disco... +Error: number of arguments does not match. +https://disco-lang.readthedocs.io/en/latest/reference/num-args.html diff --git a/test/error-numpatterns/input b/test/error-numpatterns/input new file mode 100644 --- /dev/null +++ b/test/error-numpatterns/input @@ -0,0 +1,1 @@ +:load test/error-numpatterns/numpatterns.disco diff --git a/test/error-numpatterns/numpatterns.disco b/test/error-numpatterns/numpatterns.disco new file mode 100644 --- /dev/null +++ b/test/error-numpatterns/numpatterns.disco @@ -0,0 +1,3 @@ +f : N -> N -> Bool +f 3 = \x.x > 2 +f x y = true diff --git a/test/error-pattype/expected b/test/error-pattype/expected new file mode 100644 --- /dev/null +++ b/test/error-pattype/expected @@ -0,0 +1,14 @@ +Error: the pattern + left(x) +is supposed to have type + List(ℤ), +but instead it has a sum type. +https://disco-lang.readthedocs.io/en/latest/reference/pattern-type.html +Error: the pattern + (x1, y) +is supposed to have type + ℕ, +but instead it has a product type. +https://disco-lang.readthedocs.io/en/latest/reference/pattern-type.html +Error: the shape of two types does not match. +https://disco-lang.readthedocs.io/en/latest/reference/shape-mismatch.html diff --git a/test/error-pattype/input b/test/error-pattype/input new file mode 100644 --- /dev/null +++ b/test/error-pattype/input @@ -0,0 +1,8 @@ +f : List(Int) -> Bool +f (left(x)) = false + +g : N -> Bool +g (x,y) = false + +h : Z*Z -> Bool +h(3:Z) = false diff --git a/test/error-polyrec/expected b/test/error-polyrec/expected new file mode 100644 --- /dev/null +++ b/test/error-polyrec/expected @@ -0,0 +1,4 @@ +Loading polyrec.disco... +Error: in the definition of Bush(a): recursive occurrences of Bush may only have type variables as arguments. + Bush(a × a) does not follow this rule. +https://disco-lang.readthedocs.io/en/latest/reference/no-poly-rec.html diff --git a/test/error-polyrec/input b/test/error-polyrec/input new file mode 100644 --- /dev/null +++ b/test/error-polyrec/input @@ -0,0 +1,1 @@ +:load test/error-polyrec/polyrec.disco diff --git a/test/error-polyrec/polyrec.disco b/test/error-polyrec/polyrec.disco new file mode 100644 --- /dev/null +++ b/test/error-polyrec/polyrec.disco @@ -0,0 +1,1 @@ +type Bush(a) = a + Bush(a*a) diff --git a/test/error-qualskolem/expected b/test/error-qualskolem/expected new file mode 100644 --- /dev/null +++ b/test/error-qualskolem/expected @@ -0,0 +1,4 @@ +Loading qualskolem.disco... +Error: type variable a represents any type, so we cannot assume values of that type + can be subtracted. +https://disco-lang.readthedocs.io/en/latest/reference/qual-skolem.html diff --git a/test/error-qualskolem/input b/test/error-qualskolem/input new file mode 100644 --- /dev/null +++ b/test/error-qualskolem/input @@ -0,0 +1,1 @@ +:load test/error-qualskolem/qualskolem.disco diff --git a/test/error-qualskolem/qualskolem.disco b/test/error-qualskolem/qualskolem.disco new file mode 100644 --- /dev/null +++ b/test/error-qualskolem/qualskolem.disco @@ -0,0 +1,2 @@ +f : a -> a +f (-x) = x diff --git a/test/error-tyargs/error-tyargs.disco b/test/error-tyargs/error-tyargs.disco new file mode 100644 --- /dev/null +++ b/test/error-tyargs/error-tyargs.disco @@ -0,0 +1,1 @@ +type T(a,b) = Unit + a*b diff --git a/test/error-tyargs/expected b/test/error-tyargs/expected new file mode 100644 --- /dev/null +++ b/test/error-tyargs/expected @@ -0,0 +1,12 @@ +Loading error-tyargs.disco... +Loaded. +Error: not enough arguments for the type 'T'. +https://disco-lang.readthedocs.io/en/latest/reference/num-args-type.html +Error: not enough arguments for the type 'T'. +https://disco-lang.readthedocs.io/en/latest/reference/num-args-type.html +Error: too many arguments for the type 'T'. +https://disco-lang.readthedocs.io/en/latest/reference/num-args-type.html +Error: not enough arguments for the type 'List'. +https://disco-lang.readthedocs.io/en/latest/reference/num-args-type.html +Error: too many arguments for the type 'List'. +https://disco-lang.readthedocs.io/en/latest/reference/num-args-type.html diff --git a/test/error-tyargs/input b/test/error-tyargs/input new file mode 100644 --- /dev/null +++ b/test/error-tyargs/input @@ -0,0 +1,7 @@ +:load test/error-tyargs/error-tyargs.disco +x : T +y : T(Int) +z : T(Int,Char) +w : T(Int,Char,Bool) +q : List +p : List(Int,Char) diff --git a/test/error-unboundtyvar/expected b/test/error-unboundtyvar/expected new file mode 100644 --- /dev/null +++ b/test/error-unboundtyvar/expected @@ -0,0 +1,3 @@ +Loading unboundtyvar.disco... +Error: Unknown type variable 'b'. +https://disco-lang.readthedocs.io/en/latest/reference/unbound-tyvar.html diff --git a/test/error-unboundtyvar/input b/test/error-unboundtyvar/input new file mode 100644 --- /dev/null +++ b/test/error-unboundtyvar/input @@ -0,0 +1,1 @@ +:load test/error-unboundtyvar/unboundtyvar.disco diff --git a/test/error-unboundtyvar/unboundtyvar.disco b/test/error-unboundtyvar/unboundtyvar.disco new file mode 100644 --- /dev/null +++ b/test/error-unboundtyvar/unboundtyvar.disco @@ -0,0 +1,1 @@ +type T(a) = a + b diff --git a/test/error-unqual-base/expected b/test/error-unqual-base/expected new file mode 100644 --- /dev/null +++ b/test/error-unqual-base/expected @@ -0,0 +1,3 @@ +Loading unqualbase.disco... +Error: values of type ℕ cannot be subtracted. +https://disco-lang.readthedocs.io/en/latest/reference/not-qual.html diff --git a/test/error-unqual-base/input b/test/error-unqual-base/input new file mode 100644 --- /dev/null +++ b/test/error-unqual-base/input @@ -0,0 +1,1 @@ +:load test/error-unqual-base/unqualbase.disco diff --git a/test/error-unqual-base/unqualbase.disco b/test/error-unqual-base/unqualbase.disco new file mode 100644 --- /dev/null +++ b/test/error-unqual-base/unqualbase.disco @@ -0,0 +1,2 @@ +f : N -> N +f (-x) = x diff --git a/test/error-unqual/expected b/test/error-unqual/expected new file mode 100644 --- /dev/null +++ b/test/error-unqual/expected @@ -0,0 +1,2 @@ +Error: values of type a2 → a3 cannot be compared. +https://disco-lang.readthedocs.io/en/latest/reference/not-qual.html diff --git a/test/error-unqual/input b/test/error-unqual/input new file mode 100644 --- /dev/null +++ b/test/error-unqual/input @@ -0,0 +1,1 @@ +(\x.x) == (\y.y) diff --git a/test/error-wildcard/expected b/test/error-wildcard/expected new file mode 100644 --- /dev/null +++ b/test/error-wildcard/expected @@ -0,0 +1,2 @@ +Error: wildcards (_) are not allowed in expressions. +https://disco-lang.readthedocs.io/en/latest/reference/wildcard-expr.html diff --git a/test/error-wildcard/input b/test/error-wildcard/input new file mode 100644 --- /dev/null +++ b/test/error-wildcard/input @@ -0,0 +1,1 @@ +1 + _ diff --git a/test/graphs-basic/expected b/test/graphs-basic/expected new file mode 100644 --- /dev/null +++ b/test/graphs-basic/expected @@ -0,0 +1,16 @@ +emptyGraph : Graph(ℕ) +emptyGraph +vertex(1) : Graph(ℕ) +vertex(1) +map({(1, {})}) +vertex(1) + vertex(2) : Graph(ℕ) +vertex(1) + vertex(2) +map({(1, {}), (2, {})}) +vertex('a') + vertex('b') + vertex('c') : Graph(Char) +vertex('a') + vertex('b') + vertex('c') +map({('a', {}), ('b', {}), ('c', {})}) +(vertex(1) + vertex(2)) * vertex(3) : Graph(ℕ) +(vertex(1) + vertex(2)) * vertex(3) +map({(1, {3}), (2, {3}), (3, {})}) +vertex(1) * (vertex(2) * (vertex(3) * (vertex(4) * (vertex(5) * emptyGraph)))) +map({(1, {2, 3, 4, 5}), (2, {3, 4, 5}), (3, {4, 5}), (4, {5}), (5, {})}) diff --git a/test/graphs-basic/input b/test/graphs-basic/input new file mode 100644 --- /dev/null +++ b/test/graphs-basic/input @@ -0,0 +1,17 @@ +:type emptyGraph +emptyGraph +:type vertex 1 +vertex 1 +summary (vertex 1) +:type vertex 1 + vertex 2 +vertex 1 + vertex 2 +summary (vertex 1 + vertex 2) +:type vertex 'a' + vertex 'b' + vertex 'c' +vertex 'a' + vertex 'b' + vertex 'c' +summary (vertex 'a' + vertex 'b' + vertex 'c') +:type (vertex 1 + vertex 2) * vertex 3 +(vertex 1 + vertex 2) * vertex 3 +summary ((vertex 1 + vertex 2) * vertex 3) +import list +foldr(~*~, emptyGraph, each(vertex, [1..5])) +summary it diff --git a/test/graphs-equality/expected b/test/graphs-equality/expected new file mode 100644 --- /dev/null +++ b/test/graphs-equality/expected @@ -0,0 +1,4 @@ +true +true +true +true diff --git a/test/graphs-equality/input b/test/graphs-equality/input new file mode 100644 --- /dev/null +++ b/test/graphs-equality/input @@ -0,0 +1,4 @@ +emptyGraph == emptyGraph +vertex(1) + vertex(2) == vertex(2) + vertex(1) +vertex(1) * (vertex 2 + vertex 3) == vertex 1 * vertex 2 + vertex 1 * vertex 3 +vertex 1 * vertex 2 * vertex 3 == vertex 1 * vertex 2 + vertex 1 * vertex 3 + vertex 2 * vertex 3 diff --git a/test/interp-loop/expected b/test/interp-loop/expected new file mode 100644 --- /dev/null +++ b/test/interp-loop/expected @@ -0,0 +1,1 @@ +Error: infinite loop detected! diff --git a/test/interp-loop/input b/test/interp-loop/input new file mode 100644 --- /dev/null +++ b/test/interp-loop/input @@ -0,0 +1,2 @@ +x : N +x = x diff --git a/test/interp-strictmatch/bomb.disco b/test/interp-strictmatch/bomb.disco new file mode 100644 --- /dev/null +++ b/test/interp-strictmatch/bomb.disco @@ -0,0 +1,3 @@ +-- A function to produce a runtime exception at any type +bomb : a -> a +bomb x = {? x if 0 == 1 ?} diff --git a/test/interp-strictmatch/expected b/test/interp-strictmatch/expected new file mode 100644 --- /dev/null +++ b/test/interp-strictmatch/expected @@ -0,0 +1,13 @@ +Error: division by zero. +Error: division by zero. +Error: division by zero. +Error: division by zero. +Loading bomb.disco... +Loaded. +Error: value did not match any of the branches in a case expression. +Error: value did not match any of the branches in a case expression. +Error: value did not match any of the branches in a case expression. +Error: value did not match any of the branches in a case expression. +Error: value did not match any of the branches in a case expression. +Error: division by zero. +Error: value did not match any of the branches in a case expression. diff --git a/test/interp-strictmatch/input b/test/interp-strictmatch/input new file mode 100644 --- /dev/null +++ b/test/interp-strictmatch/input @@ -0,0 +1,13 @@ +{? x when (0, 0/0) is (x+1, 3) ?} +{? x when (0, 0/0) is (x+1, 3), 2 otherwise ?} +{? x when [1,2,3/0] is [x,3,5], 2 otherwise ?} +{? x when [1,2,3/0] is [x,2,5], 2 otherwise ?} + +:load test/interp-strictmatch/bomb.disco +{? 1 when (0, bomb 'a' ) is (x+1, 'a' ), 2 otherwise ?} +{? 1 when (0, bomb true) is (x+1, true), 2 otherwise ?} +{? 1 when (0, bomb unit) is (x+1, unit), 2 otherwise ?} +{? 1 when (0, bomb [] ) is (x+1, [] ), 2 otherwise ?} +{? 1 when (0, bomb "xy") is (x+1, "xy"), 2 otherwise ?} +{? 1 when left (0/0) is right 3, 2 otherwise ?} +{? 1 when left (bomb 'a') is right 'a', 2 otherwise ?} diff --git a/test/lib-oeis/expected b/test/lib-oeis/expected new file mode 100644 --- /dev/null +++ b/test/lib-oeis/expected @@ -0,0 +1,8 @@ +Loading oeis.disco... +right("https://oeis.org/A000045") +left(■) +left(■) +[1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 27, 29, 31, 33, 35, 37, 39, 41, 43, 45, 47, 49, 51, 53, 55, 57, 59, 61, 63, 65, 67, 69, 71, 73, 75, 77, 79, 81, 83, 85, 87, 89, 91, 93, 95, 97, 99, 101, 103, 105, 107, 109, 111, 113, 115, 117, 119, 121, 123, 125, 127, 129, 131] +[] +[1, 10011] +[1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 27, 29, 31, 33, 35, 37, 39, 41, 43, 45, 47, 49, 51, 53, 55, 57, 59, 61, 63, 65, 67, 69, 71, 73, 75, 77, 79, 81, 83, 85, 87, 89, 91, 93, 95, 97, 99, 101, 103, 105, 107, 109, 111, 113, 115, 117, 119, 121, 123, 125, 127, 129, 131] diff --git a/test/lib-oeis/input b/test/lib-oeis/input new file mode 100644 --- /dev/null +++ b/test/lib-oeis/input @@ -0,0 +1,22 @@ +import oeis + +-- valid sequence +lookupSequence [1,1,2,3,5] + +-- empty list +lookupSequence [] + +-- unknown sequence +lookupSequence [1,10011] + +-- known sequence +extendSequence [1,3,5,7] + +-- empty list +extendSequence [] + +-- unknown sequence +extendSequence [1,10011] + +-- extend a long sequence +extendSequence [1,3,5,7,9,11,13,15,17,19,21,23,25,27,29,31,33,35,37,39,41,43,45,47,49,51,53,55,57,59,61,63,65,67,69,71,73,75,77,79,81,83,85,87,89,91,93,95,97,99] diff --git a/test/list-comp/expected b/test/list-comp/expected new file mode 100644 --- /dev/null +++ b/test/list-comp/expected @@ -0,0 +1,11 @@ +Loading list.disco... +Loading num.disco... +[1, 2, 3] +[] +[12, 22, 32, 13, 23, 33, 14, 24, 34, 15, 25, 35, 16, 26, 36, 17, 27, 37] +[(3, 4, 5), (5, 12, 13), (6, 8, 10), (9, 12, 15)] +[1] +[1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1] +[(10, 10), (10, 8), (10, 6), (10, 4), (10, 2), (8, 8), (8, 6), (8, 4), (8, 2), (6, 6), (6, 4), (6, 2), (4, 4), (4, 2), (2, 2)] +[(x, y) | x in [10 .. 1], even(x), y in [x .. 1], even(y)] : List(ℕ × ℕ) +[(x, y) | x in [10 .. 1], even(x), y in [x .. 1], even(y)] : List(ℕ × ℕ) diff --git a/test/list-comp/input b/test/list-comp/input new file mode 100644 --- /dev/null +++ b/test/list-comp/input @@ -0,0 +1,12 @@ +import list +import num + +[x | x in [1,2,3]] +[x | x in [1,2,3], y in ([] : List(Q))] +[x+y+z | z in [1,2,3], x in [z,z+1], y in [10,20,30]] +[(a,b,c) | a in [1..15], b in [a..15], c in [b..15], a^2 + b^2 == c^2] +[g | a in [1], b in [a], c in [b], d in [c], e in [d], f in [e], g in [f]] +[g | a in [1], b in [a,a], c in [b,b], d in [c,c], e in [d,d], f in [e,e], g in [f,f]] +[(x,y) | x in [10..1], even x, y in [x..1], even y] +:type [(x,y) | x in [10..1], even x, y in [x..1], even y] +:type [(x,y) | x <- [10..1], even x, y <- [x..1], even y] diff --git a/test/list-poly/expected b/test/list-poly/expected new file mode 100644 --- /dev/null +++ b/test/list-poly/expected @@ -0,0 +1,32 @@ +Loading list.disco... +[1, 2, 3, 4, 5] +[5, 4, 3, 2, 1] +[1, 2, 3, 4, 5] +[1, 2, 3, 4, 5] +[1, 2, 3, 4, 5] +[1, 2, 3, 4, 5] +[] +[1] +[1, 1, 1, 1, 1, 1, 1, 1, 1, 1] +[1, 3, 5, 7, 9] +[0, 1/2, 1, 3/2, 2, 5/2, 3] +[10, 9, 8, 7, 6] +[1, 3, 6, 10, 15, 21] +[1, 4, 9, 16, 25, 36] +true +[] +[1, 3, 4, 4, 3, 1, -2, -6, -11, -17] +[1, 3/2, 2, 5/2, 3] +[1, 3/2, 2, 5/2, 3] +[1, 3, 6, 2, 17, 28, 32, 4, 77, 3, 8, 12, -50399, -532856] +[1 .. 5] : List(ℕ) +[1, 3 .. 5] : List(ℕ) +[1, -3 .. 5] : List(ℤ) +[0, 1 / 3 .. 5] : List(𝔽) +[-2, 1 / 3 .. 5] : List(ℚ) +[2, 3 .. -6] : List(ℤ) +[2, 3 .. 8 / 3] : List(𝔽) +[-2, 3 .. 8 / 3] : List(ℚ) +[1.5] +[1, 2, 3, 4, 5] +[1, 2, 3, 4, 5] diff --git a/test/list-poly/input b/test/list-poly/input new file mode 100644 --- /dev/null +++ b/test/list-poly/input @@ -0,0 +1,32 @@ +import list +[1 .. 5] +[5 .. 1] +[1 ........ 5] +[1, 2 .. 5] +[1, 2, 3 .. 5] +[1, 2, 3, 4 .. 5] +[1, 2 .. 0] +[1 .. 1] +take(10, [1, 1 .. 1]) +[1, 3 .. 10] +[0, 1/2 .. 3] +[10, 9 .. 6] +[1, 3, 6 ... 21] +[1, 4, 9 ... 38] +[x^3 | x in [1 .. 100]] == [1,8,27,64 .. 100^3] +[1, 3, 4 .. 10] +[1, 3, 4 .. -20] +[1.0, 3/2 .. 3] +[1, 3/2 .. 3.0] +take(14, [1, 3, 6, 2, 17, 28, 32, 4, 77, 3, 8, 12 .. -1000000]) +:type [1 .. 5] +:type [1, 3 .. 5] +:type [1, -3 .. 5] +:type [0, 1/3 .. 5] +:type [-2, 1/3 .. 5] +:type [2, 3 .. -6] +:type [2, 3 .. 8/3] +:type [-2, 3 .. 8/3] +[1.5] +[1..5] +[1...5] diff --git a/test/logic-bools/expected b/test/logic-bools/expected new file mode 100644 --- /dev/null +++ b/test/logic-bools/expected @@ -0,0 +1,20 @@ +true +false +true +false +true +false +false +false +false +true +true +true +false +true +false +true +true +false +true +true diff --git a/test/logic-bools/input b/test/logic-bools/input new file mode 100644 --- /dev/null +++ b/test/logic-bools/input @@ -0,0 +1,20 @@ +true +false +True +False +true and true +true and false +false and true +false and false +true && false +true or true +true or false +false or true +false or false +true || false +not true +not false +true ==> true +true ==> false +false ==> true +false ==> false diff --git a/test/logic-cmp/expected b/test/logic-cmp/expected new file mode 100644 --- /dev/null +++ b/test/logic-cmp/expected @@ -0,0 +1,45 @@ +true +false +false +true +true +true +false +true +false +false +true +true +false +false +true +true +false +true +true +false +true +false +true +false +false +true +true +true +false +true +false +true +true +false +true +true +false +false +true +3 +5 +1 +5 +[1, 2, 3, 5, 2, 6] +[1, 2, 1, 3, 1, 2] diff --git a/test/logic-cmp/input b/test/logic-cmp/input new file mode 100644 --- /dev/null +++ b/test/logic-cmp/input @@ -0,0 +1,45 @@ +1 < 2 +2 < 2 +3 < 2 +1/2 < 2/3 +1 <= 2 +2 <= 2 +3 <= 2 +3 > 1 +3 > 3 +3 > 4 +3 >= 1 +3 >= 3 +3 >= 4 +3 == 5 +3 == 3 +3 /= 5 +3 /= 3 +(1,2) < (1,3) +(1,3) < (2,1) +(2,2) < (2,1) +(2,3) == (2,3) +(2,3) == (2,4) +[1,2,3] == [1,2,3] +[1,2,3] == [1,2,3,4] +[1,2,3] == [1,2,4] +([] : List(N)) < [1] +[1,2] < [1,2,3] +[1,2] < [2] +[1,2,3,5,2,6] < [1,2,1,3,1,2] +[1,2,3,5,2,6] < [1,2,4,3,1,2] +(left 3 : N + N) < (left 2 : N + N) +(left 3 : N + N) < (left 4 : N + N) +(left 3 : N + N) < (right 1 : N + N) +(right 3 : N + N) < (right 1 : N + N) +(right 3 : N + N) < (right 4 : N + N) +unit <= unit +unit < unit +false < false +false < true +3 min 5 +3 max 5 +3 min 2 min 5 min 1 min 4 +3 max 2 max 5 max 1 max 4 +[1,2,3,5,2,6] max [1,2,1,3,1,2] +[1,2,3,5,2,6] min [1,2,1,3,1,2] diff --git a/test/map-basic/expected b/test/map-basic/expected new file mode 100644 --- /dev/null +++ b/test/map-basic/expected @@ -0,0 +1,23 @@ +Loading list.disco... +map : Set(ℕ × a) → Map(ℕ, a) +map({(1, 3), (4, 6)}) : Map(ℕ, ℕ) +map({(1, 3), (4, 6)}) +insert : ℕ × a × Map(ℕ, a) → Map(ℕ, a) +map({}) : Map(ℕ, a) +map({}) +insert(1, 3, insert(4, 6, map({}))) : Map(ℕ, ℕ) +map({(1, 3), (4, 6)}) +map({(1, 3)}) +lookup : ℕ × Map(ℕ, a) → Unit + a +right(3) +right(6) +left(■) +map({(1, "hello"), (3, "there"), (4, "you")}) +map({(1, 3)}) +insert(1, {"hi", "there"}, insert(2, {}, insert(4, {"why", "not", "now"}, insert(2, {"blah"}, map({}))))) : Map(ℕ, Set(List(Char))) +map({(1, {"hi", "there"}), (2, {}), (4, {"not", "now", "why"})}) +map({(1, "A")}) +map({(1, "B")}) +map({("hi", 1), ("there", 2)}) +{} +{("hi", 1), ("there", 2)} diff --git a/test/map-basic/input b/test/map-basic/input new file mode 100644 --- /dev/null +++ b/test/map-basic/input @@ -0,0 +1,25 @@ +import list +:type map +:type map {(1,3), (4,6)} +map {(1,3), (4,6)} +:type insert +:type map {} +map {} +:type insert(1, 3, insert(4, 6, map {})) +insert(1, 3, insert(4, 6, map {})) +insert(1, 3, insert(1, 4, map {})) +m : Map(N, N) +m = insert(1, 3, insert(4, 6, map {})) +:type lookup +lookup(1,m) +lookup(4,m) +lookup(5,m) +foldr(\((k,v),m). insert(k,v,m), map {}, [(1,"hello"), (3, "there"), (4, "you")]) +map {(1,3), (1,1), (1,2)} +:type insert(1, {"hi","there"}, insert(2, {}, insert(4, {"why","not","now"}, insert(2, {"blah"}, map {})))) +insert(1, {"hi","there"}, insert(2, {}, insert(4, {"why","not","now"}, insert(2, {"blah"}, map {})))) +insert(1, "A", insert(1, "B", map {})) +insert(1, "B", insert(1, "A", map {})) +insert("hi", 1, insert("there", 2, map {})) +mapToSet(map{}) +mapToSet(insert("hi", 1, insert("there", 2, map {}))) diff --git a/test/map-compare/expected b/test/map-compare/expected new file mode 100644 --- /dev/null +++ b/test/map-compare/expected @@ -0,0 +1,4 @@ +true +true +true +true diff --git a/test/map-compare/input b/test/map-compare/input new file mode 100644 --- /dev/null +++ b/test/map-compare/input @@ -0,0 +1,4 @@ +map({}) == map({}) +insert(1, 'x', insert(2, 'y', map {})) == insert(2, 'y', insert(1, 'x', map {})) +map {(1, 'a')} < map {(1, 'b')} +map {(1, 'a')} < map {(2, 'b')} diff --git a/test/module-basic/a.disco b/test/module-basic/a.disco new file mode 100644 --- /dev/null +++ b/test/module-basic/a.disco @@ -0,0 +1,7 @@ +-- Test to check whether importing a single module which doesn't import any other modules works as +-- expeced + +import b + +x : N +x = 3 + y diff --git a/test/module-basic/b.disco b/test/module-basic/b.disco new file mode 100644 --- /dev/null +++ b/test/module-basic/b.disco @@ -0,0 +1,2 @@ +y : N +y = 5 diff --git a/test/module-basic/c.disco b/test/module-basic/c.disco new file mode 100644 --- /dev/null +++ b/test/module-basic/c.disco @@ -0,0 +1,6 @@ +-- Test for importing the standard library + +import list + +l : List(N) +l = each(\x. x + 1, [1,2,3]) diff --git a/test/module-basic/e.disco b/test/module-basic/e.disco new file mode 100644 --- /dev/null +++ b/test/module-basic/e.disco @@ -0,0 +1,5 @@ +-- Importing a module in a subdirectory, with a .disco extension +import subdir/d.disco + +zz : Z +zz = qq + 1 diff --git a/test/module-basic/expected b/test/module-basic/expected new file mode 100644 --- /dev/null +++ b/test/module-basic/expected @@ -0,0 +1,13 @@ +Loading a.disco... +Loading b.disco... +Loaded. +8 +5 +Loading c.disco... +Loading list.disco... +Loaded. +[2, 3, 4] +Loading e.disco... +Loading subdir/d.disco... +Loaded. +-9 diff --git a/test/module-basic/input b/test/module-basic/input new file mode 100644 --- /dev/null +++ b/test/module-basic/input @@ -0,0 +1,7 @@ +:l test/module-basic/a.disco +x +y +:l test/module-basic/c.disco +l +:l test/module-basic/e.disco +zz diff --git a/test/module-basic/subdir/d.disco b/test/module-basic/subdir/d.disco new file mode 100644 --- /dev/null +++ b/test/module-basic/subdir/d.disco @@ -0,0 +1,2 @@ +qq : Z +qq = -10 diff --git a/test/module-cycle/cyclic1.disco b/test/module-cycle/cyclic1.disco new file mode 100644 --- /dev/null +++ b/test/module-cycle/cyclic1.disco @@ -0,0 +1,3 @@ +import cyclic2 + +x = 3 diff --git a/test/module-cycle/cyclic2.disco b/test/module-cycle/cyclic2.disco new file mode 100644 --- /dev/null +++ b/test/module-cycle/cyclic2.disco @@ -0,0 +1,3 @@ +import cyclic1 + +y = 2 diff --git a/test/module-cycle/expected b/test/module-cycle/expected new file mode 100644 --- /dev/null +++ b/test/module-cycle/expected @@ -0,0 +1,4 @@ +Loading cyclic1.disco... +Loading cyclic2.disco... +Error: module imports form a cycle: + cyclic1 -> cyclic2 -> cyclic1 diff --git a/test/module-cycle/input b/test/module-cycle/input new file mode 100644 --- /dev/null +++ b/test/module-cycle/input @@ -0,0 +1,1 @@ +:load test/module-cycle/cyclic1 diff --git a/test/module-notfound/expected b/test/module-notfound/expected new file mode 100644 --- /dev/null +++ b/test/module-notfound/expected @@ -0,0 +1,1 @@ +Error: couldn't find a module named 'foo'. diff --git a/test/module-notfound/input b/test/module-notfound/input new file mode 100644 --- /dev/null +++ b/test/module-notfound/input @@ -0,0 +1,1 @@ +import foo diff --git a/test/parse-245/expected b/test/parse-245/expected new file mode 100644 --- /dev/null +++ b/test/parse-245/expected @@ -0,0 +1,4 @@ +2 .- 4 : ℕ +2 .- 4 : ℕ +0 +0 diff --git a/test/parse-245/input b/test/parse-245/input new file mode 100644 --- /dev/null +++ b/test/parse-245/input @@ -0,0 +1,4 @@ +:type 2.-4 +:type 2 .- 4 +2.-4 +2 .- 4 diff --git a/test/parse-280/capitalvars.disco b/test/parse-280/capitalvars.disco new file mode 100644 --- /dev/null +++ b/test/parse-280/capitalvars.disco @@ -0,0 +1,5 @@ +A : Set(ℕ) +A = {1, 3, 6} + +B : Set(ℕ) +B = { x+1 | x <- A, x mod 2 == 1 } diff --git a/test/parse-280/expected b/test/parse-280/expected new file mode 100644 --- /dev/null +++ b/test/parse-280/expected @@ -0,0 +1,2 @@ +Loading capitalvars.disco... +Loaded. diff --git a/test/parse-280/input b/test/parse-280/input new file mode 100644 --- /dev/null +++ b/test/parse-280/input @@ -0,0 +1,1 @@ +:load test/parse-280/capitalvars.disco diff --git a/test/parse-case-expr/expected b/test/parse-case-expr/expected new file mode 100644 --- /dev/null +++ b/test/parse-case-expr/expected @@ -0,0 +1,1 @@ +[false, false] diff --git a/test/parse-case-expr/input b/test/parse-case-expr/input new file mode 100644 --- /dev/null +++ b/test/parse-case-expr/input @@ -0,0 +1,1 @@ +let n = 3 in {? true if 2 divides n, false otherwise ?} :: false :: [] diff --git a/test/parse-nested-list/expected b/test/parse-nested-list/expected new file mode 100644 --- /dev/null +++ b/test/parse-nested-list/expected @@ -0,0 +1,2 @@ +[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[10]]]]]]]]]]]]]]]]]]]]]]]]]]]]]] : List(List(List(List(List(List(List(List(List(List(List(List(List(List(List(List(List(List(List(List(List(List(List(List(List(List(List(List(List(List(ℕ)))))))))))))))))))))))))))))) +[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[10]]]]]]]]]]]]]]]]]]]]]]]]]]]]]] diff --git a/test/parse-nested-list/input b/test/parse-nested-list/input new file mode 100644 --- /dev/null +++ b/test/parse-nested-list/input @@ -0,0 +1,2 @@ +:type [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[10]]]]]]]]]]]]]]]]]]]]]]]]]]]]]] +[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[10]]]]]]]]]]]]]]]]]]]]]]]]]]]]]] diff --git a/test/parse-quantifiers/expected b/test/parse-quantifiers/expected new file mode 100644 --- /dev/null +++ b/test/parse-quantifiers/expected @@ -0,0 +1,37 @@ +TAbs_ Lam () (<[PVar_ () x]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) +TAbs_ Lam () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) +TAbs_ Lam () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PVar_ () y]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ Lam () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ Lam () (<[PVar_ () x,PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ Lam () (<[PVar_ () x]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) +TAbs_ Lam () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) +TAbs_ Lam () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PVar_ () y]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ Lam () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ Lam () (<[PVar_ () x,PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +8 +Error: the shape of two types does not match. +https://disco-lang.readthedocs.io/en/latest/reference/shape-mismatch.html +8 +8 +8 +TAbs_ Ex () (<[PVar_ () x]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) +TAbs_ Ex () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) +TAbs_ Ex () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PVar_ () y]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ Ex () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ Ex () (<[PVar_ () x,PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ Ex () (<[PVar_ () x]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) +TAbs_ Ex () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) +TAbs_ Ex () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PVar_ () y]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ Ex () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ Ex () (<[PVar_ () x,PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ All () (<[PVar_ () x]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) +TAbs_ All () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) +TAbs_ All () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PVar_ () y]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ All () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ All () (<[PVar_ () x,PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ All () (<[PVar_ () x]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) +TAbs_ All () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TNat_ () 3])) +TAbs_ All () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PVar_ () y]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ All () (<[PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ All () (<[PVar_ () x,PAscr_ () (PVar_ () y) (TyAtom (ABase F))]> TApp_ () (TPrim_ () (PrimBOp Gt)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])) +TAbs_ All () (<[PTup_ () [PAscr_ () (PVar_ () x) (TyAtom (ABase N)),PAscr_ () (PVar_ () y) (TyAtom (ABase N)),PAscr_ () (PVar_ () z) (TyAtom (ABase N))]]> TApp_ () (TPrim_ () (PrimBOp Impl)) (TTup_ () [TApp_ () (TPrim_ () (PrimBOp And)) (TTup_ () [TParens_ () (TApp_ () (TPrim_ () (PrimBOp Eq)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@1])),TParens_ () (TApp_ () (TPrim_ () (PrimBOp Eq)) (TTup_ () [TVar_ () 0@1,TVar_ () 0@2]))]),TApp_ () (TPrim_ () (PrimBOp Eq)) (TTup_ () [TVar_ () 0@0,TVar_ () 0@2])])) diff --git a/test/parse-quantifiers/input b/test/parse-quantifiers/input new file mode 100644 --- /dev/null +++ b/test/parse-quantifiers/input @@ -0,0 +1,36 @@ +:parse λ x. x > 3 +:parse λ (x:N). x > 3 +:parse λ (x:N), y. x > y +:parse λ (x:N), (y:F). x > y +:parse λ x, (y:F). x > y +:parse \ x. x > 3 +:parse \ (x:N). x > 3 +:parse \ (x:N), y. x > y +:parse \ (x:N), (y:F). x > y +:parse \ x, (y:F). x > y +(\x, y. x + y) 3 5 +(\(x : N, y : N). x + y) 3 5 +(\(x : N, y : N). x + y) (3, 5) +(\(x:N), (y:N). x + y) 3 5 +(\(x:N). \(y:N). x + y) 3 5 +:parse exists x. x > 3 +:parse exists (x:N). x > 3 +:parse exists (x:N), y. x > y +:parse exists (x:N), (y:F). x > y +:parse exists x, (y:F). x > y +:parse ∃ x. x > 3 +:parse ∃ (x:N). x > 3 +:parse ∃ (x:N), y. x > y +:parse ∃ (x:N), (y:F). x > y +:parse ∃ x, (y:F). x > y +:parse forall x. x > 3 +:parse forall (x:N). x > 3 +:parse forall (x:N), y. x > y +:parse forall (x:N), (y:F). x > y +:parse forall x, (y:F). x > y +:parse ∀ x. x > 3 +:parse ∀ (x:N). x > 3 +:parse ∀ (x:N), y. x > y +:parse ∀ (x:N), (y:F). x > y +:parse ∀ x, (y:F). x > y +:parse ∀ (x : N, y : N, z: N). (x == y) and (y == z) ==> x == z diff --git a/test/parse-top-term/expected b/test/parse-top-term/expected new file mode 100644 --- /dev/null +++ b/test/parse-top-term/expected @@ -0,0 +1,2 @@ +Loading parse-top-term.disco... +Loaded. diff --git a/test/parse-top-term/input b/test/parse-top-term/input new file mode 100644 --- /dev/null +++ b/test/parse-top-term/input @@ -0,0 +1,1 @@ +:load test/parse-top-term/parse-top-term.disco diff --git a/test/parse-top-term/parse-top-term.disco b/test/parse-top-term/parse-top-term.disco new file mode 100644 --- /dev/null +++ b/test/parse-top-term/parse-top-term.disco @@ -0,0 +1,14 @@ +g : N -> N +g(x) = x + 1 + +-- each(g, f) + +3 + 17 + +4 + + 9 + + 7 + + 16 + +f : List(N) +f = [1,2,3] diff --git a/test/poly-bad/expected b/test/poly-bad/expected new file mode 100644 --- /dev/null +++ b/test/poly-bad/expected @@ -0,0 +1,12 @@ +Error: the shape of two types does not match. +https://disco-lang.readthedocs.io/en/latest/reference/shape-mismatch.html +Error: typechecking failed. +https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html +Error: the shape of two types does not match. +https://disco-lang.readthedocs.io/en/latest/reference/shape-mismatch.html +Error: the shape of two types does not match. +https://disco-lang.readthedocs.io/en/latest/reference/shape-mismatch.html +Error: typechecking failed. +https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html +Error: typechecking failed. +https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html diff --git a/test/poly-bad/input b/test/poly-bad/input new file mode 100644 --- /dev/null +++ b/test/poly-bad/input @@ -0,0 +1,6 @@ +let f : a -> a = \x. x+1 in f +let f : a -> a = \x. x+x in f +let f : a -> b -> a = \x, y. y in f +let f : a*b -> b = \p. {? a when p is (a,_) ?} in f +let f : List(a) -> List(a) = \x. list (bag x) in f +let f : a -> a -> Bool = \x, y. x < y in f diff --git a/test/poly-infer-sort/expected b/test/poly-infer-sort/expected new file mode 100644 --- /dev/null +++ b/test/poly-infer-sort/expected @@ -0,0 +1,11 @@ +let f : (a → a) → a → a = λg. λx. g(g(x)) in f(λx. x + x) : ℕ → ℕ +let f : (a → a) → a → a = λg. λx. g(g(x)) in f(λx. x - x) : ℤ → ℤ +let f : (a → a) → a → a = λg. λx. g(g(x)) in f(λx. x / x) : 𝔽 → 𝔽 +let f : (a → a) → a → a = λg. λx. g(g(x)) in f(λx. -x / x) : ℚ → ℚ +λx. x : a → a +λx, y. x : a1 → a → a1 +λx, y, z. x + y + z : ℕ → ℕ → ℕ → ℕ +λx, y : ℕ. x - y : ℤ → ℕ → ℤ +λw, x : ℕ, y, z : 𝔽. w - x + y + z : ℚ → ℕ → ℚ → 𝔽 → ℚ +Error: typechecking failed. +https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html diff --git a/test/poly-infer-sort/input b/test/poly-infer-sort/input new file mode 100644 --- /dev/null +++ b/test/poly-infer-sort/input @@ -0,0 +1,10 @@ +:type let f : (a -> a) -> a -> a = \g. (\x. g (g x)) in f (\x. x+x) +:type let f : (a -> a) -> a -> a = \g. (\x. g (g x)) in f (\x. x-x) +:type let f : (a -> a) -> a -> a = \g. (\x. g (g x)) in f (\x. x/x) +:type let f : (a -> a) -> a -> a = \g. (\x. g (g x)) in f (\x. -x/x) +:type \x.x +:type \x, y. x +:type \x, y, z. x + y + z +:type \x, (y:Nat). x - y +:type \w, (x:Nat), y, (z : Frac). w - x + y + z +\x, (y:Bool). x - y diff --git a/test/poly-instantiate/expected b/test/poly-instantiate/expected new file mode 100644 --- /dev/null +++ b/test/poly-instantiate/expected @@ -0,0 +1,12 @@ +Loading poly-instantiate.disco... +Loaded. +foldr : (a → r → r) → r → List(a) → r +foldr(λx, y. x) : a → List(a) → a +foldr(λx, y. y) : r → List(a) → r +foldr(λx, y. x + 1) : ℕ → List(ℕ) → ℕ +foldr(λx, y. y + 1) : ℕ → List(a) → ℕ +foldr(λx, y. y + 1)(1) : List(a) → ℕ +foldr(λx, y. y + 1)(-1) : List(a) → ℤ +foldr(λx, y. x)(false) : List(Bool) → Bool +foldr(λx, y. x + 1)(1 / 2) : List(ℕ) → 𝔽 +foldr(λx, y. x - 1)(1 / 2) : List(ℤ) → ℚ diff --git a/test/poly-instantiate/input b/test/poly-instantiate/input new file mode 100644 --- /dev/null +++ b/test/poly-instantiate/input @@ -0,0 +1,11 @@ +:load test/poly-instantiate/poly-instantiate.disco +:type foldr +:type foldr (\x, y. x) +:type foldr (\x, y. y) +:type foldr (\x, y. x+1) +:type foldr (\x, y. y+1) +:type foldr (\x, y. y+1) 1 +:type foldr (\x, y. y+1) (-1) +:type foldr (\x, y. x) false +:type foldr (\x, y. x+1) (1/2) +:type foldr (\x, y. x-1) (1/2) diff --git a/test/poly-instantiate/poly-instantiate.disco b/test/poly-instantiate/poly-instantiate.disco new file mode 100644 --- /dev/null +++ b/test/poly-instantiate/poly-instantiate.disco @@ -0,0 +1,5 @@ +using NoStdLib + +foldr : (a -> r -> r) -> r -> List(a) -> r +foldr _ z [] = z +foldr f z (a :: as) = f a (foldr f z as) diff --git a/test/poly-rectype/expected b/test/poly-rectype/expected new file mode 100644 --- /dev/null +++ b/test/poly-rectype/expected @@ -0,0 +1,2 @@ +Loading poly-rectype.disco... +Loaded. diff --git a/test/poly-rectype/input b/test/poly-rectype/input new file mode 100644 --- /dev/null +++ b/test/poly-rectype/input @@ -0,0 +1,1 @@ +:load test/poly-rectype/poly-rectype.disco diff --git a/test/poly-rectype/poly-rectype.disco b/test/poly-rectype/poly-rectype.disco new file mode 100644 --- /dev/null +++ b/test/poly-rectype/poly-rectype.disco @@ -0,0 +1,10 @@ +type X = Unit + X + +lst : List(X) +lst = [left(■), right(left(■))] + +f : List(a) -> N +f(_) = 3 + +n : N +n = f(lst) diff --git a/test/pretty-defn/expected b/test/pretty-defn/expected new file mode 100644 --- /dev/null +++ b/test/pretty-defn/expected @@ -0,0 +1,5 @@ +f : ℕ → ℕ +f(x) = x + 2 +type P = ℕ × ℕ +type Pair(a) = a × a +type HPair(a, b) = a × b diff --git a/test/pretty-defn/input b/test/pretty-defn/input new file mode 100644 --- /dev/null +++ b/test/pretty-defn/input @@ -0,0 +1,10 @@ +f : N -> N +f x = x+2 +type P = N * N +type Pair(a) = a * a +type HPair(a,b) = a * b + +:defn f +:defn P +:defn Pair +:defn HPair diff --git a/test/pretty-functions/expected b/test/pretty-functions/expected new file mode 100644 --- /dev/null +++ b/test/pretty-functions/expected @@ -0,0 +1,3 @@ + +<(a1 → a2) × List(a1) → List(a2)> + diff --git a/test/pretty-functions/input b/test/pretty-functions/input new file mode 100644 --- /dev/null +++ b/test/pretty-functions/input @@ -0,0 +1,3 @@ +\x.x +each +\xs. each (list,xs) diff --git a/test/pretty-issue258/expected b/test/pretty-issue258/expected new file mode 100644 --- /dev/null +++ b/test/pretty-issue258/expected @@ -0,0 +1,12 @@ +Loading catalan.disco... +Loading list.disco... +Loading oeis.disco... +Loaded. +treesOfSize : ℕ → List(BT) +treesOfSize(0) = [left(■)] +treesOfSize(k + 1) = [right(l, r) | x in [0 .. k], l in treesOfSize(x), r in treesOfSize(k .- x)] +Loading tree.disco... +Loaded. +treeFold : r11 × (ℕ × r11 × r11 → r11) × Tree → r11 +treeFold(x, f, left(■)) = x +treeFold(x, f, right(n, l, r)) = f(n, treeFold(x, f, l), treeFold(x, f, r)) diff --git a/test/pretty-issue258/input b/test/pretty-issue258/input new file mode 100644 --- /dev/null +++ b/test/pretty-issue258/input @@ -0,0 +1,4 @@ +:load example/catalan.disco +:defn treesOfSize +:load example/tree.disco +:defn treeFold diff --git a/test/pretty-lit/expected b/test/pretty-lit/expected new file mode 100644 --- /dev/null +++ b/test/pretty-lit/expected @@ -0,0 +1,3 @@ +1 +1.0 +3.0 / -7 : ℚ diff --git a/test/pretty-lit/input b/test/pretty-lit/input new file mode 100644 --- /dev/null +++ b/test/pretty-lit/input @@ -0,0 +1,3 @@ +:pretty 1 +:pretty 1.0 +:type 3.0/(-7) diff --git a/test/pretty-ops/expected b/test/pretty-ops/expected new file mode 100644 --- /dev/null +++ b/test/pretty-ops/expected @@ -0,0 +1,6 @@ +not true +5! +6 + 3 +6 + 5 * 2 +6 + 5 * 2 +(6 + 5) * 2 diff --git a/test/pretty-ops/input b/test/pretty-ops/input new file mode 100644 --- /dev/null +++ b/test/pretty-ops/input @@ -0,0 +1,6 @@ +:pretty ¬true +:pretty 5! +:pretty 6 + 3 +:pretty 6+5*2 +:pretty 6+(5*2) +:pretty (6+5)*2 diff --git a/test/pretty-pattern/expected b/test/pretty-pattern/expected new file mode 100644 --- /dev/null +++ b/test/pretty-pattern/expected @@ -0,0 +1,11 @@ +λ5 * (x + 3). x +λ(x + 3) * 5. x +λ5 * (x - 3). x +λ(x - 3) * 5. x +λ5 + x - 3. x +λ5 + x - 3. x +λ5 + (x - 3). x +λ1 + x + 2 + 3. x +λ1 + (x + (2 + 3)). x +λ(p + 1) / (q + 1). p + q +λ-p / q. p + q diff --git a/test/pretty-pattern/input b/test/pretty-pattern/input new file mode 100644 --- /dev/null +++ b/test/pretty-pattern/input @@ -0,0 +1,11 @@ +:pretty \(5 * (x + 3)).x +:pretty \((x + 3) * 5).x +:pretty \(5 * (x - 3)).x +:pretty \((x - 3) * 5).x +:pretty \(5 + x - 3).x +:pretty \((5 + x) - 3).x +:pretty \(5 + (x - 3)).x +:pretty \1 + x + 2 + 3.x +:pretty \1 + (x + (2 + 3)).x +:pretty \(p+1)/(q+1).p+q +:pretty \-p/q.p+q diff --git a/test/pretty-torture/expected b/test/pretty-torture/expected new file mode 100644 --- /dev/null +++ b/test/pretty-torture/expected @@ -0,0 +1,25 @@ +Loading demo.disco... +Loaded. +{} : Set(Map(Set(ℕ), Map(Set(ℕ), Graph(Set(ℕ))))) +right(■) : P(Set(ℕ)) + Unit +[1, 2 : ℕ, 3] +TAbs_ Lam () (<[PVar_ () x]> TAscr_ () (TVar_ () 0@0) (Forall (<[]> TyAtom (ABase N)))) +λx. x : ℕ +(λx. x) : ℕ +λx. x : ℕ +let f = λx. x + 1 : ℕ → ℕ in f : ℕ → ℕ +(let f = λx. x + 1 : ℕ → ℕ in f) : ℕ → ℕ +let f = λx. x + 1 : ℕ → ℕ in f(3 : ℕ) +let f = λx. x + 1 : ℕ → ℕ in f(3) : ℕ +(let f = λx. x + 1 : ℕ → ℕ in f)(3) : ℕ +(let f = λx. x + 1 : ℕ → ℕ in f)(3 : ℕ) +(let x = 3 in x) : ℕ +let x = 3 in x : ℕ +let x = 3 in x : ℕ +λx : ℕ. x +λ(x : ℕ) + 1. x +λx + 1 : ℕ. x +(λx. x)(2, 3) +right(2, 3) +Loading num.disco... +lg(24)! diff --git a/test/pretty-torture/input b/test/pretty-torture/input new file mode 100644 --- /dev/null +++ b/test/pretty-torture/input @@ -0,0 +1,24 @@ +:load example/demo.disco +:pretty {} : Set(Map(Set(ℕ), Map(Set((N)), ((Graph (Set(N))))))) +:pretty right(■) : P (Set(N)) + Unit +:pretty [1, 2 : N, 3] +:parse \x. x : N +:pretty \x. (x : ℕ) +:pretty (\x. x) : ℕ +:pretty \x. x : ℕ +:pretty let f = (λx. x + 1 : ℕ → ℕ) in (f : ℕ → ℕ) +:pretty (let f = λx. x + 1 : ℕ → ℕ in f) : ℕ → ℕ +:pretty let f = λx. x + 1 : ℕ → ℕ in f (3 : N) +:pretty let f = λx. x + 1 : ℕ → ℕ in f 3 : N +:pretty (let f = λx. x + 1 : ℕ → ℕ in f) 3 : N +:pretty (let f = λx. x + 1 : ℕ → ℕ in f) (3 : N) +:pretty (let x = 3 in x) : N +:pretty let x = 3 in (x : N) +:pretty let x = 3 in x : N +:pretty \(x:N).x +:pretty \((x:N)+1).x +:pretty \(x+1 : N).x +:pretty (\x.x)(2,3) +:pretty right(2,3) +import num +:pretty (lg 24)! diff --git a/test/pretty-type/expected b/test/pretty-type/expected new file mode 100644 --- /dev/null +++ b/test/pretty-type/expected @@ -0,0 +1,3 @@ +[1, 2, 3, 4] : List(ℕ) +[[1, 2], [3, 4]] : List(List(ℕ)) +[[(2, true), (3, false)], [(-5, true)]] : List(List(ℤ × Bool)) diff --git a/test/pretty-type/input b/test/pretty-type/input new file mode 100644 --- /dev/null +++ b/test/pretty-type/input @@ -0,0 +1,3 @@ +:type [1,2,3,4] +:type [[1,2],[3,4]] +:type [[(2,true), (3,false)], [(-5,true)]] diff --git a/test/pretty-whnf/expected b/test/pretty-whnf/expected new file mode 100644 --- /dev/null +++ b/test/pretty-whnf/expected @@ -0,0 +1,2 @@ +left(■) + diff --git a/test/pretty-whnf/input b/test/pretty-whnf/input new file mode 100644 --- /dev/null +++ b/test/pretty-whnf/input @@ -0,0 +1,2 @@ +left(■) : Unit + Nat +\(x:Void). 3 diff --git a/test/prim-crash/expected b/test/prim-crash/expected new file mode 100644 --- /dev/null +++ b/test/prim-crash/expected @@ -0,0 +1,11 @@ +Loading prim.disco... +User crash: nope +User crash: nope +User crash: nope +let x : ℕ = crash("nope") in 3 + x : ℕ +User crash: nope +crash : List(Char) → a +User crash: nope +User crash: nope +(λx : ℕ. 1)(crash("nope")) : ℕ +User crash: nope diff --git a/test/prim-crash/input b/test/prim-crash/input new file mode 100644 --- /dev/null +++ b/test/prim-crash/input @@ -0,0 +1,11 @@ +import prim +crash "nope" +let x : N = crash "nope" in 3 + 4 +let x : List(N) = crash "nope" in 3 + 4 +:type let x : N = crash "nope" in 3 + x +let x : N = crash "nope" in 3 + x +:type crash +(\(x: List(N)). 1) (crash "nope") +(\(x:N). 1) (crash "nope") +:type (\(x:N). 1) (crash "nope") +(\(x:N). 1) (1 + crash "nope") diff --git a/test/prim-frac/expected b/test/prim-frac/expected new file mode 100644 --- /dev/null +++ b/test/prim-frac/expected @@ -0,0 +1,10 @@ +$frac : ℚ → ℤ × ℕ +(0, 1) +(1, 1) +(5, 1) +(-6, 1) +(2, 3) +(2, 3) +(7, 3) +(-1, 8) +(1, 3) diff --git a/test/prim-frac/input b/test/prim-frac/input new file mode 100644 --- /dev/null +++ b/test/prim-frac/input @@ -0,0 +1,11 @@ +using primitives +:type $frac +$frac 0 +$frac 1 +$frac 5 +$frac (-6) +$frac (2/3) +$frac (4/6) +$frac (7/3) +$frac (-1/8) +$frac ((-1)/(-3)) diff --git a/test/prim-sum/expected b/test/prim-sum/expected new file mode 100644 --- /dev/null +++ b/test/prim-sum/expected @@ -0,0 +1,3 @@ +left : a1 → a1 + a +right : a1 → a + a1 +[left(1), left(2), left(3)] diff --git a/test/prim-sum/input b/test/prim-sum/input new file mode 100644 --- /dev/null +++ b/test/prim-sum/input @@ -0,0 +1,3 @@ +:type left +:type right +each(left, [1,2,3]) diff --git a/test/prop-basic/expected b/test/prop-basic/expected new file mode 100644 --- /dev/null +++ b/test/prop-basic/expected @@ -0,0 +1,12 @@ +Loading prop-basic.disco... +Loaded. + - Test passed: injective(λx. x * 2) + Checked 100 possibilities without finding a counterexample. + - Test passed: idempotent(λx. x max 10) + Checked 100 possibilities without finding a counterexample. + - Test passed: commutative(λ(a, b). a * b) + Checked 100 possibilities without finding a counterexample. + - Test passed: associative(λ(a, b). a + b) + Checked 100 possibilities without finding a counterexample. + - Test passed: identityFor(0, λ(a, b). a max b) + Checked 100 possibilities without finding a counterexample. diff --git a/test/prop-basic/input b/test/prop-basic/input new file mode 100644 --- /dev/null +++ b/test/prop-basic/input @@ -0,0 +1,9 @@ +:load test/prop-basic/prop-basic.disco +:test injective (\x. x * 2) +:test idempotent (\x. x max 10) +:test commutative (\(a, b). a * b) +:test associative (\(a, b). a + b) +:test identityFor(0, \(a, b). a max b) + +-- Randomized testing doesn't do a good job with exists inside forall! +-- :test surjective (\x. x) diff --git a/test/prop-basic/prop-basic.disco b/test/prop-basic/prop-basic.disco new file mode 100644 --- /dev/null +++ b/test/prop-basic/prop-basic.disco @@ -0,0 +1,23 @@ +-- XXX need a syntax for writing qualified types! +-- really want to say something like (Cmp a, Cmp b) => (a -> b) -> Prop. + +injective : (ℕ → ℕ) → Prop +injective(f) = ∀ x : N, y : N. (f(x) == f(y)) ==> (x == y) + +surjective : (ℕ → ℕ) → Prop +surjective(f) = ∀ y : N. ∃ x : N. f x == y + +-- bijective : (ℕ → ℕ) → Prop +-- bijective(f) = injective(f) and surjective(f) + +idempotent : (ℕ → ℕ) → Prop +idempotent(f) = ∀ x : N. f(f(x)) == f(x) + +commutative : (ℕ×ℕ → ℕ) → Prop +commutative(f) = ∀ x : N, y : N. f(x,y) == f(y,x) + +associative : (ℕ×ℕ → ℕ) → Prop +associative(f) = ∀ (x : N, y : N, z : N). f(x, f(y,z)) == f(f(x,y), z) + +identityFor : ℕ × (ℕ×ℕ → ℕ) → Prop +identityFor(e,f) = ∀ x : N. f(x,e) == x and f(e,x) == x diff --git a/test/prop-cmp/expected b/test/prop-cmp/expected new file mode 100644 --- /dev/null +++ b/test/prop-cmp/expected @@ -0,0 +1,6 @@ +Error: typechecking failed. +https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html +Error: typechecking failed. +https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html +Error: typechecking failed. +https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html diff --git a/test/prop-cmp/input b/test/prop-cmp/input new file mode 100644 --- /dev/null +++ b/test/prop-cmp/input @@ -0,0 +1,3 @@ +:type \(x:Prop). x == x +:type (forall (x:N). x >= 0) == (forall (y:N). y >= 0) +:type (exists (x:N). x > 0) < (forall (x:N). x > 0) diff --git a/test/prop-fail/bad-tests.disco b/test/prop-fail/bad-tests.disco new file mode 100644 --- /dev/null +++ b/test/prop-fail/bad-tests.disco @@ -0,0 +1,21 @@ +||| A function that doesn't do what it's supposed to. + +!!! badmap (\x. x/0) [3,4,5] =!= [6,7,8] +!!! badmap (\x. x) [1,2] =!= [1,2] +!!! badmap (\x. x + 1) [3,4] > [5,6] + +badmap : (Q -> Q) -> List(Q) -> List(Q) +badmap _ [] = [3] +badmap f (x::xs) = f x :: f x :: badmap f xs + + +||| A function we have some mistaken beliefs about. + +!!! forall a : Q, b : Q. divide a b * b =!= a + +!!! forall a : Q. divide a 2 < a + +!!! exists a : Q. divide a 2 =!= abs a + 1 + +divide : Q -> Q -> Q +divide a b = a / b diff --git a/test/prop-fail/expected b/test/prop-fail/expected new file mode 100644 --- /dev/null +++ b/test/prop-fail/expected @@ -0,0 +1,21 @@ +Loading bad-tests.disco... +Running tests... + badmap: + - Test failed: badmap(λx. x / 0)([3, 4, 5]) =!= [6, 7, 8] + DivByZero + - Test result mismatch for: badmap(λx. x)([1, 2]) =!= [1, 2] + - Left side: [1, 2] + - Right side: [1, 1, 2, 2, 3] + - Test is false: badmap(λx. x + 1)([3, 4]) > [5, 6] + divide: + - Test failed: ∀a, b. divide(a)(b) * b =!= a + DivByZero + Counterexample: + a = 0 + b = 0 + - Test is false: ∀a. divide(a)(2) < a + Counterexample: + a = 0 + - No example was found: ∃a. divide(a)(2) =!= abs(a) + 1 + Checked 50 possibilities. +Loaded. diff --git a/test/prop-fail/input b/test/prop-fail/input new file mode 100644 --- /dev/null +++ b/test/prop-fail/input @@ -0,0 +1,1 @@ +:load test/prop-fail/bad-tests.disco diff --git a/test/prop-fairness/expected b/test/prop-fairness/expected new file mode 100644 --- /dev/null +++ b/test/prop-fairness/expected @@ -0,0 +1,4 @@ +false +true +true +true diff --git a/test/prop-fairness/input b/test/prop-fairness/input new file mode 100644 --- /dev/null +++ b/test/prop-fairness/input @@ -0,0 +1,4 @@ +holds (forall (a : Q), (b : Q). abs a < 4 or abs b < 4) +holds (exists (a: N), (b : N), (c : N). (0 < a < b < c) and (a^2 + b^2 == c^2)) +holds (exists (a : N, b : N, c : N). (0 < a < b < c) and (a^2 + b^2 == c^2)) +holds (exists (x:N). exists (y:N). exists (z:N). (0 < x < y < z) and (x^2 + y^2 == z^2)) diff --git a/test/prop-higher-order/expected b/test/prop-higher-order/expected new file mode 100644 --- /dev/null +++ b/test/prop-higher-order/expected @@ -0,0 +1,19 @@ +Loading higher-order.disco... +Running tests... + pand: OK + por: OK +Loaded. + - Test passed: ∀x. por(x =!= 0, ∃n. n * x >= 1) + Checked 100 possibilities without finding a counterexample. + - Test passed: ∀f. any([∀x. f(x) =!= not x, ∀x. f(x) =!= x, ∀x. f(x) =!= false, ∀x. f(x) =!= true]) + No counterexamples exist. + - Test is false: all([true, true, true, false, true]) + Counterexample: + and_side = right(■) + and_side = right(■) + and_side = right(■) + and_side = left(■) + - Test passed: ∃k. hasFactors(2 ^ k + 1) + Found example: + k = 3 + n = 3 diff --git a/test/prop-higher-order/higher-order.disco b/test/prop-higher-order/higher-order.disco new file mode 100644 --- /dev/null +++ b/test/prop-higher-order/higher-order.disco @@ -0,0 +1,35 @@ +||| 'and' for propositions. + +!!! pand(true, true) + +pand : Prop * Prop -> Prop +pand(p, q) = forall and_side : Unit + Unit. {? + p when and_side is left _, + q otherwise + ?} + +all : List(Prop) -> Prop +all ps = reduce(pand, true, ps) + +||| 'or' for propositions. + +!!! por(false, true) +!!! por(true, false) +!!! por(true, true) + +por : Prop * Prop -> Prop +por(p, q) = exists or_side : Unit + Unit. {? + p when or_side is left _, + q otherwise + ?} + +any : List(Prop) -> Prop +any ps = reduce(por, false, ps) + +||| Assert that a proposition holds on some number in a range. + +existsBetween : N * N * (N -> Prop) -> Prop +existsBetween(a, b, p) = exists n:N. all [n >= a, n < b, p n] + +hasFactors : N -> Prop +hasFactors n = existsBetween(2, n, \r. r divides n) diff --git a/test/prop-higher-order/input b/test/prop-higher-order/input new file mode 100644 --- /dev/null +++ b/test/prop-higher-order/input @@ -0,0 +1,5 @@ +:load test/prop-higher-order/higher-order.disco +:test forall x:F. por(x =!= 0, exists n:N. n * x >= 1) +:test forall f:Bool->Bool. any [forall (x: Bool). f x =!= not x, forall (x: Bool). f x =!= x, forall (x: Bool). f x =!= false, forall (x: Bool). f x =!= true] +:test all [true, true, true, false, true] +:test exists k:N. hasFactors(2^k + 1) diff --git a/test/prop-holds/expected b/test/prop-holds/expected new file mode 100644 --- /dev/null +++ b/test/prop-holds/expected @@ -0,0 +1,7 @@ +true +true +true +false +false +true +true diff --git a/test/prop-holds/input b/test/prop-holds/input new file mode 100644 --- /dev/null +++ b/test/prop-holds/input @@ -0,0 +1,7 @@ +holds (forall (x : Bool). x or not x) +holds (exists (x : Bool). x) +holds (exists (f : Bool + Bool -> Bool + Bool). forall (a : Bool). (f (left a) == right a) and (f (right a) == left a)) +holds (exists (f : Bool -> Bool). exists (x : Bool). f(x) /= f (f (f x))) +holds (forall (a:N, b:N, c:N). a^2 + b^2 == c^2) +holds (exists (xs : List(N)). xs == [2, 2, 1]) +holds (exists (xs : Set(Z)). size xs == 3 and reduce(\(a, b). a + b, 0, xs) == 0) diff --git a/test/prop-impredicative/expected b/test/prop-impredicative/expected new file mode 100644 --- /dev/null +++ b/test/prop-impredicative/expected @@ -0,0 +1,18 @@ +Loading prop-impredicative.disco... +Loaded. +Error: the type + Prop +is not searchable (i.e. it cannot be used in a forall). +https://disco-lang.readthedocs.io/en/latest/reference/no-search.html +Error: the type + Prop +is not searchable (i.e. it cannot be used in a forall). +https://disco-lang.readthedocs.io/en/latest/reference/no-search.html +Error: the type + ℕ → Prop +is not searchable (i.e. it cannot be used in a forall). +https://disco-lang.readthedocs.io/en/latest/reference/no-search.html +Error: the type + List(Prop) → ℕ +is not searchable (i.e. it cannot be used in a forall). +https://disco-lang.readthedocs.io/en/latest/reference/no-search.html diff --git a/test/prop-impredicative/input b/test/prop-impredicative/input new file mode 100644 --- /dev/null +++ b/test/prop-impredicative/input @@ -0,0 +1,9 @@ +:load test/prop-impredicative/prop-impredicative.disco +:type exists (x:Prop). x and (3 > 2) +:type forall (x:Prop). (true ==> x) +:type forall (f: N -> Prop). f 3 +:type forall (f: List(Prop) -> N). 3 == 3 +-- Should reinstate these later once we can analyze whether a type synonym has a certain sort +-- First one should be OK, second should not. +-- :type forall (f: T(N) -> N). f (left ()) == 2 +-- :type forall (f: T(Prop) -> N). f (left ()) == 2 diff --git a/test/prop-impredicative/prop-impredicative.disco b/test/prop-impredicative/prop-impredicative.disco new file mode 100644 --- /dev/null +++ b/test/prop-impredicative/prop-impredicative.disco @@ -0,0 +1,1 @@ +type T(a) = Unit + a * T(a) * T(a) diff --git a/test/prop-tests/expected b/test/prop-tests/expected new file mode 100644 --- /dev/null +++ b/test/prop-tests/expected @@ -0,0 +1,6 @@ +Loading prop-tests.disco... +Running tests... + foo: OK + reverse: OK + x: OK +Loaded. diff --git a/test/prop-tests/input b/test/prop-tests/input new file mode 100644 --- /dev/null +++ b/test/prop-tests/input @@ -0,0 +1,1 @@ +:load test/prop-tests/prop-tests.disco diff --git a/test/prop-tests/prop-tests.disco b/test/prop-tests/prop-tests.disco new file mode 100644 --- /dev/null +++ b/test/prop-tests/prop-tests.disco @@ -0,0 +1,65 @@ +||| This is a foozle function. + +!!! foo 3 == 5 +!!! foo 9 == 28 + +||| We can have more documentation before more tests. + +!!! foo 12 == 25 +!!! ∀ n:Nat. foo (n+10) == 2n+21 + +foo : N -> N +foo 3 = 5 +foo 9 = 28 +foo n = 2n + 1 + +||| Reverse a list. +!!! reverse [3,6,7] == [7,6,3] +!!! ∀ a:N, b:N. reverse [a,b] == [b,a] +!!! ∀ xs:List(N). reverse (reverse xs) == xs + +reverse : List(a) -> List(a) +reverse = revHelper [] + +revHelper : List(a) -> List(a) -> List(a) +revHelper rev [] = rev +revHelper rev (x :: xs) = revHelper (x :: rev) xs + +toBin : N -> List(Bool) +toBin 0 = [] +toBin 1 = [] +toBin n = {? false if 2 divides n, true otherwise ?} :: toBin (n // 2) + +fromBin : List(Bool) -> N +fromBin [] = 1 +fromBin (false :: bs) = 2 (fromBin bs) +fromBin (true :: bs) = 2 (fromBin bs) + 1 + +plusIso : N + N -> N +plusIso (left n) = 2n +plusIso (right n) = 2n + 1 + +plusIsoR : N -> N + N +plusIsoR n = + {? left (n // 2) if 2 divides n + , right (n // 2) otherwise + ?} + +!!! ∀ v:Void. 2 == 3 -- this is true! +!!! ∀ u:Unit. u == u -- there is only one Unit value +!!! ∀ l:List(Void). l == l +!!! ∀ l:List(Unit). l == reverse l +!!! ∀ bs : List(Bool). toBin (fromBin bs) == bs +!!! ∀ q : F. q >= 0 +!!! ∀ p : N * N. {? x + y when p is (x,y) ?} >= 0 +!!! ∀ bs : Bool * Bool. {? b1 when bs is (b1,b2) if b2, false otherwise ?} + == {? b1 and b2 when bs is (b1,b2) ?} +!!! ∀ x : N + N. plusIsoR (plusIso x) == x + +!!! ∀ x : Void + N. {? true when x is right _, false otherwise ?} + +x : N +x = 0 + + -- x is just here to give us something to attach arbitrary test + -- properties to. diff --git a/test/prop-type/expected b/test/prop-type/expected new file mode 100644 --- /dev/null +++ b/test/prop-type/expected @@ -0,0 +1,12 @@ +∃x : ℤ. x > 3 : Prop +∃x : ℚ. x > 3 : Prop +∃x : ℕ, y : ℕ. x > y : Prop +∃x : ℕ. ∃y : ℕ. x > y : Prop +∀x : ℕ, y : ℕ, z : ℕ. x + y + z == x + (y + z) : Prop +∃x : ℕ. ∀y : ℕ. x <= y : Prop +Error: typechecking failed. +https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html +Error: typechecking failed. +https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html +Error: typechecking failed. +https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html diff --git a/test/prop-type/input b/test/prop-type/input new file mode 100644 --- /dev/null +++ b/test/prop-type/input @@ -0,0 +1,9 @@ +:type ∃ (x:Z). x > 3 +:type ∃ (x:Q). x > 3 +:type ∃ (x:N), (y : N). x > y +:type ∃ (x:N). ∃ (y:N). x > y +:type ∀ (x:N), (y:N), (z:N). (x + y) + z == x + (y + z) +:type ∃ (x:N). ∀ (y:N). x <= y +:type not (∀ x:Bool. true or x) +:type (∀ x:Void. false) and true +:type (∀ x:Void. false) or true diff --git a/test/repl-ann/expected b/test/repl-ann/expected new file mode 100644 --- /dev/null +++ b/test/repl-ann/expected @@ -0,0 +1,3 @@ +Loading num.disco... +factor : ℕ → Bag(ℕ) +(λx : ℤ, y : a. (~-~ : ℤ × ℤ → ℤ)((x : ℤ, 7 : ℤ) : ℤ × ℤ) : ℤ) : ℤ → a3 → ℤ diff --git a/test/repl-ann/input b/test/repl-ann/input new file mode 100644 --- /dev/null +++ b/test/repl-ann/input @@ -0,0 +1,3 @@ +import num +:ann factor +:ann \x, y. x - 7 diff --git a/test/repl-compile/expected b/test/repl-compile/expected new file mode 100644 --- /dev/null +++ b/test/repl-compile/expected @@ -0,0 +1,2 @@ +Loading num.disco... +num.isPrime diff --git a/test/repl-compile/input b/test/repl-compile/input new file mode 100644 --- /dev/null +++ b/test/repl-compile/input @@ -0,0 +1,2 @@ +import num +:compile isPrime diff --git a/test/repl-defn/expected b/test/repl-defn/expected new file mode 100644 --- /dev/null +++ b/test/repl-defn/expected @@ -0,0 +1,4 @@ +5 +x : ℕ +true +6 diff --git a/test/repl-defn/input b/test/repl-defn/input new file mode 100644 --- /dev/null +++ b/test/repl-defn/input @@ -0,0 +1,7 @@ +x : N +x = 5 +x +:type x +x == 5 +x = 6 +x diff --git a/test/repl-defns/expected b/test/repl-defns/expected new file mode 100644 --- /dev/null +++ b/test/repl-defns/expected @@ -0,0 +1,2 @@ +2 +3 diff --git a/test/repl-defns/input b/test/repl-defns/input new file mode 100644 --- /dev/null +++ b/test/repl-defns/input @@ -0,0 +1,6 @@ +x : N +x = 2 +y : N +y = x + 1 +x +y diff --git a/test/repl-desugar/expected b/test/repl-desugar/expected new file mode 100644 --- /dev/null +++ b/test/repl-desugar/expected @@ -0,0 +1,2 @@ +Loading num.disco... +isPrime diff --git a/test/repl-desugar/input b/test/repl-desugar/input new file mode 100644 --- /dev/null +++ b/test/repl-desugar/input @@ -0,0 +1,2 @@ +import num +:desugar isPrime diff --git a/test/repl-doc/doc.disco b/test/repl-doc/doc.disco new file mode 100644 --- /dev/null +++ b/test/repl-doc/doc.disco @@ -0,0 +1,8 @@ +||| P is a type of stuff. +type P = N * N + +||| f is a function. +||| Some more documentation. +!!! f(1) == 2 +f : N -> N +f x = x + 1 diff --git a/test/repl-doc/expected b/test/repl-doc/expected new file mode 100644 --- /dev/null +++ b/test/repl-doc/expected @@ -0,0 +1,36 @@ +Loading doc.disco... +Running tests... + f: OK +Loaded. +type P = ℕ × ℕ + +P is a type of stuff. + +f : ℕ → ℕ + +f is a function. +Some more documentation. + +No documentation found for x. +~+~ : ℕ × ℕ → ℕ +precedence level 7, left associative + +The sum of two numbers, types, or graphs. + +https://disco-lang.readthedocs.io/en/latest/reference/addition.html + +~! : ℕ → ℕ +precedence level 14 + +n! computes the factorial of n, that is, 1 * 2 * ... * n. + +https://disco-lang.readthedocs.io/en/latest/reference/factorial.html + +not~ : Bool → Bool +Alternative syntax: ¬~ +precedence level 15 + +Logical negation: ¬true = false and ¬false = true. Also written 'not'. + +https://disco-lang.readthedocs.io/en/latest/reference/not.html + diff --git a/test/repl-doc/input b/test/repl-doc/input new file mode 100644 --- /dev/null +++ b/test/repl-doc/input @@ -0,0 +1,7 @@ +:load test/repl-doc/doc.disco +:doc P +:doc f +:doc x +:doc + +:doc ! +:doc not diff --git a/test/repl-eval-tydef-import/a.disco b/test/repl-eval-tydef-import/a.disco new file mode 100644 --- /dev/null +++ b/test/repl-eval-tydef-import/a.disco @@ -0,0 +1,4 @@ +import b + +x : L +x = right(3, left(unit)) diff --git a/test/repl-eval-tydef-import/b.disco b/test/repl-eval-tydef-import/b.disco new file mode 100644 --- /dev/null +++ b/test/repl-eval-tydef-import/b.disco @@ -0,0 +1,1 @@ +type L = Unit + N * L diff --git a/test/repl-eval-tydef-import/expected b/test/repl-eval-tydef-import/expected new file mode 100644 --- /dev/null +++ b/test/repl-eval-tydef-import/expected @@ -0,0 +1,4 @@ +Loading a.disco... +Loading b.disco... +Loaded. +right(3, left(■)) diff --git a/test/repl-eval-tydef-import/input b/test/repl-eval-tydef-import/input new file mode 100644 --- /dev/null +++ b/test/repl-eval-tydef-import/input @@ -0,0 +1,2 @@ +:load test/repl-eval-tydef-import/a.disco +x diff --git a/test/repl-help/expected b/test/repl-help/expected new file mode 100644 --- /dev/null +++ b/test/repl-help/expected @@ -0,0 +1,12 @@ +Commands available from the prompt: + +:defn Show a variable's definition +:doc Show documentation + Evaluate a block of code +:help Show help +:load Load a file +:names Show all names in current scope +:reload Reloads the most recently loaded file +:test Test a property using random examples + +2 diff --git a/test/repl-help/input b/test/repl-help/input new file mode 100644 --- /dev/null +++ b/test/repl-help/input @@ -0,0 +1,2 @@ +:help +1+1 diff --git a/test/repl-import/expected b/test/repl-import/expected new file mode 100644 --- /dev/null +++ b/test/repl-import/expected @@ -0,0 +1,3 @@ +Loading num.disco... +false +[4, 5] diff --git a/test/repl-import/input b/test/repl-import/input new file mode 100644 --- /dev/null +++ b/test/repl-import/input @@ -0,0 +1,3 @@ +import num +isPrime 20 +filter(\x. x > 3, [1 .. 5]) diff --git a/test/repl-names/expected b/test/repl-names/expected new file mode 100644 --- /dev/null +++ b/test/repl-names/expected @@ -0,0 +1,8 @@ +Loading logic.disco... +Loading other.disco... +Loaded. +type Maybe(a) = Unit + a +exor : Bool → Bool → Bool +implication : Bool → Bool → Bool +lnot1 : Bool → Bool +lnot2 : Bool → Bool diff --git a/test/repl-names/input b/test/repl-names/input new file mode 100644 --- /dev/null +++ b/test/repl-names/input @@ -0,0 +1,2 @@ +:load test/repl-names/logic.disco +:names diff --git a/test/repl-names/logic.disco b/test/repl-names/logic.disco new file mode 100644 --- /dev/null +++ b/test/repl-names/logic.disco @@ -0,0 +1,27 @@ +-- copied from example/logic.disco as it might change, but this file shouldn't + +import other + +-- Basic logical operators + +lnot1 : Bool -> Bool +lnot1 true = false +lnot1 false = true + +lnot2 : Bool -> Bool +lnot2 x = + {? false if x, + true otherwise + ?} + +implication : Bool -> Bool -> Bool +implication x y = + {? false if x and not y, + true otherwise + ?} + +exor : Bool -> Bool -> Bool +exor x y = (x && not y) || (not x && y) + +-- A custom type used to validate :names output +type Maybe(a) = Unit + a diff --git a/test/repl-names/other.disco b/test/repl-names/other.disco new file mode 100644 --- /dev/null +++ b/test/repl-names/other.disco @@ -0,0 +1,9 @@ +-- Another module with some definitions. +-- For now these should *not* be shown by the :names +-- command, since showing stuff from imports would also mean +-- showing thins from implicitly loaded standard library modules... + +type Foo = Int + +x : Int +x = 0 diff --git a/test/repl-proptest/expected b/test/repl-proptest/expected new file mode 100644 --- /dev/null +++ b/test/repl-proptest/expected @@ -0,0 +1,12 @@ + - Test passed: not false + - Test passed: {1, 2} =!= {2, 1} + - Test passed: ∃a, b. (a and b) =!= (a or b) + Found example: + a = false + b = false + - Test result mismatch for: ∀a, b. (a and b) =!= (a or b) + - Left side: true + - Right side: false + Counterexample: + a = false + b = true diff --git a/test/repl-proptest/input b/test/repl-proptest/input new file mode 100644 --- /dev/null +++ b/test/repl-proptest/input @@ -0,0 +1,4 @@ +:test not false +:test {1, 2} =!= {2, 1} +:test exists a : Bool, b : Bool. (a and b) =!= (a or b) +:test forall a : Bool, b : Bool. (a and b) =!= (a or b) diff --git a/test/solver-issue112/diag-iso-bad.disco b/test/solver-issue112/diag-iso-bad.disco new file mode 100644 --- /dev/null +++ b/test/solver-issue112/diag-iso-bad.disco @@ -0,0 +1,9 @@ +diagIso' : ℕ → ℕ×ℕ +diagIso' n = + let d = (sqrt(1 + 8n) - 1)//2 : N + in let t = d*(d+1)//2 + in (n .- t, d .- (n .- t)) + +-- The above shouldn't typecheck, because of the use of normal +-- subtraction in the definition of d. However, it was erroneously +-- being accepted before fixing issue #112. diff --git a/test/solver-issue112/expected b/test/solver-issue112/expected new file mode 100644 --- /dev/null +++ b/test/solver-issue112/expected @@ -0,0 +1,5 @@ +Loading diag-iso-bad.disco... +Error: typechecking failed. +https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html +Error: typechecking failed. +https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html diff --git a/test/solver-issue112/input b/test/solver-issue112/input new file mode 100644 --- /dev/null +++ b/test/solver-issue112/input @@ -0,0 +1,2 @@ +:load test/solver-issue112/diag-iso-bad.disco +:type (\x.x^(-2)) : Z -> Z diff --git a/test/syntax-chain/expected b/test/syntax-chain/expected new file mode 100644 --- /dev/null +++ b/test/syntax-chain/expected @@ -0,0 +1,16 @@ +Loading inRange.disco... +Loaded. +false +false +true +true +true +false +true +false +false +false +false +false +false +false diff --git a/test/syntax-chain/inRange.disco b/test/syntax-chain/inRange.disco new file mode 100644 --- /dev/null +++ b/test/syntax-chain/inRange.disco @@ -0,0 +1,2 @@ +inRange : N -> N -> (N -> Bool) +inRange a b = λn. a <= n <= b diff --git a/test/syntax-chain/input b/test/syntax-chain/input new file mode 100644 --- /dev/null +++ b/test/syntax-chain/input @@ -0,0 +1,15 @@ +:load test/syntax-chain/inRange.disco +inRange 2 5 0 +inRange 2 5 8 +inRange 2 5 2 +inRange 2 5 3 +inRange 2 5 5 +inRange 4 4 3 +inRange 4 4 4 +inRange 4 4 5 +inRange 3 1 0 +inRange 3 1 1 +inRange 3 1 2 +inRange 3 1 3 +inRange 3 1 4 +2 < 1 < 1/0 -- Issue #67 diff --git a/test/syntax-clause/clauses.disco b/test/syntax-clause/clauses.disco new file mode 100644 --- /dev/null +++ b/test/syntax-clause/clauses.disco @@ -0,0 +1,17 @@ +-- An example of a function defined by pattern-matching clauses, with +-- multiple clauses and multiple arguments. + +zipWithN : (N -> N -> N) -> List(N) -> List(N) -> List(N) +zipWithN _ [] _ = [] +zipWithN _ _ [] = [] +zipWithN f (m :: ms) (n :: ns) = f m n :: zipWithN f ms ns + +-- Another example of a function defined by pattern-matching +-- clauses. This one has the feature that it has the same name (ys) in +-- two of the clauses, which was causing problems for the way we +-- handle name resolution (the implementation of 'lunbinds' in +-- Desugar.desugarDefn was wrong). + +appendC : List(ℕ) × List(ℕ) → List(ℕ) +appendC ([] , ys) = ys +appendC (x::xs', ys) = x :: appendC(xs',ys) diff --git a/test/syntax-clause/expected b/test/syntax-clause/expected new file mode 100644 --- /dev/null +++ b/test/syntax-clause/expected @@ -0,0 +1,4 @@ +Loading clauses.disco... +Loaded. +[5, 11, 19] +[1, 2, 3, 4, 5, 6] diff --git a/test/syntax-clause/input b/test/syntax-clause/input new file mode 100644 --- /dev/null +++ b/test/syntax-clause/input @@ -0,0 +1,3 @@ +:load test/syntax-clause/clauses.disco +zipWithN (\x, y. x*y + 1) [1,2,3] [4,5,6] +append ([1,2,3], [4,5,6]) diff --git a/test/syntax-comment/expected b/test/syntax-comment/expected new file mode 100644 --- /dev/null +++ b/test/syntax-comment/expected @@ -0,0 +1,5 @@ +Loading fib.disco... +Running tests... + fib: OK +Loaded. +610 diff --git a/test/syntax-comment/fib.disco b/test/syntax-comment/fib.disco new file mode 100644 --- /dev/null +++ b/test/syntax-comment/fib.disco @@ -0,0 +1,18 @@ +||| A naive implementation of the fibonacci function. +!!! fib 0 == 0 +!!! fib 1 == 1 +!!! fib 2 == 1 +!!! fib 5 == 5 +!!! fib 12 == 144 +fib : Nat -> Nat -- a top-level recursive function +fib n = + {? n when + n -- note how a single branch can be + is 0 -- broken across multiple lines + , n when n is 1 -- comment + , fib (n .- 1) + fib (n .- 2) otherwise + -- note we can't write + -- fib (n-1) + fib (n-2) otherwise + -- since that doesn't pass the type checker: it doesn't believe + -- that (n-1) and (n-2) are natural numbers. + ?} diff --git a/test/syntax-comment/input b/test/syntax-comment/input new file mode 100644 --- /dev/null +++ b/test/syntax-comment/input @@ -0,0 +1,2 @@ +:load test/syntax-comment/fib.disco +fib 15 diff --git a/test/syntax-containers/expected b/test/syntax-containers/expected new file mode 100644 --- /dev/null +++ b/test/syntax-containers/expected @@ -0,0 +1,3 @@ +[1, 2, 3, 3] +⟅1, 2, 3 # 2⟆ +{1, 2, 3} diff --git a/test/syntax-containers/input b/test/syntax-containers/input new file mode 100644 --- /dev/null +++ b/test/syntax-containers/input @@ -0,0 +1,3 @@ +[ 1, 2, 3, 3 ] +⟅ 1, 2, 3, 3 ⟆ +{ 1, 2, 3, 3 } diff --git a/test/syntax-decimals/expected b/test/syntax-decimals/expected new file mode 100644 --- /dev/null +++ b/test/syntax-decimals/expected @@ -0,0 +1,24 @@ +2 +2 +2 +2 +3.[45] +3.46[45] +3.111[3] +3.111[3] +3.[3] +3/2 +1.5 +22.7 +3.8[3] +true +0.[142857] +0.[052631578947368421] +0.[032258064516129] +0.[175257731958762886597938144329896907216494845360824742268041237113402061855670103092783505154639] +0.[001] +0.0010090817356205852674066599394550958627648839556004036326942482341069626639757820383451059535822401... +0.0000000000000000000000000000000000000000001145742637671319864267636924948858003603123762210263720996... +0.000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001 +0.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001 +0.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000... diff --git a/test/syntax-decimals/input b/test/syntax-decimals/input new file mode 100644 --- /dev/null +++ b/test/syntax-decimals/input @@ -0,0 +1,24 @@ +2.0 +2.[0] +2.[00000] +2.000[00] +3.45[45] +3.46[45] +3.111[333] +3.111[3] +3.[3] +1 + 1/2 +1 + 0.5 +3.5 + 19.2 +3.5 + 1/3 +1 == 0.[9] +1/7.0 +1/19.0 +1/31.0 +17/97.0 +1/999.0 +1/991.0 +(1/3.0)^90 +(1.0/10^99) +(1.0/10^100) +(1.0/10^101) diff --git a/test/syntax-doc/expected b/test/syntax-doc/expected new file mode 100644 --- /dev/null +++ b/test/syntax-doc/expected @@ -0,0 +1,10 @@ +Loading syntax-doc.disco... +Running tests... + x: OK +Loaded. +x : ℕ + +This is some documentation. + +More documentation after a blank line. + diff --git a/test/syntax-doc/input b/test/syntax-doc/input new file mode 100644 --- /dev/null +++ b/test/syntax-doc/input @@ -0,0 +1,2 @@ +:load test/syntax-doc/syntax-doc.disco +:doc x diff --git a/test/syntax-doc/syntax-doc.disco b/test/syntax-doc/syntax-doc.disco new file mode 100644 --- /dev/null +++ b/test/syntax-doc/syntax-doc.disco @@ -0,0 +1,10 @@ +||| This is some documentation. +||| +||| More documentation after a blank line. + +!!! x == 3 -- A property + +||| Yet more documentation. + +x : Nat +x = 3 diff --git a/test/syntax-exts/expected b/test/syntax-exts/expected new file mode 100644 --- /dev/null +++ b/test/syntax-exts/expected @@ -0,0 +1,2 @@ +Loading syntax-exts.disco... +Loaded. diff --git a/test/syntax-exts/input b/test/syntax-exts/input new file mode 100644 --- /dev/null +++ b/test/syntax-exts/input @@ -0,0 +1,1 @@ +:load test/syntax-exts/syntax-exts.disco diff --git a/test/syntax-exts/syntax-exts.disco b/test/syntax-exts/syntax-exts.disco new file mode 100644 --- /dev/null +++ b/test/syntax-exts/syntax-exts.disco @@ -0,0 +1,5 @@ +using rAnDOMnesS +using Primitives + +x : N +x = 5 diff --git a/test/syntax-juxt-app/expected b/test/syntax-juxt-app/expected new file mode 100644 --- /dev/null +++ b/test/syntax-juxt-app/expected @@ -0,0 +1,3 @@ +Loading juxt-app.disco... +Loaded. +17 diff --git a/test/syntax-juxt-app/input b/test/syntax-juxt-app/input new file mode 100644 --- /dev/null +++ b/test/syntax-juxt-app/input @@ -0,0 +1,2 @@ +:load test/syntax-juxt-app/juxt-app.disco +f (\x.x^2) (3,4) 2 diff --git a/test/syntax-juxt-app/juxt-app.disco b/test/syntax-juxt-app/juxt-app.disco new file mode 100644 --- /dev/null +++ b/test/syntax-juxt-app/juxt-app.disco @@ -0,0 +1,2 @@ +f : (N -> N) -> N * N -> N -> Z +f g (x,y) z = x + g y - z -- here g y is function application diff --git a/test/syntax-juxt-mul/expected b/test/syntax-juxt-mul/expected new file mode 100644 --- /dev/null +++ b/test/syntax-juxt-mul/expected @@ -0,0 +1,18 @@ +Loading juxt-mul.disco... +Loaded. +200 +200 +Error: the expression + x +must have both a function type and also the incompatible type + ℕ. +https://disco-lang.readthedocs.io/en/latest/reference/notcon.html +24 +14 +600 +75 +75 +225 +36 +26 +192 diff --git a/test/syntax-juxt-mul/input b/test/syntax-juxt-mul/input new file mode 100644 --- /dev/null +++ b/test/syntax-juxt-mul/input @@ -0,0 +1,13 @@ +:load test/syntax-juxt-mul/juxt-mul.disco +(x^2) (y^3) +x^2 y^3 +2^x y^3 +(x + 1)(y + 2) +(x + 1) y + 2 +5x! +3x^2 +3(x^2) +(3x)^2 +f(x)^2 +f(x^2) +(x+1)(y+2)(x+3) diff --git a/test/syntax-juxt-mul/juxt-mul.disco b/test/syntax-juxt-mul/juxt-mul.disco new file mode 100644 --- /dev/null +++ b/test/syntax-juxt-mul/juxt-mul.disco @@ -0,0 +1,8 @@ +x : Nat +x = 5 + +y : Nat +y = 2 + +f : Nat -> Nat +f x = x + 1 diff --git a/test/syntax-lambda-pat/expected b/test/syntax-lambda-pat/expected new file mode 100644 --- /dev/null +++ b/test/syntax-lambda-pat/expected @@ -0,0 +1,7 @@ +3 +3 +3 +10 +((1, 3), 2, 4) +42 +λf, (a, b). f(a)(b) : (a2 → a1 → a) → a2 × a1 → a diff --git a/test/syntax-lambda-pat/input b/test/syntax-lambda-pat/input new file mode 100644 --- /dev/null +++ b/test/syntax-lambda-pat/input @@ -0,0 +1,7 @@ +let f1 = \(x, y). x + y in f1 (1, 2) +let f2 = \(x:N, y:N). x + y in f2 (1, 2) +let f3 = \((x, y) : N*N). x + y in f3 (1, 2) +let h = \left (x, y). x in h (left (10, -10)) +let fwop = \(x1, y1), (x2, y2). ((x1, x2), (y1, y2)) in fwop (1, 2) (3, 4) +let uncurry = \f, (a, b). f a b in uncurry (\a, b. a + b) (40, 2) +:type \f, (a, b). f a b diff --git a/test/syntax-lambda/expected b/test/syntax-lambda/expected new file mode 100644 --- /dev/null +++ b/test/syntax-lambda/expected @@ -0,0 +1,14 @@ +4 +let f = λx : ℕ. x + 1 in f : ℕ → ℕ +4 +let f = (λx. x + 1) : ℕ → ℕ in f : ℕ → ℕ +let f = λx. x + 1 : ℕ in f : ℕ → ℕ +let f = λx. x + 1 : ℕ in f : ℕ → ℕ +(9, 8) +5 +λx : ℤ, y : ℕ. x * y : ℤ → ℕ → ℤ +[false, true, true] +let f = λg : ℤ → ℕ → Bool. [g(1)(1), g(1)(2), g(-1)(0)] in f(λx, y : ℤ. x + 1 == y) : List(Bool) +3 +TAbs_ Lam () (<[PWild_ ()]> TNat_ () 3) +3 diff --git a/test/syntax-lambda/input b/test/syntax-lambda/input new file mode 100644 --- /dev/null +++ b/test/syntax-lambda/input @@ -0,0 +1,14 @@ +let f = \(x:N). x + 1 in f 3 +:type let f = \(x:N). x + 1 in f +let f = (λx. x + 1) : N -> N in f 3 +:type let f = (λx. x + 1) : N -> N in f +:type let f = λx. (x + 1 : N) in f +:type let f = λx. x + 1 : N in f +let g = λx:N, b:Bool.{? x*x if b, x+2 otherwise ?} in (g 3 true, g 6 false) +let q = \ (f : (N -> N) -> N) . f (\(x:N) . x*x) in q (\g. g 1 + g 2) +:type (\ x:Z, y:N . x * y) +let f = \(g : Z -> N -> Bool).[g 1 1, g 1 2, g (-1) 0] in f (\x, y:Z. x + 1 == y) +:type let f = \(g : Z -> N -> Bool).[g 1 1, g 1 2, g (-1) 0] in f (\x, y:Z. x + 1 == y) +let f : N -> N -> N = \x.\y.x+y in f 1 2 +:parse \_.3 +(\_.3) "hello" diff --git a/test/syntax-let/expected b/test/syntax-let/expected new file mode 100644 --- /dev/null +++ b/test/syntax-let/expected @@ -0,0 +1,6 @@ +8 +12 +4399 +let x = 2, y = x + 3, z = 2 * y + x + 1 in z ^ 3 * x + y : ℕ +16 +let x : ℕ = 5 + 3 in x + x : ℕ diff --git a/test/syntax-let/input b/test/syntax-let/input new file mode 100644 --- /dev/null +++ b/test/syntax-let/input @@ -0,0 +1,6 @@ +let x = 3, y = 5 in x + y +let x = 3 in let y = x + 1 in x*y +let x = 2, y = x + 3, z = 2y + x + 1 in z^3*x + y +:type let x = 2, y = x + 3, z = 2y + x + 1 in z^3*x + y +let x : N = 5 + 3 in x + x +:type let x : N = 5 + 3 in x + x diff --git a/test/syntax-many-args/expected b/test/syntax-many-args/expected new file mode 100644 --- /dev/null +++ b/test/syntax-many-args/expected @@ -0,0 +1,4 @@ +Loading many-args.disco... +Loaded. +10260 +0 diff --git a/test/syntax-many-args/input b/test/syntax-many-args/input new file mode 100644 --- /dev/null +++ b/test/syntax-many-args/input @@ -0,0 +1,3 @@ +:load test/syntax-many-args/many-args.disco +f (0,1) (2,3) (4,5) (6,7) (8,9) (10,11) (12,13) (14,15) (16,17) (18,19) (20,21) (22,23) (24,25) (26,27) (28,29) (30,31) (32,33) (34,35) (36,37) (38,39) [1,2,3,4,5] [6,7,8] [9,10] +f (0,1) (2,3) (4,5) (6,7) (8,9) (10,11) (12,13) (14,15) (16,17) (18,19) (20,21) (22,23) (24,25) (26,27) (28,29) (30,31) (32,33) (34,35) (36,37) (38,39) [1,2,3,4,5] [6,7,8] [9,11] diff --git a/test/syntax-many-args/many-args.disco b/test/syntax-many-args/many-args.disco new file mode 100644 --- /dev/null +++ b/test/syntax-many-args/many-args.disco @@ -0,0 +1,4 @@ +-- A stress test: a function with a lot of pattern arguments +f : N * N -> N * N -> N * N -> N * N -> N * N -> N * N -> N * N -> N * N -> N * N -> N * N -> N * N -> N * N -> N * N -> N * N -> N * N -> N * N -> N * N -> N * N -> N * N -> N * N -> List(N) -> List(N) -> List(N) -> N +f (a0,b1) (a2,b3) (a4,b5) (a6,b7) (a8,b9) (a10,b11) (a12,b13) (a14,b15) (a16,b17) (a18,b19) (a20,b21) (a22,b23) (a24,b25) (a26,b27) (a28,b29) (a30,b31) (a32,b33) (a34,b35) (a36,b37) (a38,b39) [1,2,3,4,5] [6,7,8] [9,10] = a0 * b1 + a2 * b3 + a4 * b5 + a6 * b7 + a8 * b9 + a10 * b11 + a12 * b13 + a14 * b15 + a16 * b17 + a18 * b19 + a20 * b21 + a22 * b23 + a24 * b25 + a26 * b27 + a28 * b29 + a30 * b31 + a32 * b33 + a34 * b35 + a36 * b37 + a38 * b39 +f _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = 0 diff --git a/test/syntax-many-clauses/expected b/test/syntax-many-clauses/expected new file mode 100644 --- /dev/null +++ b/test/syntax-many-clauses/expected @@ -0,0 +1,9 @@ +Loading many-clauses.disco... +Loaded. +0 +1 +144 +15 +5000 +100 +267 diff --git a/test/syntax-many-clauses/input b/test/syntax-many-clauses/input new file mode 100644 --- /dev/null +++ b/test/syntax-many-clauses/input @@ -0,0 +1,8 @@ +:load test/syntax-many-clauses/many-clauses.disco +f 0 +f 1 +f 14 +f 15 +f 87 +f 100 +f 153 diff --git a/test/syntax-many-clauses/many-clauses.disco b/test/syntax-many-clauses/many-clauses.disco new file mode 100644 --- /dev/null +++ b/test/syntax-many-clauses/many-clauses.disco @@ -0,0 +1,104 @@ +-- Another stress test: a function with many clauses +f : N -> N +f 0 = 0 +f 1 = 1 +f 2 = 2 +f 3 = 3 +f 4 = 4 +f 5 = 5 +f 6 = 6 +f 7 = 7 +f 8 = 8 +f 9 = 9 +f 10 = 10 +f 11 = 11 +f 12 = 12 +f 13 = 13 +f 14 = 144 +f 15 = 15 +f 16 = 16 +f 17 = 17 +f 18 = 18 +f 19 = 19 +f 20 = 20 +f 21 = 21 +f 22 = 22 +f 23 = 23 +f 24 = 24 +f 25 = 25 +f 26 = 26 +f 27 = 27 +f 28 = 28 +f 29 = 29 +f 30 = 30 +f 31 = 31 +f 32 = 32 +f 33 = 33 +f 34 = 34 +f 35 = 35 +f 36 = 36 +f 37 = 37 +f 38 = 38 +f 39 = 39 +f 40 = 40 +f 41 = 41 +f 42 = 42 +f 43 = 43 +f 44 = 44 +f 45 = 45 +f 46 = 46 +f 47 = 47 +f 48 = 48 +f 49 = 49 +f 50 = 50 +f 51 = 51 +f 52 = 52 +f 53 = 53 +f 54 = 54 +f 55 = 55 +f 56 = 56 +f 57 = 57 +f 58 = 58 +f 59 = 59 +f 60 = 60 +f 61 = 61 +f 62 = 62 +f 63 = 63 +f 64 = 64 +f 65 = 65 +f 66 = 66 +f 67 = 67 +f 68 = 68 +f 69 = 69 +f 70 = 70 +f 71 = 71 +f 72 = 72 +f 73 = 73 +f 74 = 74 +f 75 = 75 +f 76 = 76 +f 77 = 77 +f 78 = 78 +f 79 = 79 +f 80 = 80 +f 81 = 81 +f 82 = 82 +f 83 = 83 +f 84 = 84 +f 85 = 85 +f 86 = 86 +f 87 = 5000 +f 88 = 88 +f 89 = 89 +f 90 = 90 +f 91 = 91 +f 92 = 92 +f 93 = 93 +f 94 = 94 +f 95 = 95 +f 96 = 96 +f 97 = 97 +f 98 = 98 +f 99 = 99 +f 100 = 100 +f _ = 267 diff --git a/test/syntax-patclause/expected b/test/syntax-patclause/expected new file mode 100644 --- /dev/null +++ b/test/syntax-patclause/expected @@ -0,0 +1,4 @@ +Loading fact.disco... +Loaded. +3628800 +3628800 diff --git a/test/syntax-patclause/fact.disco b/test/syntax-patclause/fact.disco new file mode 100644 --- /dev/null +++ b/test/syntax-patclause/fact.disco @@ -0,0 +1,13 @@ +-- Here are two equivalent definitions of factorial using the two +-- different styles: one with a case expression, and one with two +-- pattern-matching clauses. + +fact : N -> N +fact n = + {? 1 when n is 0, + n * fact m when n is m+1 + ?} + +fact2 : N -> N +fact2 0 = 1 +fact2 (m+1) = (m + 1) * fact2 m diff --git a/test/syntax-patclause/input b/test/syntax-patclause/input new file mode 100644 --- /dev/null +++ b/test/syntax-patclause/input @@ -0,0 +1,3 @@ +:load test/syntax-patclause/fact.disco +fact 10 +fact2 10 diff --git a/test/syntax-prims/expected b/test/syntax-prims/expected new file mode 100644 --- /dev/null +++ b/test/syntax-prims/expected @@ -0,0 +1,4 @@ +Loading syntax-prims.disco... +Loaded. +x : ℕ → ℕ +User crash: bad dog! diff --git a/test/syntax-prims/input b/test/syntax-prims/input new file mode 100644 --- /dev/null +++ b/test/syntax-prims/input @@ -0,0 +1,3 @@ +:load test/syntax-prims/syntax-prims.disco +:type x +x 4 diff --git a/test/syntax-prims/syntax-prims.disco b/test/syntax-prims/syntax-prims.disco new file mode 100644 --- /dev/null +++ b/test/syntax-prims/syntax-prims.disco @@ -0,0 +1,4 @@ +using primitives + +x : N -> N +x _ = $crash "bad dog!" diff --git a/test/syntax-tuples/expected b/test/syntax-tuples/expected new file mode 100644 --- /dev/null +++ b/test/syntax-tuples/expected @@ -0,0 +1,10 @@ +(1, 2) +1 +(1, 2, 3, 4, 5) +(1, 2, 3, 4, 5) +((1, 2), 3, 4, 5) +(1, 2, -3, 4.0, -5.0) : ℕ × ℕ × ℤ × 𝔽 × ℚ +((1 / 2, 1), 2) : (𝔽 × ℕ) × ℕ +3 +29 +-50 diff --git a/test/syntax-tuples/input b/test/syntax-tuples/input new file mode 100644 --- /dev/null +++ b/test/syntax-tuples/input @@ -0,0 +1,10 @@ +(1,2) +(1) +(1,2,3,4,5) +(1,2,(3,4,5)) +((1,2),3,4,5) +:type (1,2,-3,4.0,-5.0) +:type ((1/2,1),2) +{? x when (3,4,5) is (x,y,z) ?} +{? x+y when (7,22,45) is (x,y,z) ?} +{? a*f when (10,15,-23,7,3,-5) is (a,b,c,d,e,f) ?} diff --git a/test/syntax-types/expected b/test/syntax-types/expected new file mode 100644 --- /dev/null +++ b/test/syntax-types/expected @@ -0,0 +1,11 @@ +[1, 1, 1, 1] +[-1, -1, -1, -1] +[1/2, 1/2] +[-1/2, -1/2, -1/2] +[true, true] +[■, ■] +[] +{} +{} +⟅⟆ +⟅⟆ diff --git a/test/syntax-types/input b/test/syntax-types/input new file mode 100644 --- /dev/null +++ b/test/syntax-types/input @@ -0,0 +1,12 @@ +[1 : N, 1 : Nat, 1 : Natural, 1 : ℕ] +[-1 : Z, -1 : Int, -1 : Integer, -1 : ℤ] +[1/2 : F, 1/2 : 𝔽] +[-1/2 : Q, -1/2 : Rational, -1/2 : ℚ] +[true : Bool, true : Boolean] +[unit : Unit, ■ : Unit] +[] : List(Void) +-- [3 : Fin 5, 3 : Z 5, 3 : Z5, 3 : ℤ 5, 3 : ℤ5] +{} : Set(Natural) +{} : Set(Set(Natural)) +⟅ ⟆ : Bag(Rational) +⟅⟆ : Bag(Set(Integer)) diff --git a/test/types-192/expected b/test/types-192/expected new file mode 100644 --- /dev/null +++ b/test/types-192/expected @@ -0,0 +1,1 @@ +λx, y, z. x + y / z : 𝔽 → 𝔽 → 𝔽 → 𝔽 diff --git a/test/types-192/input b/test/types-192/input new file mode 100644 --- /dev/null +++ b/test/types-192/input @@ -0,0 +1,1 @@ +:type \x,y,z. x + y / z diff --git a/test/types-bind/expected b/test/types-bind/expected new file mode 100644 --- /dev/null +++ b/test/types-bind/expected @@ -0,0 +1,1 @@ +8 diff --git a/test/types-bind/input b/test/types-bind/input new file mode 100644 --- /dev/null +++ b/test/types-bind/input @@ -0,0 +1,1 @@ +((let y = 3 in (\x. x + y)) : N -> N) 5 diff --git a/test/types-char-string/expected b/test/types-char-string/expected new file mode 100644 --- /dev/null +++ b/test/types-char-string/expected @@ -0,0 +1,34 @@ +'a' +'a' : Char +'c' +'\n' +'\'' +'"' +'#' +'\\' +'"' +true +1 +2 +3 +(λx. {? 1 when x is 'a' + ?})("Disco") +1:3: + | +1 | ' a' + | ^ +unexpected 'a' +expecting ''' + +' ' +"Disco" +"Disco" : List(Char) +"Di sco" +"'" +"\n" +"'" +"a\na\a\a\"" +"\\" +true +2 +1 diff --git a/test/types-char-string/input b/test/types-char-string/input new file mode 100644 --- /dev/null +++ b/test/types-char-string/input @@ -0,0 +1,30 @@ +-- Chars +'a' +:type 'a' +'c' +'\n' +''' +'"' +'#' +'\\' +'\"' +'a' < 'b' +(\x. {? 1 when x is 'a', 2 when x is 'z', 3 otherwise ?}) 'a' +(\x. {? 1 when x is 'a', 2 when x is 'z', 3 otherwise ?}) 'z' +(\x. {? 1 when x is 'a', 2 when x is 'z', 3 otherwise ?}) 'k' +:pretty (\x. {? 1 when x is 'a' ?}) "Disco" +' a' +' ' + +-- Strings +"Disco" +:type "Disco" +"Di sco" +"\'" +"\n" +"'" +"a\na\a\a\"" +"\\" +"bed" < "boat" +(\x. {? 1 when x is "Disco", 2 otherwise ?}) "blahblah" +(\x. {? 1 when x is "Disco", 2 otherwise ?}) "Disco" diff --git a/test/types-compare/expected b/test/types-compare/expected new file mode 100644 --- /dev/null +++ b/test/types-compare/expected @@ -0,0 +1,1 @@ +true diff --git a/test/types-compare/input b/test/types-compare/input new file mode 100644 --- /dev/null +++ b/test/types-compare/input @@ -0,0 +1,1 @@ +([1,2,3] : List(Z)) == ([1,2,3] : List(N)) diff --git a/test/types-container/expected b/test/types-container/expected new file mode 100644 --- /dev/null +++ b/test/types-container/expected @@ -0,0 +1,12 @@ +[] +{} +⟅⟆ +[] : List(a) +{} : Set(a) +⟅⟆ : Bag(a) +[3] : List(ℕ) +{3} : Set(ℕ) +⟅3⟆ : Bag(ℕ) +list : List(a) → List(a) +bag : List(ℕ) → Bag(ℕ) +set : List(ℕ) → Set(ℕ) diff --git a/test/types-container/input b/test/types-container/input new file mode 100644 --- /dev/null +++ b/test/types-container/input @@ -0,0 +1,13 @@ +[] +{} +⟅⟆ +:type [] +:type {} +:type ⟅⟆ +:type [3] +:type {3} +:type ⟅3⟆ +:type list +:type bag +:type set +-- :type {1,2,3} union {4,5} : Set Z3 diff --git a/test/types-kinds/expected b/test/types-kinds/expected new file mode 100644 --- /dev/null +++ b/test/types-kinds/expected @@ -0,0 +1,10 @@ +Error: too many arguments for the type 'List'. +https://disco-lang.readthedocs.io/en/latest/reference/num-args-type.html +Error: too many arguments for the type 'List'. +https://disco-lang.readthedocs.io/en/latest/reference/num-args-type.html +Error: the shape of two types does not match. +https://disco-lang.readthedocs.io/en/latest/reference/shape-mismatch.html +Error: too many arguments for the type 'List'. +https://disco-lang.readthedocs.io/en/latest/reference/num-args-type.html +Error: too many arguments for the type 'List'. +https://disco-lang.readthedocs.io/en/latest/reference/num-args-type.html diff --git a/test/types-kinds/input b/test/types-kinds/input new file mode 100644 --- /dev/null +++ b/test/types-kinds/input @@ -0,0 +1,5 @@ +3 : List(N,N) +3 : List(N,Z) +3 : List(List(N)) +3 : (List(List,N)) +:type \x:List(N,N).x == x diff --git a/test/types-naked-ops/expected b/test/types-naked-ops/expected new file mode 100644 --- /dev/null +++ b/test/types-naked-ops/expected @@ -0,0 +1,5 @@ +~max~ : ℕ × ℕ → ℕ +~! : ℕ → ℕ +~mod~ : ℤ × ℤ → ℤ +~+~ : ℕ × ℕ → ℕ +not~ : Bool → Bool diff --git a/test/types-naked-ops/input b/test/types-naked-ops/input new file mode 100644 --- /dev/null +++ b/test/types-naked-ops/input @@ -0,0 +1,5 @@ +:type max +:type ! +:type % +:type + +:type ¬ diff --git a/test/types-numpats/expected b/test/types-numpats/expected new file mode 100644 --- /dev/null +++ b/test/types-numpats/expected @@ -0,0 +1,2 @@ +Loading types-numpats.disco... +Loaded. diff --git a/test/types-numpats/input b/test/types-numpats/input new file mode 100644 --- /dev/null +++ b/test/types-numpats/input @@ -0,0 +1,1 @@ +:load test/types-numpats/types-numpats.disco diff --git a/test/types-numpats/types-numpats.disco b/test/types-numpats/types-numpats.disco new file mode 100644 --- /dev/null +++ b/test/types-numpats/types-numpats.disco @@ -0,0 +1,9 @@ +type X = N -> N + +f : X +f(0) = 3 +f(n) = n+1 + +g : N -> X +g(0)(2) = 1 +g(_)(_) = 2 diff --git a/test/types-ops/expected b/test/types-ops/expected new file mode 100644 --- /dev/null +++ b/test/types-ops/expected @@ -0,0 +1,38 @@ +Loading list.disco... +right(0) +right(1) +right(2) +right(16) +right(4) +right(1) +right(1) +left(■) +right(0) +right(0) +right(1) +right(0) +right(1) +[] +[, , , ] +[left(false, false), left(false, true), left(true, false), left(true, true), right(false), right(true)] +[left(■), right(false), right(true)] +[] +[[]] +[[]] +[false, true] +[[], [■], [■, ■], [■, ■, ■], [■, ■, ■, ■]] +[0, 1, 2, 3, 4, 5, 6, 7, 8, 9] +[(0, 0), (0, 1), (1, 0), (0, 2), (1, 1), (2, 0)] +[] +[] +[] +[] +[] +right(1) +left(■) +right(1) +right(2) +right(4) +right(1114112) +right(1) +right(0) diff --git a/test/types-ops/input b/test/types-ops/input new file mode 100644 --- /dev/null +++ b/test/types-ops/input @@ -0,0 +1,50 @@ +import list +count Void +count Unit +count Bool +count (Bool + Bool -> Bool) +count (Bool * Bool) +count (List(Void)) +count (List (Void * Bool + Void)) +count (List(Unit)) +count (Void * Nat) +count (Nat * Void) +count (Void -> Nat) +count (Nat -> Void) +count (Void -> Void) +enumerate Void +enumerate (Bool -> Bool) +enumerate (Bool * Bool + Bool) +enumerate (Unit + Bool) +enumerate (Void * Unit) +enumerate (List(Void)) +enumerate (List (Void * Bool + Void)) +enumerate(Bool) +take(5, enumerate(List(Unit))) +take(10, enumerate(N)) +take(6, enumerate(N * N)) +enumerate (Void * Nat) +enumerate (Nat * Void) +enumerate (Void -> Nat) +enumerate (Nat -> Void) +enumerate (Void -> Void) +-- count Z5 +-- count (Z5 * Z4) +-- count (Z3 + Z6) +-- count (Z3 -> Z2) +-- count (Z3 + Z4 -> Z2) +-- enumerate Z10 +-- enumerate (Z2 * Z3) +-- enumerate (Z2 -> Z2) +-- enumerate (Z3 + Z4) +count (Bag(Void)) +count (Bag(Unit)) +count (Set(Void)) +count (Set(Unit)) +count (Set(Bool)) +count Char +count ((N -> Void) -> N) +count (N -> (N -> Void)) +-- each(\f. f unit, enumerate (Unit -> Unit)) == [unit] +-- each(\f. f unit, enumerate (Unit -> Bool)) == [false, true] +-- each(\f. f true, enumerate (Bool -> Bool)) == [false] diff --git a/test/types-rational/expected b/test/types-rational/expected new file mode 100644 --- /dev/null +++ b/test/types-rational/expected @@ -0,0 +1,19 @@ +3 / 5 : 𝔽 +1 / 2 + 2 / 3 : 𝔽 +1 / 2 * (2 / 3) : 𝔽 +3 ^ (-2) : 𝔽 +(1 / 2) ^ (-2) : 𝔽 +(1 / 2) ^ 3 : 𝔽 +[1, 2 / 3] : List(𝔽) +1 :: 2 / 3 :: [] : List(𝔽) +-3 / 5 : ℚ +3 / -5 : ℚ +-(3 / 5) : ℚ +1 / 2 - 2 / 3 : ℚ +1 / 2 * -3 : ℚ +-1 / 2 * 3 : ℚ +(-3) ^ (-2) : ℚ +(-2 / 3) ^ (-2) : ℚ +(-1 / 2) ^ 3 : ℚ +[1, -1, 2 / 3] : List(ℚ) +1 :: -1 :: 2 / 3 :: [] : List(ℚ) diff --git a/test/types-rational/input b/test/types-rational/input new file mode 100644 --- /dev/null +++ b/test/types-rational/input @@ -0,0 +1,22 @@ +-- Some things of type ℚ⁺ +:type 3 / 5 +:type 1/2 + 2/3 +:type (1/2) * (2/3) +:type 3^(-2) +:type (1/2)^(-2) +:type (1/2)^3 +:type [1,2/3] +:type (1 :: 2/3 :: []) + +-- Some things of type ℚ +:type (-3) / 5 +:type 3 / (-5) +:type -(3/5) +:type 1/2 - 2/3 +:type 1/2 * (-3) +:type (-1/2) * 3 +:type (-3)^(-2) +:type (-2/3)^(-2) +:type (-1/2)^3 +:type [1,-1,2/3] +:type (1 :: -1 :: 2/3 :: []) diff --git a/test/types-rec/expected b/test/types-rec/expected new file mode 100644 --- /dev/null +++ b/test/types-rec/expected @@ -0,0 +1,5 @@ +Loading types-rec.disco... +Loading product.disco... +Loaded. +Error: typechecking failed. +https://disco-lang.readthedocs.io/en/latest/reference/typecheck-fail.html diff --git a/test/types-rec/input b/test/types-rec/input new file mode 100644 --- /dev/null +++ b/test/types-rec/input @@ -0,0 +1,2 @@ +:load test/types-rec/types-rec.disco +snd(e : T2)(e') diff --git a/test/types-rec/types-rec.disco b/test/types-rec/types-rec.disco new file mode 100644 --- /dev/null +++ b/test/types-rec/types-rec.disco @@ -0,0 +1,24 @@ +import product + +type DoubleStream = N * N * DoubleStream + +cons : N * DoubleStream -> DoubleStream +cons = \x.x + +-- Example from section 24.3 of PFPL + +type T1 = (T1 -> N) * (T1 -> Z) +type T2 = (T2 -> Z) * (T2 -> Z) + +e : T1 +e = (\x:T1. 4, \x:T1. sqrt(fst(x)(x))) + +e' : T2 +e' = (\x:T2. -4, \x:T2. 0) + +-- If the system can (erroneously) derive T1 <: T2, then e : T2, and +-- snd(e : T2)(e') would be well-typed but would reduce to sqrt(-4). +-- The reason one might erroneously have T1 <: T2 is with a subtly +-- wrong subtyping rule, where we use the same type variable to stand +-- for recursive occurrences of both sides. Fortunately Disco does +-- not fall into this trap. diff --git a/test/types-squash/expected b/test/types-squash/expected new file mode 100644 --- /dev/null +++ b/test/types-squash/expected @@ -0,0 +1,8 @@ +floor(0) : ℕ +floor(1 / 2) : ℕ +floor(-1) : ℤ +floor(-1 / 2) : ℤ +abs(0) : ℕ +abs(1 / 2) : 𝔽 +abs(-1) : ℕ +abs(-1 / 2) : 𝔽 diff --git a/test/types-squash/input b/test/types-squash/input new file mode 100644 --- /dev/null +++ b/test/types-squash/input @@ -0,0 +1,10 @@ +:type floor 0 +:type floor (1/2) +:type floor (-1) +:type floor (-1/2) +-- :type floor (2 : Z7) +:type abs 0 +:type abs (1/2) +:type abs (-1) +:type abs (-1/2) +-- :type abs (2 : Z7) diff --git a/test/types-standalone-ops/expected b/test/types-standalone-ops/expected new file mode 100644 --- /dev/null +++ b/test/types-standalone-ops/expected @@ -0,0 +1,4 @@ +~and~ : Bool × Bool → Bool +false and true : Bool +λx. x and true : Bool → Bool +let f : (Bool × Bool → Bool) → Bool = λg. g(true, false) in f(~and~) : Bool diff --git a/test/types-standalone-ops/input b/test/types-standalone-ops/input new file mode 100644 --- /dev/null +++ b/test/types-standalone-ops/input @@ -0,0 +1,4 @@ +:type ~and~ +:type ~and~ (False, True) +:type \x. ~and~ (x, True) +:type let f : (Bool * Bool -> Bool) -> Bool = \g. g (True, False) in f ~and~ diff --git a/test/types-toomanypats/expected b/test/types-toomanypats/expected new file mode 100644 --- /dev/null +++ b/test/types-toomanypats/expected @@ -0,0 +1,3 @@ +Loading toomanypats.disco... +Error: number of arguments does not match. +https://disco-lang.readthedocs.io/en/latest/reference/num-args.html diff --git a/test/types-toomanypats/input b/test/types-toomanypats/input new file mode 100644 --- /dev/null +++ b/test/types-toomanypats/input @@ -0,0 +1,1 @@ +:load test/types-toomanypats/toomanypats.disco diff --git a/test/types-toomanypats/toomanypats.disco b/test/types-toomanypats/toomanypats.disco new file mode 100644 --- /dev/null +++ b/test/types-toomanypats/toomanypats.disco @@ -0,0 +1,2 @@ +f : N -> Bool +f x y = true diff --git a/test/types-tydef-bad/expected b/test/types-tydef-bad/expected new file mode 100644 --- /dev/null +++ b/test/types-tydef-bad/expected @@ -0,0 +1,3 @@ +Loading types-tydef-bad.disco... +Error: there is no built-in or user-defined type named 'Flerb'. +https://disco-lang.readthedocs.io/en/latest/reference/no-tydef.html diff --git a/test/types-tydef-bad/input b/test/types-tydef-bad/input new file mode 100644 --- /dev/null +++ b/test/types-tydef-bad/input @@ -0,0 +1,1 @@ +:load test/types-tydef-bad/types-tydef-bad.disco diff --git a/test/types-tydef-bad/types-tydef-bad.disco b/test/types-tydef-bad/types-tydef-bad.disco new file mode 100644 --- /dev/null +++ b/test/types-tydef-bad/types-tydef-bad.disco @@ -0,0 +1,1 @@ +type X = Int -> Flerb(Int) diff --git a/test/types-tydef-kind/expected b/test/types-tydef-kind/expected new file mode 100644 --- /dev/null +++ b/test/types-tydef-kind/expected @@ -0,0 +1,3 @@ +Loading types-tydef-kind.disco... +Error: not enough arguments for the type 'Foo'. +https://disco-lang.readthedocs.io/en/latest/reference/num-args-type.html diff --git a/test/types-tydef-kind/input b/test/types-tydef-kind/input new file mode 100644 --- /dev/null +++ b/test/types-tydef-kind/input @@ -0,0 +1,2 @@ +-- See issue #295. Make sure we kind-check type definitions. +:load test/types-tydef-kind/types-tydef-kind.disco diff --git a/test/types-tydef-kind/types-tydef-kind.disco b/test/types-tydef-kind/types-tydef-kind.disco new file mode 100644 --- /dev/null +++ b/test/types-tydef-kind/types-tydef-kind.disco @@ -0,0 +1,5 @@ +type Foo(a) = a + Foo + +type Bar = Bar + Foo + +type Zip = Unit + Graph diff --git a/test/types-tydef-param/expected b/test/types-tydef-param/expected new file mode 100644 --- /dev/null +++ b/test/types-tydef-param/expected @@ -0,0 +1,9 @@ +Loading types-tydef-param.disco... +Loaded. +right(5, right(2, left(■), left(■)), right(7, right(1, left(■), left(■)), left(■))) +15 +right(3, right(true, right(5, right(false, right(7, left(■)))))) +15 +type Maybe(a) = Unit + a +type Tree(a) = Unit + a × Tree(a) × Tree(a) +type AltList(a, b) = Unit + a × AltList(b, a) diff --git a/test/types-tydef-param/input b/test/types-tydef-param/input new file mode 100644 --- /dev/null +++ b/test/types-tydef-param/input @@ -0,0 +1,8 @@ +:load test/types-tydef-param/types-tydef-param.disco +t +sumTree t +alt1 +sumAltList alt1 +:def Maybe +:def Tree +:def AltList diff --git a/test/types-tydef-param/types-tydef-param.disco b/test/types-tydef-param/types-tydef-param.disco new file mode 100644 --- /dev/null +++ b/test/types-tydef-param/types-tydef-param.disco @@ -0,0 +1,37 @@ +type Maybe(a) = Unit + a + +maybe : b -> (a -> b) -> Maybe(a) -> b +maybe b _ (left(■)) = b +maybe _ f (right(a)) = f a + +m1 : Maybe(N) +m1 = left(■) + +m2 : Maybe(N) +m2 = right 3 + + +type Tree(a) = Unit + a * Tree(a) * Tree(a) + +foldTree : r -> (a -> r -> r -> r) -> Tree(a) -> r +foldTree z f (left(■)) = z +foldTree z f (right (a,l,r)) = f a (foldTree z f l) (foldTree z f r) + +sumTree : Tree(N) -> N +sumTree = foldTree 0 (\a, l, r. a+l+r) + +t : Tree(N) +t = right (5, right (2, left(■), left(■)), right (7, right (1, left(■), left(■)), left(■))) + + +type AltList(a,b) = Unit + a * AltList(b,a) + +alt1 : AltList(N, Bool) +alt1 = right (3, right (true, right (5, right (false, right (7, left(■)))))) + +foldAltList : r -> (a -> r -> r) -> (b -> r -> r) -> AltList(a, b) -> r +foldAltList z _ _ (left(■)) = z +foldAltList z f g (right (a, l)) = f a (foldAltList z g f l) + +sumAltList : AltList(N,Bool) -> N +sumAltList = foldAltList 0 (\x, y. x+y) (\b, r. r) diff --git a/test/types-tydefs/expected b/test/types-tydefs/expected new file mode 100644 --- /dev/null +++ b/test/types-tydefs/expected @@ -0,0 +1,7 @@ +Loading types-tydefs.disco... +Loaded. +incr : Wahoo → Wahoo +let f = λx : Wahoo. x + 1 in f(3) : ℕ +4 +sumTripletList : List(Triplet) → ℕ +21 diff --git a/test/types-tydefs/input b/test/types-tydefs/input new file mode 100644 --- /dev/null +++ b/test/types-tydefs/input @@ -0,0 +1,6 @@ +:l test/types-tydefs/types-tydefs.disco +:type incr +:type let f = \(x: Wahoo). x + 1 in f 3 +let f = \(x: Wahoo). x + 1 in f 3 +:type sumTripletList +let x = [(1,2,3), (4,5,6)] : List(Triplet) in sumTripletList x diff --git a/test/types-tydefs/types-tydefs.disco b/test/types-tydefs/types-tydefs.disco new file mode 100644 --- /dev/null +++ b/test/types-tydefs/types-tydefs.disco @@ -0,0 +1,20 @@ +type Wahoo = Cat + +type Cat = Corn + +type Corn = Rain + +type Rain = Groot + +type Groot = Bat + +type Bat = Nat + +incr : Wahoo -> Wahoo +incr w = w + 1 + +type Triplet = (Nat * Nat * Nat) + +sumTripletList : List(Triplet) -> N +sumTripletList [] = 0 +sumTripletList ((n1, n2, n3) :: rest) = (n1 + n2 + n3 + (sumTripletList rest))