packages feed

disco (empty) → 0.1.0.0

raw patch · 423 files changed

+19601/−0 lines, 423 filesdep +QuickCheckdep +algebraic-graphsdep +arithmoisetup-changed

Dependencies added: QuickCheck, algebraic-graphs, arithmoi, base, bytestring, containers, directory, disco, exact-combinatorics, exceptions, fgl, filepath, haskeline, integer-logarithms, lens, megaparsec, mtl, oeis, optparse-applicative, parser-combinators, polysemy, polysemy-plugin, polysemy-zoo, pretty, pretty-show, process, simple-enumeration, split, splitmix, tasty, tasty-golden, transformers, unbound-generics

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import           Distribution.Simple+main = defaultMain
+ disco.cabal view
@@ -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
+ docs/tutorial/example/arith-pattern.disco view
@@ -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 ?}
+ docs/tutorial/example/basic-ellipsis.disco view
@@ -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]
+ docs/tutorial/example/basics.disco view
@@ -0,0 +1,5 @@+approx_pi : Rational+approx_pi = 22/7++increment : N -> N+increment(n) = n + 1
+ docs/tutorial/example/case-pattern.disco view
@@ -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+       ?}
+ docs/tutorial/example/case.disco view
@@ -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+       ?}
+ docs/tutorial/example/comment.disco view
@@ -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
+ docs/tutorial/example/comprehension.disco view
@@ -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+  ]
+ docs/tutorial/example/doc.disco view
@@ -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
+ docs/tutorial/example/function-desugar.disco view
@@ -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)+           ?}
+ docs/tutorial/example/function.disco view
@@ -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)
+ docs/tutorial/example/general-ellipsis.disco view
@@ -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]
+ docs/tutorial/example/higher-order.disco view
@@ -0,0 +1,2 @@+thrice : (N -> N) -> (N -> N)+thrice(f)(n) = f(f(f(n)))
+ docs/tutorial/example/let.disco view
@@ -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
+ docs/tutorial/example/list.disco view
@@ -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
+ docs/tutorial/example/multi-arg-functions.disco view
@@ -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)
+ docs/tutorial/example/pair.disco view
@@ -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)
+ docs/tutorial/example/poly.disco view
@@ -0,0 +1,3 @@+maplist : (a -> b) -> List(a) -> List(b)+maplist _ [] = []+maplist f (a :: as) = f a :: (maplist f as)
+ docs/tutorial/example/property.disco view
@@ -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
+ docs/tutorial/example/sum.disco view
@@ -0,0 +1,8 @@+sum1 : N + Bool+sum1 = left(3)++sum2 : N + Bool+sum2 = right(false)++sum3 : N + N + N+sum3 = right(right(3))
+ docs/tutorial/example/tydefs-poly.disco view
@@ -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)
+ docs/tutorial/example/tydefs.disco view
@@ -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)
+ docs/tutorial/example/unit-test.disco view
@@ -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)+
+ example/TestExamples.hs view
@@ -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)
+ example/abs.disco view
@@ -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+  ?}
+ example/catalan.disco view
@@ -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)
+ example/demo.disco view
@@ -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)
+ example/gcd.disco view
@@ -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)
+ example/grid.disco view
@@ -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)+  ?}
+ example/lists.disco view
@@ -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,_) ?}
+ example/logic.disco view
@@ -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)
+ example/nim.disco view
@@ -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+      ?}
+ example/prime.disco view
@@ -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+  ?}
+ example/prog.disco view
@@ -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
+ example/prop.disco view
@@ -0,0 +1,4 @@++!!! ∀ x : N, y : N. plus x y == plus y x+plus : N -> N -> N+plus x y = x + y
+ example/rsa.disco view
@@ -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)+  ?}
+ example/sums.disco view
@@ -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+  ?}
+ example/tree.disco view
@@ -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)
+ lib/container.disco view
@@ -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))
+ lib/graph.disco view
@@ -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+    ?}
+ lib/list.disco view
@@ -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+  ?}
+ lib/num.disco view
@@ -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)
+ lib/oeis.disco view
@@ -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
+ lib/prim.disco view
@@ -0,0 +1,4 @@+using Primitives++crash : List(Char) -> a+crash = $crash
+ lib/product.disco view
@@ -0,0 +1,7 @@+using NoStdLib++fst : (a × b) → a+fst (a,_) = a++snd : (a × b) → b+snd (_,b) = b
+ lib/prop.disco view
@@ -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
+ repl/REPL.hs view
@@ -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
+ src/Disco/AST/Core.hs view
@@ -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{}    -> "∃"
+ src/Disco/AST/Desugared.hs view
@@ -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
+ src/Disco/AST/Generic.hs view
@@ -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.+-- <https://arxiv.org/abs/1610.04799>+--+-- 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 <test>@)+  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
+ src/Disco/AST/Surface.hs view
@@ -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)+
+ src/Disco/AST/Typed.hs view
@@ -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))
+ src/Disco/Compile.hs view
@@ -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)
+ src/Disco/Context.hs view
@@ -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
+ src/Disco/Data.hs view
@@ -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)+
+ src/Disco/Desugar.hs view
@@ -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"
+ src/Disco/Effects/Counter.hs view
@@ -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
+ src/Disco/Effects/Fresh.hs view
@@ -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 #-}
+ src/Disco/Effects/Input.hs view
@@ -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 })+
+ src/Disco/Effects/LFresh.hs view
@@ -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
+ src/Disco/Effects/Random.hs view
@@ -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
+ src/Disco/Effects/State.hs view
@@ -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)
+ src/Disco/Effects/Store.hs view
@@ -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))
+ src/Disco/Enumerate.hs view
@@ -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
+ src/Disco/Error.hs view
@@ -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"+
+ src/Disco/Eval.hs view
@@ -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
+ src/Disco/Extensions.hs view
@@ -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
+ src/Disco/Interactive/CmdLine.hs view
@@ -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.
+ src/Disco/Interactive/Commands.hs view
@@ -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 <term>"+    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 <term>",+      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   = "<code>"+  , 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 <filename>",+      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 <expr>",+      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 <expr>",+      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 <var>",+      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 <property>",+      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 <term>",+      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)
+ src/Disco/Interpret/CESK.hs view
@@ -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/<oeis_sequence_id>"'+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
+ src/Disco/Messages.hs view
@@ -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
+ src/Disco/Module.hs view
@@ -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
+ src/Disco/Names.hs view
@@ -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
+ src/Disco/Parser.hs view
@@ -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 <modulename>@.+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).+--+-- @+-- <container>+--   ::= '[' <container-contents> ']'+--     | '{' <container-contents> '}'+--+-- <container-contents>+--   ::= empty | <nonempty-container>+--+-- <nonempty-container>+--   ::= <term> [ <ellipsis> ]+--     | <term> <container-end>+--+-- <container-end>+--   ::= '|' <comprehension>+--     | ',' [ <term> (',' <item>)* ] [ <ellipsis> ]+--+-- <comprehension> ::= <qual> [ ',' <qual> ]*+--+-- <qual>+--   ::= <ident> 'in' <term>+--     | <term>+--+-- <ellipsis> ::= '..' [ <term> ]+-- @++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+    -- <https://github.com/disco-lang/disco/issues/71> .+    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
+ src/Disco/Pretty.hs view
@@ -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)
+ src/Disco/Pretty/DSL.hs view
@@ -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
+ src/Disco/Pretty/Prec.hs view
@@ -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)
+ src/Disco/Property.hs view
@@ -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?
+ src/Disco/Report.hs view
@@ -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++------------------------------------------------------------+
+ src/Disco/Subst.hs view
@@ -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
+ src/Disco/Syntax/Operators.hs view
@@ -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
+ src/Disco/Syntax/Prims.hs view
@@ -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"+  ]
+ src/Disco/Typecheck.hs view
@@ -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
+ src/Disco/Typecheck/Constraints.hs view
@@ -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
+ src/Disco/Typecheck/Erase.hs view
@@ -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))
+ src/Disco/Typecheck/Graph.hs view
@@ -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)
+ src/Disco/Typecheck/Solve.hs view
@@ -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
+ src/Disco/Typecheck/Unify.hs view
@@ -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!"
+ src/Disco/Typecheck/Util.hs view
@@ -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")
+ src/Disco/Types.hs view
@@ -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 _ = "<tydef>"++-- | 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+++++++++++++++++++++++++++++++++++++
+ src/Disco/Types/Qualifiers.hs view
@@ -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
+ src/Disco/Types/Rules.hs view
@@ -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
+ src/Disco/Util.hs view
@@ -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
+ src/Disco/Value.hs view
@@ -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 _ = "<fun>"++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
+ stack.yaml view
@@ -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
+ test/README.md view
@@ -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.
+ test/Tests.hs view
@@ -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+        ]
+ test/arith-basic-bin/expected view
@@ -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
+ test/arith-basic-bin/input view
@@ -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)
+ test/arith-basic-un/expected view
@@ -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 : 𝔽) : ℚ
+ test/arith-basic-un/input view
@@ -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))
+ test/arith-count/expected view
@@ -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
+ test/arith-count/input view
@@ -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
+ test/arith-numthry/expected view
@@ -0,0 +1,12 @@+3+3+true+true+true+true+true+false+false+false+true+true
+ test/arith-numthry/input view
@@ -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
+ test/arith-prim/arith-prim.disco view
@@ -0,0 +1,4 @@+import num++ps : List(N)+ps = filter(isPrime, [1 .. 100])
+ test/arith-prim/expected view
@@ -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]
+ test/arith-prim/input view
@@ -0,0 +1,2 @@+:load test/arith-prim/arith-prim.disco+ps
+ test/arith-round/expected view
@@ -0,0 +1,15 @@+0+3+5+1+1+3+1+3+3+2+2+11+2+2+-2
+ test/arith-round/input view
@@ -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)
+ test/case-arith/case-arith.disco view
@@ -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
+ test/case-arith/expected view
@@ -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
+ test/case-arith/input view
@@ -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))
+ test/case-basic/case-basic.disco view
@@ -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+ ?}
+ test/case-basic/expected view
@@ -0,0 +1,7 @@+Loading case-basic.disco...+Loaded.+0+1+2+3+4
+ test/case-basic/input view
@@ -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])
+ test/case-let/case-let.disco view
@@ -0,0 +1,5 @@+f : N -> N+f x = {? z   if 2 divides x+             let z = x // 2+      ,  x   otherwise+      ?}
+ test/case-let/expected view
@@ -0,0 +1,4 @@+Loading case-let.disco...+Loaded.+3+5
+ test/case-let/input view
@@ -0,0 +1,3 @@+:load test/case-let/case-let.disco+f 6+f 5
+ test/compile-cons/expected view
@@ -0,0 +1,1 @@+[3, 5]
+ test/compile-cons/input view
@@ -0,0 +1,1 @@+(\x. (\z. ~::~ (x,z))) 3 [5]
+ test/compile-misc/expected view
@@ -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!
+ test/compile-misc/input view
@@ -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!
+ test/containers-cmp/expected view
@@ -0,0 +1,4 @@+{{1, 2}, {1, 3}, {2, 3}}+true+{⟅1 # 3⟆, ⟅2 # 5⟆}+true
+ test/containers-cmp/input view
@@ -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⟆
+ test/containers-comp/expected view
@@ -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}
+ test/containers-comp/input view
@@ -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 }
+ test/containers-convert/expected view
@@ -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]
+ test/containers-convert/input view
@@ -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]
+ test/containers-each/expected view
@@ -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}
+ test/containers-each/input view
@@ -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})
+ test/containers-ellipsis/expected view
@@ -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"
+ test/containers-ellipsis/input view
@@ -0,0 +1,5 @@+{ 1 .. 5 }+{ 1, 3, 6 .. 50 }+⟅ 1 .. 5 ⟆+⟅ 1, 3, 6 .. 50 ⟆+[ 'a' .. 'z' ]
+ test/containers-filter/expected view
@@ -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]
+ test/containers-filter/input view
@@ -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]))
+ test/containers-join/expected view
@@ -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⟆
+ test/containers-join/input view
@@ -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)}]))
+ test/containers-merge/expected view
@@ -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}
+ test/containers-merge/input view
@@ -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})
+ test/containers-ops/expected view
@@ -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⟆
+ test/containers-ops/input view
@@ -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)⟆
+ test/containers-reduce/containers-reduce.disco view
@@ -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))
+ test/containers-reduce/expected view
@@ -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
+ test/containers-reduce/input view
@@ -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
+ test/error-ambiguous/a.disco view
@@ -0,0 +1,2 @@+x : Int+x = 1
+ test/error-ambiguous/ambiguous.disco view
@@ -0,0 +1,8 @@+import a+import b++x : Int+x = 0++y : Int+y = x + 1
+ test/error-ambiguous/b.disco view
@@ -0,0 +1,2 @@+x : Int+x = 2
+ test/error-ambiguous/expected view
@@ -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
+ test/error-ambiguous/input view
@@ -0,0 +1,1 @@+:load test/error-ambiguous/ambiguous.disco
+ test/error-cyclic/cyclic.disco view
@@ -0,0 +1,3 @@+type A = B+type B = C+type C = A
+ test/error-cyclic/expected view
@@ -0,0 +1,3 @@+Loading cyclic.disco...+Error: cyclic type definition for A.+https://disco-lang.readthedocs.io/en/latest/reference/cyc-ty.html
+ test/error-cyclic/input view
@@ -0,0 +1,1 @@+:load test/error-cyclic/cyclic.disco
+ test/error-duplicatedecls/dupdecls.disco view
@@ -0,0 +1,5 @@+x : Z+x = 3++x : Z+x = 4
+ test/error-duplicatedecls/expected view
@@ -0,0 +1,3 @@+Loading dupdecls.disco...+Error: duplicate type signature for x.+https://disco-lang.readthedocs.io/en/latest/reference/dup-sig.html
+ test/error-duplicatedecls/input view
@@ -0,0 +1,1 @@+:load test/error-duplicatedecls/dupdecls.disco
+ test/error-duplicatedefns/dupdefns.disco view
@@ -0,0 +1,3 @@+x : N+x = 1+x = 2
+ test/error-duplicatedefns/expected view
@@ -0,0 +1,3 @@+Loading dupdefns.disco...+Error: duplicate definition for x.+https://disco-lang.readthedocs.io/en/latest/reference/dup-def.html
+ test/error-duplicatedefns/input view
@@ -0,0 +1,1 @@+:load test/error-duplicatedefns/dupdefns.disco
+ test/error-duplicatetydefns/duptydefns.disco view
@@ -0,0 +1,2 @@+type XYZ = N+type XYZ = Z
+ test/error-duplicatetydefns/expected view
@@ -0,0 +1,3 @@+Loading duptydefns.disco...+Error: duplicate definition for type XYZ.+https://disco-lang.readthedocs.io/en/latest/reference/dup-tydef.html
+ test/error-duplicatetydefns/input view
@@ -0,0 +1,1 @@+:load test/error-duplicatetydefns/duptydefns.disco
+ test/error-emptycase/expected view
@@ -0,0 +1,2 @@+Error: empty case expressions {? ?} are not allowed.+https://disco-lang.readthedocs.io/en/latest/reference/empty-case.html
+ test/error-emptycase/input view
@@ -0,0 +1,1 @@+{? ?}
+ test/error-names/expected view
@@ -0,0 +1,2 @@+Error: there is nothing named x.+https://disco-lang.readthedocs.io/en/latest/reference/unbound.html
+ test/error-names/input view
@@ -0,0 +1,1 @@+x + 2
+ test/error-notcon/expected view
@@ -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
+ test/error-notcon/input view
@@ -0,0 +1,4 @@+f : List(Int) -> List(Int)+f x = x++f (\x:Z.x)
+ test/error-notype/expected view
@@ -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
+ test/error-notype/input view
@@ -0,0 +1,1 @@+x = 3
+ test/error-numpatterns/expected view
@@ -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
+ test/error-numpatterns/input view
@@ -0,0 +1,1 @@+:load test/error-numpatterns/numpatterns.disco
+ test/error-numpatterns/numpatterns.disco view
@@ -0,0 +1,3 @@+f : N -> N -> Bool+f 3 = \x.x > 2+f x y = true
+ test/error-pattype/expected view
@@ -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
+ test/error-pattype/input view
@@ -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
+ test/error-polyrec/expected view
@@ -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
+ test/error-polyrec/input view
@@ -0,0 +1,1 @@+:load test/error-polyrec/polyrec.disco
+ test/error-polyrec/polyrec.disco view
@@ -0,0 +1,1 @@+type Bush(a) = a + Bush(a*a)
+ test/error-qualskolem/expected view
@@ -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
+ test/error-qualskolem/input view
@@ -0,0 +1,1 @@+:load test/error-qualskolem/qualskolem.disco
+ test/error-qualskolem/qualskolem.disco view
@@ -0,0 +1,2 @@+f : a -> a+f (-x) = x
+ test/error-tyargs/error-tyargs.disco view
@@ -0,0 +1,1 @@+type T(a,b) = Unit + a*b
+ test/error-tyargs/expected view
@@ -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
+ test/error-tyargs/input view
@@ -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)
+ test/error-unboundtyvar/expected view
@@ -0,0 +1,3 @@+Loading unboundtyvar.disco...+Error: Unknown type variable 'b'.+https://disco-lang.readthedocs.io/en/latest/reference/unbound-tyvar.html
+ test/error-unboundtyvar/input view
@@ -0,0 +1,1 @@+:load test/error-unboundtyvar/unboundtyvar.disco
+ test/error-unboundtyvar/unboundtyvar.disco view
@@ -0,0 +1,1 @@+type T(a) = a + b
+ test/error-unqual-base/expected view
@@ -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
+ test/error-unqual-base/input view
@@ -0,0 +1,1 @@+:load test/error-unqual-base/unqualbase.disco
+ test/error-unqual-base/unqualbase.disco view
@@ -0,0 +1,2 @@+f : N -> N+f (-x) = x
+ test/error-unqual/expected view
@@ -0,0 +1,2 @@+Error: values of type a2 → a3 cannot be compared.+https://disco-lang.readthedocs.io/en/latest/reference/not-qual.html
+ test/error-unqual/input view
@@ -0,0 +1,1 @@+(\x.x) == (\y.y)
+ test/error-wildcard/expected view
@@ -0,0 +1,2 @@+Error: wildcards (_) are not allowed in expressions.+https://disco-lang.readthedocs.io/en/latest/reference/wildcard-expr.html
+ test/error-wildcard/input view
@@ -0,0 +1,1 @@+1 + _
+ test/graphs-basic/expected view
@@ -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, {})})
+ test/graphs-basic/input view
@@ -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
+ test/graphs-equality/expected view
@@ -0,0 +1,4 @@+true+true+true+true
+ test/graphs-equality/input view
@@ -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
+ test/interp-loop/expected view
@@ -0,0 +1,1 @@+Error: infinite loop detected!
+ test/interp-loop/input view
@@ -0,0 +1,2 @@+x : N+x = x
+ test/interp-strictmatch/bomb.disco view
@@ -0,0 +1,3 @@+-- A function to produce a runtime exception at any type+bomb : a -> a+bomb x = {? x if 0 == 1 ?}
+ test/interp-strictmatch/expected view
@@ -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.
+ test/interp-strictmatch/input view
@@ -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 ?}
+ test/lib-oeis/expected view
@@ -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]
+ test/lib-oeis/input view
@@ -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]
+ test/list-comp/expected view
@@ -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(ℕ × ℕ)
+ test/list-comp/input view
@@ -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]
+ test/list-poly/expected view
@@ -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]
+ test/list-poly/input view
@@ -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]
+ test/logic-bools/expected view
@@ -0,0 +1,20 @@+true+false+true+false+true+false+false+false+false+true+true+true+false+true+false+true+true+false+true+true
+ test/logic-bools/input view
@@ -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
+ test/logic-cmp/expected view
@@ -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]
+ test/logic-cmp/input view
@@ -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]
+ test/map-basic/expected view
@@ -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)}
+ test/map-basic/input view
@@ -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 {})))
+ test/map-compare/expected view
@@ -0,0 +1,4 @@+true+true+true+true
+ test/map-compare/input view
@@ -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')}
+ test/module-basic/a.disco view
@@ -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
+ test/module-basic/b.disco view
@@ -0,0 +1,2 @@+y : N+y = 5
+ test/module-basic/c.disco view
@@ -0,0 +1,6 @@+-- Test for importing the standard library++import list++l : List(N)+l = each(\x. x + 1, [1,2,3])
+ test/module-basic/e.disco view
@@ -0,0 +1,5 @@+-- Importing a module in a subdirectory, with a .disco extension+import subdir/d.disco++zz : Z+zz = qq + 1
+ test/module-basic/expected view
@@ -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
+ test/module-basic/input view
@@ -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
+ test/module-basic/subdir/d.disco view
@@ -0,0 +1,2 @@+qq : Z+qq = -10
+ test/module-cycle/cyclic1.disco view
@@ -0,0 +1,3 @@+import cyclic2++x = 3
+ test/module-cycle/cyclic2.disco view
@@ -0,0 +1,3 @@+import cyclic1++y = 2
+ test/module-cycle/expected view
@@ -0,0 +1,4 @@+Loading cyclic1.disco...+Loading cyclic2.disco...+Error: module imports form a cycle:+  cyclic1 -> cyclic2 -> cyclic1
+ test/module-cycle/input view
@@ -0,0 +1,1 @@+:load test/module-cycle/cyclic1
+ test/module-notfound/expected view
@@ -0,0 +1,1 @@+Error: couldn't find a module named 'foo'.
+ test/module-notfound/input view
@@ -0,0 +1,1 @@+import foo
+ test/parse-245/expected view
@@ -0,0 +1,4 @@+2 .- 4 : ℕ+2 .- 4 : ℕ+0+0
+ test/parse-245/input view
@@ -0,0 +1,4 @@+:type 2.-4+:type 2 .- 4+2.-4+2 .- 4
+ test/parse-280/capitalvars.disco view
@@ -0,0 +1,5 @@+A : Set(ℕ)+A = {1, 3, 6}++B : Set(ℕ)+B = { x+1 | x <- A, x mod 2 == 1 }
+ test/parse-280/expected view
@@ -0,0 +1,2 @@+Loading capitalvars.disco...+Loaded.
+ test/parse-280/input view
@@ -0,0 +1,1 @@+:load test/parse-280/capitalvars.disco
+ test/parse-case-expr/expected view
@@ -0,0 +1,1 @@+[false, false]
+ test/parse-case-expr/input view
@@ -0,0 +1,1 @@+let n = 3 in {? true if 2 divides n, false otherwise ?} :: false :: []
+ test/parse-nested-list/expected view
@@ -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]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]
+ test/parse-nested-list/input view
@@ -0,0 +1,2 @@+:type [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[10]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]+[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[10]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]
+ test/parse-quantifiers/expected view
@@ -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])]))
+ test/parse-quantifiers/input view
@@ -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
+ test/parse-top-term/expected view
@@ -0,0 +1,2 @@+Loading parse-top-term.disco...+Loaded.
+ test/parse-top-term/input view
@@ -0,0 +1,1 @@+:load test/parse-top-term/parse-top-term.disco
+ test/parse-top-term/parse-top-term.disco view
@@ -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]
+ test/poly-bad/expected view
@@ -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
+ test/poly-bad/input view
@@ -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
+ test/poly-infer-sort/expected view
@@ -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
+ test/poly-infer-sort/input view
@@ -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
+ test/poly-instantiate/expected view
@@ -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(ℤ) → ℚ
+ test/poly-instantiate/input view
@@ -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)
+ test/poly-instantiate/poly-instantiate.disco view
@@ -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)
+ test/poly-rectype/expected view
@@ -0,0 +1,2 @@+Loading poly-rectype.disco...+Loaded.
+ test/poly-rectype/input view
@@ -0,0 +1,1 @@+:load test/poly-rectype/poly-rectype.disco
+ test/poly-rectype/poly-rectype.disco view
@@ -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)
+ test/pretty-defn/expected view
@@ -0,0 +1,5 @@+f : ℕ → ℕ+f(x) = x + 2+type P = ℕ × ℕ+type Pair(a) = a × a+type HPair(a, b) = a × b
+ test/pretty-defn/input view
@@ -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
+ test/pretty-functions/expected view
@@ -0,0 +1,3 @@+<a1 → a1>+<(a1 → a2) × List(a1) → List(a2)>+<List(List(a6)) → List(List(a6))>
+ test/pretty-functions/input view
@@ -0,0 +1,3 @@+\x.x+each+\xs. each (list,xs)
+ test/pretty-issue258/expected view
@@ -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))
+ test/pretty-issue258/input view
@@ -0,0 +1,4 @@+:load example/catalan.disco+:defn treesOfSize+:load example/tree.disco+:defn treeFold
+ test/pretty-lit/expected view
@@ -0,0 +1,3 @@+1+1.0+3.0 / -7 : ℚ
+ test/pretty-lit/input view
@@ -0,0 +1,3 @@+:pretty 1+:pretty 1.0+:type 3.0/(-7)
+ test/pretty-ops/expected view
@@ -0,0 +1,6 @@+not true+5!+6 + 3+6 + 5 * 2+6 + 5 * 2+(6 + 5) * 2
+ test/pretty-ops/input view
@@ -0,0 +1,6 @@+:pretty ¬true+:pretty 5!+:pretty 6 + 3+:pretty 6+5*2+:pretty 6+(5*2)+:pretty (6+5)*2
+ test/pretty-pattern/expected view
@@ -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
+ test/pretty-pattern/input view
@@ -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
+ test/pretty-torture/expected view
@@ -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)!
+ test/pretty-torture/input view
@@ -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)!
+ test/pretty-type/expected view
@@ -0,0 +1,3 @@+[1, 2, 3, 4] : List(ℕ)+[[1, 2], [3, 4]] : List(List(ℕ))+[[(2, true), (3, false)], [(-5, true)]] : List(List(ℤ × Bool))
+ test/pretty-type/input view
@@ -0,0 +1,3 @@+:type [1,2,3,4]+:type [[1,2],[3,4]]+:type [[(2,true), (3,false)], [(-5,true)]]
+ test/pretty-whnf/expected view
@@ -0,0 +1,2 @@+left(■)+<Void → ℕ>
+ test/pretty-whnf/input view
@@ -0,0 +1,2 @@+left(■) : Unit + Nat+\(x:Void). 3
+ test/prim-crash/expected view
@@ -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
+ test/prim-crash/input view
@@ -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")
+ test/prim-frac/expected view
@@ -0,0 +1,10 @@+$frac : ℚ → ℤ × ℕ+(0, 1)+(1, 1)+(5, 1)+(-6, 1)+(2, 3)+(2, 3)+(7, 3)+(-1, 8)+(1, 3)
+ test/prim-frac/input view
@@ -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))
+ test/prim-sum/expected view
@@ -0,0 +1,3 @@+left : a1 → a1 + a+right : a1 → a + a1+[left(1), left(2), left(3)]
+ test/prim-sum/input view
@@ -0,0 +1,3 @@+:type left+:type right+each(left, [1,2,3])
+ test/prop-basic/expected view
@@ -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.
+ test/prop-basic/input view
@@ -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)
+ test/prop-basic/prop-basic.disco view
@@ -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
+ test/prop-cmp/expected view
@@ -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
+ test/prop-cmp/input view
@@ -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)
+ test/prop-fail/bad-tests.disco view
@@ -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
+ test/prop-fail/expected view
@@ -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.
+ test/prop-fail/input view
@@ -0,0 +1,1 @@+:load test/prop-fail/bad-tests.disco
+ test/prop-fairness/expected view
@@ -0,0 +1,4 @@+false+true+true+true
+ test/prop-fairness/input view
@@ -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))
+ test/prop-higher-order/expected view
@@ -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
+ test/prop-higher-order/higher-order.disco view
@@ -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)
+ test/prop-higher-order/input view
@@ -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)
+ test/prop-holds/expected view
@@ -0,0 +1,7 @@+true+true+true+false+false+true+true
+ test/prop-holds/input view
@@ -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)
+ test/prop-impredicative/expected view
@@ -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
+ test/prop-impredicative/input view
@@ -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
+ test/prop-impredicative/prop-impredicative.disco view
@@ -0,0 +1,1 @@+type T(a) = Unit + a * T(a) * T(a)
+ test/prop-tests/expected view
@@ -0,0 +1,6 @@+Loading prop-tests.disco...+Running tests...+  foo: OK+  reverse: OK+  x: OK+Loaded.
+ test/prop-tests/input view
@@ -0,0 +1,1 @@+:load test/prop-tests/prop-tests.disco
+ test/prop-tests/prop-tests.disco view
@@ -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.
+ test/prop-type/expected view
@@ -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
+ test/prop-type/input view
@@ -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
+ test/repl-ann/expected view
@@ -0,0 +1,3 @@+Loading num.disco...+factor : ℕ → Bag(ℕ)+(λx : ℤ, y : a. (~-~ : ℤ × ℤ → ℤ)((x : ℤ, 7 : ℤ) : ℤ × ℤ) : ℤ) : ℤ → a3 → ℤ
+ test/repl-ann/input view
@@ -0,0 +1,3 @@+import num+:ann factor+:ann \x, y. x - 7
+ test/repl-compile/expected view
@@ -0,0 +1,2 @@+Loading num.disco...+num.isPrime
+ test/repl-compile/input view
@@ -0,0 +1,2 @@+import num+:compile isPrime
+ test/repl-defn/expected view
@@ -0,0 +1,4 @@+5+x : ℕ+true+6
+ test/repl-defn/input view
@@ -0,0 +1,7 @@+x : N+x = 5+x+:type x+x == 5+x = 6+x
+ test/repl-defns/expected view
@@ -0,0 +1,2 @@+2+3
+ test/repl-defns/input view
@@ -0,0 +1,6 @@+x : N+x = 2+y : N+y = x + 1+x+y
+ test/repl-desugar/expected view
@@ -0,0 +1,2 @@+Loading num.disco...+isPrime
+ test/repl-desugar/input view
@@ -0,0 +1,2 @@+import num+:desugar isPrime
+ test/repl-doc/doc.disco view
@@ -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
+ test/repl-doc/expected view
@@ -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+
+ test/repl-doc/input view
@@ -0,0 +1,7 @@+:load test/repl-doc/doc.disco+:doc P+:doc f+:doc x+:doc ++:doc !+:doc not
+ test/repl-eval-tydef-import/a.disco view
@@ -0,0 +1,4 @@+import b++x : L+x = right(3, left(unit))
+ test/repl-eval-tydef-import/b.disco view
@@ -0,0 +1,1 @@+type L = Unit + N * L
+ test/repl-eval-tydef-import/expected view
@@ -0,0 +1,4 @@+Loading a.disco...+Loading b.disco...+Loaded.+right(3, left(■))
+ test/repl-eval-tydef-import/input view
@@ -0,0 +1,2 @@+:load test/repl-eval-tydef-import/a.disco+x
+ test/repl-help/expected view
@@ -0,0 +1,12 @@+Commands available from the prompt:++:defn <var>       Show a variable's definition+:doc <term>       Show documentation+<code>            Evaluate a block of code+:help             Show help+:load <filename>  Load a file+:names            Show all names in current scope+:reload           Reloads the most recently loaded file+:test <property>  Test a property using random examples++2
+ test/repl-help/input view
@@ -0,0 +1,2 @@+:help+1+1
+ test/repl-import/expected view
@@ -0,0 +1,3 @@+Loading num.disco...+false+[4, 5]
+ test/repl-import/input view
@@ -0,0 +1,3 @@+import num+isPrime 20+filter(\x. x > 3, [1 .. 5])
+ test/repl-names/expected view
@@ -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
+ test/repl-names/input view
@@ -0,0 +1,2 @@+:load test/repl-names/logic.disco+:names
+ test/repl-names/logic.disco view
@@ -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
+ test/repl-names/other.disco view
@@ -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
+ test/repl-proptest/expected view
@@ -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
+ test/repl-proptest/input view
@@ -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)
+ test/solver-issue112/diag-iso-bad.disco view
@@ -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.
+ test/solver-issue112/expected view
@@ -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
+ test/solver-issue112/input view
@@ -0,0 +1,2 @@+:load test/solver-issue112/diag-iso-bad.disco+:type (\x.x^(-2)) : Z -> Z
+ test/syntax-chain/expected view
@@ -0,0 +1,16 @@+Loading inRange.disco...+Loaded.+false+false+true+true+true+false+true+false+false+false+false+false+false+false
+ test/syntax-chain/inRange.disco view
@@ -0,0 +1,2 @@+inRange : N -> N -> (N -> Bool)+inRange a b = λn. a <= n <= b
+ test/syntax-chain/input view
@@ -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
+ test/syntax-clause/clauses.disco view
@@ -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)
+ test/syntax-clause/expected view
@@ -0,0 +1,4 @@+Loading clauses.disco...+Loaded.+[5, 11, 19]+[1, 2, 3, 4, 5, 6]
+ test/syntax-clause/input view
@@ -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])
+ test/syntax-comment/expected view
@@ -0,0 +1,5 @@+Loading fib.disco...+Running tests...+  fib: OK+Loaded.+610
+ test/syntax-comment/fib.disco view
@@ -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.+  ?}
+ test/syntax-comment/input view
@@ -0,0 +1,2 @@+:load test/syntax-comment/fib.disco+fib 15
+ test/syntax-containers/expected view
@@ -0,0 +1,3 @@+[1, 2, 3, 3]+⟅1, 2, 3 # 2⟆+{1, 2, 3}
+ test/syntax-containers/input view
@@ -0,0 +1,3 @@+[ 1, 2, 3, 3 ]+⟅ 1, 2, 3, 3 ⟆+{ 1, 2, 3, 3 }
+ test/syntax-decimals/expected view
@@ -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...
+ test/syntax-decimals/input view
@@ -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)
+ test/syntax-doc/expected view
@@ -0,0 +1,10 @@+Loading syntax-doc.disco...+Running tests...+  x: OK+Loaded.+x : ℕ++This is some documentation.++More documentation after a blank line.+
+ test/syntax-doc/input view
@@ -0,0 +1,2 @@+:load test/syntax-doc/syntax-doc.disco+:doc x
+ test/syntax-doc/syntax-doc.disco view
@@ -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
+ test/syntax-exts/expected view
@@ -0,0 +1,2 @@+Loading syntax-exts.disco...+Loaded.
+ test/syntax-exts/input view
@@ -0,0 +1,1 @@+:load test/syntax-exts/syntax-exts.disco
+ test/syntax-exts/syntax-exts.disco view
@@ -0,0 +1,5 @@+using rAnDOMnesS+using Primitives++x : N+x = 5
+ test/syntax-juxt-app/expected view
@@ -0,0 +1,3 @@+Loading juxt-app.disco...+Loaded.+17
+ test/syntax-juxt-app/input view
@@ -0,0 +1,2 @@+:load test/syntax-juxt-app/juxt-app.disco+f (\x.x^2) (3,4) 2
+ test/syntax-juxt-app/juxt-app.disco view
@@ -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
+ test/syntax-juxt-mul/expected view
@@ -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
+ test/syntax-juxt-mul/input view
@@ -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)
+ test/syntax-juxt-mul/juxt-mul.disco view
@@ -0,0 +1,8 @@+x : Nat+x = 5++y : Nat+y = 2++f : Nat -> Nat+f x = x + 1
+ test/syntax-lambda-pat/expected view
@@ -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
+ test/syntax-lambda-pat/input view
@@ -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
+ test/syntax-lambda/expected view
@@ -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
+ test/syntax-lambda/input view
@@ -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"
+ test/syntax-let/expected view
@@ -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 : ℕ
+ test/syntax-let/input view
@@ -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
+ test/syntax-many-args/expected view
@@ -0,0 +1,4 @@+Loading many-args.disco...+Loaded.+10260+0
+ test/syntax-many-args/input view
@@ -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]
+ test/syntax-many-args/many-args.disco view
@@ -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
+ test/syntax-many-clauses/expected view
@@ -0,0 +1,9 @@+Loading many-clauses.disco...+Loaded.+0+1+144+15+5000+100+267
+ test/syntax-many-clauses/input view
@@ -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
+ test/syntax-many-clauses/many-clauses.disco view
@@ -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
+ test/syntax-patclause/expected view
@@ -0,0 +1,4 @@+Loading fact.disco...+Loaded.+3628800+3628800
+ test/syntax-patclause/fact.disco view
@@ -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
+ test/syntax-patclause/input view
@@ -0,0 +1,3 @@+:load test/syntax-patclause/fact.disco+fact 10+fact2 10
+ test/syntax-prims/expected view
@@ -0,0 +1,4 @@+Loading syntax-prims.disco...+Loaded.+x : ℕ → ℕ+User crash: bad dog!
+ test/syntax-prims/input view
@@ -0,0 +1,3 @@+:load test/syntax-prims/syntax-prims.disco+:type x+x 4
+ test/syntax-prims/syntax-prims.disco view
@@ -0,0 +1,4 @@+using primitives++x : N -> N+x _ = $crash "bad dog!"
+ test/syntax-tuples/expected view
@@ -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
+ test/syntax-tuples/input view
@@ -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) ?}
+ test/syntax-types/expected view
@@ -0,0 +1,11 @@+[1, 1, 1, 1]+[-1, -1, -1, -1]+[1/2, 1/2]+[-1/2, -1/2, -1/2]+[true, true]+[■, ■]+[]+{}+{}+⟅⟆+⟅⟆
+ test/syntax-types/input view
@@ -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))
+ test/types-192/expected view
@@ -0,0 +1,1 @@+λx, y, z. x + y / z : 𝔽 → 𝔽 → 𝔽 → 𝔽
+ test/types-192/input view
@@ -0,0 +1,1 @@+:type \x,y,z. x + y / z
+ test/types-bind/expected view
@@ -0,0 +1,1 @@+8
+ test/types-bind/input view
@@ -0,0 +1,1 @@+((let y = 3 in (\x. x + y)) : N -> N) 5
+ test/types-char-string/expected view
@@ -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
+ test/types-char-string/input view
@@ -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"
+ test/types-compare/expected view
@@ -0,0 +1,1 @@+true
+ test/types-compare/input view
@@ -0,0 +1,1 @@+([1,2,3] : List(Z)) == ([1,2,3] : List(N))
+ test/types-container/expected view
@@ -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(ℕ)
+ test/types-container/input view
@@ -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
+ test/types-kinds/expected view
@@ -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
+ test/types-kinds/input view
@@ -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
+ test/types-naked-ops/expected view
@@ -0,0 +1,5 @@+~max~ : ℕ × ℕ → ℕ+~! : ℕ → ℕ+~mod~ : ℤ × ℤ → ℤ+~+~ : ℕ × ℕ → ℕ+not~ : Bool → Bool
+ test/types-naked-ops/input view
@@ -0,0 +1,5 @@+:type max+:type !+:type %+:type ++:type ¬
+ test/types-numpats/expected view
@@ -0,0 +1,2 @@+Loading types-numpats.disco...+Loaded.
+ test/types-numpats/input view
@@ -0,0 +1,1 @@+:load test/types-numpats/types-numpats.disco
+ test/types-numpats/types-numpats.disco view
@@ -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
+ test/types-ops/expected view
@@ -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)+[]+[<Bool → Bool>, <Bool → Bool>, <Bool → Bool>, <Bool → Bool>]+[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)]+[]+[]+[<Void → ℕ>]+[]+[<Void → Void>]+right(1)+left(■)+right(1)+right(2)+right(4)+right(1114112)+right(1)+right(0)
+ test/types-ops/input view
@@ -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]
+ test/types-rational/expected view
@@ -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(ℚ)
+ test/types-rational/input view
@@ -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 :: [])
+ test/types-rec/expected view
@@ -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
+ test/types-rec/input view
@@ -0,0 +1,2 @@+:load test/types-rec/types-rec.disco+snd(e : T2)(e')
+ test/types-rec/types-rec.disco view
@@ -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.
+ test/types-squash/expected view
@@ -0,0 +1,8 @@+floor(0) : ℕ+floor(1 / 2) : ℕ+floor(-1) : ℤ+floor(-1 / 2) : ℤ+abs(0) : ℕ+abs(1 / 2) : 𝔽+abs(-1) : ℕ+abs(-1 / 2) : 𝔽
+ test/types-squash/input view
@@ -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)
+ test/types-standalone-ops/expected view
@@ -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
+ test/types-standalone-ops/input view
@@ -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~
+ test/types-toomanypats/expected view
@@ -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
+ test/types-toomanypats/input view
@@ -0,0 +1,1 @@+:load test/types-toomanypats/toomanypats.disco
+ test/types-toomanypats/toomanypats.disco view
@@ -0,0 +1,2 @@+f : N -> Bool+f x y = true
+ test/types-tydef-bad/expected view
@@ -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
+ test/types-tydef-bad/input view
@@ -0,0 +1,1 @@+:load test/types-tydef-bad/types-tydef-bad.disco
+ test/types-tydef-bad/types-tydef-bad.disco view
@@ -0,0 +1,1 @@+type X = Int -> Flerb(Int)
+ test/types-tydef-kind/expected view
@@ -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
+ test/types-tydef-kind/input view
@@ -0,0 +1,2 @@+-- See issue #295.  Make sure we kind-check type definitions.+:load test/types-tydef-kind/types-tydef-kind.disco
+ test/types-tydef-kind/types-tydef-kind.disco view
@@ -0,0 +1,5 @@+type Foo(a) = a + Foo++type Bar = Bar + Foo++type Zip = Unit + Graph
+ test/types-tydef-param/expected view
@@ -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)
+ test/types-tydef-param/input view
@@ -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
+ test/types-tydef-param/types-tydef-param.disco view
@@ -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)
+ test/types-tydefs/expected view
@@ -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
+ test/types-tydefs/input view
@@ -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
+ test/types-tydefs/types-tydefs.disco view
@@ -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))