packages feed

Agda 2.6.2.2 → 2.8.0

raw patch · 537 files changed

This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.

Files

Agda.cabal view
@@ -1,828 +1,1021 @@-name:            Agda-version:         2.6.2.2-cabal-version:   >= 1.10-build-type:      Custom-license:         OtherLicense-license-file:    LICENSE-copyright:       (c) 2005-2022 The Agda Team.-author:          Ulf Norell and The Agda Team, see https://agda.readthedocs.io/en/latest/team.html-maintainer:      The Agda Team-homepage:        http://wiki.portal.chalmers.se/agda/-bug-reports:     https://github.com/agda/agda/issues-category:        Dependent types-synopsis:        A dependently typed functional programming language and proof assistant-description:-  Agda is a dependently typed functional programming language: It has-  inductive families, which are similar to Haskell's GADTs, but they-  can be indexed by values and not just types. It also has-  parameterised modules, mixfix operators, Unicode characters, and an-  interactive Emacs interface (the type checker can assist in the-  development of your code).-  .-  Agda is also a proof assistant: It is an interactive system for-  writing and checking proofs. Agda is based on intuitionistic type-  theory, a foundational system for constructive mathematics developed-  by the Swedish logician Per Martin-L&#xf6;f. It has many-  similarities with other proof assistants based on dependent types,-  such as Coq, Idris, Lean and NuPRL.-  .-  This package includes both a command-line program (agda) and an-  Emacs mode. If you want to use the Emacs mode you can set it up by-  running @agda-mode setup@ (see the README).-  .-  Note that the Agda package does not follow the package versioning-  policy, because it is not intended to be used by third-party-  packages.--tested-with:        GHC == 8.0.2-                    GHC == 8.2.2-                    GHC == 8.4.4-                    GHC == 8.6.5-                    GHC == 8.8.4-                    GHC == 8.10.7-                    GHC == 9.0.1-                    GHC == 9.0.2-                    GHC == 9.2.1-                    GHC == 9.2.2--extra-source-files: CHANGELOG.md-                    README.md-                    doc/release-notes/2.6.2.1.md-                    doc/release-notes/2.6.2.md-                    doc/release-notes/2.6.1.3.md-                    doc/release-notes/2.6.1.2.md-                    doc/release-notes/2.6.1.1.md-                    doc/release-notes/2.6.1.md-                    doc/release-notes/2.6.0.1.md-                    doc/release-notes/2.6.0.md-                    doc/release-notes/2.5.4.2.md-                    doc/release-notes/2.5.4.1.md-                    doc/release-notes/2.5.4.md-                    doc/release-notes/2.5.3.md-                    doc/release-notes/2.5.2.md-                    doc/release-notes/2.5.1.2.md-                    doc/release-notes/2.5.1.1.md-                    doc/release-notes/2.5.1.md-                    doc/release-notes/2.4.2.5.md-                    doc/release-notes/2.4.2.4.md-                    doc/release-notes/2.4.2.3.md-                    doc/release-notes/2.4.2.2.md-                    doc/release-notes/2.4.2.1.md-                    doc/release-notes/2.4.2.md-                    doc/release-notes/2.4.0.2.md-                    doc/release-notes/2.4.0.1.md-                    doc/release-notes/2.4.0.md-                    doc/release-notes/2.3.2.2.md-                    doc/release-notes/2.3.2.1.md-                    doc/release-notes/2.3.2.md-                    doc/release-notes/2.3.0.md-                    doc/release-notes/2.2.10.md-                    doc/release-notes/2.2.8.md-                    doc/release-notes/2.2.6.md-                    doc/release-notes/2.2.2.md-                    doc/release-notes/2.2.4.md-                    doc/release-notes/2.2.0.md--- Liang-Ting (2019-11-26): See Issues #4216---                    doc/user-manual.pdf-                    stack-8.0.2.yaml-                    stack-8.2.2.yaml-                    stack-8.4.4.yaml-                    stack-8.6.5.yaml-                    stack-8.8.4.yaml-                    stack-8.10.7.yaml-                    stack-9.0.1.yaml-                    stack-9.0.2.yaml-                    stack-9.2.1.yaml-                    stack-9.2.2.yaml--data-dir:           src/data-data-files:         emacs-mode/*.el-                    html/Agda.css-                    html/highlight-hover.js-                    JS/agda-rts.js-                    latex/agda.sty-                    latex/postprocess-latex.pl-                    lib/prim/Agda/Builtin/Bool.agda-                    lib/prim/Agda/Builtin/Char.agda-                    lib/prim/Agda/Builtin/Char/Properties.agda-                    lib/prim/Agda/Builtin/Coinduction.agda-                    lib/prim/Agda/Builtin/Cubical/Path.agda-                    lib/prim/Agda/Builtin/Cubical/Id.agda-                    lib/prim/Agda/Builtin/Cubical/Sub.agda-                    lib/prim/Agda/Builtin/Cubical/Glue.agda-                    lib/prim/Agda/Builtin/Cubical/HCompU.agda-                    lib/prim/Agda/Builtin/Equality.agda-                    lib/prim/Agda/Builtin/Equality/Erase.agda-                    lib/prim/Agda/Builtin/Equality/Rewrite.agda-                    lib/prim/Agda/Builtin/Float.agda-                    lib/prim/Agda/Builtin/Float/Properties.agda-                    lib/prim/Agda/Builtin/FromNat.agda-                    lib/prim/Agda/Builtin/FromNeg.agda-                    lib/prim/Agda/Builtin/FromString.agda-                    lib/prim/Agda/Builtin/IO.agda-                    lib/prim/Agda/Builtin/Int.agda-                    lib/prim/Agda/Builtin/List.agda-                    lib/prim/Agda/Builtin/Maybe.agda-                    lib/prim/Agda/Builtin/Nat.agda-                    lib/prim/Agda/Builtin/Reflection.agda-                    lib/prim/Agda/Builtin/Reflection/External.agda-                    lib/prim/Agda/Builtin/Reflection/Properties.agda-                    lib/prim/Agda/Builtin/Sigma.agda-                    lib/prim/Agda/Builtin/Size.agda-                    lib/prim/Agda/Builtin/Strict.agda-                    lib/prim/Agda/Builtin/String.agda-                    lib/prim/Agda/Builtin/String/Properties.agda-                    lib/prim/Agda/Builtin/TrustMe.agda-                    lib/prim/Agda/Builtin/Unit.agda-                    lib/prim/Agda/Builtin/Word.agda-                    lib/prim/Agda/Builtin/Word/Properties.agda-                    lib/prim/Agda/Primitive.agda-                    lib/prim/Agda/Primitive/Cubical.agda-                    MAlonzo/src/MAlonzo/*.hs-                    MAlonzo/src/MAlonzo/RTE/*.hs--source-repository head-  type:     git-  location: https://github.com/agda/agda.git--source-repository this-  type:     git-  location: https://github.com/agda/agda.git-  tag:      v2.6.2.2--flag cpphs-  default:     False-  manual:      True-  description: Use cpphs instead of cpp.--flag debug-  default: False-  manual: True-  description:-    Enable debugging features that may slow Agda down.--flag enable-cluster-counting-  default: False-  description:-    Enable the --count-clusters flag. (If enable-cluster-counting is-    False, then the --count-clusters flag triggers an error message.)--flag optimise-heavily-  default: False-  description:-    Enable some expensive optimisations when compiling Agda.--custom-setup-  setup-depends:  base >= 4.9.0.0 && < 4.17-                , Cabal >= 1.24.0.0 && < 3.7-                , directory >= 1.2.6.2 && < 1.4-                , filepath >= 1.4.1.0 && < 1.5-                , process >= 1.4.2.0 && < 1.7--library-  hs-source-dirs:   src/full--  if flag(cpphs)-    -- We don't write an upper bound for cpphs because the-    -- `build-tools` field can not be modified in Hackage.--    build-tools: cpphs >= 1.20.9-    ghc-options: -pgmP cpphs -optP --cpp--  if flag(debug)-    cpp-options:    -DDEBUG--  if flag(enable-cluster-counting)-    cpp-options:    -DCOUNT_CLUSTERS-    build-depends:  text-icu >= 0.7.1.0--  if os(windows)-    build-depends:  Win32 >= 2.3.1.1 && < 2.13--  -- Agda cannot be built with GHC 8.6.1 due to a compiler bug, see-  -- Agda Issue #3344.-  if impl(ghc == 8.6.1)-    buildable: False--  -- Agda cannot be built with Windows and GHC 8.6.3 due to a compiler-  -- bug, see Agda Issue #3657.-  if os(windows) && impl(ghc == 8.6.3)-    buildable: False--  build-depends:  aeson >= 1.1.2.0 && < 2.1-                , array >= 0.5.1.1 && < 0.6-                , async >= 2.2 && < 2.3-                , base >= 4.9.0.0 && < 4.17-                , binary >= 0.8.3.0 && < 0.9-                , blaze-html >= 0.8 && < 0.10-                , boxes >= 0.1.3 && < 0.2-                , bytestring >= 0.10.8.1 && < 0.12-                , case-insensitive >= 1.2.0.4 && < 1.3-                -- containers-0.5.11.0 is the first to contain IntSet.intersection-                , containers >= 0.5.11.0 && < 0.7-                , data-hash >= 0.2.0.0 && < 0.3-                , deepseq >= 1.4.2.0 && < 1.5-                , directory >= 1.2.6.2 && < 1.4-                , edit-distance >= 0.2.1.2 && < 0.3-                , equivalence >= 0.3.2 && < 0.5-                -- exceptions-0.8 instead of 0.10 because of stack-                , exceptions >= 0.8 && < 0.11-                , filepath >= 1.4.1.0 && < 1.5-                , gitrev >= 1.3.1 && < 2.0-                -- hashable 1.2.0.10 makes library-test 10x-                -- slower. The issue was fixed in hashable 1.2.1.0.-                -- https://github.com/tibbe/hashable/issues/57.-                , hashable >= 1.2.1.0 && < 1.5-                -- There is a "serious bug"-                -- (https://hackage.haskell.org/package/hashtables-1.2.0.2/changelog)-                -- in hashtables 1.2.0.0/1.2.0.1. This bug seems to-                -- have made Agda much slower (infinitely slower?) in-                -- some cases.-                , hashtables >= 1.2.0.2 && < 1.4-                , haskeline >= 0.7.2.3 && < 0.9-                -- monad-control-1.0.1.0 is the first to contain liftThrough-                , monad-control >= 1.0.1.0 && < 1.1-                -- mtl >= 2.2 && < 2.2.1 doesn't export Control.Monad.Except.-                -- Need mtl 2.2.2  for export of Control.Monad.IdentityT (ghc 8.2.2+)-                , mtl >= 2.2.1 && < 2.4-                , murmur-hash >= 0.1 && < 0.2-                , parallel >= 3.2.2.0 && < 3.3-                , pretty >= 1.1.3.3 && < 1.2-                , process >= 1.4.2.0 && < 1.7-                , regex-tdfa >= 1.3.1.0 && < 1.4-                , split >= 0.2.0.0 && < 0.2.4-                , stm >= 2.4.4 && < 2.6-                , strict >= 0.3.2 && < 0.5-                , template-haskell >= 2.11.0.0 && < 2.19-                , text >= 1.2.3.0 && < 2.1-                , time >= 1.6.0.1 && < 1.13-                , transformers >= 0.5 && < 0.7-                , unordered-containers >= 0.2.5.0 && < 0.3-                , uri-encode >= 1.5.0.4 && < 1.6-                , zlib == 0.6.*--  -- Andreas, 2022-02-02, issue #5659:-  -- Build failure with transformers-0.6.0.{0,1,2} and GHC 8.6.-  -- Transformers-0.6.0.3 might restored GHC 8.6 buildability.-  if impl(ghc == 8.6.*)-    build-depends: transformers < 0.6 || >= 0.6.0.3--  -- Andreas, 2021-03-10:-  -- All packages we depend upon should be mentioned in an unconditional-  -- build-depends field, but additional restrictions on their-  -- version for specific GHCs may be placed in conditionals.-  ---  -- The goal is to be able to make (e.g. when a new GHC comes out)-  -- revisions on hackage, e.g. relaxing upper bounds.  This process-  -- currently does not support revising conditionals.--  -- ASR (2018-10-16).-  -- text-1.2.3.0 required for supporting GHC 8.4.1, 8.4.2 and-  -- 8.4.3. See Issue #3277.-  -- The other GHC versions can be restricted to >= 1.2.3.1.-  if impl(ghc < 8.4.1) || impl(ghc > 8.4.3)-    build-depends: text >= 1.2.3.1--  if impl(ghc >= 8.4)-    build-depends: ghc-compact == 0.1.*--  -- We don't write upper bounds for Alex nor Happy because the-  -- `build-tools` field can not be modified in Hackage. Agda doesn't-  -- build with Alex 3.2.0 and segfaults with 3.2.2.-  build-tools:  alex >= 3.1.0 && < 3.2.0 || == 3.2.1 || >= 3.2.3-              , happy >= 1.19.4--  exposed-modules:  Agda.Auto.Auto-                    Agda.Auto.Options-                    Agda.Auto.CaseSplit-                    Agda.Auto.Convert-                    Agda.Auto.NarrowingSearch-                    Agda.Auto.SearchControl-                    Agda.Auto.Syntax-                    Agda.Auto.Typecheck-                    Agda.Benchmarking-                    Agda.Compiler.Backend-                    Agda.Compiler.Builtin-                    Agda.Compiler.CallCompiler-                    Agda.Compiler.Common-                    Agda.Compiler.JS.Compiler-                    Agda.Compiler.JS.Syntax-                    Agda.Compiler.JS.Substitution-                    Agda.Compiler.JS.Pretty-                    Agda.Compiler.MAlonzo.Coerce-                    Agda.Compiler.MAlonzo.Compiler-                    Agda.Compiler.MAlonzo.Encode-                    Agda.Compiler.MAlonzo.HaskellTypes-                    Agda.Compiler.MAlonzo.Misc-                    Agda.Compiler.MAlonzo.Pragmas-                    Agda.Compiler.MAlonzo.Pretty-                    Agda.Compiler.MAlonzo.Primitives-                    Agda.Compiler.MAlonzo.Strict-                    Agda.Compiler.ToTreeless-                    Agda.Compiler.Treeless.AsPatterns-                    Agda.Compiler.Treeless.Builtin-                    Agda.Compiler.Treeless.Compare-                    Agda.Compiler.Treeless.EliminateDefaults-                    Agda.Compiler.Treeless.EliminateLiteralPatterns-                    Agda.Compiler.Treeless.Erase-                    Agda.Compiler.Treeless.GuardsToPrims-                    Agda.Compiler.Treeless.Identity-                    Agda.Compiler.Treeless.NormalizeNames-                    Agda.Compiler.Treeless.Pretty-                    Agda.Compiler.Treeless.Simplify-                    Agda.Compiler.Treeless.Subst-                    Agda.Compiler.Treeless.Uncase-                    Agda.Compiler.Treeless.Unused-                    Agda.ImpossibleTest-                    Agda.Interaction.AgdaTop-                    Agda.Interaction.Base-                    Agda.Interaction.BasicOps-                    Agda.Interaction.SearchAbout-                    Agda.Interaction.CommandLine-                    Agda.Interaction.EmacsCommand-                    Agda.Interaction.EmacsTop-                    Agda.Interaction.ExitCode-                    Agda.Interaction.JSONTop-                    Agda.Interaction.JSON-                    Agda.Interaction.FindFile-                    Agda.Interaction.Highlighting.Common-                    Agda.Interaction.Highlighting.Dot-                    Agda.Interaction.Highlighting.Emacs-                    Agda.Interaction.Highlighting.FromAbstract-                    Agda.Interaction.Highlighting.Generate-                    Agda.Interaction.Highlighting.HTML-                    Agda.Interaction.Highlighting.JSON-                    Agda.Interaction.Highlighting.Precise-                    Agda.Interaction.Highlighting.Range-                    Agda.Interaction.Highlighting.Vim-                    Agda.Interaction.Highlighting.LaTeX-                    Agda.Interaction.Imports-                    Agda.Interaction.InteractionTop-                    Agda.Interaction.Response-                    Agda.Interaction.MakeCase-                    Agda.Interaction.Monad-                    Agda.Interaction.Library-                    Agda.Interaction.Library.Base-                    Agda.Interaction.Library.Parse-                    Agda.Interaction.Options-                    Agda.Interaction.Options.Help-                    Agda.Interaction.Options.Lenses-                    Agda.Interaction.Options.Warnings-                    Agda.Main-                    Agda.Syntax.Abstract.Name-                    Agda.Syntax.Abstract.Pattern-                    Agda.Syntax.Abstract.PatternSynonyms-                    Agda.Syntax.Abstract.Pretty-                    Agda.Syntax.Abstract.Views-                    Agda.Syntax.Abstract-                    Agda.Syntax.Builtin-                    Agda.Syntax.Common-                    Agda.Syntax.Concrete.Attribute-                    Agda.Syntax.Concrete.Definitions-                    Agda.Syntax.Concrete.Definitions.Errors-                    Agda.Syntax.Concrete.Definitions.Monad-                    Agda.Syntax.Concrete.Definitions.Types-                    Agda.Syntax.Concrete.Fixity-                    Agda.Syntax.Concrete.Generic-                    Agda.Syntax.Concrete.Glyph-                    Agda.Syntax.Concrete.Name-                    Agda.Syntax.Concrete.Operators.Parser-                    Agda.Syntax.Concrete.Operators.Parser.Monad-                    Agda.Syntax.Concrete.Operators-                    Agda.Syntax.Concrete.Pattern-                    Agda.Syntax.Concrete.Pretty-                    Agda.Syntax.Concrete-                    Agda.Syntax.DoNotation-                    Agda.Syntax.Fixity-                    Agda.Syntax.IdiomBrackets-                    Agda.Syntax.Info-                    Agda.Syntax.Internal-                    Agda.Syntax.Internal.Blockers-                    Agda.Syntax.Internal.Defs-                    Agda.Syntax.Internal.Elim-                    Agda.Syntax.Internal.Generic-                    Agda.Syntax.Internal.MetaVars-                    Agda.Syntax.Internal.Names-                    Agda.Syntax.Internal.Pattern-                    Agda.Syntax.Internal.SanityCheck-                    Agda.Syntax.Literal-                    Agda.Syntax.Notation-                    Agda.Syntax.Parser.Alex-                    Agda.Syntax.Parser.Comments-                    Agda.Syntax.Parser.Layout-                    Agda.Syntax.Parser.LexActions-                    Agda.Syntax.Parser.Lexer-                    Agda.Syntax.Parser.Literate-                    Agda.Syntax.Parser.LookAhead-                    Agda.Syntax.Parser.Monad-                    Agda.Syntax.Parser.Parser-                    Agda.Syntax.Parser.StringLiterals-                    Agda.Syntax.Parser.Tokens-                    Agda.Syntax.Parser-                    Agda.Syntax.Position-                    Agda.Syntax.Reflected-                    Agda.Syntax.Scope.Base-                    Agda.Syntax.Scope.Monad-                    Agda.Syntax.Translation.AbstractToConcrete-                    Agda.Syntax.Translation.ConcreteToAbstract-                    Agda.Syntax.Translation.InternalToAbstract-                    Agda.Syntax.Translation.ReflectedToAbstract-                    Agda.Syntax.Treeless-                    Agda.Termination.CallGraph-                    Agda.Termination.CallMatrix-                    Agda.Termination.CutOff-                    Agda.Termination.Monad-                    Agda.Termination.Order-                    Agda.Termination.RecCheck-                    Agda.Termination.SparseMatrix-                    Agda.Termination.Semiring-                    Agda.Termination.TermCheck-                    Agda.Termination.Termination-                    Agda.TheTypeChecker-                    Agda.TypeChecking.Abstract-                    Agda.TypeChecking.CheckInternal-                    Agda.TypeChecking.CompiledClause-                    Agda.TypeChecking.CompiledClause.Compile-                    Agda.TypeChecking.CompiledClause.Match-                    Agda.TypeChecking.Constraints-                    Agda.TypeChecking.Conversion-                    Agda.TypeChecking.Conversion.Pure-                    Agda.TypeChecking.Coverage-                    Agda.TypeChecking.Coverage.Match-                    Agda.TypeChecking.Coverage.SplitTree-                    Agda.TypeChecking.Datatypes-                    Agda.TypeChecking.DeadCode-                    Agda.TypeChecking.DisplayForm-                    Agda.TypeChecking.DropArgs-                    Agda.TypeChecking.Empty-                    Agda.TypeChecking.EtaContract-                    Agda.TypeChecking.EtaExpand-                    Agda.TypeChecking.Errors-                    Agda.TypeChecking.Free-                    Agda.TypeChecking.Free.Lazy-                    Agda.TypeChecking.Free.Precompute-                    Agda.TypeChecking.Free.Reduce-                    Agda.TypeChecking.Forcing-                    Agda.TypeChecking.Functions-                    Agda.TypeChecking.Generalize-                    Agda.TypeChecking.IApplyConfluence-                    Agda.TypeChecking.Implicit-                    Agda.TypeChecking.Injectivity-                    Agda.TypeChecking.Inlining-                    Agda.TypeChecking.InstanceArguments-                    Agda.TypeChecking.Irrelevance-                    Agda.TypeChecking.Level-                    Agda.TypeChecking.LevelConstraints-                    Agda.TypeChecking.Lock-                    Agda.TypeChecking.Level.Solve-                    Agda.TypeChecking.MetaVars-                    Agda.TypeChecking.MetaVars.Mention-                    Agda.TypeChecking.MetaVars.Occurs-                    Agda.TypeChecking.Monad.Base-                    Agda.TypeChecking.Monad.Benchmark-                    Agda.TypeChecking.Monad.Builtin-                    Agda.TypeChecking.Monad.Caching-                    Agda.TypeChecking.Monad.Closure-                    Agda.TypeChecking.Monad.Constraints-                    Agda.TypeChecking.Monad.Context-                    Agda.TypeChecking.Monad.Debug-                    Agda.TypeChecking.Monad.Env-                    Agda.TypeChecking.Monad.Imports-                    Agda.TypeChecking.Monad.MetaVars-                    Agda.TypeChecking.Monad.Mutual-                    Agda.TypeChecking.Monad.Open-                    Agda.TypeChecking.Monad.Options-                    Agda.TypeChecking.Monad.Pure-                    Agda.TypeChecking.Monad.Signature-                    Agda.TypeChecking.Monad.SizedTypes-                    Agda.TypeChecking.Monad.State-                    Agda.TypeChecking.Monad.Statistics-                    Agda.TypeChecking.Monad.Trace-                    Agda.TypeChecking.Monad-                    Agda.TypeChecking.Names-                    Agda.TypeChecking.Patterns.Abstract-                    Agda.TypeChecking.Patterns.Internal-                    Agda.TypeChecking.Patterns.Match-                    Agda.TypeChecking.Polarity-                    Agda.TypeChecking.Positivity-                    Agda.TypeChecking.Positivity.Occurrence-                    Agda.TypeChecking.Pretty-                    Agda.TypeChecking.Pretty.Call-                    Agda.TypeChecking.Pretty.Constraint-                    Agda.TypeChecking.Pretty.Warning-                    Agda.TypeChecking.Primitive-                    Agda.TypeChecking.Primitive.Base-                    Agda.TypeChecking.Primitive.Cubical-                    Agda.TypeChecking.ProjectionLike-                    Agda.TypeChecking.Quote-                    Agda.TypeChecking.ReconstructParameters-                    Agda.TypeChecking.RecordPatterns-                    Agda.TypeChecking.Records-                    Agda.TypeChecking.Reduce-                    Agda.TypeChecking.Reduce.Fast-                    Agda.TypeChecking.Reduce.Monad-                    Agda.TypeChecking.Rewriting-                    Agda.TypeChecking.Rewriting.Clause-                    Agda.TypeChecking.Rewriting.Confluence-                    Agda.TypeChecking.Rewriting.NonLinMatch-                    Agda.TypeChecking.Rewriting.NonLinPattern-                    Agda.TypeChecking.Rules.Application-                    Agda.TypeChecking.Rules.Builtin-                    Agda.TypeChecking.Rules.Builtin.Coinduction-                    Agda.TypeChecking.Rules.Data-                    Agda.TypeChecking.Rules.Decl-                    Agda.TypeChecking.Rules.Def-                    Agda.TypeChecking.Rules.Display-                    Agda.TypeChecking.Rules.LHS-                    Agda.TypeChecking.Rules.LHS.Implicit-                    Agda.TypeChecking.Rules.LHS.Problem-                    Agda.TypeChecking.Rules.LHS.ProblemRest-                    Agda.TypeChecking.Rules.LHS.Unify-                    Agda.TypeChecking.Rules.Record-                    Agda.TypeChecking.Rules.Term-                    Agda.TypeChecking.Serialise-                    Agda.TypeChecking.Serialise.Base-                    Agda.TypeChecking.Serialise.Instances-                    Agda.TypeChecking.Serialise.Instances.Abstract-                    Agda.TypeChecking.Serialise.Instances.Common-                    Agda.TypeChecking.Serialise.Instances.Compilers-                    Agda.TypeChecking.Serialise.Instances.Highlighting-                    Agda.TypeChecking.Serialise.Instances.Internal-                    Agda.TypeChecking.Serialise.Instances.Errors-                    Agda.TypeChecking.SizedTypes-                    Agda.TypeChecking.SizedTypes.Solve-                    Agda.TypeChecking.SizedTypes.Syntax-                    Agda.TypeChecking.SizedTypes.Utils-                    Agda.TypeChecking.SizedTypes.WarshallSolver-                    Agda.TypeChecking.Sort-                    Agda.TypeChecking.Substitute-                    Agda.TypeChecking.Substitute.Class-                    Agda.TypeChecking.Substitute.DeBruijn-                    Agda.TypeChecking.SyntacticEquality-                    Agda.TypeChecking.Telescope-                    Agda.TypeChecking.Telescope.Path-                    Agda.TypeChecking.Unquote-                    Agda.TypeChecking.Warnings-                    Agda.TypeChecking.With-                    Agda.Utils.AffineHole-                    Agda.Utils.Applicative-                    Agda.Utils.AssocList-                    Agda.Utils.Bag-                    Agda.Utils.Benchmark-                    Agda.Utils.BiMap-                    Agda.Utils.CallStack-                    Agda.Utils.Char-                    Agda.Utils.Cluster-                    Agda.Utils.Empty-                    Agda.Utils.Environment-                    Agda.Utils.Either-                    Agda.Utils.Fail-                    Agda.Utils.Favorites-                    Agda.Utils.FileName-                    Agda.Utils.Float-                    Agda.Utils.Functor-                    Agda.Utils.Function-                    Agda.Utils.Graph.AdjacencyMap.Unidirectional-                    Agda.Utils.Graph.TopSort-                    Agda.Utils.Hash-                    Agda.Utils.Haskell.Syntax-                    Agda.Utils.Impossible-                    Agda.Utils.IndexedList-                    Agda.Utils.IntSet.Infinite-                    Agda.Utils.IO-                    Agda.Utils.IO.Binary-                    Agda.Utils.IO.Directory-                    Agda.Utils.IO.TempFile-                    Agda.Utils.IO.UTF8-                    Agda.Utils.IORef-                    Agda.Utils.Lens-                    Agda.Utils.Lens.Examples-                    Agda.Utils.List-                    Agda.Utils.List1-                    Agda.Utils.List2-                    Agda.Utils.ListT-                    Agda.Utils.Map-                    Agda.Utils.Maybe-                    Agda.Utils.Maybe.Strict-                    Agda.Utils.Memo-                    Agda.Utils.Monad-                    Agda.Utils.Monoid-                    Agda.Utils.Null-                    Agda.Utils.Parser.MemoisedCPS-                    Agda.Utils.PartialOrd-                    Agda.Utils.Permutation-                    Agda.Utils.Pointer-                    Agda.Utils.POMonoid-                    Agda.Utils.Pretty-                    Agda.Utils.RangeMap-                    Agda.Utils.SemiRing-                    Agda.Utils.Semigroup-                    Agda.Utils.Singleton-                    Agda.Utils.Size-                    Agda.Utils.SmallSet-                    Agda.Utils.String-                    Agda.Utils.Suffix-                    Agda.Utils.Three-                    Agda.Utils.Time-                    Agda.Utils.Trie-                    Agda.Utils.Tuple-                    Agda.Utils.TypeLevel-                    Agda.Utils.TypeLits-                    Agda.Utils.Update-                    Agda.Utils.VarSet-                    Agda.Utils.Warshall-                    Agda.Utils.WithDefault-                    Agda.Utils.Zipper-                    Agda.Version-                    Agda.VersionCommit--  other-modules:    Paths_Agda-                    Agda.Interaction.Highlighting.Dot.Backend-                    Agda.Interaction.Highlighting.Dot.Base-                    Agda.Interaction.Highlighting.HTML.Backend-                    Agda.Interaction.Highlighting.HTML.Base-                    Agda.Interaction.Highlighting.LaTeX.Backend-                    Agda.Interaction.Highlighting.LaTeX.Base-                    Agda.Interaction.Options.Base-                    Agda.Interaction.Options.HasOptions-                    Agda.Utils.CallStack.Base-                    Agda.Utils.CallStack.Pretty--  if flag(optimise-heavily)-    ghc-options: -fexpose-all-unfoldings-                 -fspecialise-aggressively--  -- NOTE: If adding flags, also add to `.ghci-8.0`-  if impl(ghc <= 8.0.2)-    ghc-options: -fprint-potential-instances-                 -- Initially, we disable all the warnings.-                 -w-                 -Wwarn-                 -- This option must be the first one after disabling the-                 -- warnings. See Issue #2094.-                 -Wunrecognised-warning-flags-                 -Wdeprecated-flags-                 -Wderiving-typeable-                 -Wdodgy-exports-                 -Wdodgy-foreign-imports-                 -Wdodgy-imports-                 -Wduplicate-exports-                 -Wempty-enumerations-                 -Widentities-                 -Wincomplete-patterns-                 -Winline-rule-shadowing-                 -Wmissing-fields-                 -Wmissing-methods-                 -Wmissing-pattern-synonym-signatures-                 -Wmissing-signatures-                 -Wnoncanonical-monad-instances-                 -Wnoncanonical-monoid-instances-                 -Woverflowed-literals-                 -Woverlapping-patterns-                 -Wsemigroup-                 -Wtabs-                 -Wtyped-holes-                 -Wunrecognised-pragmas-                 -Wunticked-promoted-constructors-                 -Wunused-do-bind-                 -Wunused-foralls-                 -Wwarnings-deprecations-                 -Wwrong-do-bind-  else-    ghc-options: -fprint-potential-instances-                 -Wwarn=unrecognised-warning-flags-                 -Wwarn=deprecated-flags-                 -Wwarn=deriving-typeable-                 -Wwarn=dodgy-exports-                 -Wwarn=dodgy-foreign-imports-                 -Wwarn=dodgy-imports-                 -Wwarn=duplicate-exports-                 -Wwarn=empty-enumerations-                 -Wwarn=identities-                 -Wwarn=incomplete-patterns-                 -Wwarn=inline-rule-shadowing-                 -Wwarn=missing-fields-                 -Wwarn=missing-methods-                 -Wwarn=missing-pattern-synonym-signatures-                 -Wwarn=missing-signatures-                 -Wwarn=noncanonical-monad-instances-                 -Wwarn=noncanonical-monoid-instances-                 -Wwarn=overflowed-literals-                 -Wwarn=overlapping-patterns-                 -Wwarn=semigroup-                 -Wwarn=tabs-                 -Wwarn=typed-holes-                 -Wwarn=unrecognised-pragmas-                 -Wwarn=unticked-promoted-constructors-                 -Wwarn=unused-do-bind-                 -Wwarn=unused-foralls-                 -Wwarn=warnings-deprecations-                 -Wwarn=wrong-do-bind--  -- NOTE: If adding or removing flags, also change `.ghci-8.2`-  if impl(ghc >= 8.2)-    ghc-options: -Wcpp-undef-                 -- ASR TODO (2017-07-23): `make haddock` fails when-                 -- this flag is on.-                 -- -Wmissing-home-modules-                 -Wwarn=simplifiable-class-constraints-                 -Wwarn=unbanged-strict-patterns--  -- NOTE: If adding or removing flags, also change `.ghci-8.6`-  if impl(ghc >= 8.6)-    ghc-options: -Wwarn=inaccessible-code-                 -Wwarn=star-binder-                 -Wwarn=star-is-type--  -- The following warning is an error in GHC >= 8.10.-  if impl(ghc >= 8.6) && impl(ghc < 8.10)-    ghc-options: -Wwarn=implicit-kind-vars--  -- NOTE: If adding or removing flags, also change `.ghci-8.8`-  if impl(ghc >= 8.8)-    ghc-options: -Wwarn=missed-extra-shared-lib--  -- NOTE: If adding or removing flags, also change `.ghci-8.10`-  if impl(ghc >= 8.10)-    ghc-options: -Wwarn=deriving-defaults-                 -Wwarn=redundant-record-wildcards-                 -Wwarn=unused-packages-                 -Wwarn=unused-record-wildcards--  -- NOTE: If adding or removing flags, also change `.ghci-9.0`-  if impl(ghc >= 9.0)-    ghc-options: -Wwarn=invalid-haddock--  default-language: Haskell2010--  -- NOTE: If adding or removing default extensions, also change:-  --         .ghci-8.0-  --         .hlint.yaml-  -- This should also use the same extensions as the `test-suite` target below.-  default-extensions: BangPatterns-                    , ConstraintKinds-                    --L-T Chen (2019-07-15):-                    -- Enabling DataKinds only locally makes the compile time-                    -- slightly shorter, see PR #3920.-                    --, DataKinds-                    , DefaultSignatures-                    , DeriveDataTypeable-                    , DeriveFoldable-                    , DeriveFunctor-                    , DeriveGeneric-                    , DeriveTraversable-                    , ExistentialQuantification-                    , FlexibleContexts-                    , FlexibleInstances-                    , FunctionalDependencies-                    , GeneralizedNewtypeDeriving-                    , InstanceSigs-                    , LambdaCase-                    , MultiParamTypeClasses-                    , MultiWayIf-                    , NamedFieldPuns-                    , OverloadedStrings-                    , PatternSynonyms-                    , RankNTypes-                    , RecordWildCards-                    , ScopedTypeVariables-                    , StandaloneDeriving-                    , TupleSections-                    , TypeFamilies-                    , TypeSynonymInstances--executable agda-  hs-source-dirs: src/main-  main-is:        Main.hs-  build-depends:  Agda-                  -- A version range on Agda generates a warning with-                  -- some versions of Cabal and GHC-                  -- (e.g. cabal-install version 1.24.0.2 compiled-                  -- using version 1.24.2.0 of the Cabal library and-                  -- GHC 8.2.1 RC1).--                  -- Nothing is used from the following package,-                  -- except for the Prelude.-                , base-  default-language: Haskell2010-  -- If someone installs Agda with the setuid bit set, then the-  -- presence of +RTS may be a security problem (see GHC bug #3910).-  -- However, we sometimes recommend people to use +RTS to control-  -- Agda's memory usage, so we want this functionality enabled by-  -- default.--  -- The threaded RTS by default starts a major GC after a program has-  -- been idle for 0.3 s. This feature turned out to be annoying, so-  -- the idle GC is now by default turned off (-I0).-  ghc-options: -threaded -rtsopts-               "-with-rtsopts=-M3.5G -I0"--executable agda-mode-  hs-source-dirs:   src/agda-mode-  main-is:          Main.hs-  other-modules:    Paths_Agda-  build-depends:    base >= 4.9.0.0 && < 4.17-                  , directory >= 1.2.6.2 && < 1.4-                  , filepath >= 1.4.1.0 && < 1.5-                  , process >= 1.4.2.0 && < 1.7-  default-language: Haskell2010+cabal-version:   2.4+name:            Agda+version:         2.8.0+build-type:      Simple+license:         MIT+license-file:    LICENSE+copyright:       (c) 2005-2025 The Agda Team.+author:          The Agda Team, see https://agda.readthedocs.io/en/latest/team.html+maintainer:      The Agda Team+homepage:        https://wiki.portal.chalmers.se/agda/+bug-reports:     https://github.com/agda/agda/issues+category:        Dependent types+synopsis:        A dependently typed functional programming language and proof assistant+description:+    Agda is a dependently typed functional programming language: It has+    inductive families, which are similar to Haskell's GADTs, but they+    can be indexed by values and not just types. It also has+    parameterised modules, mixfix operators, Unicode characters, and an+    interactive Emacs interface (the type checker can assist in the+    development of your code).+    .+    Agda is also a proof assistant: It is an interactive system for+    writing and checking proofs. Agda is based on intuitionistic type+    theory, a foundational system for constructive mathematics developed+    by the Swedish logician Per Martin-L&#xf6;f. It has many+    similarities with other proof assistants based on dependent types,+    such as Rocq (formerly known as Coq), Idris, Lean and NuPRL.+    .+    This package includes both a command-line program (agda) and an+    Emacs mode.++tested-with:+    GHC == 9.12.2+    GHC == 9.10.2+    GHC == 9.8.4+    GHC == 9.6.7+    GHC == 9.4.8+    GHC == 9.2.8+    GHC == 9.0.2+    GHC == 8.10.7+    GHC == 8.8.4++extra-doc-files:+    CHANGELOG.md+    README.md+    doc/user-manual/agda.svg+    doc/release-notes/2.7.0.1.md+    doc/release-notes/2.7.0.md+    doc/release-notes/2.6.4.3.md+    doc/release-notes/2.6.4.2.md+    doc/release-notes/2.6.4.1.md+    doc/release-notes/2.6.4.md+    doc/release-notes/2.6.3.md+    doc/release-notes/2.6.2.2.md+    doc/release-notes/2.6.2.1.md+    doc/release-notes/2.6.2.md+    doc/release-notes/2.6.1.3.md+    doc/release-notes/2.6.1.2.md+    doc/release-notes/2.6.1.1.md+    doc/release-notes/2.6.1.md+    doc/release-notes/2.6.0.1.md+    doc/release-notes/2.6.0.md+    doc/release-notes/2.5.4.2.md+    doc/release-notes/2.5.4.1.md+    doc/release-notes/2.5.4.md+    doc/release-notes/2.5.3.md+    doc/release-notes/2.5.2.md+    doc/release-notes/2.5.1.2.md+    doc/release-notes/2.5.1.1.md+    doc/release-notes/2.5.1.md+    doc/release-notes/2.4.2.5.md+    doc/release-notes/2.4.2.4.md+    doc/release-notes/2.4.2.3.md+    doc/release-notes/2.4.2.2.md+    doc/release-notes/2.4.2.1.md+    doc/release-notes/2.4.2.md+    doc/release-notes/2.4.0.2.md+    doc/release-notes/2.4.0.1.md+    doc/release-notes/2.4.0.md+    doc/release-notes/2.3.2.2.md+    doc/release-notes/2.3.2.1.md+    doc/release-notes/2.3.2.md+    doc/release-notes/2.3.0.md+    doc/release-notes/2.2.10.md+    doc/release-notes/2.2.8.md+    doc/release-notes/2.2.6.md+    doc/release-notes/2.2.2.md+    doc/release-notes/2.2.4.md+    doc/release-notes/2.2.0.md++extra-source-files:+    stack-9.12.2.yaml+    stack-9.10.2.yaml+    stack-9.8.4.yaml+    stack-9.6.7.yaml+    stack-9.4.8.yaml+    stack-9.2.8.yaml+    stack-9.0.2.yaml+    stack-8.10.7.yaml+    stack-8.8.4.yaml+    -- Agda's data files, embedded by module Agda.Setup.+    -- Keep in sync with the list in Agda.Setup.DataFiles and below.+    src/data/emacs-mode/agda-input.el+    src/data/emacs-mode/agda2-abbrevs.el+    src/data/emacs-mode/agda2-highlight.el+    src/data/emacs-mode/agda2-mode-pkg.el+    src/data/emacs-mode/agda2-mode.el+    src/data/emacs-mode/agda2-queue.el+    src/data/emacs-mode/agda2.el+    src/data/emacs-mode/annotation.el+    src/data/emacs-mode/eri.el+    src/data/html/Agda.css+    src/data/html/highlight-hover.js+    src/data/JS/agda-rts.mjs+    src/data/JS/agda-rts.js+    src/data/JS/agda-rts.amd.js+    src/data/latex/agda.sty+    src/data/latex/postprocess-latex.pl+    src/data/lib/prim/agda-builtins.agda-lib+    src/data/lib/prim/Agda/Builtin/Bool.agda+    src/data/lib/prim/Agda/Builtin/Char.agda+    src/data/lib/prim/Agda/Builtin/Char/Properties.agda+    src/data/lib/prim/Agda/Builtin/Coinduction.agda+    src/data/lib/prim/Agda/Builtin/Cubical/Path.agda+    src/data/lib/prim/Agda/Builtin/Cubical/Sub.agda+    src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda+    src/data/lib/prim/Agda/Builtin/Cubical/Equiv.agda+    src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda+    src/data/lib/prim/Agda/Builtin/Equality.agda+    src/data/lib/prim/Agda/Builtin/Equality/Erase.agda+    src/data/lib/prim/Agda/Builtin/Equality/Rewrite.agda+    src/data/lib/prim/Agda/Builtin/Float.agda+    src/data/lib/prim/Agda/Builtin/Float/Properties.agda+    src/data/lib/prim/Agda/Builtin/FromNat.agda+    src/data/lib/prim/Agda/Builtin/FromNeg.agda+    src/data/lib/prim/Agda/Builtin/FromString.agda+    src/data/lib/prim/Agda/Builtin/IO.agda+    src/data/lib/prim/Agda/Builtin/Int.agda+    src/data/lib/prim/Agda/Builtin/List.agda+    src/data/lib/prim/Agda/Builtin/Maybe.agda+    src/data/lib/prim/Agda/Builtin/Nat.agda+    src/data/lib/prim/Agda/Builtin/Reflection.agda+    src/data/lib/prim/Agda/Builtin/Reflection/External.agda+    src/data/lib/prim/Agda/Builtin/Reflection/Properties.agda+    src/data/lib/prim/Agda/Builtin/Sigma.agda+    src/data/lib/prim/Agda/Builtin/Size.agda+    src/data/lib/prim/Agda/Builtin/Strict.agda+    src/data/lib/prim/Agda/Builtin/String.agda+    src/data/lib/prim/Agda/Builtin/String/Properties.agda+    src/data/lib/prim/Agda/Builtin/TrustMe.agda+    src/data/lib/prim/Agda/Builtin/Unit.agda+    src/data/lib/prim/Agda/Builtin/Word.agda+    src/data/lib/prim/Agda/Builtin/Word/Properties.agda+    src/data/lib/prim/Agda/Primitive.agda+    src/data/lib/prim/Agda/Primitive/Cubical.agda+    src/data/MAlonzo/src/MAlonzo/RTE.hs+    src/data/MAlonzo/src/MAlonzo/RTE/Float.hs++data-dir: src/data+data-files:+    emacs-mode/agda-input.el+    emacs-mode/agda2-abbrevs.el+    emacs-mode/agda2-highlight.el+    emacs-mode/agda2-mode-pkg.el+    emacs-mode/agda2-mode.el+    emacs-mode/agda2-queue.el+    emacs-mode/agda2.el+    emacs-mode/annotation.el+    emacs-mode/eri.el+    html/Agda.css+    html/highlight-hover.js+    JS/agda-rts.mjs+    JS/agda-rts.js+    JS/agda-rts.amd.js+    latex/agda.sty+    latex/postprocess-latex.pl+    lib/prim/agda-builtins.agda-lib+    lib/prim/Agda/Builtin/Bool.agda+    lib/prim/Agda/Builtin/Char.agda+    lib/prim/Agda/Builtin/Char/Properties.agda+    lib/prim/Agda/Builtin/Coinduction.agda+    lib/prim/Agda/Builtin/Cubical/Path.agda+    lib/prim/Agda/Builtin/Cubical/Sub.agda+    lib/prim/Agda/Builtin/Cubical/Glue.agda+    lib/prim/Agda/Builtin/Cubical/Equiv.agda+    lib/prim/Agda/Builtin/Cubical/HCompU.agda+    lib/prim/Agda/Builtin/Equality.agda+    lib/prim/Agda/Builtin/Equality/Erase.agda+    lib/prim/Agda/Builtin/Equality/Rewrite.agda+    lib/prim/Agda/Builtin/Float.agda+    lib/prim/Agda/Builtin/Float/Properties.agda+    lib/prim/Agda/Builtin/FromNat.agda+    lib/prim/Agda/Builtin/FromNeg.agda+    lib/prim/Agda/Builtin/FromString.agda+    lib/prim/Agda/Builtin/IO.agda+    lib/prim/Agda/Builtin/Int.agda+    lib/prim/Agda/Builtin/List.agda+    lib/prim/Agda/Builtin/Maybe.agda+    lib/prim/Agda/Builtin/Nat.agda+    lib/prim/Agda/Builtin/Reflection.agda+    lib/prim/Agda/Builtin/Reflection/External.agda+    lib/prim/Agda/Builtin/Reflection/Properties.agda+    lib/prim/Agda/Builtin/Sigma.agda+    lib/prim/Agda/Builtin/Size.agda+    lib/prim/Agda/Builtin/Strict.agda+    lib/prim/Agda/Builtin/String.agda+    lib/prim/Agda/Builtin/String/Properties.agda+    lib/prim/Agda/Builtin/TrustMe.agda+    lib/prim/Agda/Builtin/Unit.agda+    lib/prim/Agda/Builtin/Word.agda+    lib/prim/Agda/Builtin/Word/Properties.agda+    lib/prim/Agda/Primitive.agda+    lib/prim/Agda/Primitive/Cubical.agda+    MAlonzo/src/MAlonzo/RTE.hs+    MAlonzo/src/MAlonzo/RTE/Float.hs++source-repository head+  type:     git+  location: https://github.com/agda/agda.git++source-repository this+  type:     git+  location: https://github.com/agda/agda.git+  tag:      v2.8.0++-- Build flags+---------------------------------------------------------------------------++flag dump-core+  default: False+  manual: True+  description: Write GHC core output.++flag debug+  default: False+  manual: True+  description:+    Enable debug printing. This makes Agda slightly slower, and+    building Agda slower as well. The --verbose=N option only+    has an effect when Agda was built with this flag.++flag debug-serialisation+  default: False+  manual: True+  description:+    Enable debug mode in serialisation. This makes serialisation slower.++flag debug-parsing+  default: False+  manual: True+  description:+    Enable debug mode in parsing. This makes parsing slower.++flag enable-cluster-counting+  default: False+  manual: True+  description:+    Enable the --count-clusters flag. (If enable-cluster-counting is+    False, then the --count-clusters flag triggers an error message.)++flag optimise-heavily+  default: True+  manual: True+  description:+    Enable some expensive optimisations when compiling Agda.++flag use-xdg-data-home+  default: False+  manual: True+  description:+    Install data files under $XDG_DATA_HOME\/agda\/$AGDA_VERSION by default+    instead of the installation location defined by Cabal.+    This should not be enabled in declarative build environments like Nix or Guix.++-- Common stanzas+---------------------------------------------------------------------------++common language++  if flag(optimise-heavily)+    cpp-options:+      -DOPTIMISE_HEAVILY+    ghc-options:+      -fexpose-all-unfoldings+      -fspecialise-aggressively++  if flag(use-xdg-data-home)+    cpp-options:+      -DUSE_XDG_DATA_HOME++  if flag(dump-core)+    ghc-options:+      -dsuppress-coercions -ddump-simpl -dsuppress-idinfo+      -dsuppress-type-applications -dsuppress-uniques+      -dsuppress-module-prefixes -ddump-to-file++  ghc-options:+      -- ASR (2022-05-31). Workaround to Issue #5932.+      -Wwarn+      -Wwarn=cpp-undef+      -Wwarn=deprecated-flags+      -Wwarn=deriving-typeable+      -Wwarn=dodgy-exports+      -Wwarn=dodgy-foreign-imports+      -Wwarn=dodgy-imports+      -Wwarn=duplicate-exports+      -Wwarn=empty-enumerations+      -Wwarn=identities+      -Wwarn=inaccessible-code+      -Wwarn=inline-rule-shadowing+      -Wwarn=missed-extra-shared-lib+      -Wwarn=missing-fields+      -Wwarn=missing-home-modules+      -Wwarn=missing-methods+      -Wwarn=missing-pattern-synonym-signatures+      -Wwarn=missing-signatures+      -Wwarn=noncanonical-monad-instances+      -Wwarn=noncanonical-monoid-instances+      -Wwarn=overflowed-literals+      -Wwarn=overlapping-patterns+--      -Wwarn=redundant-constraints+      -Wwarn=simplifiable-class-constraints+      -Wwarn=star-binder+      -Wwarn=star-is-type+      -Wwarn=tabs+      -Wwarn=typed-holes+      -Wwarn=unbanged-strict-patterns+      -Wwarn=unrecognised-pragmas+      -Wwarn=unrecognised-warning-flags+      -Wwarn=unticked-promoted-constructors+      -Wwarn=unused-do-bind+      -Wwarn=unused-foralls+      -Wwarn=warnings-deprecations+      -Wwarn=wrong-do-bind++  -- The following warning is an error in GHC >= 8.10.+  if impl(ghc < 8.10)+    ghc-options:+      -Wwarn=implicit-kind-vars+      -- #6623: Turn off this (nameless) warning:+      -- "Pattern match checker exceeded (2000000) iterations in a case alternative."+      -- See: https://gitlab.haskell.org/ghc/ghc/-/issues/13464+      -Wno-incomplete-patterns+      -Wno-overlapping-patterns++  if impl(ghc < 9.10)+    ghc-options:+      -Wwarn=semigroup+        -- The semigroup warning is deprecated in GHC 9.10++  if impl(ghc >= 8.10)+    ghc-options:+      -Wwarn=deriving-defaults+      -Wwarn=redundant-record-wildcards+      -Wwarn=unused-packages+      -Wwarn=unused-record-wildcards++  if impl(ghc >= 9.0)+    ghc-options:+      -Wwarn=invalid-haddock+      -- #6137: coverage checker works only sufficiently well from GHC 9.0+      -Wwarn=incomplete-patterns+      -Wwarn=incomplete-record-updates+      -Wwarn=overlapping-patterns++  -- ASR (2022-04-27). This warning was added in GHC 9.0.2, removed+  -- from 9.2.1 and added back in 9.2.2.+  if impl(ghc == 9.0.2 || >= 9.2.2)+    ghc-options:+      -Wwarn=unicode-bidirectional-format-characters++  if impl(ghc >= 9.2)+    ghc-options:+      -Wwarn=operator-whitespace+      -Wwarn=redundant-bang-patterns++  if impl(ghc >= 9.4)+    ghc-options:+      -Wwarn=type-equality-out-of-scope++  if impl(ghc >= 9.4 && < 9.10)+    ghc-options:+      -Wwarn=forall-identifier+        -- The forall-identifier warning is deprecated in GHC 9.10++  default-language: Haskell2010++  -- NOTE: If adding or removing default extensions, also change:+  --         .hlint.yaml+  default-extensions:+      BangPatterns+      BlockArguments+      ConstraintKinds+      --L-T Chen (2019-07-15):+      -- Enabling DataKinds only locally makes the compile time+      -- slightly shorter, see PR #3920.+      -- DataKinds+      DefaultSignatures+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedStrings+      PatternSynonyms+      RankNTypes+      RecordWildCards+      ScopedTypeVariables+      StandaloneDeriving+      TupleSections+      TypeFamilies+      TypeOperators+      TypeSynonymInstances+      ViewPatterns+      TypeApplications++  other-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      CPP+      DataKinds+      DeriveAnyClass+      ImplicitParams+      KindSignatures+      MagicHash+      NondecreasingIndentation+      OverloadedLists+      PartialTypeSignatures+      PatternGuards+      PolyKinds+      RebindableSyntax+      TemplateHaskell+      UnboxedTuples+      UndecidableInstances+++-- Agda library+---------------------------------------------------------------------------++library+  import:           language++  hs-source-dirs:   src/full src/setup++  -- Andreas, 2021-03-10:+  -- All packages we depend upon should be mentioned in an unconditional+  -- build-depends field, but additional restrictions on their+  -- version for specific GHCs may be placed in conditionals.+  --+  -- The goal is to be able to make (e.g. when a new GHC comes out)+  -- revisions on hackage, e.g. relaxing upper bounds.  This process+  -- currently does not support revising conditionals.+  --+  -- An exceptions are packages that are only needed for certain configurations,+  -- like for flags, Windows, etc.++  if flag(debug)+    cpp-options:    -DDEBUG++  if flag(debug-serialisation)+    cpp-options:    -DDEBUG_SERIALISATION++  if flag(debug-parsing)+    cpp-options:    -DDEBUG_PARSING++  if flag(enable-cluster-counting)+    cpp-options:    -DCOUNT_CLUSTERS+    build-depends:+      text-icu             >= 0.7.1.0   && < 0.9++  if os(windows)+    build-depends:+      Win32                >= 2.6.1.0   && < 2.15++  -- We need instance TH.Lift ByteString in Agda.Setup.+  -- bytestring-0.11.2.0 adds "Lift instances for all flavors of ByteString"+  -- GHC 9.2 comes with bytestring-0.11.4.0+  -- Older GHCs can get the instance from th-lift-instances.+  if impl(ghc < 9.2)+    build-depends:+      th-lift-instances    >= 0.1.18    && < 0.1.21++  -- For libraries that come with GHC, we take the shipped version as default lower bound.+  -- For the other libraries, we take the lower bound from the oldest LTS we support.+  -- This is currently LTS 16.31 (last for GHC 8.8.4).+  build-depends:+    -- Please keep in alphabetical order!+    , aeson                >= 1.4.7.1   && < 2.3+    , ansi-terminal        >= 0.10.3    && < 1.2+    , array                >= 0.5.4.0   && < 0.6+    , async                >= 2.2.2     && < 2.3+    , base                 >= 4.13.0.0  && < 4.22+    , binary               >= 0.8.7.0   && < 0.9+    , blaze-html           >= 0.9.1.2   && < 0.10+    , boxes                >= 0.1.5     && < 0.2+    , bytestring           >= 0.10.10.1 && < 0.13+    , case-insensitive     >= 1.2.1.0   && < 1.3+    , containers           >= 0.6.2.1   && < 0.8+        -- containers-0.6.3.1 adds IntSet.mapMonotonic, but its too young for GHC 8.8+    , data-hash            >= 0.2.0.1   && < 0.3+    , deepseq              >= 1.4.4.0   && < 1.6+    , directory            >= 1.3.6.0   && < 1.4+    , dlist                >= 0.8.0.8   && < 1.1+    , edit-distance        >= 0.2.2.1   && < 0.3+    , enummapset           >= 0.6.0.3   && < 0.8+    , equivalence          >= 0.3.5     && < 0.5+    , exceptions           >= 0.10.4    && < 0.11+    , filelock             >= 0.1.1.5   && < 0.2+    , filepath             >= 1.4.2.1   && < 1.6+    , filemanip            >= 0.3.6.3   && < 0.4+    , generic-data         >= 0.9.2.0   && < 1.2+        -- generic-data-0.9.2.0 adds instance of Bounded for FiniteEnumeration+    , ghc-compact          == 0.1.*+    , gitrev               >= 1.3.1     && < 2+    , hashable             >= 1.3.0.0   && < 1.6+    , haskeline            >= 0.7.5.0   && < 0.9+    , monad-control        >= 1.0.2.3   && < 1.1+    , mtl                  >= 2.2.2     && < 2.4+    , murmur-hash          >= 0.1.0.9   && < 0.2+    , nonempty-containers  >= 0.3.4.1   && < 0.4+    , parallel             >= 3.2.2.0   && < 3.3+    , peano                >= 0.1.0.1   && < 0.2+    , pqueue               >= 1.4.1.3   && < 1.6+    , pretty               >= 1.1.3.6   && < 1.2+    , process              >= 1.6.9.0   && < 1.7+    , process-extras       >= 0.7.4     && < 0.8+    , regex-tdfa           >= 1.3.1.0   && < 1.4+    , split                >= 0.2.3.4   && < 0.3+    , stm                  >= 2.5.0.0   && < 2.6+    , STMonadTrans         >= 0.4.5     && < 0.5+    , strict               >= 0.4.0.1   && < 0.6+        -- module Data.Strict.Classes entered in strict-0.4+    , template-haskell     >= 2.15.0.0  && < 2.24+    , text                 >= 1.2.4.0   && < 2.2+    , time                 >= 1.9.3     && < 1.15+    , transformers         >= 0.5.6.2   && < 0.7+    , unordered-containers >= 0.2.10.0  && < 0.3+    , uri-encode           >= 1.5.0.7   && < 1.6+    , vector               >= 0.12.1.2  && < 0.14+    , vector-hashtables    >= 0.1.1.1   && < 0.2+    , zlib                 >= 0.6.2.2   && < 0.8++  -- We don't write upper bounds for Alex nor Happy because the+  -- `build-tool-depends` field can not be modified in Hackage.+  build-tool-depends:+    , alex:alex   >= 3.2.5+        -- alex-3.2.5 contains fixes for building with GHC 8.8+    , happy:happy >= 1.19.12+        -- happy-1.19.12 contains fixes for building with GHC 8.8++  exposed-modules:+      Agda.Benchmarking+      Agda.Compiler.Backend+      Agda.Compiler.Backend.Base+      Agda.Compiler.Builtin+      Agda.Compiler.CallCompiler+      Agda.Compiler.Common+      Agda.Compiler.JS.Compiler+      Agda.Compiler.JS.Syntax+      Agda.Compiler.JS.Substitution+      Agda.Compiler.JS.Pretty+      Agda.Compiler.MAlonzo.Coerce+      Agda.Compiler.MAlonzo.Compiler+      Agda.Compiler.MAlonzo.Encode+      Agda.Compiler.MAlonzo.HaskellTypes+      Agda.Compiler.MAlonzo.Misc+      Agda.Compiler.MAlonzo.Pragmas+      Agda.Compiler.MAlonzo.Pretty+      Agda.Compiler.MAlonzo.Primitives+      Agda.Compiler.MAlonzo.Strict+      Agda.Compiler.ToTreeless+      Agda.Compiler.Treeless.AsPatterns+      Agda.Compiler.Treeless.Builtin+      Agda.Compiler.Treeless.Compare+      Agda.Compiler.Treeless.EliminateDefaults+      Agda.Compiler.Treeless.EliminateLiteralPatterns+      Agda.Compiler.Treeless.Erase+      Agda.Compiler.Treeless.GuardsToPrims+      Agda.Compiler.Treeless.Identity+      Agda.Compiler.Treeless.NormalizeNames+      Agda.Compiler.Treeless.Pretty+      Agda.Compiler.Treeless.Simplify+      Agda.Compiler.Treeless.Subst+      Agda.Compiler.Treeless.Uncase+      Agda.Compiler.Treeless.Unused+      Agda.ImpossibleTest+      Agda.Interaction.AgdaTop+      Agda.Interaction.Base+      Agda.Interaction.BasicOps+      Agda.Interaction.BuildLibrary+      Agda.Interaction.Command+      Agda.Interaction.SearchAbout+      Agda.Interaction.CommandLine+      Agda.Interaction.EmacsCommand+      Agda.Interaction.EmacsTop+      Agda.Interaction.ExitCode+      Agda.Interaction.JSONTop+      Agda.Interaction.JSON+      Agda.Interaction.FindFile+      Agda.Interaction.Highlighting.Common+      Agda.Interaction.Highlighting.Dot+      Agda.Interaction.Highlighting.Dot.Backend+      Agda.Interaction.Highlighting.Dot.Base+      Agda.Interaction.Highlighting.Emacs+      Agda.Interaction.Highlighting.FromAbstract+      Agda.Interaction.Highlighting.Generate+      Agda.Interaction.Highlighting.HTML+      Agda.Interaction.Highlighting.HTML.Backend+      Agda.Interaction.Highlighting.HTML.Base+      Agda.Interaction.Highlighting.JSON+      Agda.Interaction.Highlighting.Precise+      Agda.Interaction.Highlighting.Range+      Agda.Interaction.Highlighting.Vim+      Agda.Interaction.Highlighting.LaTeX+      Agda.Interaction.Highlighting.LaTeX.Backend+      Agda.Interaction.Highlighting.LaTeX.Base+      Agda.Interaction.Imports+      Agda.Interaction.InteractionTop+      Agda.Interaction.Output+      Agda.Interaction.Response+      Agda.Interaction.Response.Base+      Agda.Interaction.MakeCase+      Agda.Interaction.Monad+      Agda.Interaction.Library+      Agda.Interaction.Library.Base+      Agda.Interaction.Library.Parse+      Agda.Interaction.Options+      Agda.Interaction.Options.Errors+      Agda.Interaction.Options.Help+      Agda.Interaction.Options.Lenses+      Agda.Interaction.Options.Warnings+      Agda.Main+      Agda.Mimer.Mimer+      Agda.Mimer.Options+      Agda.Setup+      Agda.Setup.DataFiles+      Agda.Setup.EmacsMode+      Agda.Syntax.Abstract.Name+      Agda.Syntax.Abstract.Pattern+      Agda.Syntax.Abstract.PatternSynonyms+      Agda.Syntax.Abstract.Pretty+      Agda.Syntax.Abstract.UsedNames+      Agda.Syntax.Abstract.Views+      Agda.Syntax.Abstract+      Agda.Syntax.Builtin+      Agda.Syntax.Common+      Agda.Syntax.Common.Aspect+      Agda.Syntax.Common.KeywordRange+      Agda.Syntax.Common.Pretty+      Agda.Syntax.Common.Pretty.ANSI+      Agda.Syntax.Concrete.Attribute+      Agda.Syntax.Concrete.Definitions+      Agda.Syntax.Concrete.Definitions.Errors+      Agda.Syntax.Concrete.Definitions.Monad+      Agda.Syntax.Concrete.Definitions.Types+      Agda.Syntax.Concrete.Fixity+      Agda.Syntax.Concrete.Generic+      Agda.Syntax.Concrete.Glyph+      Agda.Syntax.Concrete.Name+      Agda.Syntax.Concrete.Operators.Parser+      Agda.Syntax.Concrete.Operators.Parser.Monad+      Agda.Syntax.Concrete.Operators+      Agda.Syntax.Concrete.Pattern+      Agda.Syntax.Concrete.Pretty+      Agda.Syntax.Concrete+      Agda.Syntax.DoNotation+      Agda.Syntax.Fixity+      Agda.Syntax.IdiomBrackets+      Agda.Syntax.Info+      Agda.Syntax.Internal+      Agda.Syntax.Internal.Blockers+      Agda.Syntax.Internal.Defs+      Agda.Syntax.Internal.Elim+      Agda.Syntax.Internal.Generic+      Agda.Syntax.Internal.MetaVars+      Agda.Syntax.Internal.Names+      Agda.Syntax.Internal.Pattern+      Agda.Syntax.Internal.SanityCheck+      Agda.Syntax.Internal.Univ+      Agda.Syntax.Literal+      Agda.Syntax.Notation+      Agda.Syntax.Parser.Alex+      Agda.Syntax.Parser.Comments+      Agda.Syntax.Parser.Helpers+      Agda.Syntax.Parser.Layout+      Agda.Syntax.Parser.LexActions+      Agda.Syntax.Parser.Lexer+      Agda.Syntax.Parser.Literate+      Agda.Syntax.Parser.LookAhead+      Agda.Syntax.Parser.Monad+      Agda.Syntax.Parser.Parser+      Agda.Syntax.Parser.StringLiterals+      Agda.Syntax.Parser.Tokens+      Agda.Syntax.Parser+      Agda.Syntax.Position+      Agda.Syntax.Reflected+      Agda.Syntax.Scope.Base+      Agda.Syntax.Scope.Flat+      Agda.Syntax.Scope.Monad+      Agda.Syntax.TopLevelModuleName+      Agda.Syntax.TopLevelModuleName.Boot+      Agda.Syntax.Translation.AbstractToConcrete+      Agda.Syntax.Translation.ConcreteToAbstract+      Agda.Syntax.Translation.InternalToAbstract+      Agda.Syntax.Translation.ReflectedToAbstract+      Agda.Syntax.Treeless+      Agda.Termination.CallGraph+      Agda.Termination.CallMatrix+      Agda.Termination.CutOff+      Agda.Termination.Monad+      Agda.Termination.Order+      Agda.Termination.RecCheck+      Agda.Termination.SparseMatrix+      Agda.Termination.Semiring+      Agda.Termination.TermCheck+      Agda.Termination.Termination+      Agda.TheTypeChecker+      Agda.TypeChecking.Abstract+      Agda.TypeChecking.CheckInternal+      Agda.TypeChecking.CompiledClause+      Agda.TypeChecking.CompiledClause.Compile+      Agda.TypeChecking.CompiledClause.Match+      Agda.TypeChecking.Constraints+      Agda.TypeChecking.Conversion+      Agda.TypeChecking.Conversion.Pure+      Agda.TypeChecking.Coverage+      Agda.TypeChecking.Coverage.Match+      Agda.TypeChecking.Coverage.SplitTree+      Agda.TypeChecking.Coverage.SplitClause+      Agda.TypeChecking.Coverage.Cubical+      Agda.TypeChecking.Datatypes+      Agda.TypeChecking.DeadCode+      Agda.TypeChecking.DisplayForm+      Agda.TypeChecking.DropArgs+      Agda.TypeChecking.DiscrimTree+      Agda.TypeChecking.DiscrimTree.Types+      Agda.TypeChecking.Empty+      Agda.TypeChecking.EtaContract+      Agda.TypeChecking.Errors+      Agda.TypeChecking.Errors.Names+      Agda.TypeChecking.Free+      Agda.TypeChecking.Free.Lazy+      Agda.TypeChecking.Free.Precompute+      Agda.TypeChecking.Free.Reduce+      Agda.TypeChecking.Forcing+      Agda.TypeChecking.Functions+      Agda.TypeChecking.Generalize+      Agda.TypeChecking.IApplyConfluence+      Agda.TypeChecking.Implicit+      Agda.TypeChecking.Injectivity+      Agda.TypeChecking.Inlining+      Agda.TypeChecking.InstanceArguments+      Agda.TypeChecking.Irrelevance+      Agda.TypeChecking.Level+      Agda.TypeChecking.LevelConstraints+      Agda.TypeChecking.Lock+      Agda.TypeChecking.Level.Solve+      Agda.TypeChecking.MetaVars+      Agda.TypeChecking.MetaVars.Mention+      Agda.TypeChecking.MetaVars.Occurs+      Agda.TypeChecking.Modalities+      Agda.TypeChecking.Monad.Base+      Agda.TypeChecking.Monad.Base.Types+      Agda.TypeChecking.Monad.Base.Warning+      Agda.TypeChecking.Monad.Benchmark+      Agda.TypeChecking.Monad.Builtin+      Agda.TypeChecking.Monad.Caching+      Agda.TypeChecking.Monad.Closure+      Agda.TypeChecking.Monad.Constraints+      Agda.TypeChecking.Monad.Context+      Agda.TypeChecking.Monad.Debug+      Agda.TypeChecking.Monad.Env+      Agda.TypeChecking.Monad.Imports+      Agda.TypeChecking.Monad.MetaVars+      Agda.TypeChecking.Monad.Modality+      Agda.TypeChecking.Monad.Mutual+      Agda.TypeChecking.Monad.Open+      Agda.TypeChecking.Monad.Options+      Agda.TypeChecking.Monad.Pure+      Agda.TypeChecking.Monad.Signature+      Agda.TypeChecking.Monad.SizedTypes+      Agda.TypeChecking.Monad.State+      Agda.TypeChecking.Monad.Statistics+      Agda.TypeChecking.Monad.Trace+      Agda.TypeChecking.Monad+      Agda.TypeChecking.Names+      Agda.TypeChecking.Opacity+      Agda.TypeChecking.Patterns.Abstract+      Agda.TypeChecking.Patterns.Internal+      Agda.TypeChecking.Patterns.Match+      Agda.TypeChecking.Polarity+      Agda.TypeChecking.Positivity+      Agda.TypeChecking.Positivity.Occurrence+      Agda.TypeChecking.Pretty+      Agda.TypeChecking.Pretty.Call+      Agda.TypeChecking.Pretty.Constraint+      Agda.TypeChecking.Pretty.Warning+      Agda.TypeChecking.Primitive+      Agda.TypeChecking.Primitive.Base+      Agda.TypeChecking.Primitive.Cubical+      Agda.TypeChecking.Primitive.Cubical.Glue+      Agda.TypeChecking.Primitive.Cubical.Base+      Agda.TypeChecking.Primitive.Cubical.HCompU+      Agda.TypeChecking.ProjectionLike+      Agda.TypeChecking.Quote+      Agda.TypeChecking.ReconstructParameters+      Agda.TypeChecking.RecordPatterns+      Agda.TypeChecking.Records+      Agda.TypeChecking.Reduce+      Agda.TypeChecking.Reduce.Fast+      Agda.TypeChecking.Reduce.Monad+      Agda.TypeChecking.Rewriting+      Agda.TypeChecking.Rewriting.Clause+      Agda.TypeChecking.Rewriting.Confluence+      Agda.TypeChecking.Rewriting.NonLinMatch+      Agda.TypeChecking.Rewriting.NonLinPattern+      Agda.TypeChecking.Rules.Application+      Agda.TypeChecking.Rules.Builtin+      Agda.TypeChecking.Rules.Builtin.Coinduction+      Agda.TypeChecking.Rules.Data+      Agda.TypeChecking.Rules.Decl+      Agda.TypeChecking.Rules.Def+      Agda.TypeChecking.Rules.Display+      Agda.TypeChecking.Rules.LHS+      Agda.TypeChecking.Rules.LHS.Implicit+      Agda.TypeChecking.Rules.LHS.Problem+      Agda.TypeChecking.Rules.LHS.ProblemRest+      Agda.TypeChecking.Rules.LHS.Unify+      Agda.TypeChecking.Rules.LHS.Unify.Types+      Agda.TypeChecking.Rules.LHS.Unify.LeftInverse+      Agda.TypeChecking.Rules.Record+      Agda.TypeChecking.Rules.Term+      Agda.TypeChecking.Serialise+      Agda.TypeChecking.Serialise.Base+      Agda.TypeChecking.Serialise.Instances+      Agda.TypeChecking.Serialise.Instances.Abstract+      Agda.TypeChecking.Serialise.Instances.Common+      Agda.TypeChecking.Serialise.Instances.Compilers+      Agda.TypeChecking.Serialise.Instances.Highlighting+      Agda.TypeChecking.Serialise.Instances.Internal+      Agda.TypeChecking.Serialise.Instances.Errors+      Agda.TypeChecking.SizedTypes+      Agda.TypeChecking.SizedTypes.Pretty+      Agda.TypeChecking.SizedTypes.Solve+      Agda.TypeChecking.SizedTypes.Syntax+      Agda.TypeChecking.SizedTypes.Utils+      Agda.TypeChecking.SizedTypes.WarshallSolver+      Agda.TypeChecking.Sort+      Agda.TypeChecking.Substitute+      Agda.TypeChecking.Substitute.Class+      Agda.TypeChecking.Substitute.DeBruijn+      Agda.TypeChecking.SyntacticEquality+      Agda.TypeChecking.Telescope+      Agda.TypeChecking.Telescope.Path+      Agda.TypeChecking.Unquote+      Agda.TypeChecking.Warnings+      Agda.TypeChecking.With+      Agda.Utils.AffineHole+      Agda.Utils.Applicative+      Agda.Utils.AssocList+      Agda.Utils.Bag+      Agda.Utils.Benchmark+      Agda.Utils.BiMap+      Agda.Utils.Boolean+      Agda.Utils.BoolSet+      Agda.Utils.CallStack+      Agda.Utils.Char+      Agda.Utils.Cluster+      Agda.Utils.Empty+      Agda.Utils.Environment+      Agda.Utils.Either+      Agda.Utils.Fail+      Agda.Utils.Favorites+      Agda.Utils.FileName+      Agda.Utils.FileId+      Agda.Utils.Float+      Agda.Utils.Functor+      Agda.Utils.Function+      Agda.Utils.GetOpt+      Agda.Utils.Graph.AdjacencyMap.Unidirectional+      Agda.Utils.Graph.TopSort+      Agda.Utils.Hash+      Agda.Utils.HashTable+      Agda.Utils.Haskell.Syntax+      Agda.Utils.IArray+      Agda.Utils.Impossible+      Agda.Utils.IndexedList+      Agda.Utils.IntSet.Infinite+      Agda.Utils.IO+      Agda.Utils.IO.Binary+      Agda.Utils.IO.Directory+      Agda.Utils.IO.TempFile+      Agda.Utils.IO.UTF8+      Agda.Utils.IORef+      Agda.Utils.Lens+      Agda.Utils.Lens.Examples+      Agda.Utils.List+      Agda.Utils.List1+      Agda.Utils.List2+      Agda.Utils.ListT+      Agda.Utils.Map+      Agda.Utils.Map1+      Agda.Utils.Maybe+      Agda.Utils.Maybe.Strict+      Agda.Utils.Memo+      Agda.Utils.Monad+      Agda.Utils.Monoid+      Agda.Utils.Null+      Agda.Utils.Parser.MemoisedCPS+      Agda.Utils.PartialOrd+      Agda.Utils.Permutation+      Agda.Utils.POMonoid+      Agda.Utils.ProfileOptions+      Agda.Utils.RangeMap+      Agda.Utils.SemiRing+      Agda.Utils.Semigroup+      Agda.Utils.Set1+      Agda.Utils.Singleton+      Agda.Utils.Size+      Agda.Utils.SmallSet+      Agda.Utils.String+      Agda.Utils.Suffix+      Agda.Utils.Three+      Agda.Utils.Time+      Agda.Utils.Trie+      Agda.Utils.Tuple+      Agda.Utils.TypeLevel+      Agda.Utils.TypeLits+      Agda.Utils.Unsafe+      Agda.Utils.Update+      Agda.Utils.VarSet+      Agda.Utils.WithDefault+      Agda.Utils.Zipper+      Agda.Version+      Agda.VersionCommit++  autogen-modules:+      Paths_Agda++  other-modules:+      Paths_Agda+      -- Need not export submodules if parent module reexports them.+      Agda.Interaction.Options.Base+      Agda.Interaction.Options.HasOptions+      Agda.Interaction.Options.Types+      Agda.Utils.CallStack.Base+      Agda.Utils.CallStack.Pretty++-- Agda binary+---------------------------------------------------------------------------++executable agda+  hs-source-dirs: src/main+  main-is:        Main.hs+  build-depends:+    , Agda+      -- Nothing is used from the following package,+      -- except for the Prelude.+    , base+  default-language: Haskell2010+  -- If someone installs Agda with the setuid bit set, then the+  -- presence of +RTS may be a security problem (see GHC bug #3910).+  -- However, we sometimes recommend people to use +RTS to control+  -- Agda's memory usage, so we want this functionality enabled by+  -- default.++  -- The threaded RTS by default starts a major GC after a program has+  -- been idle for 0.3 s. This feature turned out to be annoying, so+  -- the idle GC is now by default turned off (-I0).+  ghc-options:+    -threaded+    -rtsopts+    -with-rtsopts=-I0++-- agda-mode executable+---------------------------------------------------------------------------++executable agda-mode+  import:           language++  hs-source-dirs:   src/agda-mode src/setup+  main-is:          Main.hs+  autogen-modules:+    Paths_Agda+  other-modules:+    Paths_Agda+    Agda.Setup+    Agda.Setup.DataFiles+    Agda.Setup.EmacsMode+    Agda.Version+    Agda.VersionCommit++  -- We need instance TH.Lift ByteString in Agda.Setup.+  -- bytestring-0.11.2.0 adds "Lift instances for all flavors of ByteString"+  -- GHC 9.2 comes with bytestring-0.11.4.0+  -- Older GHCs can get the instance from th-lift-instances.+  if impl(ghc < 9.2)+    build-depends:+      th-lift-instances    >= 0.1.18    && < 0.1.21++  build-depends:+    , base                 >= 4.13.0.0  && < 4.22+    , bytestring           >= 0.10.10.1 && < 0.13+    , directory            >= 1.3.6.0   && < 1.4+    , filelock             >= 0.1.1.5   && < 0.2+    , filepath             >= 1.4.2.1   && < 1.6+    , gitrev               >= 1.3.1     && < 2+    , process              >= 1.6.9.0   && < 1.7+    , template-haskell     >= 2.15.0.0  && < 2.24
CHANGELOG.md view
@@ -1,109 +1,639 @@-Release notes for Agda version 2.6.2.2-======================================+Release notes for Agda version 2.8.0+====================================  Highlights ---------- -* Agda 2.6.2.2 catches up to changes in the Haskell ecosystem-  (`bytestring-0.11.2.0`, `mtl-2.3-rc3/4`, `text-icu-0.8.0.1`,-  stackage `lts-19.0` and `nightly`).+* Agda is now a self-contained single binary. -* Fixes inconsistency [#5838](https://github.com/agda/agda/issues/5838)-  in `--cubical`.+* Build all Agda files reachable from paths in the `.agda-lib` file with new flag `--build-library`. -* Fixes some regressions introduced in 2.6.1:+* Experimental support for polarity annotations with new flag `--polarity`. -  - [#5809](https://github.com/agda/agda/issues/5809):-    internal error with `--irrelevant-projections`.+* Compile to JavaScript with ES6 module syntax with new flag `--js-es6`. -* Fixes some regressions introduced in 2.6.2:+* Errors now have an identifier and follow the GNU standard. -  - [#5705](https://github.com/agda/agda/issues/5705) and-    [#5706](https://github.com/agda/agda/issues/5706):-    inconsistency from universe level `Int` overflow.+Installation+------------ -  - [#5784](https://github.com/agda/agda/issues/5784):-    `primEraseEquality` does not compute.+* Dropped support for GHC 8.6, added support for GHC 9.12. -  - [#5805](https://github.com/agda/agda/issues/5805):-    internal error involving holes and `with`.+* Agda supports GHC versions 8.8.4 to 9.12.2. -  - [#5819](https://github.com/agda/agda/issues/5819):-    internal error when reducing in termination checker.+* The `agda` binary now contains everything to set itself up,+  it need not be shipped with additional files. -* Other-  [fixes](https://github.com/agda/agda/issues?q=is%3Aissue+milestone%3A2.6.2.2+is%3Aclosed)-  and improvements (see below).+  1. The functionality of the `agda-mode` executable has been replicated+     under the new option `--emacs-mode`.+     The `agda-mode` executable is now deprecated.+     References to `agda-mode` in your `.emacs` file should be replaced+     by `agda --emacs-mode`. -Installation and infrastructure--------------------------------+  2. Agda now contains all its data files,+     like primitive and builtin modules,+     supplements for the HTML and LaTeX backends,+     the runtimes for the `JS` and `GHC` backends,+     and the emacs mode. -Agda supports GHC versions 8.0.2 to 9.2.2.+     These will be written to the data directory+     on the first invocation of `agda` or an invocation of+     `agda --setup`, `agda --emacs-mode setup`, or `agda --emacs-mode compile`. -* UTF-8 encoding is now used for the `libraries` and `executables`-  configuration files (issue-  [#5741](https://github.com/agda/agda/issues/5741)).+     The location of the data directory can be printed using+     `agda --print-agda-data-dir` and can be controlled by the `use-xdg-data-home`+     flag at build time and the `Agda_datadir` environment variable at runtime; see the+     documentation for more information. +* The Cabal/Stack custom installation `Setup.hs` has been removed+  that previously generated the `.agdai` files for the builtin and primitive modules.+  These will now be generated by Agda whenever they are needed,+  just as for ordinary modules.++  This change might be **breaking** for packagers of Agda+  as the packaging routines might need to be updated: in particular,+  declarative build systems like Nix or Guix should generate the `.agdai` files+  by invoking Agda at build time.++* Pre-built binaries are available as release assets for the following platforms++  * Windows (x86-64)+  * Linux (x86-64)+  * macOS (x86-64)+  * macOS (arm64)++  Installation instructions are provided in the Agda user manual.++* The `optimise-heavily` build flag is now turned on by default.++  This requires more resources when building Agda, but leads to a faster Agda binary.+  Should GHC run out of memory when building Agda, turn this flag off.++* Added cabal build flag `dump-core` to save the optimised GHC Core code during+  compilation of Agda. This can be useful for people working on improving the+  performance of the Agda implementation.++Pragmas and options+-------------------++* **BREAKING**: Abbreviation of options, such as `--warning` to `--warn`, is no longer supported.++* New main mode of operation `--build-library` (issue [#4338](https://github.com/agda/agda/issues/4338)).+  Invoking `agda --build-library` will look for an `.agda-lib` file starting in the current directory.+  It will then extract the `include` directories of this library,+  collect all Agda files in these directories and their subdirectories,+  and check all these files.++* New option `--setup` that writes out the Agda data files (see above)+  and can be used to regenerate them.++* New option `--emacs-mode` to administer the Emacs mode+  as previously done by the `agda-mode` executable.++* Option `--local-interfaces` and warning `DuplicateInterfaceFiles` have been removed.++* New option `--js-es6` for generating JavaScript with ES6 module syntax.++* `DISPLAY` pragmas can now define display forms that match on defined names+  beyond constructors ([issue #7533](https://github.com/agda/agda/issues/7533)).+  Example:+  ```agda+  {-# DISPLAY Irrelevant Empty = ⊥ #-}+  ```+  `Empty` used to be interpreted as a pattern variable, effectively installing+  the display form `Irrelevant _ = ⊥`.+  Now `Empty` is treated as a matchable name, as one would intuitively expect+  from a display form.+  As a consequence, only `Irrelevant Empty` is displayed as `⊥`, not just any+  `Irrelevant A`.++* A new **experimental** flag `--experimental-lazy-instances` causes+  instance selection to be deferred until the type of the instance+  constraint is determined enough to make an unamibiguous decision at+  the discrimination tree level. This significantly improves performance+  for cases where instances can be distinguished by rigid data.++  This flag will become the default in the future, but it is currently+  **disabled by default** because it has unexpected interactions with+  parts of the codebase (and macros) which rely on constraint solving+  order (see e.g. [issue #7882](https://github.com/agda/agda/issues/7883)+  and [issue #7847](https://github.com/agda/agda/issues/7847)).++Warnings+--------++* New warning `RewritesNothing` if a `rewrite` clause did not fire.++* New deadcode warnings `FixingCohesion`, `FixingPolarity` and `FixingRelevance`+  when wrong user-written attribute was corrected automatically by Agda.++* New deadcode warning `InvalidDisplayForm` instead of hard error+  when a display form is illegal (and thus ignored).++* New warning `UnusedVariablesInDisplayForm` when DISPLAY pragma+  binds variables that are not used.+  Example:+  ```agda+  {-# DISPLAY List (Fin n) = ListFin #-}+  ```+  Since pattern variable `n` is not used on the right hand side `ListFin`,+  Agda throws a warning and recommeds to rewrite it as:+  ```agda+  {-# DISPLAY List (Fin _) = ListFin #-}+  ```++* Unused `CATCHALL` pragmas now trigger `UselessPragma` warnings.++* New deadcode warning `EmptyPolarityPragma` for POLARITY pragma without polarities.+  E.g. triggered by `{-# POLARITY F #-}`.++* New parser warnings `MisplacedAttributes`, `UnknownAttribute`, and `UnknownPolarity`+  instead of hard parser errors.++* New deadcode warning `TooManyPolarities` instead of hard error+  when a POLARITY pragma gives polarities that exceed the known+  arity of the postulate.++* New deadcode warning `UselessTactic` when a `@tactic` attribute has no effect,+  typically when it is attached to a non-hidden or instance argument.++* New warning `WithClauseProjectionFixityMismatch` instead of hard error+  when in a with-clause a projection is used in a different fixity+  (prefix vs. postfix) than in its parent clause.++* New error warning `TooManyArgumentsToSort` instead of hard error.++* Warning `AbsurdPatternRequiresNoRHS` has been renamed to+  `AbsurdPatternRequiresAbsentRHS`.++* Warnings `OpenPublicAbstract` and `OpenPublicPrivate` have been replaced+  by new warnings `OpenImportAbstract` and `OpenImportPrivate`.++* Warning `NoGuardednessFlag` has been removed.+  Instead Agda gives a hint when `--guardedness` would help with termination checking,+  unless options `--sized-types` or `--no-guardedness` are set.+++Polarity+--------++* Support for polarity annotations can be enabled by the feature flag+  `--polarity`.++  This flag is infective.++  Uses of variables bound with polarity annotations are checked through modal+  typing rules, and the positivity checker has been expanded to take annotations+  into account. This means that the following is now definable:++  ```agda+  {-# OPTIONS --polarity #-}++  data Mu (F : @++ Set → Set) : Set where+    fix : F (Mu F) → Mu F+  ```++Syntax+------++Additions to the Agda syntax.++* Add new literate agda: forester, see [#7403](https://github.com/agda/agda/pull/7403).+  You will need the postprocessor [`agda-tree`](https://github.com/dannypsnl/agda-tree),+  see Agda user manual on literate programming for more information.++* It is now always possible to refer to the name of a record type's+  constructor, even if a name was not explicitly specified. This is done+  using the new `(Record name).constructor` syntax;+  see [issue #6964](https://github.com/agda/agda/issues/6964) for the motivation.++* The *left-hand-sides* of functions bound in a `let` expression can now+  contain the same types of patterns that are allowed in lambda+  expressions, in dependent function types, and in other `let` bindings.++  This means that++  ```agda+  let+    f : A → B → C+    f p1 p2 = ...+  in ...+  ```++  should be accepted exactly when, and have the same meaning as,++  ```agda+  let+    f : A → B → C+    f = λ p1 p2 → ...+  ```++  See [#7572](https://github.com/agda/agda/pull/7572).+ Language -------- -* `macro` definitions can now be used even when they are declared as erased-  (PR [#5744](https://github.com/agda/agda/pull/5744)).-  For example, this is now accepted:+Changes to type checker and other components defining the Agda language.++* **BREAKING**: The primitive "cubical identity type", previously+  exported from `Agda.Builtin.Cubical.Id`, has been removed. Its+  computational behaviour is exactly replicated by the user-definable+  identity type, which is also exported from `Agda.Builtin.Equality`.++  See [agda/cubical#1005](https://github.com/agda/cubical/pull/1005) for+  the PR removing it from the library, and+  [#7652](https://github.com/agda/agda/pull/7652) for the compiler.++* Inlining constructors no longer happens on the right-hand-sides of+  `INLINE` functions. This allows using `INLINE` functions to define+  "smart constructors" for record types which have the same reduction+  behaviour as using the actual constructor would. Small example:+   ```agda-  macro-    @0 trivial : Term → TC ⊤-    trivial = unify (con (quote refl) [])+  triple : Nat → Nat → Nat → Nat × Nat × Nat+  {-# INLINE triple #-}+  triple x y z = record { fst = x ; snd = y , z } -  test : 42 ≡ 42-  test = trivial+  ex = triple 1 2 3   ``` -* Fixed inconsistent `--cubical` reductions for `transp`:-  issue [#5838](https://github.com/agda/agda/issues/5838).+  Here, constructor inlining happens on the right hand side *of `ex`*+  rather than of `triple`. -* Fixed issues with reflection:+Reflection+---------- -  - [#5762](https://github.com/agda/agda/issues/5762):-    do not eagerly check existence of commands in `executables` file.+Changes to the meta-programming facilities. -  - [#5695](https://github.com/agda/agda/issues/5695):-    fix `elaborate-and-give` interaction command.+* New reflection primitive: `checkFromStringTC : String → Type → TC Term` -  - [#5700](https://github.com/agda/agda/issues/5700):-    scope of metas created during macro expansion.+  Parse and type check the given string against the given type, returning+  the resulting term (when successful). -  - [#5712](https://github.com/agda/agda/issues/5712):-    internal error with tactics on record fields of function type. -* Fixed issues with instance search:+Library management+------------------ -  - [#5583](https://github.com/agda/agda/issues/5583):-    constructor instances from parameterized modules.+* **BREAKING**: Agda no longer accepts several `.agda-lib` files in the root+  of an Agda project.+  (Previously, it allowed this and took the union of their contents.) -  - [#5787](https://github.com/agda/agda/issues/5787):-    erased instance arguments. -* Fixed issue [#5683](https://github.com/agda/agda/issues/5683) with-  generalization in `let`.+Interaction and emacs mode+-------------------------- -Compiler backends------------------+* Agda's error messages now follow the [GNU standard](https://www.gnu.org/prep/standards/html_node/Errors.html).+  To comply with this policy, line and column are now separated by a dot instead of comma.+  The format of regular errors and error warnings follows this template: -* `.hs` files generated by the GHC backend now switch off the-  `warn-overlapping-patterns` warning (issue-  [#5758](https://github.com/agda/agda/issues/5758)).+  > _sourcefile_:_line1_._column1_-_line2_._column2_: error: [_ErrorName_]+  > ...+  > _error message_+  > ...+  > when _error context_ -* The GHC backend now calls `ghc` with environment setting-  `GHC_CHARENC=UTF-8` (issue-  [#5742](https://github.com/agda/agda/issues/5742)).+  _line2_ or even _column2_ can be missing, in some cases even the entire error location.+  Internal errors might follow a different format. -Performance------------+  Warnings are printed in a similar format: -* Better caching of interfaces-  (issue [#2767](https://github.com/agda/agda/issues/2767)).+  > _sourcefile_:_line1_._column1_-_line2_._column2_: warning: -W[no]_WarningName_+  > ...+  > _warning text_+  > ...+  > when _warning context_ -* Various performance improvements concerning meta-variables:-  issue [#5388](https://github.com/agda/agda/issues/5388)-  and PR [#5733](https://github.com/agda/agda/pull/5733).+* Emacs: new face `agda2-highlight-cosmetic-problem-face`+  for highlighting the new aspect `CosmeticProblem`.++* Emacs: new face `agda2-highlight-instance-problem-face`+  for highlighting the new aspect `InstanceProblem`.++* When generating clauses after case splitting on a datatype defined in a parameterised module,+  Agda now prints constructor names without a module prefix rather than fully qualified (see issue #3209).+  This is only a surface-level fix, since Agda might still fail to find the properly qualified name for+  the constructor in scope, but should at least make more sense in most situations.++* New bindings for unicode 'tacks' (⟘⟙⟛⟝⟞⫫⫪) via \tack (as well as specialised names for each of them)++Backends+--------++* New `backendInteractTop/backendInteractHole` fields for providing backend-specific interaction commands+  (run with keyboard shortcut `C-c C-i`).++* Buggy unused argument optimization removed from the JavaScript backend+  ([PR #7509](https://github.com/agda/agda/pull/7509)).++Issues closed+-------------++For 2.8.0, the following issues were+[closed](https://github.com/agda/agda/issues?q=is%3Aissue+milestone%3A2.8.0+is%3Aclosed)+(see [bug tracker](https://github.com/agda/agda/issues)):++Issues for closed for milestone 2.8.0+- [Issue #570](https://github.com/agda/agda/issues/570): Explicit polarity annotation+- [Issue #2004](https://github.com/agda/agda/issues/2004): `DISPLAY` should be more pragmatic+- [Issue #4100](https://github.com/agda/agda/issues/4100): GHC backend produces code that is wrongly compiled by GHC 8.4.* and 8.6.*+- [Issue #4338](https://github.com/agda/agda/issues/4338): Add mechanism to type check entire Agda libraries+- [Issue #4343](https://github.com/agda/agda/issues/4343): File order of checking matters (rewrite rules)+- [Issue #5299](https://github.com/agda/agda/issues/5299): Postfix projections are not documented+- [Issue #5865](https://github.com/agda/agda/issues/5865): Non Pattern Match Lambdas Missing From Docs+- [Issue #6111](https://github.com/agda/agda/issues/6111): Is compile-time irrelevance supposed to be erased with `COMPILE` pragmas?+- [Issue #6320](https://github.com/agda/agda/issues/6320): Parse strings to terms as reflection operation+- [Issue #6657](https://github.com/agda/agda/issues/6657): Turn `--guardedness` warning into an error-hint+- [Issue #6781](https://github.com/agda/agda/issues/6781): Making `@tactic` arguments visible leads to unsolved constraints+- [Issue #6916](https://github.com/agda/agda/issues/6916): Internal error at Agda/TypeChecking/Sort.hs:224:21+- [Issue #6964](https://github.com/agda/agda/issues/6964): Allow referring to unnamed record constructors+- [Issue #6994](https://github.com/agda/agda/issues/6994): Warnings are turned off, but code is still highlighted+- [Issue #7057](https://github.com/agda/agda/issues/7057): Document let-bindings in telescopes+- [Issue #7066](https://github.com/agda/agda/issues/7066): Documentation for anonymous modules+- [Issue #7157](https://github.com/agda/agda/issues/7157): Future: cabal build-type `Setup` will be phased out in favor of `Hooks`+- [Issue #7163](https://github.com/agda/agda/issues/7163): `cabal install Agda` fails with executable-dynamic+- [Issue #7321](https://github.com/agda/agda/issues/7321): No warning about useless `{-# CATCHALL #-}` pragma+- [Issue #7324](https://github.com/agda/agda/issues/7324): HTML backend: inconsistent highlighting for macro names+- [Issue #7375](https://github.com/agda/agda/issues/7375): The specification of `--safe` misses the pragmas+- [Issue #7381](https://github.com/agda/agda/issues/7381): Our error messages do not follow the GNU standard+- [Issue #7392](https://github.com/agda/agda/issues/7392): Pattern matching unifier does not preserve instances+- [Issue #7434](https://github.com/agda/agda/issues/7434): Range printed twice for "Parse error"+- [Issue #7440](https://github.com/agda/agda/issues/7440): Unexpected hidden argument in nested records/modules+- [Issue #7495](https://github.com/agda/agda/issues/7495): Catchall clauses with less arguments are considered exact+- [Issue #7503](https://github.com/agda/agda/issues/7503): Cumulativity `Prop <= Set` loses canonicity+- [Issue #7507](https://github.com/agda/agda/issues/7507): Broken CI/haskell installation on GitHub?+- [Issue #7508](https://github.com/agda/agda/issues/7508): Unused-arg optimization breaks function call+- [Issue #7517](https://github.com/agda/agda/issues/7517): `quoteTerm` accepts hidden arguments+- [Issue #7529](https://github.com/agda/agda/issues/7529): Strange problem with --level-universe and --cubical+- [Issue #7530](https://github.com/agda/agda/issues/7530): Generalized variable blocks projection-likeness+- [Issue #7531](https://github.com/agda/agda/issues/7531): JS backend crashes on big case split+- [Issue #7533](https://github.com/agda/agda/issues/7533): `DISPLAY` pragmas should treat any defined name as matchable+- [Issue #7535](https://github.com/agda/agda/issues/7535): Regression in 2.6.4: Agda thinks large propositions can be transported+- [Issue #7537](https://github.com/agda/agda/issues/7537): Type checking a definition with higher inductive type fails to terminate+- [Issue #7546](https://github.com/agda/agda/issues/7546): Why do we allow empty POLARITY pragmas?+- [Issue #7573](https://github.com/agda/agda/issues/7573): `primFloatRound` broken in JS+- [Issue #7574](https://github.com/agda/agda/issues/7574): Support GHC 9.12+- [Issue #7575](https://github.com/agda/agda/issues/7575): impossible error: `variable` in `BUILTIN`+- [Issue #7576](https://github.com/agda/agda/issues/7576): impossible error: parameter overflow in `declareData`+- [Issue #7580](https://github.com/agda/agda/issues/7580): Our Setup.hs does not build with Cabal-3.14+- [Issue #7585](https://github.com/agda/agda/issues/7585): Happy-2.1.1 causes Agda build to fail+- [Issue #7587](https://github.com/agda/agda/issues/7587): Mimer takes an absurd lambda as the solution of the original goal rather than the current (sub)goal+- [Issue #7588](https://github.com/agda/agda/issues/7588): __IMPOSSIBLE__, called at src/full/Agda/Compiler/JS/Compiler.hs:596:45+- [Issue #7590](https://github.com/agda/agda/issues/7590): Internal error with interaction point in a shared type signature+- [Issue #7618](https://github.com/agda/agda/issues/7618): De Bruijn index out of scope in the presence of rewrite rules and records+- [Issue #7624](https://github.com/agda/agda/issues/7624): Internal error when interactively checking expression with new meta-variables+- [Issue #7639](https://github.com/agda/agda/issues/7639): Internal error in `Agda/TypeChecking/Monad/Context.hs` using Mimer+- [Issue #7641](https://github.com/agda/agda/issues/7641): No error highlighting when "fits in" test fails+- [Issue #7642](https://github.com/agda/agda/issues/7642): Better not claim "Level should be a function type"+- [Issue #7643](https://github.com/agda/agda/issues/7643): Panic: uncaught pattern violation+- [Issue #7650](https://github.com/agda/agda/issues/7650): Internal error when utilizing Emacs case splits and `with .. in ..`+- [Issue #7655](https://github.com/agda/agda/issues/7655): haskell/cabal#10235 can still occur with Agda-2.7.0.1+- [Issue #7659](https://github.com/agda/agda/issues/7659): Using auto leads to `__IMPOSSIBLE__` when Σ and case_of_ are both present+- [Issue #7660](https://github.com/agda/agda/issues/7660): Add a warning for unresolved constructor name+- [Issue #7662](https://github.com/agda/agda/issues/7662): Using Auto with a goal involving musical coinduction `♭` produces incorrect projection+- [Issue #7668](https://github.com/agda/agda/issues/7668): Inductive identity allowed in negative position, inconsistent in Cubical Agda+- [Issue #7669](https://github.com/agda/agda/issues/7669): Positivity checker doesn't respect definitional equality+- [Issue #7673](https://github.com/agda/agda/issues/7673): `nix build` skips "generation of Agda core library interface files"+- [Issue #7675](https://github.com/agda/agda/issues/7675): `toIFile` logic from #6988 leads to scattering of `.agdai` files+- [Issue #7678](https://github.com/agda/agda/issues/7678): Order of agda-lib files in a directory affects flag settings+- [Issue #7692](https://github.com/agda/agda/issues/7692): Option to completely disable generation of dot patterns+- [Issue #7696](https://github.com/agda/agda/issues/7696): Panic: de Bruijn index out of scope+- [Issue #7707](https://github.com/agda/agda/issues/7707): ConstructorDoesNotFitInData error for record in Prop with Set fields+- [Issue #7709](https://github.com/agda/agda/issues/7709): Slow typecheck when importing a module with instances+- [Issue #7710](https://github.com/agda/agda/issues/7710): Forcing evaluation can give incorrect results in ghc compiled code+- [Issue #7712](https://github.com/agda/agda/issues/7712): Embed data files using file-embed+- [Issue #7722](https://github.com/agda/agda/issues/7722): Exponential behavior in pattern operator parser+- [Issue #7730](https://github.com/agda/agda/issues/7730): emacs-mode files fail to build with "file has no `lexical-binding` directive"+- [Issue #7738](https://github.com/agda/agda/issues/7738): Rewriting by a constructor+- [Issue #7751](https://github.com/agda/agda/issues/7751): Application of module with datatype fools the termination checker+- [Issue #7753](https://github.com/agda/agda/issues/7753): Coverage checker internal error with copatterns and dot patterns+- [Issue #7759](https://github.com/agda/agda/issues/7759): Internal error for ellipsis without with-patterns+- [Issue #7761](https://github.com/agda/agda/issues/7761): Propω is not actually proof irrelevant+- [Issue #7765](https://github.com/agda/agda/issues/7765): Supply reason with UselessPublic warning+- [Issue #7766](https://github.com/agda/agda/issues/7766): .lagda.org: {-1} outside agda code block messes up hole detection+- [Issue #7769](https://github.com/agda/agda/issues/7769): The warning OpenPublicAbstract is wrongly formulated+- [Issue #7777](https://github.com/agda/agda/issues/7777): Parse error when using tactic and irrelevance+- [Issue #7788](https://github.com/agda/agda/issues/7788): TooManyPatternsInWithClause when nesting hidden `with`+- [Issue #7792](https://github.com/agda/agda/issues/7792): Inlining happens at most twice+- [Issue #7795](https://github.com/agda/agda/issues/7795): Polarity annotation ignored by positivity checker?+- [Issue #7796](https://github.com/agda/agda/issues/7796): Distinguish --no-guardedness from default value in termination hints?+- [Issue #7799](https://github.com/agda/agda/issues/7799): Potential regression related to instance resolution+- [Issue #7811](https://github.com/agda/agda/issues/7811): Internal error with Path and with-abstraction II+- [Issue #7815](https://github.com/agda/agda/issues/7815): Missing highlighting in module telescopes+- [Issue #7823](https://github.com/agda/agda/issues/7823): DISPLAY matches pattern with wrong amount of arguments+- [Issue #7825](https://github.com/agda/agda/issues/7825): DISPLAY form on irrelevant projection drops arguments+- [Issue #7832](https://github.com/agda/agda/issues/7832): Recursive function over inductive record treats arguments as irrelevant+- [Issue #7851](https://github.com/agda/agda/issues/7851): Error TooManyPolarities is too eager+- [Issue #7853](https://github.com/agda/agda/issues/7853): Subject reduction failure with instance constructors in parameterised modules+- [Issue #7856](https://github.com/agda/agda/issues/7856): Strange interaction between `opaque` and extended lambdas+- [Issue #7863](https://github.com/agda/agda/issues/7863): Internal error when calling MakeCase on target `__`+- [Issue #7878](https://github.com/agda/agda/issues/7878): Impossible with malformed notation RHS+- [Issue #7884](https://github.com/agda/agda/issues/7884): Better documentation of forester backend in CHANGELOG+- [Issue #7898](https://github.com/agda/agda/issues/7898): Solving with auto doesn't update constraints+- [Issue #7903](https://github.com/agda/agda/issues/7903): Constructor inlining defeated by moving binders+- [Issue #7911](https://github.com/agda/agda/issues/7911): `UnsolvedConstraints` error should reference location even when all metas were solved+- [Issue #7912](https://github.com/agda/agda/issues/7912): Missing error location for error: [ModuleNameDoesntMatchFileName]+- [Issue #7916](https://github.com/agda/agda/issues/7916): Make `-f optimise-heavily` default+- [Issue #7935](https://github.com/agda/agda/issues/7935): Document scoping rules for rewrite rules+- [Issue #7938](https://github.com/agda/agda/issues/7938): Request: Expose backend-internal modules as part of the library+- [Issue #7943](https://github.com/agda/agda/issues/7943): Local erased definition remains in compiled code+- [Issue #7944](https://github.com/agda/agda/issues/7944): Local erased modules break erasure analysis+- [Issue #7952](https://github.com/agda/agda/issues/7952): Primitive root example in docs+- [Issue #7953](https://github.com/agda/agda/issues/7953): Confusing error in case of illegal declaration before top-level module in a nested file+- [Issue #7966](https://github.com/agda/agda/issues/7966): Disallow option abbreviation+- [Issue #7973](https://github.com/agda/agda/issues/7973): If rewrite does not rewrite anything, give a warning+- [Issue #7977](https://github.com/agda/agda/issues/7977): Soft error for unknown attributes++PRs for closed for milestone 2.8.0++- [PR #6629](https://github.com/agda/agda/issues/6629): Reflection primitive for parsing surface level syntax from string.+- [PR #7010](https://github.com/agda/agda/issues/7010): [new] backend-end specific interaction+- [PR #7023](https://github.com/agda/agda/issues/7023): Add ⧺ in agda-input.el+- [PR #7287](https://github.com/agda/agda/issues/7287): Temporary fix for reflection of partial elements.+- [PR #7366](https://github.com/agda/agda/issues/7366): Handle symlinks correctly when computing interface file locations+- [PR #7374](https://github.com/agda/agda/issues/7374): New warning `WithClauseProjectionFixityMismatch` instead of GenericError+- [PR #7377](https://github.com/agda/agda/issues/7377): New warning `RecursiveDisplayForm` instead of hard error+- [PR #7379](https://github.com/agda/agda/issues/7379): Print error name with error message+- [PR #7385](https://github.com/agda/agda/issues/7385): New error group GHCBackendError instead of GenericError+- [PR #7387](https://github.com/agda/agda/issues/7387): Factor out `give_` and remove PatternErr handler+- [PR #7388](https://github.com/agda/agda/issues/7388): GenericError crusade, continued+- [PR #7391](https://github.com/agda/agda/issues/7391): New error NeedOptionAllowExec etc. instead of GenericError+- [PR #7394](https://github.com/agda/agda/issues/7394): New error group InteractionError+- [PR #7395](https://github.com/agda/agda/issues/7395): Get rid of some MonadFail in favor of __IMPOSSIBLE__+- [PR #7396](https://github.com/agda/agda/issues/7396): instance warning+- [PR #7403](https://github.com/agda/agda/issues/7403): New literate programming backend forester, `*.lagda.tree`+- [PR #7409](https://github.com/agda/agda/issues/7409): GenericError crusade goes on: NeedOptionSizedTypes etc.+- [PR #7412](https://github.com/agda/agda/issues/7412): pattern in path lambda+- [PR #7414](https://github.com/agda/agda/issues/7414): Replace interaction `Cmd_no_metas` by `Cmd_load_no_metas`+- [PR #7415](https://github.com/agda/agda/issues/7415): Error refactoring: use of `Exception`, generic errors+- [PR #7418](https://github.com/agda/agda/issues/7418): New errors CannotGenerate{HComp,Transport}Clause+- [PR #7425](https://github.com/agda/agda/issues/7425): GenericError replacements+- [PR #7426](https://github.com/agda/agda/issues/7426): #7371: add Mimer tests for -s and -l+- [PR #7430](https://github.com/agda/agda/issues/7430): Warnings instead of GenericError for ill-formed pragmas+- [PR #7435](https://github.com/agda/agda/issues/7435): Print warning name on same line as location+- [PR #7437](https://github.com/agda/agda/issues/7437): Reform printing of parse error+- [PR #7447](https://github.com/agda/agda/issues/7447): Add new error `InvalidModalTelescopeUse` and add reproducer.+- [PR #7451](https://github.com/agda/agda/issues/7451): New warning FixingRelevance instead of GenericError+- [PR #7453](https://github.com/agda/agda/issues/7453): New error NotAllowedInDotPatterns instead of GenericError+- [PR #7458](https://github.com/agda/agda/issues/7458): Add ZuriHac Video to tutorial-list+- [PR #7459](https://github.com/agda/agda/issues/7459): NotAValidLet{Expression,Binding} instead of GenericError+- [PR #7462](https://github.com/agda/agda/issues/7462): Naming generic syntax errors (GenericError quest)+- [PR #7473](https://github.com/agda/agda/issues/7473): Re #6919: also separate compilation warnings by newlines+- [PR #7478](https://github.com/agda/agda/issues/7478): Store warnings in a set rather than a list+- [PR #7481](https://github.com/agda/agda/issues/7481): Named Backend errors instead of GenericError+- [PR #7483](https://github.com/agda/agda/issues/7483): Some named scope errors replacing GenericError+- [PR #7488](https://github.com/agda/agda/issues/7488): Named scope errors instead of GenericError+- [PR #7491](https://github.com/agda/agda/issues/7491): ES6 modules+- [PR #7492](https://github.com/agda/agda/issues/7492): Correctly print ParserWarning range, remove `mdo`+- [PR #7496](https://github.com/agda/agda/issues/7496): Fix #7495: Check extra split clause patterns are trivial for exactness+- [PR #7498](https://github.com/agda/agda/issues/7498): Add Left Multimap (⟜) to agda-input.el+- [PR #7500](https://github.com/agda/agda/issues/7500): Fix & test `primShowNat`+- [PR #7501](https://github.com/agda/agda/issues/7501): handle ProjPs in DISPLAY pragmas+- [PR #7502](https://github.com/agda/agda/issues/7502): Make termination checking more permissive wrt non-exact clause reduction+- [PR #7504](https://github.com/agda/agda/issues/7504): [ fix #7503 ] Use principal sort of datatype for checking if split is ok+- [PR #7509](https://github.com/agda/agda/issues/7509): Fix #7508: remove unused-arg optimization from the JS backend+- [PR #7510](https://github.com/agda/agda/issues/7510): Expose the names of generated record constructors (reopen #6975)+- [PR #7511](https://github.com/agda/agda/issues/7511): Fix #7381: comply to GNU error standard: use dot instead of comma in ranges+- [PR #7512](https://github.com/agda/agda/issues/7512): GenericError crusade+- [PR #7513](https://github.com/agda/agda/issues/7513): Reconcile PR #7510 with commit ac2888a7ad: add Maybe Induction to scopeRecords+- [PR #7516](https://github.com/agda/agda/issues/7516): New error CannotQuote instead of GenericError+- [PR #7518](https://github.com/agda/agda/issues/7518): OccursCheckErrors+- [PR #7520](https://github.com/agda/agda/issues/7520): Drop GHC 8.6+- [PR #7534](https://github.com/agda/agda/issues/7534): Fix #7529: treat `LevelUniv` in Cubical Agda+- [PR #7536](https://github.com/agda/agda/issues/7536): Re #7533: warn when DISPLAY form binds variables unused on the rhs+- [PR #7539](https://github.com/agda/agda/issues/7539): Fix #7413: Cubical: a `GenericError` is actually `__IMPOSSIBLE__`+- [PR #7543](https://github.com/agda/agda/issues/7543): DISPLAY: match on defined names+- [PR #7545](https://github.com/agda/agda/issues/7545): Fix #7531: Preserve let bindings in the JS backend+- [PR #7550](https://github.com/agda/agda/issues/7550): Fix #7546: warn about empty POLARITY pragmas+- [PR #7555](https://github.com/agda/agda/issues/7555): Some error housekeeping+- [PR #7556](https://github.com/agda/agda/issues/7556): unquote errors+- [PR #7557](https://github.com/agda/agda/issues/7557): kill GenericError in instance search+- [PR #7559](https://github.com/agda/agda/issues/7559): Fix compilation of serialisation code on 32 bit platforms+- [PR #7566](https://github.com/agda/agda/issues/7566): Make dangling hidden/instance args into a warning+- [PR #7570](https://github.com/agda/agda/issues/7570): Optimize concrete name scopeLookup+- [PR #7572](https://github.com/agda/agda/issues/7572): Improvements to let desugaring+- [PR #7577](https://github.com/agda/agda/issues/7577): chore: remove uses of genericError+- [PR #7581](https://github.com/agda/agda/issues/7581): don't add generalizedTel definitions to mutual blocks+- [PR #7583](https://github.com/agda/agda/issues/7583): Implement conversion to JS `BigInt`+- [PR #7586](https://github.com/agda/agda/issues/7586): Support Happy 2.1.1+- [PR #7589](https://github.com/agda/agda/issues/7589): Fix #7575: Check if variables are generalizable in builtin pragmas+- [PR #7591](https://github.com/agda/agda/issues/7591): Fix #7588: Remove overlapping branches when simplifying chained cases+- [PR #7593](https://github.com/agda/agda/issues/7593): Fix #7576+- [PR #7604](https://github.com/agda/agda/issues/7604): REPL: fix printing of result of `:typeOf`+- [PR #7613](https://github.com/agda/agda/issues/7613): Correct parameters to wrapper modules created in module telescopes+- [PR #7617](https://github.com/agda/agda/issues/7617): Fix de Bruijn indices in Treeless primitive translation+- [PR #7622](https://github.com/agda/agda/issues/7622): [ fix #7618 ] Use `underAbstraction_` for going under lambda in `reduceAndEtaContract`+- [PR #7640](https://github.com/agda/agda/issues/7640): [ emacs ] adding su(b/p)(sim/approx) to input method+- [PR #7645](https://github.com/agda/agda/issues/7645): Fix #7642: new error CannotApply that mentions also term, not only type+- [PR #7648](https://github.com/agda/agda/issues/7648): Fix #7641: Range for ConstructorDoesNotFit warning (anon. rec. con.)+- [PR #7651](https://github.com/agda/agda/issues/7651): Fix #7650: Throw CaseSplitError when splitting on with-abstraction equality+- [PR #7652](https://github.com/agda/agda/issues/7652): remove the cubical identity type+- [PR #7653](https://github.com/agda/agda/issues/7653): Print point-ranges as such (line.col rather than line:col-col)+- [PR #7657](https://github.com/agda/agda/issues/7657): Setup: unconditionally check if we want interfaces+- [PR #7670](https://github.com/agda/agda/issues/7670): Fix typo `COMPILED`+- [PR #7672](https://github.com/agda/agda/issues/7672): Fix #7643: coverage: handle blocked sort in isFibrant+- [PR #7674](https://github.com/agda/agda/issues/7674): Fix #7669: positivity checker: compute function arity up to def. eq.+- [PR #7676](https://github.com/agda/agda/issues/7676): Remove `--local-interfaces` and warning `DuplicateInterfaceFiles`+- [PR #7677](https://github.com/agda/agda/issues/7677): Setup: fix `wantInterfaces` check+- [PR #7679](https://github.com/agda/agda/issues/7679): Disallow several .agda-lib files in the project root (#7678)+- [PR #7682](https://github.com/agda/agda/issues/7682): New main mode `--build-library`+- [PR #7685](https://github.com/agda/agda/issues/7685): Add dump-core cabal flag+- [PR #7686](https://github.com/agda/agda/issues/7686): Monomorphise unifyIndices+- [PR #7687](https://github.com/agda/agda/issues/7687): Make toTerm return a monadic function+- [PR #7688](https://github.com/agda/agda/issues/7688): Add some links to lecture notes and videos on Agda+- [PR #7697](https://github.com/agda/agda/issues/7697): Fix #7696: Add missing `addContext` when splitting on literals+- [PR #7699](https://github.com/agda/agda/issues/7699): Remove custom Setup.hs+- [PR #7700](https://github.com/agda/agda/issues/7700): Never generate dot patterns under --keep-pattern-variables+- [PR #7704](https://github.com/agda/agda/issues/7704): Speed up nix build+- [PR #7719](https://github.com/agda/agda/issues/7719): Embed data files into Agda binary+- [PR #7726](https://github.com/agda/agda/issues/7726): Compare overlapping instances in the right context+- [PR #7727](https://github.com/agda/agda/issues/7727): Fix #7722: in pattern parser only consider pattern-relevant operators+- [PR #7728](https://github.com/agda/agda/issues/7728): Improvements to instance search performance+- [PR #7729](https://github.com/agda/agda/issues/7729): Let Agda perform several of `--help`, `--version` etc. if the user requests so+- [PR #7732](https://github.com/agda/agda/issues/7732): Duplicate `agda-mode` as `agda --emacs-mode`+- [PR #7734](https://github.com/agda/agda/issues/7734): Doc: executable-dynamic no longer a problem on Linux+- [PR #7739](https://github.com/agda/agda/issues/7739): Fix #7738: Allow rewrite rule defined with constructor or primitive+- [PR #7742](https://github.com/agda/agda/issues/7742): Fix #7741: Fix printing inserted binder from operator section+- [PR #7743](https://github.com/agda/agda/issues/7743): Re-enable dot-pattern termination for Cubical Agda+- [PR #7745](https://github.com/agda/agda/issues/7745): Limit depth of constructed discrimination tree+- [PR #7746](https://github.com/agda/agda/issues/7746): Compute occurrences in trX “constructors”+- [PR #7750](https://github.com/agda/agda/issues/7750): Support GHC 9.12.2+- [PR #7752](https://github.com/agda/agda/issues/7752): Fix #7751: Consider datatype clauses generated from module application in recursion checker+- [PR #7758](https://github.com/agda/agda/issues/7758): Fix #7753: a possible `__IMPOSSIBLE__`+- [PR #7763](https://github.com/agda/agda/issues/7763): Fix #7761: Include large Prop in checks whether something is a Prop+- [PR #7764](https://github.com/agda/agda/issues/7764): Fixed #7730+- [PR #7767](https://github.com/agda/agda/issues/7767): Fix #7766: emacs org mode: fix code block end detection+- [PR #7768](https://github.com/agda/agda/issues/7768): Reason for UselessPublic; `private` useless in `where` blocks+- [PR #7771](https://github.com/agda/agda/issues/7771): Fix #7769: replace warning `OpenPublic{Abstract,Private}`+- [PR #7772](https://github.com/agda/agda/issues/7772): Fix #7707: wording of warning `ConstructorDoesNotFitInData`+- [PR #7773](https://github.com/agda/agda/issues/7773): Fix #7662: Mimer: special case for printing ♭+- [PR #7774](https://github.com/agda/agda/issues/7774): Fix #7321: warn about unused CATCHALL pragmas+- [PR #7775](https://github.com/agda/agda/issues/7775): Fix #6994: highlighting only for enabled warnings+- [PR #7776](https://github.com/agda/agda/issues/7776): Fix #7624 by reifying Term before wrapping it in GoalAndElaboration+- [PR #7778](https://github.com/agda/agda/issues/7778): Fix #6657: termination checker hints at missing --guardedness flag+- [PR #7782](https://github.com/agda/agda/issues/7782): re #3209: print out-of-scope names unqualified in case splits+- [PR #7783](https://github.com/agda/agda/issues/7783): Don't inline constructors into inline functions+- [PR #7785](https://github.com/agda/agda/issues/7785): Fix #7777: parse both attributes and irrelevance markers+- [PR #7786](https://github.com/agda/agda/issues/7786): New warning `UselessTactic` for `tactic` attribute on non-hidden binder+- [PR #7787](https://github.com/agda/agda/issues/7787): Small fixes for parsing and printing attributes+- [PR #7789](https://github.com/agda/agda/issues/7789): Fix issues #7759 and #7788: wrong counting of with-patterns in nested with+- [PR #7791](https://github.com/agda/agda/issues/7791): [ new ] unicode symbols for various 'tacks'+- [PR #7793](https://github.com/agda/agda/issues/7793): re #7792: keep inlining after inlining a copy+- [PR #7800](https://github.com/agda/agda/issues/7800): Fix #7796: don't hint towards --guardedness when --no-guardedness+- [PR #7802](https://github.com/agda/agda/issues/7802): Remove broken AbsurdLam heuristics from Mimer+- [PR #7804](https://github.com/agda/agda/issues/7804): re #7799: add instance hack to checkSectionApplication+- [PR #7812](https://github.com/agda/agda/issues/7812): Fix #7803 fix #7811: new error PathAbstractionFailed instead of crash+- [PR #7814](https://github.com/agda/agda/issues/7814): Fix #7660: new DisambiguateConstructor postponed tc problem+- [PR #7816](https://github.com/agda/agda/issues/7816): re #7815: propagate range into wrapper modules+- [PR #7817](https://github.com/agda/agda/issues/7817): Add documentation for telescopes and some related things+- [PR #7818](https://github.com/agda/agda/issues/7818): Make data directory overridable, default to XDG_DATA_HOME+- [PR #7819](https://github.com/agda/agda/issues/7819): [ fix #7392 ] Ensure wildcards and variable instances are kept+- [PR #7822](https://github.com/agda/agda/issues/7822): Fix issue #7537+- [PR #7824](https://github.com/agda/agda/issues/7824): Fix #7823: Compare number of arguments when matching on DISPLAY pragma+- [PR #7826](https://github.com/agda/agda/issues/7826): Fix #7825 by using `droppedPars` instead of hand-knitted code+- [PR #7830](https://github.com/agda/agda/issues/7830): Disregard qualified names when assigning clauses to functions in the nicifier+- [PR #7831](https://github.com/agda/agda/issues/7831): Fix #7829 by reactivating my own fix of #1618+- [PR #7834](https://github.com/agda/agda/issues/7834): fix #7795: Use occurrences from type for defs+- [PR #7840](https://github.com/agda/agda/issues/7840): Document which pragmas are unsafe+- [PR #7848](https://github.com/agda/agda/issues/7848): fix #7846: instance hack in abstract axioms+- [PR #7849](https://github.com/agda/agda/issues/7849): Fix for #7639+- [PR #7850](https://github.com/agda/agda/issues/7850): Re #7225: new error DatatypeIndexPolarity instead of GenericError+- [PR #7852](https://github.com/agda/agda/issues/7852): Turn TooManyPolarities error into warning (fixes #7851)+- [PR #7854](https://github.com/agda/agda/issues/7854): Modality warnings for constructors and fields+- [PR #7855](https://github.com/agda/agda/issues/7855): Re #7225 name error CubicalNotErasure+- [PR #7857](https://github.com/agda/agda/issues/7857): Forget opacity when checking signatures+- [PR #7858](https://github.com/agda/agda/issues/7858): Fix for #7659+- [PR #7859](https://github.com/agda/agda/issues/7859): Fix #7853: don't drop parameters of constructor in the same module+- [PR #7860](https://github.com/agda/agda/issues/7860): [ re #7587 ] Properly reintroduce absurd lambdas to Mimer+- [PR #7865](https://github.com/agda/agda/issues/7865): Fix #7863: properly parse names before case-splitting+- [PR #7867](https://github.com/agda/agda/issues/7867): Fix #7832 by placing properlyMatching in monad to have isEtaRecordConstructor+- [PR #7879](https://github.com/agda/agda/issues/7879): Fix #7878: reorder checks in `mkNotation`+- [PR #7880](https://github.com/agda/agda/issues/7880): Defer `MissingDefinitions` error in `--safe` until after typechecking+- [PR #7885](https://github.com/agda/agda/issues/7885): disable discrim-based instance deferral by default+- [PR #7886](https://github.com/agda/agda/issues/7886): [doc] explain how to do postprocessing for literate forester+- [PR #7891](https://github.com/agda/agda/issues/7891): Remove duplicate inverse scope computation.+- [PR #7895](https://github.com/agda/agda/issues/7895): Fix #7590+- [PR #7896](https://github.com/agda/agda/issues/7896): Fix #7324: highlighting of macro names in their definition+- [PR #7900](https://github.com/agda/agda/issues/7900): intro: filter (higher) constructors based on dimension+- [PR #7901](https://github.com/agda/agda/issues/7901): Properly update interaction points when solving with Mimer+- [PR #7904](https://github.com/agda/agda/issues/7904): Fix lexical-scope issue in emacs mode+- [PR #7907](https://github.com/agda/agda/issues/7907): Fix issue #7903: etaExpandClause before constructor inlining+- [PR #7913](https://github.com/agda/agda/issues/7913): Range information for unsolved instance constraints+- [PR #7920](https://github.com/agda/agda/issues/7920): Fix #7916: make optimise-heavily the default+- [PR #7924](https://github.com/agda/agda/issues/7924): Add a few notes on irrelevance+- [PR #7925](https://github.com/agda/agda/issues/7925): Add documentation for lambda expressions and absurd lambdas+- [PR #7931](https://github.com/agda/agda/issues/7931): Hint towards --guardedness even when --sized-types is on+- [PR #7932](https://github.com/agda/agda/issues/7932): Add `use-xdg-data-home`+- [PR #7934](https://github.com/agda/agda/issues/7934): Hygienic import of rewrite rules+- [PR #7936](https://github.com/agda/agda/issues/7936): Highlight only record keyword when fields are missing+- [PR #7939](https://github.com/agda/agda/issues/7939): Fix #7938: API: export Agda Highlighting Backend modules+- [PR #7942](https://github.com/agda/agda/issues/7942): [ doc ] remove reference to Cubical.Core.Everything+- [PR #7945](https://github.com/agda/agda/issues/7945): Fix #7944: do not apply `@0` from where-module to clause rhs+- [PR #7946](https://github.com/agda/agda/issues/7946): Fix #7943: propagate erasure status to `where` blocks.+- [PR #7956](https://github.com/agda/agda/issues/7956): Fix #7955: replace impossible with syntax error+- [PR #7957](https://github.com/agda/agda/issues/7957): Doc: replace PrimRoot by PrimeFactor in introductory text+- [PR #7958](https://github.com/agda/agda/issues/7958): Fix #7953: remember whether top-level module name was inferred+- [PR #7965](https://github.com/agda/agda/issues/7965): Re #7932: restore data-files in Agda.cabal and default data-dir+- [PR #7967](https://github.com/agda/agda/issues/7967): Fix #7966: fork GetOpt to disallow long option abbreviations+- [PR #7971](https://github.com/agda/agda/issues/7971): flake: use --build-library to build the builtins+- [PR #7978](https://github.com/agda/agda/issues/7978): Fix #7973: print warning if `rewrite` does not fire+- [PR #7981](https://github.com/agda/agda/issues/7981): Parse warning instead of error on unknown attributes and polarities
LICENSE view
@@ -1,22 +1,31 @@-Copyright (c) 2005-2022 remains with the authors.+Copyright (c) 2005-2025 remains with the authors. Agda 2 was originally written by Ulf Norell, partially based on code from Agda 1 by Catarina Coquand and Makoto Takeyama, and from Agdalight by Ulf Norell and Andreas Abel.+Cubical Agda was originally contributed by Andrea Vezzosi.  Agda 2 is currently actively developed mainly by Andreas Abel,-Guillaume Allais, Liang-Ting Chen, Jesper Cockx, Matthew Daggitt, Nils-Anders Danielsson, Ulf Norell, Andrés Sicard-Ramírez, and Andrea-Vezzosi.+Liang-Ting Chen, Lawrence Chonavel, Jesper Cockx,+Nils Anders Danielsson, Amélia Liao, Ulf Norell, and Szumi Xie. -Further, Agda 2 has received contributions by, amongst others, Stevan-Andjelkovic, Marcin Benke, Jean-Philippe Bernardy, Guillaume Brunerie,-James Chapman, Dominique Devriese, Péter Diviánszky, Robert Estelle,-Olle Fredriksson, Adam Gundry, Daniel Gustafsson, Philipp Hausmann,-Alan Jeffrey, Wolfram Kahl, Wen Kokke, John Leo, Fredrik Lindblad,-Víctor López Juan, Ting-Gan Lua, Francesco Mazzoli, Stefan Monnier,-Guilhem Moulin, Fredrik Nordvall Forsberg, Nicolas Pouillard, Jonathan-Prieto, Christian Sattler, Makoto Takeyama, Noam Zeilberger, and Tesla-Ice Zhang.  The full list of contributors is available at+Further, Agda 2 has received contributions by, amongst others,+Arthur Adjedj,  Guillaume Allais, Malin Altenmüller, Stevan Andjelkovic,+Marcin Benke, Jean-Philippe Bernardy, Guillaume Brunerie,+James Chapman, Joris Ceulemans, Jonathan Coates,+Matthew Daggitt, Dominique Devriese, Péter Diviánszky,+Lucas Escot, Robert Estelle,+Naïm Favier, Kuen-Bang Hou (Favonia), Olle Fredriksson,+Adam Gundry, Daniel Gustafsson,+Philipp Hausmann, Alex Haršáni,+Alan Jeffrey, Phil de Joux,+Wolfram Kahl, Andre Knispel, Wen Kokke, András Kovács,+John Leo, Fredrik Lindblad, Víctor López Juan, Ting-Gan Lua,+Francesco Mazzoli, Stefan Monnier, Guilhem Moulin,+Konstantin Nisht, Fredrik Nordvall Forsberg, Andreas Nuyts,+Josselin Poiret, Nicolas Pouillard, Jonathan Prieto,+Christian Sattler, Michael Shulman, Andrés Sicard-Ramírez,+Makoto Takeyama, Andrea Vezzosi, Noam Zeilberger, and Tesla Ice Zhang.+The full list of contributors is available at https://github.com/agda/agda/graphs/contributors or from the git repository via ``git shortlog -sne``. @@ -38,64 +47,3 @@ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.------------------------------------------------------------------------------------The file src/full/Agda/Utils/Maybe/Strict.hs (and the following-license text?) uses the following license:--Copyright (c) Roman Leshchinskiy 2006-2007--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:--1. Redistributions of source code must retain the above copyright-   notice, this list of conditions and the following disclaimer.-2. 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.-3. Neither the name of the author nor the names of his contributors-   may be used to endorse or promote products derived from this software-   without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.----------------------------------------------------------------------------The file src/data/html/highlight-hover.js (and the following licence-text?) seems to use the following licence:--Copyright 2002-2010, Simon Marlow.  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.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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
@@ -3,12 +3,11 @@  [![Hackage version](https://img.shields.io/hackage/v/Agda.svg?label=Hackage)](http://hackage.haskell.org/package/Agda) [![Stackage version](https://www.stackage.org/package/Agda/badge/lts?label=Stackage)](https://www.stackage.org/package/Agda)-[![Test](https://github.com/agda/agda/workflows/Build,%20Test,%20and%20Benchmark/badge.svg?branch=master)](https://github.com/agda/agda/actions?query=workflow%3A%22Build%2C+Test%2C+and+Benchmark%22)-[![Stack Build Status via GH Actions](https://github.com/agda/agda/workflows/stack%20build/badge.svg)](https://github.com/agda/agda/actions?query=workflow%3A%22stack+build%22)+[![Build, Test, and Benchmark](https://github.com/agda/agda/actions/workflows/test.yml/badge.svg)](https://github.com/agda/agda/actions/workflows/test.yml) [![Documentation Status](https://readthedocs.org/projects/agda/badge/?version=latest)](http://agda.readthedocs.io/en/latest/?badge=latest) [![Agda Zulip](https://img.shields.io/badge/zulip-join_chat-brightgreen.svg)](https://agda.zulipchat.com) -![The official Agda logo](doc/user-manual/agda.svg)+![The official Agda logo](https://raw.githubusercontent.com/agda/agda/master/doc/user-manual/agda.svg)  Note that this README is only about Agda, not its standard library. See the [Agda Wiki][agdawiki] for information about the@@ -19,7 +18,7 @@  * [User manual](http://agda.readthedocs.io)   (per-commit pdf can be downloaded from the-  [github actions](https://github.com/agda/agda/actions?query=workflow%3A%22User+Manual%22) page)+  [github actions](https://github.com/agda/agda/actions/workflows/user_manual.yml) page) * [CHANGELOG](https://github.com/agda/agda/blob/master/CHANGELOG.md)  Getting Started
− Setup.hs 
@@ -1,133 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NondecreasingIndentation #-}--import Data.Maybe--import Distribution.Simple-import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.Setup-import Distribution.Simple.BuildPaths (exeExtension)-import Distribution.PackageDescription-#if MIN_VERSION_Cabal(2,3,0)-import Distribution.System ( buildPlatform )-#endif-import System.FilePath-import System.Directory (makeAbsolute, removeFile)-import System.Environment (getEnvironment)-import System.Process-import System.Exit-import System.IO.Error (isDoesNotExistError)--import Control.Monad (when, forM_, unless)-import Control.Exception (catch, throwIO)--main :: IO ()-main = defaultMainWithHooks userhooks--userhooks :: UserHooks-userhooks = simpleUserHooks-  { copyHook  = copyHook'-  , instHook  = instHook'-  }---- Install and copy hooks are default, but amended with .agdai files in data-files.-instHook' :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO ()-instHook' pd lbi hooks flags = instHook simpleUserHooks pd' lbi hooks flags where-  pd' = pd { dataFiles = concatMap expandAgdaExt $ dataFiles pd }---- Andreas, 2020-04-25, issue #4569: defer 'generateInterface' until after--- the library has been copied to a destination where it can be found.--- @cabal build@ will likely no longer produce the .agdai files, but @cabal install@ does.-copyHook' :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO ()-copyHook' pd lbi hooks flags = do-  -- Copy library and executable etc.-  copyHook simpleUserHooks pd lbi hooks flags-  unless (skipInterfaces lbi) $ do-    -- Generate .agdai files.-    generateInterfaces pd lbi-    -- Copy again, now including the .agdai files.-    copyHook simpleUserHooks pd' lbi hooks flags-  where-  pd' = pd-    { dataFiles = concatMap expandAgdaExt $ dataFiles pd-      -- Andreas, 2020-04-25, issue #4569:-      -- I tried clearing some fields to avoid copying again.-      -- However, cabal does not like me messing with the PackageDescription.-      -- Clearing @library@ or @executables@ leads to internal errors.-      -- Thus, we just copy things again.  Not a terrible problem.-    -- , library       = Nothing-    -- , executables   = []-    -- , subLibraries  = []-    -- , foreignLibs   = []-    -- , testSuites    = []-    -- , benchmarks    = []-    -- , extraSrcFiles = []-    -- , extraTmpFiles = []-    -- , extraDocFiles = []-    }---- Used to add .agdai files to data-files-expandAgdaExt :: FilePath -> [FilePath]-expandAgdaExt fp | takeExtension fp == ".agda" = [ fp, toIFile fp ]-                 | otherwise                   = [ fp ]--toIFile :: FilePath -> FilePath-toIFile file = replaceExtension file ".agdai"---- Andreas, 2019-10-21, issue #4151:--- skip the generation of interface files with program suffix "-quicker"-skipInterfaces :: LocalBuildInfo -> Bool-skipInterfaces lbi = fromPathTemplate (progSuffix lbi) == "-quicker"--generateInterfaces :: PackageDescription -> LocalBuildInfo -> IO ()-generateInterfaces pd lbi = do--  -- for debugging, these are examples how you can inspect the flags...-  -- print $ flagAssignment lbi-  -- print $ fromPathTemplate $ progSuffix lbi--  -- then...-  let bdir = buildDir lbi-      agda = bdir </> "agda" </> "agda" <.> agdaExeExtension--  ddir <- makeAbsolute $ "src" </> "data"--  -- assuming we want to type check all .agda files in data-files-  -- current directory root of the package.--  putStrLn "Generating Agda library interface files..."-  forM_ (dataFiles pd) $ \fp -> when (takeExtension fp == ".agda") $ do-    let fullpath  = ddir </> fp-    let fullpathi = toIFile fullpath--    -- remove existing interface file-    let handleExists e | isDoesNotExistError e = return ()-                       | otherwise             = throwIO e--    removeFile fullpathi `catch` handleExists--    putStrLn $ "... " ++ fullpath-    ok <- rawSystem' ddir agda [ "--no-libraries", "--local-interfaces"-                               , "--ignore-all-interfaces"-                               , "-Werror"-                               , fullpath, "-v0"-                               ]-    case ok of-      ExitSuccess   -> return ()-      ExitFailure _ -> die $ "Error: Failed to typecheck " ++ fullpath ++ "!"--agdaExeExtension :: String-#if MIN_VERSION_Cabal(2,3,0)-agdaExeExtension = exeExtension buildPlatform-#else-agdaExeExtension = exeExtension-#endif--rawSystem' :: FilePath -> String -> [String] -> IO ExitCode-rawSystem' agda_datadir cmd args = do-  -- modify environment with Agda_datadir, so agda-executable will look-  -- for data-files in the right place-  e <- getEnvironment-  let e' = ("Agda_datadir", agda_datadir) : e-  (_,_,_,p) <- createProcess_ "rawSystem" (proc cmd args) { delegate_ctlc = True, env = Just e' }-  waitForProcess p
+ doc/release-notes/2.6.2.2.md view
@@ -0,0 +1,109 @@+Release notes for Agda version 2.6.2.2+======================================++Highlights+----------++* Agda 2.6.2.2 catches up to changes in the Haskell ecosystem+  (`bytestring-0.11.2.0`, `mtl-2.3-rc3/4`, `text-icu-0.8.0.1`,+  stackage `lts-19.0` and `nightly`).++* Fixes inconsistency [#5838](https://github.com/agda/agda/issues/5838)+  in `--cubical`.++* Fixes some regressions introduced in 2.6.1:++  - [#5809](https://github.com/agda/agda/issues/5809):+    internal error with `--irrelevant-projections`.++* Fixes some regressions introduced in 2.6.2:++  - [#5705](https://github.com/agda/agda/issues/5705) and+    [#5706](https://github.com/agda/agda/issues/5706):+    inconsistency from universe level `Int` overflow.++  - [#5784](https://github.com/agda/agda/issues/5784):+    `primEraseEquality` does not compute.++  - [#5805](https://github.com/agda/agda/issues/5805):+    internal error involving holes and `with`.++  - [#5819](https://github.com/agda/agda/issues/5819):+    internal error when reducing in termination checker.++* Other+  [fixes](https://github.com/agda/agda/issues?q=is%3Aissue+milestone%3A2.6.2.2+is%3Aclosed)+  and improvements (see below).++Installation and infrastructure+-------------------------------++Agda supports GHC versions 8.0.2 to 9.2.2.++* UTF-8 encoding is now used for the `libraries` and `executables`+  configuration files (issue+  [#5741](https://github.com/agda/agda/issues/5741)).++Language+--------++* `macro` definitions can now be used even when they are declared as erased+  (PR [#5744](https://github.com/agda/agda/pull/5744)).+  For example, this is now accepted:+  ```agda+  macro+    @0 trivial : Term → TC ⊤+    trivial = unify (con (quote refl) [])++  test : 42 ≡ 42+  test = trivial+  ```++* Fixed inconsistent `--cubical` reductions for `transp`:+  issue [#5838](https://github.com/agda/agda/issues/5838).++* Fixed issues with reflection:++  - [#5762](https://github.com/agda/agda/issues/5762):+    do not eagerly check existence of commands in `executables` file.++  - [#5695](https://github.com/agda/agda/issues/5695):+    fix `elaborate-and-give` interaction command.++  - [#5700](https://github.com/agda/agda/issues/5700):+    scope of metas created during macro expansion.++  - [#5712](https://github.com/agda/agda/issues/5712):+    internal error with tactics on record fields of function type.++* Fixed issues with instance search:++  - [#5583](https://github.com/agda/agda/issues/5583):+    constructor instances from parameterized modules.++  - [#5787](https://github.com/agda/agda/issues/5787):+    erased instance arguments.++* Fixed issue [#5683](https://github.com/agda/agda/issues/5683) with+  generalization in `let`.++Compiler backends+-----------------++* `.hs` files generated by the GHC backend now switch off the+  `warn-overlapping-patterns` warning (issue+  [#5758](https://github.com/agda/agda/issues/5758)).++* The GHC backend now calls `ghc` with environment setting+  `GHC_CHARENC=UTF-8` (issue+  [#5742](https://github.com/agda/agda/issues/5742)).++Performance+-----------++* Better caching of interfaces+  (issue [#2767](https://github.com/agda/agda/issues/2767)).++* Various performance improvements concerning meta-variables:+  issue [#5388](https://github.com/agda/agda/issues/5388)+  and PR [#5733](https://github.com/agda/agda/pull/5733).
+ doc/release-notes/2.6.3.md view
@@ -0,0 +1,522 @@+Release notes for Agda version 2.6.3+====================================++Highlights+----------++* Added support for [Erased Cubical+  Agda](https://agda.readthedocs.io/en/v2.6.3/language/cubical.html#cubical-agda-with-erased-glue),+  a variant of Cubical Agda that is supported by the GHC backend,+  under the flag `--erased-cubical`.++* Added a new flag `--cubical-compatible` to turn on generation of+  Cubical Agda-specific support code (previously this behaviour was+  part of `--without-K`).++  Since `--cubical-compatible` mode implies that functions should work+  with the preliminary support for [indexed inductive types in Cubical+  Agda](https://agda.readthedocs.io/en/v2.6.3/language/cubical.html#indexed-inductive-types),+  many pattern matching functions will now emit an+  `UnsupportedIndexedMatch` warning, indicating that the function will+  not compute when applied to transports (from `--cubical` code).++  This warning can be disabled with `-WnoUnsupportedIndexedMatch`, which+  can be used either in an `OPTIONS` pragma or in your `agda-lib` file.+  The latter is recommended if your project is only+  `--cubical-compatible`, or if it is already making extensive use of+  indexed types.++  Note that code that uses (only) `--without-K` can no longer be+  imported from code that uses `--cubical`. Thus it may make sense to+  replace `--without-K` with `--cubical-compatible` in library code,+  if possible.++  Note also that Agda tends to be quite a bit faster if `--without-K`+  is used instead of `--cubical-compatible`.++* Agda 2.6.3 seems to type-check one variant of the standard library+  about [30%+  faster](https://github.com/agda/agda/issues/6049#issuecomment-1329163727)+  than Agda 2.6.2.2 (on one system; the library was changed in a small+  way between the tests to accommodate changes to Agda). In that test+  the standard library did not use the new flag+  `--cubical-compatible`. With that flag enabled in all the files that+  used to use `--without-K` (and the warning `UnsupportedIndexedMatch`+  turned off) Agda 2.6.3 was still about 10% faster.++* New primitives `declareData`, `defineData`, and `unquoteDecl data`+  for generating new data types have been added to the [reflection+  API](https://agda.readthedocs.io/en/v2.6.3/language/reflection.html#metaprogramming).++Installation and infrastructure+-------------------------------++Agda supports GHC versions 8.0.2 to 9.4.4.++Erasure+-------++* The new option `--erased-cubical` turns on a variant of Cubical Agda+  (see [#4701](https://github.com/agda/agda/issues/4701)).++  When this variant of Cubical Agda is used glue (and some related+  builtins) may only be used in erased settings. One can import+  regular Cubical Agda code from this variant of Cubical Agda, but+  names defined using Cubical Agda are (mostly) treated as if they had+  been marked as erased. See the [reference+  manual](https://agda.readthedocs.io/en/v2.6.3/language/cubical.html#cubical-agda-with-erased-glue-and-erased-higher-constructors)+  for more details.++  The GHC backend can compile code that uses `--erased-cubical` if the+  top-level module uses this flag.++  This feature is experimental.++* Added an option `--erase-record-parameters` that marks parameters to+  record fields and definitions in a record module as erased (see+  [#4786](https://github.com/agda/agda/issues/4786) and+  [#5770](https://github.com/agda/agda/issues/5770)). For example:++  ```agda+  {-# OPTIONS --erase-record-parameters #-}++  record R (A : Set) : Set where+    field+      f : A++  test : {@0 A : Set} → R A → A+  test = R.f+  ```++Cubical Agda+------------++* [**Breaking**] The generation of Cubical Agda-specific support code was removed+  from `--without-K` and transferred to its own flag,+  `--cubical-compatible` (see+  [#5843](https://github.com/agda/agda/issues/5843) and+  [#6049](https://github.com/agda/agda/issues/6049) for the+  rationale).++* Cubical Agda now has experimental support for indexed inductive types+  ([#3733](https://github.com/agda/agda/issues/3733)).+  See the [user guide](https://agda.readthedocs.io/en/v2.6.3/language/cubical.html#indexed-inductive-types)+  for caveats.++* The cubical interval `I` now belongs to its own sort, `IUniv`, rather+  than `SSet`. For `J : IUniv` and `A : J → Set l`, we have+  `(j : J) → A j : Set l`, that is, the type of functions from a type in `IUniv`+  to a fibrant type is fibrant.++* The option `--experimental-irrelevance` is now perhaps incompatible+  with Cubical Agda and perhaps also postulated univalence (see+  [#5611](https://github.com/agda/agda/issues/5611) and+  [#5861](https://github.com/agda/agda/pull/5861)).++  This is not meant to imply that the option was not already+  incompatible with those things. Note that+  `--experimental-irrelevance` cannot be used together with `--safe`.++* A new built-in constructor `REFLID` was added to the cubical identity+  types. This is definitionally equal to the reflexivity identification+  built with `conid`, with the difference being that matching on+  `REFLID` is allowed.++  ```agda+  symId : ∀ {a} {A : Set a} {x y : A} → Id x y → Id y x+  symId reflId = reflId+  ```++* Definitions which pattern match on higher-inductive types are no+  longer considered for injectivity analysis.+  ([#6219](https://github.com/agda/agda/pull/6219))++* [**Breaking**] Higher constructors are no longer considered as guarding in the productivity check.+  ([#6108](https://github.com/agda/agda/issues/6108))++* Rewrite rules with interval arguments are now supported.+  ([#4384](https://github.com/agda/agda/issues/4384))++The flat modality+-----------------++* [**Breaking**] The `@flat`/`@♭` modality is now by default disabled (see+  [#4927](https://github.com/agda/agda/issues/4927)).++  It can be enabled using the infective flag `--cohesion`.++* [**Breaking**] Matching on `@flat` arguments is now disabled by default, the flag+  `--no-flat-split` has been removed, and the flag `--flat-split` is+  now infective (see [#6238](https://github.com/agda/agda/issues/6238)+  and [#6263](https://github.com/agda/agda/issues/6263)).++  Matching can be enabled using the `--flat-split` flag. Note that in+  Cubical Agda functions that match on an argument marked with `@flat`+  trigger the `UnsupportedIndexedMatch` warning, and the code might+  not compute properly.++Reflection+----------++* Two new reflection primitives++  ```agda+  declareData      : Name → Nat → Type → TC ⊤+  defineData       : Name → List (Σ Name (λ _ → Type)) → TC ⊤+  ```++  are added for declaring and defining datatypes, similar to+  `declareDef` and `defineDef`.++* The construct `unquoteDecl` is extended with the ability of bringing+  a datatype `d` and its constructors `c₁ ... cₙ` given by a `TC`+  computation `m` into scope by the following syntax:++  ```agda+  unquoteDecl data x constructor c₁ .. cₙ = m+  ```++* A new reflection primitive `getInstances : Meta → TC (List Term)`+  was added to `Agda.Builtin.Reflection`. This operation returns the+  list of all possibly valid instance candidates for a given+  metavariable. For example, the following macro instantiates the goal+  with the first instance candidate, even if there are several:+  ```agda+  macro+    pickWhatever : Term → TC ⊤+    pickWhatever hole@(meta m _) = do+      (cand ∷ _) ← getInstances m+        where [] -> typeError (strErr "No candidates!" ∷ [])+      unify hole cand+    pickWhatever _ = typeError (strErr "Already solved!" ∷ [])+  ```++* [**Breaking**] The reflection primitives `getContext` and `inContext` use a nominal context+  `List (Σ String λ _ → Arg Type)` instead of  `List (Arg Type)` for printing+  type information better. Similarly, `extendContext` takes an extra argument+  of type `String`.++* `macro` definitions can now be used even when they are declared as erased.+  For example, this is now accepted:+  ```agda+  macro+    @0 trivial : Term → TC ⊤+    trivial = unify (con (quote refl) [])++  test : 42 ≡ 42+  test = trivial+  ```++* A new reflection primitive `formatErrorParts : List ErrorPart → TC String`+  is added. It takes a list of `ErrorPart` and return its formatted string.++* [**Breaking**] A new constructor `pattErr : Pattern → ErrorPart` of `ErrorPart` for reflection+  is added.++* [**Breaking**] The reflection primitives `getType` and+  `getDefinition` respect the module context they are invoked from+  instead of returning information that would be expected in the top+  context.++* [**Breaking**] The reflection primitive `inContext` cannot step+  outside of the context that the `TC` computation is invoked from+  anymore. The telescope is now relative to that context instead.++Syntax+------++* It is now OK to put lambda-bound variables anywhere in the+  right-hand side of a syntax declaration. However, there must always+  be at least one "identifier" between any two regular "holes". For+  instance, the following syntax declaration is accepted because `-`+  is between the holes `B` and `D`.++  ```agda+  postulate+    F : (Set → Set) → (Set → Set) → Set++  syntax F (λ A → B) (λ C → D) = B A C - D+  ```++* Syntax can now use lambdas with multiple arguments+  ([#394](https://github.com/agda/agda/issues/394)).++  Example:++  ```agda+  postulate+    Σ₂ : (A : Set) → (A → A → Set) → Set++  syntax Σ₂ A (λ x₁ x₂ → P) = [ x₁ x₂ ⦂ A ] × P+  ```++Builtins+--------++* [**Breaking**] Change `primFloatToWord64` to return `Maybe Word64`.+  (See [#6093](https://github.com/agda/agda/issues/6093).)++  The new type is+  ```agda+    primFloatToWord64 : Float → Maybe Word64+  ```+  and it returns `nothing` for `NaN`.++* [**Breaking**] The type expected by the builtin `EQUIVPROOF` has been changed to+  properly encode the condition that `EQUVIFUN` is an equivalence.+  ([#5661](https://github.com/agda/agda/issues/5661),+  [#6032](https://github.com/agda/agda/pull/6032))++* [**Breaking**] The primitive `primIdJ` has been removed+  ([#6032](https://github.com/agda/agda/pull/6032)) in favour of+  matching on the cubical identity type.++* [**Breaking**] The builtin `SUBIN` is now exported from `Agda.Builtin.Cubical.Sub` as+  **`inS`** rather than `inc`. Similarly, the internal modules refer to+  `primSubOut` as `outS`. ([#6032](https://github.com/agda/agda/pull/6032))++Pragmas and options+-------------------++* It is now possible to declare several `BUILTIN REWRITE` relations.+  Example:+  ```agda+  {-# OPTIONS --rewriting #-}++  open import Agda.Builtin.Equality+  open import Agda.Builtin.Equality.Rewrite  -- 1st rewrite relation++  postulate+    R : (A : Set) → A → A → Set+    A : Set+    a b c : A+    foo : R A a b  -- using 2nd rewrite relation+    bar : b ≡ c    -- using 1st rewrite relation++  {-# BUILTIN REWRITE R #-}  -- 2nd rewrite relation+  {-# REWRITE foo bar #-}++  test : a ≡ c+  test = refl+  ```++* [**Breaking**] The option `--experimental-lossy-unification` that+  makes Agda sometimes use first-order unification has been renamed to+  `--lossy-unification`+  ([#1625](https://github.com/agda/agda/issues/1625)).++  Note that use of this option is associated with some potential+  [drawbacks](https://agda.readthedocs.io/en/v2.6.3/language/lossy-unification.html#drawbacks).++* The new option `--no-load-primitives` complements `--no-import-sorts`+  by foregoing loading of the primitive modules altogether. This option+  leaves Agda in a very fragile state, as the built-in sorts are used+  extensively throughout the implementation. It is intended to be used+  by Literate Agda projects which want to bind `BUILTIN TYPE` (and+  other primitives) in their own literate files.++* If `--interaction-exit-on-error` is used, then Agda exits with a+  non-zero exit code if `--interaction` or `--interaction-json` are+  used and a type error is encountered. The option also makes Agda+  exit with exit code 113 if Agda fails to parse a command.++  This option might for instance be used if Agda is controlled from a+  script.++* Add a `NOT_PROJECTION_LIKE` pragma, which marks a function as not+  suitable for projection-likeness. Projection-like functions have some of+  their arguments erased, which can cause confusing behaviour when they+  are printed instantiated (see [#6203](https://github.com/agda/agda/issues/6203)).++* [**Breaking**] The options `--subtyping` and `--no-subtyping` have been removed+  (see [#5427](https://github.com/agda/agda/issues/5427)).++Profiling and performance+-------------------------++* New verbosity `-v debug.time:100` adds time stamps to debugging output.++* [**Breaking**] Profiling options are now turned on with a new `--profile` flag+  instead of abusing the debug verbosity option. (See+  [#5781](https://github.com/agda/agda/issues/5781).)++* The new profiling option `--profile=conversion` collects statistics+  on how often various steps of the conversion algorithm are used+  (reduction, eta-expansion, syntactic equality, etc).++* Meta-variables can now be saved in `.agdai` files, instead+  of being expanded. This can affect performance. (See+  [#5731](https://github.com/agda/agda/issues/5731).)++  Meta-variables are saved if the pragma option `--save-metas` is+  used. This option can be overridden by `--no-save-metas`.++* The new option `--syntactic-equality[=FUEL]` can be used to limit+  how many times the syntactic equality shortcut is allowed to fail+  (see [#5801](https://github.com/agda/agda/issues/5801)).++  If `FUEL` is omitted, then the syntactic equality shortcut is+  enabled without any restrictions.++  If `FUEL` is given, then the syntactic equality shortcut is given+  `FUEL` units of fuel. The exact meaning of this is+  implementation-dependent, but successful uses of the shortcut do not+  affect the amount of fuel. Currently the fuel is decreased in the+  failure continuations of the implementation of the syntactic+  equality shortcut. When a failure continuation completes the fuel is+  restored to its previous amount.++  The idea for this option comes from András Kovács'+  [smalltt](https://github.com/AndrasKovacs/smalltt/blob/989b020309686e04374f1ab7844f468386d2eb2f/README.md#approximate-conversion-checking).++  Note that this option is experimental and subject to change.++Library management+------------------++* Library files below the "project root" are now ignored+  (see [#5644](https://github.com/agda/agda/issues/5644)).++  For instance, if you have a module called `A.B.C` in the directory+  `Root/A/B`, then `.agda-lib` files in `Root/A` or `Root/A/B` do not+  affect what options are used to type-check `A.B.C`: `.agda-lib`+  files for `A.B.C` have to reside in `Root`, or further up the+  directory hierarchy.++Interaction+-----------++* Agsy ([automatic proof search](https://agda.readthedocs.io/en/v2.6.3/tools/auto.html)) can+  now be invoked in the right-hand-sides of copattern matching clauses.+  ([#5827](https://github.com/agda/agda/pull/5827))++Compiler backends+-----------------++* [**Breaking**] Both the GHC and JS backends now refuse to compile code that uses+  `--cubical`.++  Note that support for compiling code that uses `--erased-cubical`+  has been added to the GHC backend (see above).++* If the GHC backend is invoked when `--interaction` or+  `--interaction-json` is active (for instance when the Emacs mode is+  used), then GHC is now invoked from the directory containing the+  `MAlonzo` directory (see+  [#6194](https://github.com/agda/agda/issues/6194)).++  Before GHC was invoked from the Agda process's current working+  directory, and that is still the case if `--interaction` and+  `--interaction-json` are not used.++DOT backend+-----------++* The new option `--dependency-graph-include=LIBRARY` can be used to+  restrict the dependency graph to modules from one or more libraries+  (see [#5634](https://github.com/agda/agda/issues/5634)).++  Note that the module given on the command line might not be+  included.++* The generated graphs no longer contain "redundant" edges: if a+  module is imported both directly and indirectly, then the edge+  corresponding to the direct import is omitted.++JSON API+--------++* [**Breaking**] The JSON API now represents meta-variables differently, using+  objects containing two keys, `id` and `module`, both with values+  that are (natural) numbers. See+  [#5731](https://github.com/agda/agda/issues/5731).+++Other issues closed+--------------------++For 2.6.3, the following issues were also closed (see [bug+tracker](https://github.com/agda/agda/issues)):++  - [#3660](https://github.com/agda/agda/issues/3660): Wrong variable name in constraints for higher constructor+  - [#3986](https://github.com/agda/agda/issues/3986): Subtyping `.A -> B <= A -> B` leads to wrong `ArgInfo`+  - [#4103](https://github.com/agda/agda/issues/4103): Rewrite rule rejected because of projection likeness+  - [#4506](https://github.com/agda/agda/issues/4506): Lack of unicode support in locale may result in uncaught `IOException`+  - [#4725](https://github.com/agda/agda/issues/4725): Cubical Agda: Program rejected by termination checker due to moved dot pattern+  - [#4755](https://github.com/agda/agda/issues/4755): Rewrite rule on constructor uses wrong type for matching+  - [#4763](https://github.com/agda/agda/issues/4763): Cubical Agda: Unquote anonymous copattern involving path+  - [#5191](https://github.com/agda/agda/issues/5191): Unifier can use erased variables in non-erased data parameters+  - [#5257](https://github.com/agda/agda/issues/5257): Internal error when matching on user syntax with binding+  - [#5378](https://github.com/agda/agda/issues/5378): Internal error with tactic on record field+  - [#5448](https://github.com/agda/agda/issues/5448): Should the predicate be erasable in the subst rule (without-K)+  - [#5462](https://github.com/agda/agda/issues/5462): Internal error caused by a REWRITE on a projection-like function+  - [#5468](https://github.com/agda/agda/issues/5468): Disallow certain forms of pattern matching when an index is erased+  - [#5525](https://github.com/agda/agda/issues/5525): Duplicate entries in `executables` file lead to undefined behavior+  - [#5548](https://github.com/agda/agda/issues/5548): Agda infers an incorrect type with subtyping on+  - [#5551](https://github.com/agda/agda/issues/5551): Panic when showing module contents with pattern synonym+  - [#5563](https://github.com/agda/agda/issues/5563): Allow erased names in the type signatures of let-bound definitions+  - [#5577](https://github.com/agda/agda/issues/5577): The "Could not generate equivalence" warning is not always emitted+  - [#5581](https://github.com/agda/agda/issues/5581): Lexical error with tab character in literate Agda text+  - [#5589](https://github.com/agda/agda/issues/5589): Internal error with REWRITE of function from path+  - [#5681](https://github.com/agda/agda/issues/5681): Panic on record declaration with unknown sort+  - [#5702](https://github.com/agda/agda/issues/5702): Can't case split an `HitInt` with some already existing cases+  - [#5715](https://github.com/agda/agda/issues/5715): Reflection: Use `Telescope` for `getContext`, `inContext`, and `extendContext`+  - [#5727](https://github.com/agda/agda/issues/5727): Reducing universe levels before checking is not sufficient+  - [#5728](https://github.com/agda/agda/issues/5728): Internal error when pattern matching on `...` in with statement without providing a pattern match+  - [#5734](https://github.com/agda/agda/issues/5734): Relevance check in reflection+  - [#5751](https://github.com/agda/agda/issues/5751): json interaction produces Haskell output for `SolveAll`+  - [#5754](https://github.com/agda/agda/issues/5754): Internal error when compiling program with quoted metavariable+  - [#5760](https://github.com/agda/agda/issues/5760): Some code related to Cubical Agda runs also when the K rule is on+  - [#5763](https://github.com/agda/agda/issues/5763): Internal parser error using syntax rules+  - [#5765](https://github.com/agda/agda/issues/5765): Erasure check failure when pattern matching on refl in erased definition+  - [#5775](https://github.com/agda/agda/issues/5775): JSON interaction produces fully qualified terms+  - [#5794](https://github.com/agda/agda/issues/5794): Agsy/Auto crashes with `Prelude.!!: index too large`+  - [#5823](https://github.com/agda/agda/issues/5823): Singleton check loops on recursive eta record+  - [#5828](https://github.com/agda/agda/issues/5828): Agsy/Auto panics with `-r` in the presence of a pattern synonym+  - [#5845](https://github.com/agda/agda/issues/5845): Internal error caused by abstracting `variables`+  - [#5848](https://github.com/agda/agda/issues/5848): Internal error with `--confluence-check`+  - [#5850](https://github.com/agda/agda/issues/5850): Warn about useless hiding in `variable` declaration+  - [#5856](https://github.com/agda/agda/issues/5856): Lambda with irrefutable pattern is not rejected when used on Path+  - [#5868](https://github.com/agda/agda/issues/5868): Document `--two-level`+  - [#5875](https://github.com/agda/agda/issues/5875): Instance Search breaks Termination Highlighting+  - [#5891](https://github.com/agda/agda/issues/5891): `SizeUniv : SizeUniv` is inconsistent+  - [#5901](https://github.com/agda/agda/issues/5901): Use `emacs --batch` mode in `agda-mode` setup+  - [#5920](https://github.com/agda/agda/issues/5920): Erased constructors skipped in modality check+  - [#5922](https://github.com/agda/agda/issues/5922): Failure of termination checking for reflection-generated code due to data projections+  - [#5923](https://github.com/agda/agda/issues/5923): Internal error in rewriting+  - [#5944](https://github.com/agda/agda/issues/5944): Internal error in rewriting with `--two-level`+  - [#5953](https://github.com/agda/agda/issues/5953): Recursor of inductive-inductive type does not pass termination check in Cubical Agda+  - [#5955](https://github.com/agda/agda/issues/5955): Composition of Glue Type Causes Infinite Loop+  - [#5956](https://github.com/agda/agda/issues/5956): Cubical Agda crashes when printing empty system+  - [#5966](https://github.com/agda/agda/issues/5966): Improved performance by switching to `vector-hashtables`+  - [#5989](https://github.com/agda/agda/issues/5989): Dead-code elimination crashes function with private tactic argument+  - [#6003](https://github.com/agda/agda/issues/6003): de Bruijn index out of scope when rewriting+  - [#6006](https://github.com/agda/agda/issues/6006): Internal error rewriting with holes+  - [#6015](https://github.com/agda/agda/issues/6015): Pi types and Partial types should not be considered inter-convertible+  - [#6022](https://github.com/agda/agda/issues/6022): Private bindings in imported modules defeat check for binding of primIdFace/primIdPath+  - [#6042](https://github.com/agda/agda/issues/6042): De Bruijn index out of scope when rewriting without-K+  - [#6043](https://github.com/agda/agda/issues/6043): de Bruijn error on unexpected implicit argument+  - [#6059](https://github.com/agda/agda/issues/6059): Non-terminating function over tuples passed with `--termination-depth=2`+  - [#6066](https://github.com/agda/agda/issues/6066): Document the meaning of `pattern` without `no-eta-equality`+  - [#6067](https://github.com/agda/agda/issues/6067): Another de Bruijn error in rewriting+  - [#6073](https://github.com/agda/agda/issues/6073): Constraint solving does not honour singleton types+  - [#6074](https://github.com/agda/agda/issues/6074): `piSort`/`funSort` of `IUniv` should be blocked on the codomain+  - [#6076](https://github.com/agda/agda/issues/6076): Agda input mode (emacs): Minibuffer display for `\;` is strange+  - [#6080](https://github.com/agda/agda/issues/6080): A space leak due to `absName`+  - [#6082](https://github.com/agda/agda/issues/6082): Elaborate-and-give does not respect `--postfix-projections`+  - [#6095](https://github.com/agda/agda/issues/6095): Ambiguous pattern synonyms broken with anonymous module+  - [#6112](https://github.com/agda/agda/issues/6112): Internal error: non-confluent rewriting to singletons+  - [#6200](https://github.com/agda/agda/issues/6200): The reflection machinery does not treat the module telescope consistently+  - [#6203](https://github.com/agda/agda/issues/6203): Projection-likeness and instance arguments+  - [#6205](https://github.com/agda/agda/issues/6205): Internal error with `withReconstructed`+  - [#6244](https://github.com/agda/agda/issues/6244): Make `--no-load-primitives` not `--safe`+  - [#6250](https://github.com/agda/agda/issues/6250): Documentation says `--sized-types` is the default when it isn't+  - [#6257](https://github.com/agda/agda/issues/6257): Document options `--prop`, `--guarded`, and `--two-level`.+  - [#6265](https://github.com/agda/agda/issues/6265): Some options should be listed in `restartOptions`+  - [#6273](https://github.com/agda/agda/issues/6273): Missing highlighting when interleaved mutual is used+  - [#6276](https://github.com/agda/agda/issues/6276): LaTeX/HTML generation doesn't properly render parameters of pre-declared records+  - [#6281](https://github.com/agda/agda/issues/6281): Special treatment of attribute followed by underscore in pretty-printer+  - [#6337](https://github.com/agda/agda/issues/6337): `--lossy-unification` in Agda 2.6.3+  - [#6338](https://github.com/agda/agda/issues/6338): internal error in Agda, perhaps related to `--rewriting`+  - [#6377](https://github.com/agda/agda/issues/6377): Fix installation docs concerning icu libraries+  - [#6379](https://github.com/agda/agda/issues/6379): Weird warning for instance declarations of bad type
+ doc/release-notes/2.6.4.1.md view
@@ -0,0 +1,75 @@+Release notes for Agda version 2.6.4.1+======================================++This is a minor release of Agda 2.6.4 featuring a few changes:++- Make recursion on proofs legal again.+- Improve performance, e.g. by removing debug printing unless built with cabal flag `debug`.+- Switch to XDG directory convention.+- Reflection: change to order of results returned by `getInstances`.+- Fix some internal errors.++Installation+------------++* Agda supports GHC versions 8.6.5 to 9.8.1.++* Verbose output printing via `-v` or `--verbose` is now only active if Agda is built with the `debug` cabal flag.+  Without `debug`, no code is generated for verbose printing, which makes building Agda faster and Agda itself+  faster as well. (PR [#6863](https://github.com/agda/agda/pull/6863))++Language+--------++* A [change](https://github.com/agda/agda/pull/6639) in 2.6.4 that prevented all recursion on proofs,+  i.e., members of a type `A : Prop ℓ`, has been [reverted](https://github.com/agda/agda/pull/6936).+  It is possible again to use proofs as termination arguments.+  (See [issue #6930](https://github.com/agda/agda/issues/6930).)++Reflection+----------++Changes to the meta-programming facilities.++* The reflection primitive `getInstances` will now return instance+  candidates ordered by _specificity_, rather than in unspecified order:+  If a candidate `c1 : T` has a type which is a substitution instance of+  that of another candidate `c2 : S`, `c1` will appear earlier in the+  list.++  As a concrete example, if you have instances `F (Nat → Nat)`, `F (Nat+  → a)`, and `F (a → b)`, they will be returned in this order. See+  [issue #6944](https://github.com/agda/agda/issues/6944) for further+  motivation.++Library management+------------------++* Agda now follows the XDG base directory standard on Unix-like systems,+  see [PR #6858](https://github.com/agda/agda/pull/6858).+  This means, it will look for configuration files in `~/.config/agda` rather than `~/.agda`.++  For backward compatibility, if you still have an `~/.agda` directory, it will look there first.++  No change on Windows, it will continue to use `%APPDATA%` (e.g. `C:/Users/USERNAME/AppData/Roaming/agda`).+++Other issues closed+-------------------++For 2.6.4.1, the following issues were also+[closed](https://github.com/agda/agda/issues?q=is%3Aissue+milestone%3A2.6.4.1+is%3Aclosed)+(see [bug tracker](https://github.com/agda/agda/issues)):++- [#6745](https://github.com/agda/agda/issues/6745): Strange interaction between `opaque` and `let open`+- [#6746](https://github.com/agda/agda/issues/6746): Support GHC 9.8+- [#6852](https://github.com/agda/agda/issues/6852): Follow XDG Base Directory Specification+- [#6913](https://github.com/agda/agda/issues/6913): Internal error on `primLockUniv`-sorted functions+- [#6930](https://github.com/agda/agda/issues/6930): Termination checking with --prop: change in 2.6.4 compared with 2.6.3+- [#6931](https://github.com/agda/agda/issues/6931): Internal error with an empty parametrized module from a different file+- [#6941](https://github.com/agda/agda/issues/6941): Interaction between opaque and instance arguments+- [#6944](https://github.com/agda/agda/issues/6944): Order instances by specificity for reflection+- [#6953](https://github.com/agda/agda/issues/6953): Emacs 30 breaks agda mode+- [#6957](https://github.com/agda/agda/issues/6957): Agda stdlib installation instructions broken link+- [#6959](https://github.com/agda/agda/issues/6959): Warn about opaque `unquoteDecl`/`unquoteDef`+- [#6983](https://github.com/agda/agda/issues/6983): Refine command does not work on Emacs 30
+ doc/release-notes/2.6.4.2.md view
@@ -0,0 +1,47 @@+Release notes for Agda version 2.6.4.2+======================================++This is a bug-fix release.  It aims to be API-compatible with 2.6.4.1.+Agda 2.6.4.2 supports GHC versions 8.6.5 to 9.8.1.++Highlights+----------++- Fix an inconsistency in Cubical Agda related to catch-all clauses: [Issue #7033](https://github.com/agda/agda/issues/7033)+- Fix a regression in instance search introduced in 2.6.4.2: [Issue #7113](https://github.com/agda/agda/issues/7113)+- Fix a bug related to `opaque`:  [Issue #6972](https://github.com/agda/agda/issues/6972)+- Fix some internal errors:+  * [Issue #7029](https://github.com/agda/agda/issues/7029)+  * [Issue #7034](https://github.com/agda/agda/issues/7034)+  * [Issue #7044](https://github.com/agda/agda/issues/7044)+- Fix building with cabal flag `-f debug-serialisation`: [Issue #7081](https://github.com/agda/agda/issues/7081)++List of closed issues+---------------------++For 2.6.4.2, the following issues were+[closed](https://github.com/agda/agda/issues?q=is%3Aissue+milestone%3A2.6.4.2+is%3Aclosed)+(see [bug tracker](https://github.com/agda/agda/issues)):++- [Issue #6972](https://github.com/agda/agda/issues/6972): Unfolding fails when code is split up into multiple files+- [Issue #6999](https://github.com/agda/agda/issues/6999): Unification failure for function type with erased argument+- [Issue #7020](https://github.com/agda/agda/issues/7020): question: haskell backend extraction of `Data.Nat.DivMod.DivMod`?+- [Issue #7029](https://github.com/agda/agda/issues/7029): Internal error on confluence check when rewriting a defined symbol with a hole+- [Issue #7033](https://github.com/agda/agda/issues/7033): transpX clauses can be beat out by user-written _ clauses, leading to proof of ⊥+- [Issue #7034](https://github.com/agda/agda/issues/7034): Internal error with --two-level due to blocking on solved meta+- [Issue #7044](https://github.com/agda/agda/issues/7044): Serializer crashes on blocked definitions when using --allow-unsolved-metas+- [Issue #7048](https://github.com/agda/agda/issues/7048): hcomp symbols in interface not hidden under --cubical-compatible+- [Issue #7059](https://github.com/agda/agda/issues/7059): Don't recompile if --keep-pattern-variables option changes+- [Issue #7070](https://github.com/agda/agda/issues/7070): Don't set a default maximum heapsize for Agda runs+- [Issue #7081](https://github.com/agda/agda/issues/7081): Missing `IsString` instance with debug flags enabled+- [Issue #7095](https://github.com/agda/agda/issues/7095): Agda build flags appear as "automatic", but they are all "manual"+- [Issue #7104](https://github.com/agda/agda/issues/7104): Warning "there are two interface files" should not be serialized+- [Issue #7105](https://github.com/agda/agda/issues/7105): Internal error in generate-helper (C-c C-h)+- [Issue #7113](https://github.com/agda/agda/issues/7113): Instance resolution runs too late, leads to `with`-abstraction failure++These PRs not corresponding to issues were merged:++- [PR #6988](https://github.com/agda/agda/issues/6988): Provide a `.agda-lib` for Agda builtins+- [PR #7065](https://github.com/agda/agda/issues/7065): Some documentation fixes+- [PR #7072](https://github.com/agda/agda/issues/7072): Add 'Inference in Agda' to the list of tutorials+- [PR #7091](https://github.com/agda/agda/issues/7091): Add course to “Courses using Agda”
+ doc/release-notes/2.6.4.3.md view
@@ -0,0 +1,17 @@+Release notes for Agda version 2.6.4.3+======================================++This release fixes a regression in 2.6.4.2 and one in 2.6.4.+It aims to be API-compatible with 2.6.4.1 and 2.6.4.2.++Agda 2.6.4.3 supports GHC versions 8.6.5 to 9.8.1.++Closed issues+-------------++For 2.6.4.3, the following issues were+[closed](https://github.com/agda/agda/issues?q=is%3Aissue+milestone%3A2.6.4.3+is%3Aclosed)+(see [bug tracker](https://github.com/agda/agda/issues)):++- [Issue #7148](https://github.com/agda/agda/issues/7148): Regression in 2.6.4.2 concerning `with`+- [Issue #7150](https://github.com/agda/agda/issues/7150): Regression in 2.6.4 in `rewrite` with instances
+ doc/release-notes/2.6.4.md view
@@ -0,0 +1,588 @@+Release notes for Agda version 2.6.4+====================================++Highlights+----------++* Cubical Agda now displays boundary conditions in interactive mode+  (PR [#6529](https://github.com/agda/agda/pull/6529)).++* An inconsistency in the treatment of large indices has been fixed+  (Issue [#6654](https://github.com/agda/agda/issues/6654)).++* Unfolding of definitions can now be fine-controlled via `opaque` definitions.++* Additions to the sort system: `LevelUniv` and `Propω`.++* New flag `--erasure` with several improvements to erasure (declared run-time irrelevance).++* New reflection primitives for meta-programming.++Installation+------------++* Removed the cabal flag `cpphs` that enabled building Agda with `cpphs` instead of the default C preprocessor.++* Agda supports GHC versions 8.6.5 to 9.6.3.++Pragmas and options+-------------------++* New command-line option `--numeric-version` to just print the version number of Agda.++* Option `--version` now also prints the cabal flags active in this build of Agda+  (e.g. whether Agda was built with `-f enable-cluster-counting`).++* New command-line option `--trace-imports` to switch on notification messages+  on the end of compilation of an imported module+  or on access to an interface file during the type-checking.++  See [--trace-imports](https://agda.readthedocs.io/en/v2.6.4/tools/command-line-options.html#cmdoption-trace-imports)+  in the documentation for more.++* New option `--no-infer-absurd-clauses` to simplify coverage checking and case splitting:+  Agda will then no longer attempt to automatically eliminate absurd clauses which can be a costly operation.+  This means that these absurd clauses have to be written out in the Agda text.+  Try this option if you experience type checking performance degradation with omitted absurd clauses.++  Opposite: `--infer-absurd-clauses`.++* Benign warnings are now printed together with their warning name, to give a hint how they can be disabled+  (see [#6229](https://github.com/agda/agda/issues/6229)).++* New option `--level-universe` to make `Level` inhabit its own universe `LevelUniv`:+  When this option is turned on, `Level` can now only depend on terms of type `Level`.++  Note: While compatible with the `--cubical` option, this option is currently not compatible with cubical builtin files, and an error will be raised when trying to import them in a file using `--level-universe`.++  Opposite: `--no-level-universe`.++* Most boolean options now have their opposite, e.g., `--allow-unsolved-metas` is complemented by `--no-allow-unsolved-metas`.+  With the opposite one can override a previously given option.+  Options given on the command line are overwritten by options given in the `.agda-lib` file,+  which in turn get overwritten by options given in the individual `.agda` file.++  New options (all on by default):+  - `--no-allow-exec`+  - `--no-allow-incomplete-matches`+  - `--no-allow-unsolved-metas`+  - `--no-call-by-name`+  - `--no-cohesion`+  - `--no-count-clusters`+  - `--no-erased-matches`+  - `--no-erasure`+  - `--no-experimental-irrelevance`+  - `--no-flat-split`+  - `--no-guarded`+  - `--no-injective-type-constructors`+  - `--no-keep-covering-clauses`+  - `--no-lossy-unification`+  - `--no-keep-pattern-variables`+  - `--no-omega-in-omega`+  - `--no-postfix-projections`+  - `--no-rewriting`+  - `--no-show-identity-substitutions`+  - `--no-show-implicit`+  - `--no-show-irrelevant`+  - `--no-two-level`+  - `--no-type-in-type`+  - `--eta-equality`+  - `--fast-reduce`+  - `--forcing`+  - `--import-sorts`+  - `--load-primitives`+  - `--main`+  - `--pattern-matching`+  - `--positivity-check`+  - `--print-pattern-synonyms`+  - `--projection-like`+  - `--termination-check`+  - `--unicode`++* Option `--flat-split` again implies `--cohesion`.+  Reverts change introduced in Agda 2.6.3 where `--cohesion` was a prerequisite for `--flat-split`.++* Pragma `INLINE` may now be applied to constructors of types supporting co-pattern matching.+  It enables translation of right-hand-side constructor applications to left-hand-side co-pattern splits (see [PR #6682](https://github.com/agda/agda/pull/6682)).+  For example, this translation allows the `nats` function to pass termination checking:+  ```agda+    record Stream (A : Set) : Set where+      coinductive; constructor _∷_+      field head : A+            tail : Stream A+    open Stream+    {-# INLINE _∷_ #-}++    nats : Nat → Stream Nat+    nats n = n ∷ nats (1 + n)+  ```+  Inlining transforms the definition of `nats` to the following definition by copattern matching:+  ```agda+    nats n .head = n+    nats n .tail = nats (1 + n)+  ```+  This form is accepted by the termination checker;+  unlike the form before inlining, it does not admit any infinite reduction sequences.++  If option `--exact-split` is on, the inlining will trigger a `InlineNoExactSplit` warning for `nats`.+  This warning can be disabled as usual, with `-WnoInlineNoExactSplit`.++* New option `--large-indices`, controlling whether constructors of+  indexed data types are allowed to refer to data that would be "too+  large" to fit in their declared sort. Large indices are disallowed by+  default; see the [language changes](#language) for details.++* New option `--forced-argument-recursion`, on by default, controlling+  whether forced constructor arguments are usable for termination+  checking. This flag may be necessary for Agda to accept nontrivial+  uses of induction-induction.++* The suffix `Warning` has been dropped from the warning names+  `DuplicateFieldsWarning` and `TooManyFieldsWarning`.++* The warning `GenericUseless` has been split into the three warnings+  `UselessPragma`, `FaceConstraintCannotBeHidden` and `FaceConstraintCannotBeNamed`.++* New warning `PatternShadowsConstructor` which used to be an error.++Library management+------------------++* [**Breaking**] One can no longer have `.agda-lib` files that are+  located below the "project root", on the path to the file that is+  being type-checked (see+  [#6465](https://github.com/agda/agda/issues/6465)).++  For instance, if you have a module called `A.B.C` in the directory+  `Root/A/B`, then an error is raised if there are `.agda-lib` files+  in `Root/A` or `Root/A/B`.++  Previously such `.agda-lib` files were ignored.++Interaction and emacs mode+--------------------------++* Agda now supports reading files with extension `.lagda.typ`, and use the parser for+  markdown files to parse them.+  To edit such files in Emacs with Agda support, one needs to add the line+  ```elisp+  (add-to-list 'auto-mode-alist '("\\.lagda.typ\\'" . agda2-mode))+  ```+  to `.emacs`.++  Generation for highlighted code like HTML is unsupported for Typst.+  One may generate HTML with typst input, but that makes little sense,+  and markdown is recommended instead when HTML export is desired.++* Helper function (`C-c C-h`) does not abstract over module parameters anymore+  (see [#2271](https://github.com/agda/agda/issues/2271))+  and neither over generalized `variable`s+  (see [#6689](https://github.com/agda/agda/pull/6689)).++* New Agda input mode prefix `box` for APL boxed operators, e.g. `\box=` for ⌸;+  see PR [#6510](https://github.com/agda/agda/pull/6510/files) for full list of bindings.++* Cubical Agda will now report boundary information for interaction+  points which are not at the top-level of their respective clauses.+  This includes bodies of `Path`-typed values, the faces of a partial+  element, arguments to functions returning paths, etc.++  Since this information is available in a structured way _during+  interaction_, the "goal type, context, and inferred type" command will+  also display the value of the expression at each relevant face.++  See also [PR #6529](https://github.com/agda/agda/pull/6529) for a+  deeper explanation and a demo video.++Syntax+------++* Agda now skips the UTF8 byte order mark (BOM) at beginning of files+  (see [#6524](https://github.com/agda/agda/issues/6524)).+  Previously, the BOM caused a parse error.++* If the new option `--hidden-argument-puns` is used, then the pattern+  `{x}` is interpreted as `{x = x}`, and the pattern `⦃ x ⦄` is+  interpreted as `⦃ x = x ⦄` (see+  [#6325](https://github.com/agda/agda/issues/6325)). Here `x` must be+  an unqualified name that does not refer to a constructor that is in+  scope: if `x` is qualified, then the pattern is not interpreted as a+  pun, and if `x` is unqualified and refers to a constructor that is+  in scope, then the code is rejected.++  This feature can be turned off using `--no-hidden-argument-puns`.++  Note that `{(x)}` and `⦃ (x) ⦄` are not interpreted as puns.++  Note also that `{x}` is not interpreted as a pun in `λ {x} → …` or+  `syntax f {x} = …`. However, `{x}` is interpreted as a pun in+  `λ (c {x}) → …`.++* `postulate` blocks may now contain `private` declarations+  (see [#1702](https://github.com/agda/agda/issues/1702)).++Language+--------++* [**Breaking**] Constructor arguments are no longer allowed to store+  values of a type larger than their own sort, even when these values+  are forced by the indices of a constructor.++  This fixes a particular instance of the incompatibility between+  structural recursion and impredicativity, which could previously be+  exploited through the use of large data-type indices.+  (see [#6654](https://github.com/agda/agda/issues/6654)).++  This behaviour can be controlled with the flag `--large-indices`. Note+  that, when `--large-indices` is enabled, forced constructor arguments+  should not be used for termination checking. The flag+  `--[no-]forced-argument-recursion` makes the termination checker skip+  these arguments entirely. When `--safe` is given, `--large-indices` is+  incompatible with `--without-K` _and_ incompatible with+  `--forced-argument-recursion`.++* Added [`opaque` definitions](https://agda.readthedocs.io/en/v2.6.4/language/opaque-definitions.html),+  a mechanism for finer-grained control of unfolding. Unlike `abstract`+  definitions, which can never be unfolded outside of (a child module+  of) the defining module, opacity can be toggled at use-sites:++  ```agda+  opaque+    foo : Set+    foo = Nat++  opaque+    unfolding foo++    _ : foo+    _ = 123+  ```++* Unless `--no-import-sorts` is given, `Set` is in scope as before,+  but `Prop` is only in scope when `--prop` is active.+  Additionally `SSet` is now in scope when `--two-level` is active+  (see [#6634](https://github.com/agda/agda/pull/6634)).++* New sorts `Propω`, `Propω₁`, etc., in analogy to `Setω`, `Setω₁` etc.+  Requires option `--prop`.++  Example:+  ```agda+  {-# OPTIONS --prop --large-indices #-}++  open Agda.Primitive++  variable+    ℓ : Level+    A : Set ℓ++  -- Lists of elements of types at any finite level.++  data HList : Setω where+    []  : HList+    _∷_ : A → HList → HList++  variable+    x  : A+    xs : HList++  -- Predicate stating that all elements satisfy a given property.++  data All (P : ∀{ℓ} {A : Set ℓ} → A → Prop ℓ) : HList → Propω where+    []  : All P []+    _∷_ : P x → All P xs → All P (x ∷ xs)+  ```++* [**Breaking**] The algorithm for resolution of instance arguments+  has been simplified. It will now only rely on the type of instances+  to determine which candidate it should use, and no longer on their+  values.++Erasure+-------++* [**Breaking**] The new flag `--erasure` turns on support for erasure+  ([#6349](https://github.com/agda/agda/issues/6349)).++  This flag is infective.+  It is implied by `--erase-record-parameters` and `--erased-matches`.++  Unless this flag is active the following things are prohibited:+  * Use of the annotations `@0` and `@erased`.+  * Use of names defined in Cubical Agda in Erased Cubical Agda.++  When `--erasure` is used the parameter arguments of constructors and+  projections are marked as erased+  ([#4786](https://github.com/agda/agda/issues/4786)), with one+  exception: for indexed data types this only happens if the+  `--with-K` flag is active+  ([#6297](https://github.com/agda/agda/issues/6297)).++  For instance, the type of the constructor `c` below is `{@0 A :+  Set} → D A`, and the type of the projection `R.f` is `{@0 A : Set}+  → R A → A`:+  ```agda+  {-# OPTIONS --erasure #-}++  data D (A : Set) : Set where+    c : D A++  record R (A : Set) : Set where+    field+      f : A+  ```++* [**Breaking**] Unless the new flag `--erased-matches` is used+  matching is not allowed in erased positions for single-constructor+  data types or record types without η-equality+  ([#6349](https://github.com/agda/agda/issues/6349)).++  This flag is infective and implied by `--with-K`.+  If it is given explicitly, it implies `--erasure`.++* [**Breaking**] Added a hard compile-time mode (see+  [#4743](https://github.com/agda/agda/issues/4743)).++  When the hard compile-time mode is used all definitions are treated+  as erased. The hard compile-time mode is entered when an erased+  definition is checked (including an erased data or record type or+  module), but not when (for instance) a type-signature is checked.++  Previously the following code was rejected:+  ```agda+  open import Agda.Builtin.Bool++  @0 f : @0 Bool → Bool+  f = λ where+    true  → false+    false → true+  ```+  Now this code is accepted (if `--erasure` is used). On the other+  hand, the following code which used to be accepted is now rejected+  (if `--erasure` is used), because the pattern-matching lambda is+  treated as erased:+  ```agda+  open import Agda.Builtin.Equality++  data Unit : Set where+    unit : Unit++  mutual++    f : Unit → Unit+    f = _++    @0 f≡ : f ≡ λ { unit → unit }+    f≡ = refl+  ```++* One can now mark data and record types and modules as erased (see+  [#4743](https://github.com/agda/agda/issues/4743)).++  If a data type is marked as erased, then it can only be used in+  erased settings, and its constructors are erased. A data type is+  marked as erased by writing `@0` or `@erased` right after the `data`+  keyword of the data type's declaration:+  ```agda+  data @0 D₁ : Set where+    c : D₁++  data @0 D₂ : Set++  data D₂ where+    c : D₁ → D₂++  interleaved mutual++    data @0 D₃ : Set where++    data D₃ where+      c : D₃+  ```++  If a record type is marked as erased, then it can only be used in+  erased settings, its constructors and fields are erased, and+  definitions in the record module are erased. A record type is marked+  as erased by writing `@0` or `@erased` right after the `record`+  keyword of the record type's declaration:+  ```agda+  record @0 R₁ : Set where+    field+      x : D₁++  record @0 R₂ : Set++  record R₂ where+    field+      x : R₁+  ```++  If a module is marked as erased, then all definitions inside the+  module (and in the module's telescope) are erased. A module is+  marked as erased by writing `@0` or `@erased` right after the+  `module` keyword:+  ```agda+  module @0 _ where++    F : @0 Set → Set+    F A = A++  module M (A : Set) where++    record R : Set where+      field+        @0 x : A++  module @0 N (@0 A : Set) = M A++  G : (@0 A : Set) → let module @0 M₂ = M A in Set+  G A = M.R B+    module @0 _ where+      B : Set+      B = A+  ```+  If an erased module is defined by a module application, then erased+  names can be used in the application, as in the definition of `N`+  above.++* Equivalence primitives no longer require full `--cubical` mode,+  `--erased-cubical` suffices. Equivalence definition is moved out of+  `Agda.Builtin.Cubical.Glue` into its own module `Agda.Builtin.Cubical.Equiv`,+  the former reexports the latter.++Reflection+----------++* `FOREIGN` and `COMPILE` pragmas can now be generated using two new reflection primitives:++  ```agda+  pragmaForeign : String → String → TC ⊤+  pragmaCompile : String → Name → String → TC ⊤+  ```++* Add 4 reflection primitives of the form `ask*` and `with*`:++  ```agda+  withNormalisation : ∀ {a} {A : Set a} → Bool → TC A → TC A+  askNormalisation  : TC Bool++  withExpandLast : ∀ {a} {A : Set a} → Bool → TC A → TC A+  askExpandLast  : TC Bool++  withReduceDefs : ∀ {a} {A : Set a} → (Σ Bool λ _ → List Name) → TC A → TC A+  askReduceDefs  : TC (Σ Bool λ _ → List Name)++  askReconstructed  : TC Bool+  ```+  to change the behaviour of `inferType`, `checkType`, `quoteTC`, `getContext`.++* [**Breaking**] The type of `withReconstructed` has been changed from++  ```agda+  withReconstructed : ∀ {a} {A : Set a} →        TC A → TC A++  ```+  to+  ```agda+  withReconstructed : ∀ {a} {A : Set a} → Bool → TC A → TC A+  ```+  to match the type of primitives of the form `with*`.++* Two primitives `onlyReduceDefs` and `dontReduceDefs` are removed but re-implemented+  using the new family of primitives `with*` and `ask*` for backward compatibility.++* Blocking the type-checking monad can now be done with more precision+  by using the `Blocker` type, and the `blockTC` primitive:++  ```agda+  data Blocker : Set where+    blockerAny  : List Blocker → Blocker+    blockerAll  : List Blocker → Blocker+    blockerMeta : Meta → Blocker+  ```++  When blocking on a value of this type, the TCM computation will only+  be retried when any (resp. all) of the mentioned metavariables have+  been solved. This can avoid getting into loops where a macro blocks on+  a meta, gets unblocked, traverses some term again, and then blocks on+  a meta that was already present.++  The `blockOnMeta` builtin has been deprecated, and an implementation+  in terms of `blockTC` is given for backwards compatibility.+++Other issues closed+-------------------++For 2.6.4, the following issues were also+[closed](https://github.com/agda/agda/issues?q=is%3Aissue+milestone%3A2.6.4+is%3Aclosed)+(see [bug tracker](https://github.com/agda/agda/issues)):++- [#1181](https://github.com/agda/agda/issues/1181): Display of let-bound variables in goals and error messages+- [#2271](https://github.com/agda/agda/issues/2271): Helper function abstracts over module parameters, with sometimes disastrous consequences for printing+- [#3437](https://github.com/agda/agda/issues/3437): Add Propω+- [#3605](https://github.com/agda/agda/issues/3605): Improve constraint reporting for cubical+- [#3690](https://github.com/agda/agda/issues/3690): Cubical interaction: Display inferred type with interval variables instantiated+- [#5900](https://github.com/agda/agda/issues/5900): De Bruijn fail in Cubical (Was: Garbled boundary contexts & naming eta expansion.)+- [#6124](https://github.com/agda/agda/issues/6124): Reflection: cannot reduce type because variable is erased+- [#6140](https://github.com/agda/agda/issues/6140): Unapplied `List` and `Maybe` are sometimes translated to `[AgdaAny]` and `Maybe AgdaAny` by GHC backend+- [#6229](https://github.com/agda/agda/issues/6229): Print warning name along with warning text+- [#6269](https://github.com/agda/agda/issues/6269): Documentation is missing for `--keep-covering-clauses` and `--lossy-unification`+- [#6271](https://github.com/agda/agda/issues/6271): Cubical: should generated code corresponding to erased constructors be erased?+- [#6272](https://github.com/agda/agda/issues/6272): Put Level type in a different sort+- [#6309](https://github.com/agda/agda/issues/6309): Drop support for GHC 8.0, 8.2, and 8.4+- [#6325](https://github.com/agda/agda/issues/6325): Hidden argument puns+- [#6333](https://github.com/agda/agda/issues/6333): Misleading file path in "Unrecognised option" error+- [#6336](https://github.com/agda/agda/issues/6336): Paradoxical self-reference in endpoints for path constructors+- [#6364](https://github.com/agda/agda/issues/6364): Instance candidates filtered out by type errors+- [#6371](https://github.com/agda/agda/issues/6371): Preserve metavariable name suggestion when eta-expanding+- [#6374](https://github.com/agda/agda/issues/6374): Refine does not work for overloaded record constructors+- [#6380](https://github.com/agda/agda/issues/6380): Confusing warning about turning instances into instances+- [#6395](https://github.com/agda/agda/issues/6395): `dataXXX` identifiers mis-parsed by {-# COMPILE GHC #-}+- [#6407](https://github.com/agda/agda/issues/6407): Agsy produces clauses with out of scope variables+- [#6413](https://github.com/agda/agda/issues/6413): Miscompilation of nested patterns in erased fields+- [#6415](https://github.com/agda/agda/issues/6415): Apparent infinite loop in cubical with --lossy-unification+- [#6418](https://github.com/agda/agda/issues/6418): Bug in rewriting with cubical primitives+- [#6434](https://github.com/agda/agda/issues/6434): Option to increase performance: do not filter out absurd clauses automatically+- [#6448](https://github.com/agda/agda/issues/6448): Don't define dependencies for elisp files included in the agda2-mode package+- [#6506](https://github.com/agda/agda/issues/6506): Cubical: `with` abstraction failing to type check+- [#6521](https://github.com/agda/agda/issues/6521): Support GHC 9.6 with cabal+- [#6523](https://github.com/agda/agda/issues/6523): Soundness bug: Tick constraints not properly propogated in Guarded Cubical+- [#6524](https://github.com/agda/agda/issues/6524): Ignore Unicode byte order mark+- [#6525](https://github.com/agda/agda/issues/6525): Recent Emacs's escape character handling improvement leads to an error when loading agda-mode+- [#6528](https://github.com/agda/agda/issues/6528): Guarded can block on solved metas+- [#6530](https://github.com/agda/agda/issues/6530): Miscompilation of case split RHS lambdas+- [#6541](https://github.com/agda/agda/issues/6541): Internal error in Agda.TypeChecking.Reduce.Fast+- [#6551](https://github.com/agda/agda/issues/6551): Doc: the keywords `hiding`,`public`, `renaming`, and `using` are always reserved+- [#6573](https://github.com/agda/agda/issues/6573): Check on presence of `--erasure` in `--erase-record-parameters` comes too early+- [#6581](https://github.com/agda/agda/issues/6581): Cubical: no canonicity for record types without η-equality+- [#6605](https://github.com/agda/agda/issues/6605): Doc: comments in "libraries" file+- [#6621](https://github.com/agda/agda/issues/6621): Enable K also for SSetω (like for SSet)+- [#6622](https://github.com/agda/agda/issues/6622): Bad error for `mutual` in implicit mutual block+- [#6624](https://github.com/agda/agda/issues/6624): Suffix not working for SSet+- [#6627](https://github.com/agda/agda/issues/6627): CheckArguments call exposes dummy checkArguments return type+- [#6632](https://github.com/agda/agda/issues/6632): hcompU eta rule in conversion checker loses solution+- [#6633](https://github.com/agda/agda/issues/6633): Bad interaction of Type:Type and SSet+- [#6648](https://github.com/agda/agda/issues/6648): `--level-universe` not respected when solving funSort `_->_ : ? -> Set -> SetOmega`+- [#6651](https://github.com/agda/agda/issues/6651): Agda fails on `univSort ? = SetOmega` even when `SizeUniv` is a solution+- [#6654](https://github.com/agda/agda/issues/6654): Forcing analysis is inconsistent for large indices+- [#6660](https://github.com/agda/agda/issues/6660): `{-# INLINE #-}` for copattern constructors+- [#6662](https://github.com/agda/agda/issues/6662): Error message for unsafe option combinations has wrong pluralization+- [#6677](https://github.com/agda/agda/issues/6677): Helper function type includes generalized parameters+- [#6687](https://github.com/agda/agda/issues/6687): Termination checker bug with `CATCHALL`+- [#6702](https://github.com/agda/agda/issues/6702): Inlining constructors to copattern should give warning with `--exact-split`+- [#6706](https://github.com/agda/agda/issues/6706): Shape-irrelevant variables marked as irrelevant in human-readable context+- [#6711](https://github.com/agda/agda/issues/6711): Internal error on `primStringUncons` when no builtin Sigma provided+- [#6714](https://github.com/agda/agda/issues/6714): Docstring error with Emacs 29+ due to changed escape rules for single quote+- [#6715](https://github.com/agda/agda/issues/6715): Type checking loops on certain pattern match in cubical (regression in 2.6.3)+- [#6720](https://github.com/agda/agda/issues/6720): Cubical: internal error in `Sort.hs`+- [#6725](https://github.com/agda/agda/issues/6725): Cubical: internal error in `Reduce.hs` (regression in 2.6.3)+- [#6750](https://github.com/agda/agda/issues/6750): Order of deserialization depends on build of Agda (version of `hashable`)+- [#6757](https://github.com/agda/agda/issues/6757): Incorrect `InteractionMetaBoundaries` warning+- [#6767](https://github.com/agda/agda/issues/6767): Internal error related to forcing on literals+- [#6786](https://github.com/agda/agda/issues/6786): Missing "when checking parameters of module M" in error message+- [#6787](https://github.com/agda/agda/issues/6787): Refine doesn't find proof of refl=refl without K+- [#6794](https://github.com/agda/agda/issues/6794): Safe Agda accepts `{-# TERMINATING #-}` pragma in `interleaved mutual` block+- [#6795](https://github.com/agda/agda/issues/6795): Missing warning about discarded `{-# TERMINATING #-}` pragma in `where` block inside `interleaved mutual` block+- [#6823](https://github.com/agda/agda/issues/6823): Suboptimal error location for missing definition before `mutual` block+- [#6868](https://github.com/agda/agda/issues/6868): With-abstraction fails for trailing instance argument
+ doc/release-notes/2.7.0.1.md view
@@ -0,0 +1,72 @@+Release notes for Agda version 2.7.0.1+======================================++This is a minor release of Agda fixing some bugs and regressions.++Installation+------------++* During installation, Agda type-checks its built-in modules and installs the generated `.agdai` files.+  (This step is now skipped when the Agda executable is not installed, e.g. `cabal install --lib Agda`.)+  Should the generation for (some of) these files fail, the names of the missing ones are now printed,+  but installation continues nevertheless ([PR #7465](https://github.com/agda/agda/pull/7465)).+  Rationale: installation of these files is only crucial when installing Agda in super-user mode.++* Agda supports GHC versions 8.6.5 to 9.10.1.++Pragmas and options+-------------------++* The release notes of 2.7.0 claimed that the option `--exact-split` was now on by default+  ([Issue #7443](https://github.com/agda/agda/issues/7443)).+  This is actually not the case, the documentation has been suitably reverted.++* Default option `--save-metas` has been reverted to `--no-save-metas` because of performance regressions+  ([Issue #7452](https://github.com/agda/agda/issues/7452)).++Bug fixes+---------++* Fixed an internal error related to interface files+  ([Issue #7436](https://github.com/agda/agda/issues/7436)).++* Fixed two internal errors in Mimer:+  ([Issue #7402](https://github.com/agda/agda/issues/7402) and+  [Issue #7484](https://github.com/agda/agda/issues/7484)).++* Fixed a regression causing needless re-checking of files+  ([Issue #7199](https://github.com/agda/agda/issues/7199)).++* Improved printing of terms by fixing a display form bug+  ([PR #7480](https://github.com/agda/agda/issues/7480)).++List of closed issues+---------------------++For 2.7.0.1, the following issues were+[closed](https://github.com/agda/agda/issues?q=is%3Aissue+milestone%3A2.7.0.1+is%3Aclosed)+(see [bug tracker](https://github.com/agda/agda/issues)):++- [Issue #7199](https://github.com/agda/agda/issues/7199): Agda re-checks a file with an up-to-date interface file+- [Issue #7402](https://github.com/agda/agda/issues/7402): Mimer internal error in hole with constraint+- [Issue #7436](https://github.com/agda/agda/issues/7436): Code only reachable from display forms not serialised in Agda 2.7.0+- [Issue #7442](https://github.com/agda/agda/issues/7442): Regression: emptiness check fails when erased constructors are involved+- [Issue #7443](https://github.com/agda/agda/issues/7443): `--exact-split` is not default in 2.7.0, contrary to claims+- [Issue #7452](https://github.com/agda/agda/issues/7452): Performance regression caused by making `--save-metas` the default+- [Issue #7455](https://github.com/agda/agda/issues/7455): Both stack and cabal fail to install Agda+- [Issue #7484](https://github.com/agda/agda/issues/7484): Internal error using Mimer in where block++These pull requests were merged for 2.7.0.1:++- [PR #7427](https://github.com/agda/agda/issues/7427): #7402: mimer failing on higher order goal+- [PR #7444](https://github.com/agda/agda/issues/7444): Fix #7436: make display forms of imported names DeadCode roots+- [PR #7445](https://github.com/agda/agda/issues/7445): Remove disclaimer that Agda would not follow the Haskell PVP+- [PR #7454](https://github.com/agda/agda/issues/7454): Fixed #7199+- [PR #7456](https://github.com/agda/agda/issues/7456): Actually, --exact-split is not really on by default+- [PR #7457](https://github.com/agda/agda/issues/7457): Revert default to `--no-save-metas`+- [PR #7465](https://github.com/agda/agda/issues/7465): Re #7455: Setup.hs: catch when Agda did not produce (all) agdai files+- [PR #7471](https://github.com/agda/agda/issues/7471): setup: Don't assume exe is built on --lib+- [PR #7475](https://github.com/agda/agda/issues/7475): Hotfix for #7442+- [PR #7476](https://github.com/agda/agda/issues/7476): Bump std-lib to latest (v2.1.1) and cubical to latest+- [PR #7480](https://github.com/agda/agda/issues/7480): Match display forms in the right context+- [PR #7487](https://github.com/agda/agda/issues/7487): Mimer shouldn't try to use existing pattern lambdas in solutions
+ doc/release-notes/2.7.0.md view
@@ -0,0 +1,436 @@+Release notes for Agda version 2.7.0+====================================++Highlights+----------++* Mimer, a re-implementation of the "auto" term synthesizer, replaces Agsy.++* New syntax `using x ← e` to bind values on the left-hand-side of a function clause.++* Instance search is more performant thanks to a new indexing structure.+  Additionally, users can now control how instances should be selected+  in the case multiple candidates exist.++* User-facing options ~~`--exact-split`,~~ `--keep-pattern-variables`, and `--postfix-projections`+  are now on by default.++Installation+------------++* Agda versioning scheme switches to the [Haskell Package Versioning Policy](https://pvp.haskell.org/)+  so Agda can be more reliably used as a library.+  Major releases will now bump the second number in the version tuple: 2.7.0, 2.8.0, 2.9.0, ...++* When the creation of the Agda library interface files fails during installation,+  a warning is emitted rather than aborting installation.+  The absence of these interface files is not a problem if the Agda installation+  resides in user space; they will be created on the fly then.+  Yet for system-wide installations in root space or packaging,+  the interface files should be created.+  This can be achieved by a manual invocation of Agda on the library source files+  (i.e., primitive and builtin modules `Agda.*`).+  (See [Issue #7401](https://github.com/agda/agda/issues/7401) and [PR #7404](https://github.com/agda/agda/pull/7404).)++* Agda supports GHC versions 8.6.5 to 9.10.1.++Pragmas and options+-------------------++* [**Breaking**] The option `--overlapping-instances`, which allows+  backtracking during instance search, has been renamed to+  `--backtracking-instance-search`.++* These options are now on by default:++  * ~~`--exact-split`: Warn about clauses that are not definitional equalities.~~+  * `--keep-pattern-variables`: Do not introduce dot patterns in interactive splitting.+  * `--postfix-projections`: Print projections and projection patterns in postfix.+  * `--save-metas`: Try to not unfold metavariable solutions in interface files.++  To revert to the old behavior, use options `--no-...`.++* Option `--rewriting` is now considered infective.+  This means that if a module has this flag enabled,+  then all modules importing it must also have that flag enabled.++* New warnings:++  * `CoinductiveEtaRecord` if a record is declared both `coinductive` and having `eta-equality`.+    Used to be a hard error; now Agda continues, ignoring `eta-equality`.++  * `ConflictingPragmaOptions` if giving both `--this` and `--that`+    when `--this` implies `--no-that` (and analogous for `--no-this` implies+    `--that`, etc).++  * `ConstructorDoesNotFitInData` when a constructor parameter+    is too big (in the sense of universe level) for the target data type of the constructor.+    Error warning, used to be a hard error.++  * `DuplicateRecordDirectives` if e.g. a `record` is declared both `inductive` and `coinductive`,+    or declared `inductive` twice.++  * `UselessMacro` when a `macro` block does not contain any function definitions.++  * `WarningProblem` when trying to switch an unknown or non-benign warning with the `-W` option.+    Used to be a hard error.++* Rejected rewrite rules no longer cause a hard error but instead cause+  an error warning. The following warnings were added to document the+  various reasons for rejection:+  * `RewriteLHSNotDefinitionOrConstructor`+  * `RewriteVariablesNotBoundByLHS`+  * `RewriteVariablesBoundMoreThanOnce`+  * `RewriteLHSReduces`+  * `RewriteHeadSymbolIsProjection`+  * `RewriteHeadSymbolIsProjectionLikeFunction`+  * `RewriteHeadSymbolIsTypeConstructor`+  * `RewriteHeadSymbolContainsMetas`+  * `RewriteConstructorParametersNotGeneral`+  * `RewriteContainsUnsolvedMetaVariables`+  * `RewriteBlockedOnProblems`+  * `RewriteRequiresDefinitions`+  * `RewriteDoesNotTargetRewriteRelation`+  * `RewriteBeforeFunctionDefinition`+  * `RewriteBeforeMutualFunctionDefinition`++### Lossy unification++* [New option `--require-unique-meta-solutions`](https://agda.readthedocs.io/en/v2.7.0/tools/command-line-options.html#cmdoption-require-unique-meta-solutions)+  (turned on by default).+  Disabling it with `--no-require-unique-meta-solutions` allows the type checker+  to take advantage of `INJECTIVE_FOR_INFERENCE` pragmas (see below).+  The `--lossy-unification` flag implies `--no-require-unique-meta-solutions`.++* [New pragma `INJECTIVE_FOR_INFERENCE`](https://agda.readthedocs.io/en/v2.7.0/pragmas.html#injective-for-inference-pragma)+  which treats functions as injective for inferring implicit arguments if+  `--no-require-unique-meta-solutions` is given. The `--no-require-unique-meta-solutions` flag needs to be given in the+  file where the function is used, and not necessarily in the file where it is defined.+  For example:+  ```agda+  postulate+    reverse-≡ : {l l' : List A} → reverse l ≡ reverse l' → reverse l ≡ reverse l'++  []≡[] : [] ≡ []+  []≡[] = reverse-≡ (refl {x = reverse []})+  ```+  does not work since Agda won't solve `l` and `l'` for `[]`, even though it knows `reverse l = reverse []`.+  If `reverse` is marked as injective with `{-# INJECTIVE_FOR_INFERENCE reverse #-}` this example will work.++Syntax+------++Additions to the Agda syntax.++* [Left-hand side let](https://agda.readthedocs.io/en/v2.7.0/with-abstraction.html#left-hand-side-let-bindings):+  `using x ← e`+  ([PR #7078](https://github.com/agda/agda/pull/7078))++  This new construct can be use in left-hand sides together with `with` and+  `rewrite` to give names to subexpressions. It is the left-hand side+  counterpart of a `let`-binding and supports the same limited form of pattern+  matching on eta-expandable record values.++  It can be quite useful when you have a function doing a series of nested+  `with`s that share some expressions. Something like++  ```agda+  fun : A → B+  fun x using z ← e with foo z+  ... | p with bar z+  ...   | q = r+  ```++  Here the expression `e` doesn't have to be repeated in the two `with`-expressions.++  As in a `with`, multiple bindings can be separated by a `|`, and variables to+  the left are in scope in bindings to the right.++* Pattern synonyms can now expose existing instance arguments+  ([PR 7173](https://github.com/agda/agda/pull/7173)).+  Example:+  ```agda+  data D : Set where+    c : {{D}} → D++  pattern p {{d}} = c {{d}}+  ```+  This allows us to explicitly bind these argument in a pattern match+  and supply them explicitly when using the pattern synonym in an expression.+  ```agda+  f : D → D+  f (p {{d = x}}) = p {{d = x}}+  ```++  We cannot create new instance arguments this way, though.+  The following is rejected:+  ```agda+  data D : Set where+    c : D → D++  pattern p {{d}} = c d+  ```++Language+--------++Changes to type checker and other components defining the Agda language.++* Agda now uses *discrimination trees* to store and look up instance+  definitions, rather than linearly searching through all instances for+  a given "class" ([PR #7109](https://github.com/agda/agda/pull/7109)).++  This is a purely internal change, and should not result in any change+  to which programs are accepted or rejected. However, it significantly+  improves the performance of instance search, especially for the case+  of a "type class" indexed by a single type argument. The new lookup+  procedure should never be slower than the previous implementation.++Reflection+----------++Changes to the meta-programming facilities.++* [**Breaking**] Erased constructors are now supported in reflection machinery.+  Quantity argument was added to `data-cons`. For erased constructors this+  argument has a value of `quantity-0`, otherwise it's `quantity-ω`.+  `defineData` now requires setting quantity for each constructor.++* Add new primitive to run instance search from reflection code:++  ```agda+    -- Try to solve open instance constraints. When wrapped in `noConstraints`,+    -- fails if there are unsolved instance constraints left over that originate+    -- from the current macro invokation. Outside constraints are still attempted,+    -- but failure to solve them are ignored by `noConstraints`.+    solveInstanceConstraints : TC ⊤+  ```++* A new reflection primitive `workOnTypes : TC A → TC A` was added to+  `Agda.Builtin.Reflection`. This runs the given computation at the type level,+  which enables the use of erased things. In particular, this is needed when+  working with (dependent) function types with erased arguments. For example,+  one can get the type of the tuple constructor `_,_` (which now takes its type+  parameters as erased arguments, see above) and unify it with the current goal+  as follows:+  ```agda+  macro+    testM : Term → TC ⊤+    testM hole = bindTC (getType (quote _,_)) (λ t → workOnTypes (unify hole t))++  typeOfComma = testM+  ```++Interaction and emacs mode+--------------------------++* [**Breaking**] [The Auto command](https://agda.readthedocs.io/en/v2.7.0/tools/auto.html)+  _Agsy_ has been replaced by an entirely new implementation _Mimer_+  ([PR #6410](https://github.com/agda/agda/pull/6410)).+  This fixes problems where Auto would fail in the presence of language features+  it did not know about, such as copatterns or anything cubical.++  The reimplementation does not support case splitting (`-c`), disproving+  (`-d`) or refining (`-r`).++* The Agda input method for Emacs has been extended by several character bindings.+  The list of changes can be obtained with a git diff on the sources:+  ```+  git diff v2.6.4.3 v2.7.0 -- src/data/emacs-mode/agda-input.el+  ```++API+---++Highlighting some changes to Agda as a library.++* New module `Agda.Syntax.Common.KeywordRange` providing type `KwRange` isomorphic to `Range`+  to indicate source positions that just span keywords ([PR #7162](https://github.com/agda/agda/pull/7162)).+  The motivation for `KwRange` is to distinguish such ranges from ranges for whole subtrees,+  e.g. in data type `Agda.Syntax.Concrete.Declaration`.++  API:+  ```haskell+  module Agda.Syntax.Common.KeywordRange where++  type KwRange++  -- From Range to KwRange+  kwRange :: HasRange a => a -> KwRange++  -- From KwRange to Range+  instance HasRange KwRange where+    getRange :: KwRange -> Range+  ```++* New hook in ``Agda.Compiler.ToTreeless`` to enable custom pipelines in compiler backends+  ([PR #7273](https://github.com/agda/agda/pull/7273)).+++List of closed issues+---------------------++For 2.7.0, the following issues were+[closed](https://github.com/agda/agda/issues?q=is%3Aissue+milestone%3A2.7.0+is%3Aclosed)+(see [bug tracker](https://github.com/agda/agda/issues)):++- [Issue #2492](https://github.com/agda/agda/issues/2492): Limit the size of terms agsy is allowed to insert+- [Issue #2853](https://github.com/agda/agda/issues/2853): Auto does not work well with record types+- [Issue #4594](https://github.com/agda/agda/issues/4594): Improve the blocking primitive+- [Issue #4777](https://github.com/agda/agda/issues/4777): Interaction between tactics and instance search+- [Issue #5264](https://github.com/agda/agda/issues/5264): Should more flags be infective (or have coinfective negations)?+- [Issue #6101](https://github.com/agda/agda/issues/6101): Agsy gives up when no HIT is present+- [Issue #6124](https://github.com/agda/agda/issues/6124): Reflection: cannot reduce type because variable is erased+- [Issue #6181](https://github.com/agda/agda/issues/6181): Agda incorrectly reports type error when an identity function is not properly hidden from the termination checker+- [Issue #6270](https://github.com/agda/agda/issues/6270): Irrelevance in the type of a record module definition+- [Issue #6292](https://github.com/agda/agda/issues/6292): Document interaction between reflection and erasure+- [Issue #6335](https://github.com/agda/agda/issues/6335): Error message for non-canonical value when using Show instances is confusing+- [Issue #6361](https://github.com/agda/agda/issues/6361): Agsy ignores --postfix-projections+- [Issue #6406](https://github.com/agda/agda/issues/6406): Subject reduction problem related to projections with non-erased parameter arguments+- [Issue #6433](https://github.com/agda/agda/issues/6433): Add unicode character BALLOT X as \crossmark to Agda input mode+- [Issue #6509](https://github.com/agda/agda/issues/6509): Agda seems to be very slow at typechecking records with many fields+- [Issue #6584](https://github.com/agda/agda/issues/6584): Case splitting on record renames top-level function+- [Issue #6643](https://github.com/agda/agda/issues/6643): Rewrite rules are allowed in implicit mutual blocks+- [Issue #6663](https://github.com/agda/agda/issues/6663): Function arguments are nonvariant more often than they should be+- [Issue #6667](https://github.com/agda/agda/issues/6667): An internal error occurrs when (mis)using syntax declarations+- [Issue #6744](https://github.com/agda/agda/issues/6744): Alias in constructor index foils the forcing analysis+- [Issue #6768](https://github.com/agda/agda/issues/6768): auto: not implemented HITs error on non-cubical code+- [Issue #6783](https://github.com/agda/agda/issues/6783): `@tactic` does not kick in for lambdas+- [Issue #6806](https://github.com/agda/agda/issues/6806): Remove `GenericWarning`+- [Issue #6841](https://github.com/agda/agda/issues/6841): Uncaught pattern violation when using `with...in...` instead of old-school inspect+- [Issue #6866](https://github.com/agda/agda/issues/6866): User Manual: Make Installation as Easy as Possible+- [Issue #6867](https://github.com/agda/agda/issues/6867): Agda rejects identity function on indexed datatype with erased index+- [Issue #6919](https://github.com/agda/agda/issues/6919): improving formatting of warnings/errors+- [Issue #6943](https://github.com/agda/agda/issues/6943): Making `--exact-split` and `--postfix-projections` default?+- [Issue #6945](https://github.com/agda/agda/issues/6945): Missing warning for non-empty but effectless `private` blocks+- [Issue #6976](https://github.com/agda/agda/issues/6976): Unexpected failure of instance resolution+- [Issue #7017](https://github.com/agda/agda/issues/7017): Document instance projections+- [Issue #7058](https://github.com/agda/agda/issues/7058): Unclear specification and correctness of TypeChecking/DeadCode+- [Issue #7090](https://github.com/agda/agda/issues/7090): REWRITE rule with confluence, inconsistencies with documentation and error messages+- [Issue #7123](https://github.com/agda/agda/issues/7123): Citation.cff+- [Issue #7136](https://github.com/agda/agda/issues/7136): Pattern synonyms with named arguments can be defined but not used+- [Issue #7146](https://github.com/agda/agda/issues/7146): Misprinted domain-free parameters with cohesion attribute+- [Issue #7158](https://github.com/agda/agda/issues/7158): Non-sensical error since 2.5.4 when applying a non-function+- [Issue #7167](https://github.com/agda/agda/issues/7167): Underapplied pattern synonyms expand to lambdas with wrong hiding in expressions+- [Issue #7170](https://github.com/agda/agda/issues/7170): Confusing error "Unused variable in pattern synonym"+- [Issue #7176](https://github.com/agda/agda/issues/7176): Instanceness is lost when expanding absurd pattern in pattern synonym expression+- [Issue #7177](https://github.com/agda/agda/issues/7177): No scope info for underscores inserted by pattern synonym expansion+- [Issue #7181](https://github.com/agda/agda/issues/7181): Forcing translation prevents reduction within function definition+- [Issue #7182](https://github.com/agda/agda/issues/7182): `getDefinition` gives wrong constructor for record from applied parameterised module+- [Issue #7187](https://github.com/agda/agda/issues/7187): Sort metas produce ill-typed reflected terms when quoted+- [Issue #7191](https://github.com/agda/agda/issues/7191): `show` does not respect `abstract`/`opaque` when normalising a term in a hole+- [Issue #7192](https://github.com/agda/agda/issues/7192): GHC 9.10+- [Issue #7193](https://github.com/agda/agda/issues/7193): Agda always has irrelevant projections+- [Issue #7196](https://github.com/agda/agda/issues/7196): Regression when giving instances with visible arguments+- [Issue #7202](https://github.com/agda/agda/issues/7202): `ModuleDoesntExport` has imprecise deadcode highlighting+- [Issue #7208](https://github.com/agda/agda/issues/7208): Importing module with wrong namespace causes internal error instead of user-friendly error.+- [Issue #7218](https://github.com/agda/agda/issues/7218): Internal error in opaque block when case splitting when just given extended lambda+- [Issue #7219](https://github.com/agda/agda/issues/7219): Only warn about unknown warnings, don't fail hard+- [Issue #7227](https://github.com/agda/agda/issues/7227): Save-metas causes OOM during macro execution+- [Issue #7236](https://github.com/agda/agda/issues/7236): Expected a hidden argument, but found a visible argument in with-abstraction when using REWRITE+- [Issue #7262](https://github.com/agda/agda/issues/7262): Error "This clause has target type ... which is not usable" highlights pattern instead of clause+- [Issue #7266](https://github.com/agda/agda/issues/7266): Internal error at Agda/TypeChecking/Substitute.hs:140:33+- [Issue #7286](https://github.com/agda/agda/issues/7286): Hard error on `instance` definition with unsolved type+- [Issue #7301](https://github.com/agda/agda/issues/7301): Agda >=2.6.3 hangs on conflicting record directives+- [Issue #7318](https://github.com/agda/agda/issues/7318): `--postfix-projections` do not make use of mixfix syntax+- [Issue #7326](https://github.com/agda/agda/issues/7326): Internal error on pattern lambda with no clauses+- [Issue #7329](https://github.com/agda/agda/issues/7329): wrong type for unnamed record constructor+- [Issue #7331](https://github.com/agda/agda/issues/7331): Search for project root crashes when (parent) directory lacks permissions+- [Issue #7332](https://github.com/agda/agda/issues/7332): quoteTerm loops on dependent copattern lambda+- [Issue #7337](https://github.com/agda/agda/issues/7337): Caching loses reflection-generated pragmas+- [Issue #7346](https://github.com/agda/agda/issues/7346): Proof of ⊥ using HIT-indexed type++These (relevant) pull requests were merged for 2.7.0:++- [PR #5267](https://github.com/agda/agda/issues/5267): Make more flags infective+- [PR #6410](https://github.com/agda/agda/issues/6410): Mimer: a drop-in replacement for Agsy+- [PR #6569](https://github.com/agda/agda/issues/6569): Do final checks before freezing metas+- [PR #6570](https://github.com/agda/agda/issues/6570): Coerce `unquote` applications+- [PR #6640](https://github.com/agda/agda/issues/6640): Add `INJECTIVE_FOR_INFERENCE` pragma+- [PR #6674](https://github.com/agda/agda/issues/6674): Testcase for fixed #6542+- [PR #6769](https://github.com/agda/agda/issues/6769): Various symbol additions to agda-input+- [PR #6870](https://github.com/agda/agda/issues/6870): [ fix #6867 ] Only consider arguments with @0 for forcing if --erasure is on+- [PR #6978](https://github.com/agda/agda/issues/6978): [ fix #6976 ] Add constraint for resolving the head of an instance+- [PR #7055](https://github.com/agda/agda/issues/7055): Unspine system projections when they have display forms+- [PR #7071](https://github.com/agda/agda/issues/7071): Eta-expand mismatched cubical primitives+- [PR #7078](https://github.com/agda/agda/issues/7078): Left-hand side `let`+- [PR #7103](https://github.com/agda/agda/issues/7103): [ re #5267 ] Add new infective options to user manual+- [PR #7109](https://github.com/agda/agda/issues/7109): Discrimination trees for instance search+- [PR #7115](https://github.com/agda/agda/issues/7115): Flake improvements+- [PR #7119](https://github.com/agda/agda/issues/7119): Split GenericWarning into individual warnings+- [PR #7121](https://github.com/agda/agda/issues/7121): Update installation.rst+- [PR #7138](https://github.com/agda/agda/issues/7138): Fix #7136: proper error when pattern definition has unsupported arguments+- [PR #7142](https://github.com/agda/agda/issues/7142): Fix #6783: error for @tactic on lambda+- [PR #7144](https://github.com/agda/agda/issues/7144): Add reference to Cornelis in the documentation+- [PR #7147](https://github.com/agda/agda/issues/7147): Fix #7146: printing of cohesion and lock attributes+- [PR #7149](https://github.com/agda/agda/issues/7149): Fix mutual information not being set properly by the positivity checker+- [PR #7155](https://github.com/agda/agda/issues/7155): Fix #6866: User Manual: Make Installation as Easy as Possible+- [PR #7159](https://github.com/agda/agda/issues/7159): Fix #7158: Application: check for sufficient arity before checking target+- [PR #7160](https://github.com/agda/agda/issues/7160): Fix #6667: case not `__IMPOSSIBLE__` for nullary syntax+- [PR #7161](https://github.com/agda/agda/issues/7161): Fix #6945: warn about useless private even in absense of nice decls+- [PR #7162](https://github.com/agda/agda/issues/7162): Blocks in Concrete syntax: store Range of block keyword+- [PR #7168](https://github.com/agda/agda/issues/7168): Fix #7167: type checking underapplied pattern synonyms+- [PR #7169](https://github.com/agda/agda/issues/7169): Trigger and improve error UnusedVariableInPatternSynonym+- [PR #7173](https://github.com/agda/agda/issues/7173): Part of #2829: Allow instance arguments in pattern synonyms that are such in the pattern already+- [PR #7179](https://github.com/agda/agda/issues/7179): Fix #7177: only setScope when scope is not null+- [PR #7180](https://github.com/agda/agda/issues/7180): Use compareAs for assignE even in compareAtom+- [PR #7183](https://github.com/agda/agda/issues/7183): Instance overlap pragmas+- [PR #7185](https://github.com/agda/agda/issues/7185): Fix #7176: turn absurd pattern in instance position to instance meta+- [PR #7197](https://github.com/agda/agda/issues/7197): Re. #7196: Only prune instances in serialised iface+- [PR #7203](https://github.com/agda/agda/issues/7203): Fix incorrectly quoted sorts+- [PR #7204](https://github.com/agda/agda/issues/7204): Fix #7202: ModuleDoesntExport: only highlight missing names+- [PR #7209](https://github.com/agda/agda/issues/7209): Fix #7208: restore missing check for OverlappingProjects+- [PR #7210](https://github.com/agda/agda/issues/7210): Fix range for deprecated module import warning when applied+- [PR #7211](https://github.com/agda/agda/issues/7211): Fix #7181: Allow matching to continue when stuck on lazy pattern+- [PR #7222](https://github.com/agda/agda/issues/7222): Fix #7219: only warn about problems with warning options+- [PR #7231](https://github.com/agda/agda/issues/7231): Instantiate terms before traversing them in tcExtendContext+- [PR #7237](https://github.com/agda/agda/issues/7237): Fix #7236: use context rather than telescope for lambda-bound variables in rewrite patterns+- [PR #7238](https://github.com/agda/agda/issues/7238): Build with GHC 9.10+- [PR #7241](https://github.com/agda/agda/issues/7241): Drop time-compat dependency and Stack LTS for GHC 8.6+- [PR #7243](https://github.com/agda/agda/issues/7243): re. 7218: Saturate opaque blocks after Give commands+- [PR #7248](https://github.com/agda/agda/issues/7248): Overhaul dead code elimination, make --save-metas the default+- [PR #7249](https://github.com/agda/agda/issues/7249): docs/installation: point new wiki+- [PR #7251](https://github.com/agda/agda/issues/7251): re. 7250: copy instanceinfo+- [PR #7252](https://github.com/agda/agda/issues/7252): Fix #7193: persistently remember what is a projection+- [PR #7260](https://github.com/agda/agda/issues/7260): Reflection primitive to solve instances+- [PR #7273](https://github.com/agda/agda/issues/7273): ToTreeless: allow backends to define custom pipelines+- [PR #7274](https://github.com/agda/agda/issues/7274): #7182: copied records should refer to the copied constructor and fields+- [PR #7276](https://github.com/agda/agda/issues/7276): #7191: respect abstract mode when using show function+- [PR #7283](https://github.com/agda/agda/issues/7283): agdaLatex  documentation+- [PR #7292](https://github.com/agda/agda/issues/7292): New error warning `ConstructorDoesNotFitInData` instead of hard error.+- [PR #7298](https://github.com/agda/agda/issues/7298): Remove fiddly attempt at instance postponement+- [PR #7300](https://github.com/agda/agda/issues/7300): New deadcode warning CoinductiveEtaRecord instead of GenericError+- [PR #7302](https://github.com/agda/agda/issues/7302): Fix #7301 (loop in parser): move verifyRecordDirectives to scope checker+- [PR #7305](https://github.com/agda/agda/issues/7305): Fix #7286: don't fail hard when there are instances with unresolved types+- [PR #7307](https://github.com/agda/agda/issues/7307): fix #7017: document instance projections+- [PR #7310](https://github.com/agda/agda/issues/7310): Add `workOnTypes` reflection primitive+- [PR #7311](https://github.com/agda/agda/issues/7311): [ #6406 ] Add test cases from discussion on this issue+- [PR #7313](https://github.com/agda/agda/issues/7313): Update universe-levels.lagda.rst+- [PR #7314](https://github.com/agda/agda/issues/7314): Add constructors for custom backend warning/errors+- [PR #7315](https://github.com/agda/agda/issues/7315): same shadowing logic for record patterns as for constructor patterns in absToCon+- [PR #7316](https://github.com/agda/agda/issues/7316): add \crossmark to emacs input mode+- [PR #7317](https://github.com/agda/agda/issues/7317): Don't mark eta unit records as irrelevant+- [PR #7319](https://github.com/agda/agda/issues/7319): Make --postfix-projections the default+- [PR #7320](https://github.com/agda/agda/issues/7320): Turn on --exact-split by default+- [PR #7322](https://github.com/agda/agda/issues/7322): Expose constructor erasure in reflection interface+- [PR #7325](https://github.com/agda/agda/issues/7325): add CSS rule for macro names+- [PR #7327](https://github.com/agda/agda/issues/7327): proper error instead of impossible for clauseless pat-lam+- [PR #7330](https://github.com/agda/agda/issues/7330): [#7329] Correct module name in module applications+- [PR #7333](https://github.com/agda/agda/issues/7333): [#7332] don't loop when quoting dependent copattern lambdas+- [PR #7334](https://github.com/agda/agda/issues/7334): Fix #7331: handle permission error in search for project file+- [PR #7336](https://github.com/agda/agda/issues/7336): Remove duplicate imports and pragmas in MAlonzo+- [PR #7338](https://github.com/agda/agda/issues/7338): (#7337) foreign code needs to go in post-scope state+- [PR #7343](https://github.com/agda/agda/issues/7343): Turn illegal rewrite rules into an error warning+- [PR #7347](https://github.com/agda/agda/issues/7347): [ fix #7266 ] Check that constructor names match before projecting in `matchPattern`+- [PR #7349](https://github.com/agda/agda/issues/7349): Fix #7346 by not considering HIT-constructor arguments forced+- [PR #7350](https://github.com/agda/agda/issues/7350): Fix #6744 by reducing during forcing analysis.+- [PR #7352](https://github.com/agda/agda/issues/7352): Fix issue 7262: Range of the lhs modality check+- [PR #7353](https://github.com/agda/agda/issues/7353): Update installation docs (e.g. re #7163: document installation problems with `executable-dynamic`)+- [PR #7355](https://github.com/agda/agda/issues/7355): Make `--keep-pattern-variables` the default+- [PR #7356](https://github.com/agda/agda/issues/7356): Add --save-metas default to CHANGELOG+- [PR #7358](https://github.com/agda/agda/issues/7358): [ doc ] Document `--termination-depth` in user manual+- [PR #7359](https://github.com/agda/agda/issues/7359): Fix #7354 by making types of live metas live in DeadCode+- [PR #7360](https://github.com/agda/agda/issues/7360): Fix for issue #6841 and related changes+- [PR #7362](https://github.com/agda/agda/issues/7362): Fix #6919: separate warnings by empty line+- [PR #7364](https://github.com/agda/agda/issues/7364): Resolve instance overlap for irrelevant metas+- [PR #7367](https://github.com/agda/agda/issues/7367): Minor fixes to instance overlap + constraint postponement
+ doc/user-manual/agda.svg view
@@ -0,0 +1,43 @@+<?xml version="1.0" encoding="UTF-8"?>+<svg width="5217px" height="1707px" viewBox="0 0 5217 1707" version="1.1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">+    <!-- Generator: Sketch 52.6 (67491) - http://www.bohemiancoding.com/sketch -->+    <title>logotype</title>+    <desc>Created with Sketch.</desc>+    <g id="Page-1" stroke="none" stroke-width="1" fill="none" fill-rule="evenodd">+        <g id="Group" transform="translate(-4781.000000, -4784.000000)">+            <rect id="white-background" fill="#FFFFFF" x="0" y="0" width="45624" height="78038"></rect>+            <g id="black-logotypes" transform="translate(4781.000000, 4784.000000)">+                <g id="logotype" transform="translate(219.000000, 219.000000)">+                    <g id="logo">+                        <circle id="left-eye" fill="#000000" cx="240" cy="270" r="27"></circle>+                        <circle id="right-eye" fill="#000000" cx="340" cy="270" r="27"></circle>+                        <path d="M1000,0 L600,400" id="wing" stroke="#000000" stroke-width="36" stroke-linecap="round" stroke-linejoin="round"></path>+                        <path d="M1200,100 L1000,300" id="tail-middle" stroke="#000000" stroke-width="36" stroke-linecap="round" stroke-linejoin="round"></path>+                        <path d="M1200,0 L1000,200" id="tail-top" stroke="#000000" stroke-width="36" stroke-linecap="round" stroke-linejoin="round"></path>+                        <path d="M500,0 L300,200" id="head-middle" stroke="#000000" stroke-width="36" stroke-linecap="round" stroke-linejoin="round"></path>+                        <path d="M600,0 L400,200" id="head-right" stroke="#000000" stroke-width="36" stroke-linecap="round" stroke-linejoin="round"></path>+                        <path d="M400,-2.84217094e-13 L0,400 L200,400 L200,600 C200,820 380,1000 600,1000 C820,1000 1000,820 1000,600 L1000,400 L1200,200" id="body" stroke="#000000" stroke-width="36" stroke-linecap="round" stroke-linejoin="round"></path>+                    </g>+                    <g id="type" transform="translate(1200.000000, 0.000000)" stroke="#000000" stroke-width="36">+                        <g id="A">+                            <polyline id="A-body" stroke-linecap="round" stroke-linejoin="round" points="0 1000 1002 -2.27373675e-13 1002 1000"></polyline>+                            <path d="M360,640.5 L1000.5,640.5" id="A-stroke"></path>+                        </g>+                        <g id="g" transform="translate(1140.000000, 280.000000)">+                            <circle id="g-body" cx="360" cy="360" r="360"></circle>+                            <path d="M720,0 L720,630 C720,830 560,990 360,990 C225.742948,990 109.510851,917.900176 47.6033734,810.000189" id="g-stroke" stroke-linecap="round" stroke-linejoin="round"></path>+                        </g>+                        <g id="d" transform="translate(2000.000000, 0.000000)">+                            <circle id="d-body" cx="360" cy="640" r="360"></circle>+                            <path d="M720.5,5.68434189e-14 L720.5,1000" id="d-stroke" stroke-linecap="round" stroke-linejoin="round"></path>+                        </g>+                        <g id="a" transform="translate(2860.000000, 280.000000)">+                            <circle id="a-body" cx="360" cy="360" r="360"></circle>+                            <path d="M720,0 L720,720" id="a-stroke" stroke-linecap="round" stroke-linejoin="round"></path>+                        </g>+                    </g>+                </g>+            </g>+        </g>+    </g>+</svg>
src/agda-mode/Main.hs view
@@ -1,62 +1,79 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | A program which either tries to add setup code for Agda's Emacs -- mode to the users .emacs file, or provides information to Emacs -- about where the Emacs mode is installed.+--+-- This executable is deprecated, its functionality covered since 2.8+-- by the @--emacs-mode@ flag of the agda executable.+--+-- However, we will continue to ship it with Agda+-- because the emacs mode of older Agda versions assumes its existence+-- for the version switching functionality @agda2-set-program-version@.  module Main (main) where -import Control.Exception as E-import Control.Monad-import Data.Char-import Data.List (intercalate, isInfixOf)-import Data.Maybe-import Data.Version-import Numeric-import System.Directory-import System.Environment-import System.Exit-import System.FilePath-import System.IO--- import System.IO.Error (isDoesNotExistError)-import System.Process+import System.Environment ( getArgs, getProgName )+import System.Exit        ( exitFailure )+import System.FilePath    ( takeFileName ) -import Paths_Agda (getDataDir, version)+import Agda.Setup as Agda ( getDataDir, setup )+import Agda.Setup.EmacsMode+import Agda.Version       ( version )  -- | The program.  main :: IO () main = do-  prog <- getProgName+  self <- takeFileName <$> getProgName+   args <- getArgs   case args of-    [arg] | arg == locateFlag -> printEmacsModeFile-          | arg == setupFlag  -> do-             dotEmacs <- findDotEmacs-             setupDotEmacs (Files { thisProgram = prog-                                  , dotEmacs    = dotEmacs-                                  })-          | arg == compileFlag ->-             compileElispFiles-    _  -> do inform usage-             exitFailure+    [arg]+      | arg == locateFlag -> do --- Command line options.+          -- Ensure that Agda has been setup so the Emacs mode is available.+          Agda.setup False -setupFlag   = "setup"-locateFlag  = "locate"-compileFlag = "compile"+          printEmacsModeFile +      | arg == setupFlag  -> do+          inform $ deprecation self++          -- Ensure that Agda has been setup so the Emacs mode is available.+          Agda.setup False++          setupDotEmacs "agda"++      | arg == compileFlag -> do+          inform $ deprecation self++          -- Ensure that Agda has been setup so the Emacs mode is available.+          Agda.setup False++          compileElispFiles++    _  -> do+      dir <- getDataDir+      inform $ deprecation self+      inform $ usage dir+      exitFailure+ -- | Usage information. -usage :: String-usage = unlines-  [ "This program, which is part of Agda version " ++ ver ++ ", can be run"+usage :: FilePath -> String+usage dataDir = unlines+  [ "This program, which is part of Agda version " ++ version ++ ", can be run"   , "in three modes, depending on which option it is invoked with:"   , ""   , setupFlag   , ""-  , "  The program tries to add setup code for Agda's Emacs mode to the"+  , "  The program unloads Agda's data files, including the Emacs mode,"+  , "  to the following location:"+  , ""+  , "    " ++ dataDir+  , ""+  , "  It then tries to add setup code for Agda's Emacs mode to the"   , "  current user's .emacs file. It is assumed that the .emacs file"   , "  uses the character encoding specified by the locale."   , ""@@ -68,204 +85,25 @@   , ""   , compileFlag   , ""-  , "  The program tries to compile Agda's Emacs mode's source files."+  , "  The program unloads Agda's data files, including the Emacs mode,"+  , "  to the following location:"   , ""+  , "    " ++ dataDir+  , ""+  , "  It then tries to compile Agda's Emacs mode's source files."+  , ""   , "  WARNING: If you reinstall the Agda mode without recompiling the Emacs"   , "  Lisp files, then Emacs may continue using the old, compiled files."   ] --- | The current version of Agda.--ver :: String-ver = intercalate "." $ map show $-        versionBranch version----------------------------------------------------------------------------- Locating the Agda mode---- | Prints out the path to the Agda mode's main file (using UTF-8 and--- without any trailing newline).--printEmacsModeFile :: IO ()-printEmacsModeFile = do-  dataDir <- getDataDir-  let path = dataDir </> "emacs-mode" </> "agda2.el"-  hSetEncoding stdout utf8-  putStr path----------------------------------------------------------------------------- Setting up the .emacs file--data Files = Files { dotEmacs :: FilePath-                     -- ^ The .emacs file.-                   , thisProgram :: FilePath-                     -- ^ The name of the current program.-                   }---- | Tries to set up the Agda mode in the given .emacs file.--setupDotEmacs :: Files -> IO ()-setupDotEmacs files = do-  informLn $ "The .emacs file used: " ++ dotEmacs files--  already <- alreadyInstalled files-  if already then-    informLn "It seems as if setup has already been performed."-   else do--    appendFile (dotEmacs files) (setupString files)-    inform $ unlines $-      [ "Setup done. Try to (re)start Emacs and open an Agda file."-      , "The following text was appended to the .emacs file:"-      ] ++ lines (setupString files)---- | Tries to find the user's .emacs file by querying Emacs.--findDotEmacs :: IO FilePath-findDotEmacs = askEmacs "(insert (expand-file-name user-init-file))"---- | Has the Agda mode already been set up?--alreadyInstalled :: Files -> IO Bool-alreadyInstalled files = do-  exists <- doesFileExist (dotEmacs files)-  if not exists then return False else-    withFile (dotEmacs files) ReadMode $ (evaluate . (identifier files `isInfixOf`)) <=< hGetContents-      -- Uses evaluate to ensure that the file is not closed-      -- prematurely.---- | If this string occurs in the .emacs file, then it is assumed that--- setup has already been performed.--identifier :: Files -> String-identifier files =-  takeFileName (thisProgram files) ++ " " ++ locateFlag---- | The string appended to the end of the .emacs file.--setupString :: Files -> String-setupString files = unlines-  [ ""-  , "(load-file (let ((coding-system-for-read 'utf-8))"-  , "                (shell-command-to-string \""-                        ++ identifier files ++ "\")))"-  ]----------------------------------------------------------------------------- Querying Emacs---- | Evaluates the given Elisp command using Emacs. The output of the--- command (whatever was written into the current buffer) is returned.------ Note: The input is not checked. The input is assumed to come from a--- trusted source.--askEmacs :: String -> IO String-askEmacs query = do-  tempDir <- getTemporaryDirectory-  bracket (openTempFile tempDir "askEmacs")-          (removeFile . fst) $ \(file, h) -> do-    hClose h-    exit <- rawSystemWithDiagnostics "emacs"-                      [ "--no-desktop", "-nw", "--no-splash"-                          -- Andreas, 2014-01-11: ^ try a leaner startup of emacs-                          -- Andreas, 2018-09-08: -nw instead of --no-window-system as some emacses do not support the long version-                      , "--eval"-                      , "(with-temp-file " ++ escape file ++ " "-                                           ++ query ++ ")"-                      , "--kill"-                      ]-    unless (exit == ExitSuccess) $ do-      informLn "Unable to query Emacs."-      exitFailure-    withFile file ReadMode $ \h -> do-      result <- hGetContents h-      evaluate (length result)-      -- Uses evaluate to ensure that the file is not closed-      -- prematurely.-      return result---- | Like 'rawSystem' but handles 'IOException' by printing diagnostics--- (@PATH@) before 'exitFailure'.--rawSystemWithDiagnostics-  :: FilePath  -- ^ Command to run.-  -> [String]  -- ^ Arguments to command.-  -> IO ExitCode-rawSystemWithDiagnostics cmd args =-    rawSystem cmd args-  `E.catch` \ (e :: IOException) -> do-     informLn $ unwords [ "FAILED:", showCommandForUser cmd args ]-     informLn $ unwords [ "Exception:", show e ]-     -- The PATH might be useful in other exceptions, like "permission denied".-     -- when (isDoesNotExistError e) $ do-     path <- fromMaybe "(not found)" <$> findExecutable cmd-     informLn $ unwords [ "Executable", cmd, "at:", path ]-     informLn "PATH:"-     mapM_ (informLn . ("  - " ++)) =<< getSearchPath-     exitFailure---- | Escapes the string so that Emacs can parse it as an Elisp string.--escape :: FilePath -> FilePath-escape s = "\"" ++ concatMap esc s ++ "\""-  where-  esc c | c `elem` ['\\', '"']   = '\\' : [c]-        | isAscii c && isPrint c = [c]-        | otherwise              = "\\x" ++ showHex (fromEnum c) "\\ "----------------------------------------------------------------------------- Compiling Emacs Lisp files---- | The Agda mode's Emacs Lisp files, given in the order in which--- they should be compiled.+-- | Deprecation warning. -emacsLispFiles :: [FilePath]-emacsLispFiles =-  [ "agda2-abbrevs.el"-  , "annotation.el"-  , "agda2-queue.el"-  , "eri.el"-  , "agda2.el"-  , "agda-input.el"-  , "agda2-highlight.el"-  , "agda2-mode.el"+deprecation :: String -> String+deprecation self = unlines+  [ "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@"+  , "@  Warning: " ++ self ++ " has been deprecated with Agda 2.8.0   @"+  , "@  and will be removed in the future.                       @"+  , "@  From Agda 2.8.0 on, use `agda --emacs-mode` instead.     @"+  , "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@"+  , ""   ]---- | Tries to compile the Agda mode's Emacs Lisp files.--compileElispFiles :: IO ()-compileElispFiles = do-  dataDir <- (</> "emacs-mode") <$> getDataDir-  let elFiles = map (dataDir </>) emacsLispFiles-  elFiles <- filterM doesFileExist elFiles-  results <- mapM (compile dataDir) elFiles-  case catMaybes results of-    [] -> return ()-    fs -> do-      informLn "Unable to compile the following Emacs Lisp files:"-      mapM_ (informLn . ("  " ++)) fs-      exitFailure-  where-  compile dataDir f = do-    exit <- rawSystemWithDiagnostics "emacs" $-                      [ "--no-init-file", "--no-site-file"-                      , "--directory", dataDir-                      , "--batch"-                      , "--eval"-                      , "(progn \-                           \(setq byte-compile-error-on-warn t) \-                           \(byte-compile-disable-warning 'cl-functions) \-                           \(batch-byte-compile))"-                      , f-                      ]-    return $ if exit == ExitSuccess then Nothing else Just f----------------------------------------------------------------------------- Helper functions---- These functions inform the user about something by printing on--- stderr.--inform   = hPutStr   stderr-informLn = hPutStrLn stderr
+ src/data/JS/agda-rts.amd.js view
@@ -0,0 +1,374 @@+define([], function() {+var exports = {};+// Contains *most* of the primitives required by the JavaScript backend.+// (Some, e.g., those using Agda types like Maybe, are defined in their+// respective builtin modules.)+//+// Primitives prefixed by 'u' are uncurried variants, which are sometimes+// emitted by the JavaScript backend. Whenever possible, the curried primitives+// should be implemented in terms of the uncurried ones.+//+// Primitives prefixed by '_' are internal variants, usually for those primitives+// which return Agda types like Maybe. These are never emitted by the compiler,+// but can be used internally to define other prefixes.++// Integers++// primIntegerFromString : String -> Int+exports.primIntegerFromString = BigInt;++// primShowInteger : Int -> String+exports.primShowInteger = x => x.toString();++// uprimIntegerPlus : (Int, Int) -> Int+exports.uprimIntegerPlus = (x, y) => x + y;++// uprimIntegerMinus : (Int, Int) -> Int+exports.uprimIntegerMinus = (x, y) => x - y;++// uprimIntegerMultiply : (Int, Int) -> Int+exports.uprimIntegerMultiply = (x, y) => x * y;++// uprimIntegerRem : (Int, Int) -> Int+exports.uprimIntegerRem = (x, y) => x % y;++// uprimIntegerQuot : (Int, Int) -> Int+exports.uprimIntegerQuot = (x, y) => x / y;++// uprimIntegerEqual : (Int, Int) -> Bool+exports.uprimIntegerEqual = (x, y) => x === y;++// uprimIntegerGreaterOrEqualThan : (Int, Int) -> Bool+exports.uprimIntegerGreaterOrEqualThan = (x, y) => x >= y;++// uprimIntegerLessThan : (Int, Int) -> Bool+exports.uprimIntegerLessThan = (x, y) => x < y;++// Words+const WORD64_MAX_VALUE = 18446744073709552000n;++// primWord64ToNat : Word64 -> Nat+exports.primWord64ToNat = x => x;++// primWord64FromNat : Nat -> Word64+exports.primWord64FromNat = x => x % WORD64_MAX_VALUE;++// uprimWord64Plus : (Word64, Word64) -> Word64+exports.uprimWord64Plus = (x, y) => (x + y) % WORD64_MAX_VALUE;++// uprimWord64Minus : (Word64, Word64) -> Word64+exports.uprimWord64Minus = (x, y) => (x + WORD64_MAX_VALUE - y) % WORD64_MAX_VALUE;++// uprimWord64Multiply : (Word64, Word64) -> Word64+exports.uprimWord64Multiply = (x, y) => (x * y) % WORD64_MAX_VALUE;++// Natural numbers++// primNatMinus : Nat -> Nat -> Nat+exports.primNatMinus = x => y => {+  const z = x - y;+  return z < 0n ? 0n : z;+};++// Floating-point numbers+var _primFloatGreatestCommonFactor = function(x, y) {+    var z;+    x = Math.abs(x);+    y = Math.abs(y);+    while (y) {+        z = x % y;+        x = y;+        y = z;+    }+    return x;+};+exports._primFloatRound = function(x) {+    if (exports.primFloatIsNaN(x) || exports.primFloatIsInfinite(x)) {+        return null;+    }+    else {+        return BigInt(Math.round(x));+    }+};+exports._primFloatFloor = function(x) {+    if (exports.primFloatIsNaN(x) || exports.primFloatIsInfinite(x)) {+        return null;+    }+    else {+        return BigInt(Math.floor(x));+    }+};+exports._primFloatCeiling = function(x) {+    if (exports.primFloatIsNaN(x) || exports.primFloatIsInfinite(x)) {+        return null;+    }+    else {+        return BigInt(Math.ceil(x));+    }+};+exports._primFloatToRatio = function(x) {+    if (exports.primFloatIsNaN(x)) {+        return {numerator: BigInt(0), denominator: BigInt(0)};+    }+    else if (x < 0.0 && exports.primFloatIsInfinite(x)) {+        return {numerator: BigInt(-1), denominator: BigInt(0)};+    }+    else if (x > 0.0 && exports.primFloatIsInfinite(x)) {+        return {numerator: BigInt(1), denominator: BigInt(0)};+    }+    else if (exports.primFloatIsNegativeZero(x)) {+        return {numerator: BigInt(0), denominator: BigInt(1)};+    }+    else if (x == 0.0) {+        return {numerator: BigInt(0), denominator: BigInt(1)};+    }+    else {+        var numerator = Math.round(x*1e9);+        var denominator = 1e9;+        var gcf = _primFloatGreatestCommonFactor(numerator, denominator);+        numerator /= gcf;+        denominator /= gcf;+        return {numerator: BigInt(numerator), denominator: BigInt(denominator)};+    }+};+exports._primFloatDecode = function(x) {+    if (exports.primFloatIsNaN(x)) {+        return null;+    }+    else if (x < 0.0 && exports.primFloatIsInfinite(x)) {+        return null;+    }+    else if (x > 0.0 && exports.primFloatIsInfinite(x)) {+        return null;+    }+    else {+        var mantissa = x, exponent = 0;+        while (!Number.isInteger(mantissa)) {+            mantissa *= 2.0;+            exponent -= 1;+        };+        while (mantissa % 2.0 === 0) {+            mantissa /= 2.0;+            exponent += 1;+        }+        return {mantissa: BigInt(mantissa), exponent: BigInt(exponent)};+    }+};+exports.uprimFloatEquality = function(x, y) {+    return x === y;+};+exports.primFloatEquality = function(x) {+    return function(y) {+        return exports.uprimFloatEquality(x, y);+    };+};+exports.primFloatInequality = function(x) {+    return function(y) {+        return x <= y;+    };+};+exports.primFloatLess = function(x) {+    return function(y) {+        return x < y;+    };+};+exports.primFloatIsInfinite = function(x) {+    return !Number.isNaN(x) && !Number.isFinite(x);+};+exports.primFloatIsNaN = function(x) {+    return Number.isNaN(x);+};+exports.primFloatIsNegativeZero = function(x) {+    return Object.is(x,-0.0);+};+exports.primFloatIsSafeInteger = function(x) {+    return Number.isSafeInteger(x);+};+++// These WORD64 values were obtained via `castDoubleToWord64` in Haskell:+const WORD64_NAN      = 18444492273895866368n;+const WORD64_POS_INF  = 9218868437227405312n;+const WORD64_NEG_INF  = 18442240474082181120n;+const WORD64_POS_ZERO = 0n;+const WORD64_NEG_ZERO = 9223372036854775808n;++exports.primFloatToWord64 = function(x) {+    if (exports.primFloatIsNaN(x)) {+        return WORD64_NAN;+    }+    else if (x < 0.0 && exports.primFloatIsInfinite(x)) {+        return WORD64_NEG_INF;+    }+    else if (x > 0.0 && exports.primFloatIsInfinite(x)) {+        return WORD64_POS_INF;+    }+    else if (exports.primFloatIsNegativeZero(x)) {+        return WORD64_NEG_ZERO;+    }+    else if (x == 0.0) {+        return WORD64_POS_ZERO;+    }+    else {+        var mantissa, exponent;+        ({mantissa, exponent} = exports._primFloatDecode(x));+        var sign = Math.sign(mantissa);+        console.log(mantissa);+        mantissa *= sign;+        sign = (sign === -1 ? "1" : "0");+        mantissa = (mantissa.toString(2)).padStart(11, "0");+        exponent = (mantissa.toString(2)).padStart(52, "0");+        return BigInt(parseInt(sign + mantissa + exponent, 2));+    }+};++// primNatToFloat : Nat -> Float+exports.primNatToFloat = Number;++// primIntToFloat : Int -> Float+exports.primIntToFloat = Number;++// primRatioToFloat : Int -> Int -> Float+exports.primRatioToFloat = x => y => Number(x) / Number(y);++// uprimFloatEncode : (Int, Int) -> Maybe Float+exports.uprimFloatEncode = (x, y) => {+  const mantissa = Number(x);+  const exponent = Number(y);++  if (Number.isSafeInteger(mantissa) && -1024 <= exponent && exponent <= 1024) {+    return mantissa * (2 ** exponent);+  }++  else {+    return null;+  }+};++exports.primShowFloat = function(x) {+    // See Issue #2192.+    if (Number.isInteger(x)) {+        if (exports.primFloatIsNegativeZero(x)) {+            return ("-0.0");+        } else {+            return (x.toString() + ".0");+        }+    } else {+        return x.toString();+    }+};+exports.primFloatPlus = function(x) {+    return function(y) {+        return x + y;+    };+};+exports.primFloatMinus = function(x) {+    return function(y) {+        return x - y;+    };+};+exports.primFloatTimes = function(x) {+    return function(y) {+        return x * y;+    };+};+exports.primFloatNegate = function(x) {+    return -x;+};+exports.primFloatDiv = function(x) {+  return function(y) {+    return x / y;+  };+};+exports.primFloatPow = function(x) {+    return function(y) {+        return x ** y;+    };+};+exports.primFloatSqrt = function(x) {+    return Math.sqrt(x);+};+exports.primFloatExp = function(x) {+    return Math.exp(x);+};+exports.primFloatLog = function(x) {+    return Math.log(x);+};+exports.primFloatSin = function(x) {+    return Math.sin(x);+};+exports.primFloatCos = function(x) {+    return Math.cos(x);+};+exports.primFloatTan = function(x) {+    return Math.tan(x);+};+exports.primFloatASin = function(x) {+    return Math.asin(x);+};+exports.primFloatACos = function(x) {+    return Math.acos(x);+};+exports.primFloatATan = function(x) {+    return Math.atan(x);+};+exports.primFloatATan2 = function(x) {+    return function(y){+        return Math.atan2(x, y);+    };+};+exports.primFloatSinh = function(x) {+    return Math.sinh(x);+};+exports.primFloatCosh = function(x) {+    return Math.cosh(x);+};+exports.primFloatTanh = function(x) {+    return Math.tanh(x);+};+exports.primFloatASinh = function(x) {+    return Math.asinh(x);+};+exports.primFloatACosh = function(x) {+    return Math.acosh(x);+};+exports.primFloatATanh = function(x) {+    return Math.atanh(x);+};++// Cubical primitives.+exports.primIMin = x => y => x && y;+exports.primIMax = x => y => x || y;+exports.primINeg = x => !x;+exports.primPartial = _ => _ => x => x;+exports.primPartialP = _ => _ => x => x;+exports.primPOr = _ => i => _ => _ => x => y => i ? x : y;+exports.primComp = _ => _ => _ => _ => x => x;+exports.primTransp = _ => _ => _ => x => x;+exports.primHComp = _ => _ => _ => _ => x => x;+exports.primSubOut = _ => _ => _ => _ => x => x;+exports.prim_glueU = _ => _ => _ => _ => _ => x => x;+exports.prim_unglueU = _ => _ => _ => _ => x => x;+exports.primFaceForall = f => f(true) == true && f(false) == false;++// Other stuff++// primSeq : (X, Y) -> Y+exports.primSeq = (x, y) => y;++// uprimQNameEquality : (Name, Name) -> Bool+exports.uprimQNameEquality = (x, y) => x['id'] === y['id'] && x['moduleId'] === y['moduleId'];++// primQNameEquality : Name -> Name -> Bool+exports.primQNameEquality = x => y => exports.uprimQNameEquality(x, y);++// primQNameLess : Name -> Name -> Bool+exports.primQNameLess = x => y => x['id'] === y['id'] ? x['moduleId'] < y['moduleId'] : x['id'] < y['id'];++// primShowQName : Name -> String+exports.primShowQName = x => x['name'];++// primQNameFixity : Name -> Fixity+exports.primQNameFixity = x => x['fixity'];+return exports;+});
src/data/JS/agda-rts.js view
@@ -85,7 +85,7 @@         return null;     }     else {-        return Math.round(x);+        return BigInt(Math.round(x));     } }; exports._primFloatFloor = function(x) {@@ -93,7 +93,7 @@         return null;     }     else {-        return Math.floor(x);+        return BigInt(Math.floor(x));     } }; exports._primFloatCeiling = function(x) {@@ -101,24 +101,24 @@         return null;     }     else {-        return Math.ceil(x);+        return BigInt(Math.ceil(x));     } }; exports._primFloatToRatio = function(x) {     if (exports.primFloatIsNaN(x)) {-        return {numerator: 0.0, denominator: 0.0};+        return {numerator: BigInt(0), denominator: BigInt(0)};     }     else if (x < 0.0 && exports.primFloatIsInfinite(x)) {-        return {numerator: -1.0, denominator: 0.0};+        return {numerator: BigInt(-1), denominator: BigInt(0)};     }     else if (x > 0.0 && exports.primFloatIsInfinite(x)) {-        return {numerator: 1.0, denominator: 0.0};+        return {numerator: BigInt(1), denominator: BigInt(0)};     }     else if (exports.primFloatIsNegativeZero(x)) {-        return {numerator: 0.0, denominator: 1.0};+        return {numerator: BigInt(0), denominator: BigInt(1)};     }     else if (x == 0.0) {-        return {numerator: 0.0, denominator: 1.0};+        return {numerator: BigInt(0), denominator: BigInt(1)};     }     else {         var numerator = Math.round(x*1e9);@@ -126,7 +126,7 @@         var gcf = _primFloatGreatestCommonFactor(numerator, denominator);         numerator /= gcf;         denominator /= gcf;-        return {numerator: numerator, denominator: denominator};+        return {numerator: BigInt(numerator), denominator: BigInt(denominator)};     } }; exports._primFloatDecode = function(x) {@@ -149,7 +149,7 @@             mantissa /= 2.0;             exponent += 1;         }-        return {mantissa: mantissa, exponent: exponent};+        return {mantissa: BigInt(mantissa), exponent: BigInt(exponent)};     } }; exports.uprimFloatEquality = function(x, y) {@@ -185,7 +185,6 @@   // These WORD64 values were obtained via `castDoubleToWord64` in Haskell:-const WORD64_NAN      = 18444492273895866368n; const WORD64_POS_INF  = 9218868437227405312n; const WORD64_NEG_INF  = 18442240474082181120n; const WORD64_POS_ZERO = 0n;@@ -193,7 +192,7 @@  exports.primFloatToWord64 = function(x) {     if (exports.primFloatIsNaN(x)) {-        return WORD64_NAN;+        return null;     }     else if (x < 0.0 && exports.primFloatIsInfinite(x)) {         return WORD64_NEG_INF;@@ -348,13 +347,6 @@ exports.prim_glueU = _ => _ => _ => _ => _ => x => x; exports.prim_unglueU = _ => _ => _ => _ => x => x; exports.primFaceForall = f => f(true) == true && f(false) == false;-exports.primDepIMin =-    i => f => i ? f({ "tt" : a => a["tt"]() }) : false;-exports.primIdFace = _ => _ => _ => _ => x => x["i"];-exports.primIdPath = _ => _ => _ => _ => x => x["p"];-exports.primIdJ = _ => _ => _ => _ => _ => x => _ => _ => x;-exports.primIdElim =-    _ => _ => _ => _ => _ => f => x => y => f(y["i"])(x)(y["p"]);  // Other stuff @@ -375,3 +367,20 @@  // primQNameFixity : Name -> Fixity exports.primQNameFixity = x => x['fixity'];++// Meta++// primShowMeta : Meta -> String+//   Should be kept in sync with version in `primitiveFunctions` in+//   Agda.TypeChecking.Primitive+exports.primShowMeta = x => "_" + x['id'] + "@" + x['module'];++// primMetaToNat : Meta -> Nat+//   Should be kept in sync with `metaToNat` in Agda.TypeChecking.Primitive+exports.primMetaToNat = x => x['module'] * 2^64 + x['id'];++// primMetaEquality : Meta -> Meta -> Bool+exports.primMetaEquality = x => y => x['id'] === y['id'] && x['module'] === y['module'];++// primMetaLess : Meta -> Meta -> Bool+exports.primMetaLess = x => y => x['id'] === y['id'] ? x['module'] < y['module'] : x['id'] < y['id'];
+ src/data/JS/agda-rts.mjs view
@@ -0,0 +1,390 @@+// Contains *most* of the primitives required by the JavaScript backend.+// (Some, e.g., those using Agda types like Maybe, are defined in their+// respective builtin modules.)+//+// Primitives prefixed by 'u' are uncurried variants, which are sometimes+// emitted by the JavaScript backend. Whenever possible, the curried primitives+// should be implemented in terms of the uncurried ones.+//+// Primitives prefixed by '_' are internal variants, usually for those primitives+// which return Agda types like Maybe. These are never emitted by the compiler,+// but can be used internally to define other prefixes.++const exports = {};++// Integers++// primIntegerFromString : String -> Int+exports.primIntegerFromString = BigInt;++// primShowInteger : Int -> String+exports.primShowInteger = x => x.toString();++// uprimIntegerPlus : (Int, Int) -> Int+exports.uprimIntegerPlus = (x, y) => x + y;++// uprimIntegerMinus : (Int, Int) -> Int+exports.uprimIntegerMinus = (x, y) => x - y;++// uprimIntegerMultiply : (Int, Int) -> Int+exports.uprimIntegerMultiply = (x, y) => x * y;++// uprimIntegerRem : (Int, Int) -> Int+exports.uprimIntegerRem = (x, y) => x % y;++// uprimIntegerQuot : (Int, Int) -> Int+exports.uprimIntegerQuot = (x, y) => x / y;++// uprimIntegerEqual : (Int, Int) -> Bool+exports.uprimIntegerEqual = (x, y) => x === y;++// uprimIntegerGreaterOrEqualThan : (Int, Int) -> Bool+exports.uprimIntegerGreaterOrEqualThan = (x, y) => x >= y;++// uprimIntegerLessThan : (Int, Int) -> Bool+exports.uprimIntegerLessThan = (x, y) => x < y;++// Words+const WORD64_MAX_VALUE = 18446744073709552000n;++// primWord64ToNat : Word64 -> Nat+exports.primWord64ToNat = x => x;++// primWord64FromNat : Nat -> Word64+exports.primWord64FromNat = x => x % WORD64_MAX_VALUE;++// uprimWord64Plus : (Word64, Word64) -> Word64+exports.uprimWord64Plus = (x, y) => (x + y) % WORD64_MAX_VALUE;++// uprimWord64Minus : (Word64, Word64) -> Word64+exports.uprimWord64Minus = (x, y) => (x + WORD64_MAX_VALUE - y) % WORD64_MAX_VALUE;++// uprimWord64Multiply : (Word64, Word64) -> Word64+exports.uprimWord64Multiply = (x, y) => (x * y) % WORD64_MAX_VALUE;++// Natural numbers++// primNatMinus : Nat -> Nat -> Nat+exports.primNatMinus = x => y => {+  const z = x - y;+  return z < 0n ? 0n : z;+};++// Floating-point numbers+var _primFloatGreatestCommonFactor = function(x, y) {+    var z;+    x = Math.abs(x);+    y = Math.abs(y);+    while (y) {+        z = x % y;+        x = y;+        y = z;+    }+    return x;+};+exports._primFloatRound = function(x) {+    if (exports.primFloatIsNaN(x) || exports.primFloatIsInfinite(x)) {+        return null;+    }+    else {+        return BigInt(Math.round(x));+    }+};+exports._primFloatFloor = function(x) {+    if (exports.primFloatIsNaN(x) || exports.primFloatIsInfinite(x)) {+        return null;+    }+    else {+        return BigInt(Math.floor(x));+    }+};+exports._primFloatCeiling = function(x) {+    if (exports.primFloatIsNaN(x) || exports.primFloatIsInfinite(x)) {+        return null;+    }+    else {+        return BigInt(Math.ceil(x));+    }+};+exports._primFloatToRatio = function(x) {+    if (exports.primFloatIsNaN(x)) {+        return {numerator: BigInt(0), denominator: BigInt(0)};+    }+    else if (x < 0.0 && exports.primFloatIsInfinite(x)) {+        return {numerator: BigInt(-1), denominator: BigInt(0)};+    }+    else if (x > 0.0 && exports.primFloatIsInfinite(x)) {+        return {numerator: BigInt(1), denominator: BigInt(0)};+    }+    else if (exports.primFloatIsNegativeZero(x)) {+        return {numerator: BigInt(0), denominator: BigInt(1)};+    }+    else if (x == 0.0) {+        return {numerator: BigInt(0), denominator: BigInt(1)};+    }+    else {+        var numerator = Math.round(x*1e9);+        var denominator = 1e9;+        var gcf = _primFloatGreatestCommonFactor(numerator, denominator);+        numerator /= gcf;+        denominator /= gcf;+        return {numerator: BigInt(numerator), denominator: BigInt(denominator)};+    }+};+exports._primFloatDecode = function(x) {+    if (exports.primFloatIsNaN(x)) {+        return null;+    }+    else if (x < 0.0 && exports.primFloatIsInfinite(x)) {+        return null;+    }+    else if (x > 0.0 && exports.primFloatIsInfinite(x)) {+        return null;+    }+    else {+        var mantissa = x, exponent = 0;+        while (!Number.isInteger(mantissa)) {+            mantissa *= 2.0;+            exponent -= 1;+        };+        while (mantissa % 2.0 === 0) {+            mantissa /= 2.0;+            exponent += 1;+        }+        return {mantissa: BigInt(mantissa), exponent: BigInt(exponent)};+    }+};+exports.uprimFloatEquality = function(x, y) {+    return x === y;+};+exports.primFloatEquality = function(x) {+    return function(y) {+        return exports.uprimFloatEquality(x, y);+    };+};+exports.primFloatInequality = function(x) {+    return function(y) {+        return x <= y;+    };+};+exports.primFloatLess = function(x) {+    return function(y) {+        return x < y;+    };+};+exports.primFloatIsInfinite = function(x) {+    return !Number.isNaN(x) && !Number.isFinite(x);+};+exports.primFloatIsNaN = function(x) {+    return Number.isNaN(x);+};+exports.primFloatIsNegativeZero = function(x) {+    return Object.is(x,-0.0);+};+exports.primFloatIsSafeInteger = function(x) {+    return Number.isSafeInteger(x);+};+++// These WORD64 values were obtained via `castDoubleToWord64` in Haskell:+const WORD64_POS_INF  = 9218868437227405312n;+const WORD64_NEG_INF  = 18442240474082181120n;+const WORD64_POS_ZERO = 0n;+const WORD64_NEG_ZERO = 9223372036854775808n;++exports.primFloatToWord64 = function(x) {+    if (exports.primFloatIsNaN(x)) {+        return null;+    }+    else if (x < 0.0 && exports.primFloatIsInfinite(x)) {+        return WORD64_NEG_INF;+    }+    else if (x > 0.0 && exports.primFloatIsInfinite(x)) {+        return WORD64_POS_INF;+    }+    else if (exports.primFloatIsNegativeZero(x)) {+        return WORD64_NEG_ZERO;+    }+    else if (x == 0.0) {+        return WORD64_POS_ZERO;+    }+    else {+        var mantissa, exponent;+        ({mantissa, exponent} = exports._primFloatDecode(x));+        var sign = Math.sign(mantissa);+        console.log(mantissa);+        mantissa *= sign;+        sign = (sign === -1 ? "1" : "0");+        mantissa = (mantissa.toString(2)).padStart(11, "0");+        exponent = (mantissa.toString(2)).padStart(52, "0");+        return BigInt(parseInt(sign + mantissa + exponent, 2));+    }+};++// primNatToFloat : Nat -> Float+exports.primNatToFloat = Number;++// primIntToFloat : Int -> Float+exports.primIntToFloat = Number;++// primRatioToFloat : Int -> Int -> Float+exports.primRatioToFloat = x => y => Number(x) / Number(y);++// uprimFloatEncode : (Int, Int) -> Maybe Float+exports.uprimFloatEncode = (x, y) => {+  const mantissa = Number(x);+  const exponent = Number(y);++  if (Number.isSafeInteger(mantissa) && -1024 <= exponent && exponent <= 1024) {+    return mantissa * (2 ** exponent);+  }++  else {+    return null;+  }+};++exports.primShowFloat = function(x) {+    // See Issue #2192.+    if (Number.isInteger(x)) {+        if (exports.primFloatIsNegativeZero(x)) {+            return ("-0.0");+        } else {+            return (x.toString() + ".0");+        }+    } else {+        return x.toString();+    }+};+exports.primFloatPlus = function(x) {+    return function(y) {+        return x + y;+    };+};+exports.primFloatMinus = function(x) {+    return function(y) {+        return x - y;+    };+};+exports.primFloatTimes = function(x) {+    return function(y) {+        return x * y;+    };+};+exports.primFloatNegate = function(x) {+    return -x;+};+exports.primFloatDiv = function(x) {+  return function(y) {+    return x / y;+  };+};+exports.primFloatPow = function(x) {+    return function(y) {+        return x ** y;+    };+};+exports.primFloatSqrt = function(x) {+    return Math.sqrt(x);+};+exports.primFloatExp = function(x) {+    return Math.exp(x);+};+exports.primFloatLog = function(x) {+    return Math.log(x);+};+exports.primFloatSin = function(x) {+    return Math.sin(x);+};+exports.primFloatCos = function(x) {+    return Math.cos(x);+};+exports.primFloatTan = function(x) {+    return Math.tan(x);+};+exports.primFloatASin = function(x) {+    return Math.asin(x);+};+exports.primFloatACos = function(x) {+    return Math.acos(x);+};+exports.primFloatATan = function(x) {+    return Math.atan(x);+};+exports.primFloatATan2 = function(x) {+    return function(y){+        return Math.atan2(x, y);+    };+};+exports.primFloatSinh = function(x) {+    return Math.sinh(x);+};+exports.primFloatCosh = function(x) {+    return Math.cosh(x);+};+exports.primFloatTanh = function(x) {+    return Math.tanh(x);+};+exports.primFloatASinh = function(x) {+    return Math.asinh(x);+};+exports.primFloatACosh = function(x) {+    return Math.acosh(x);+};+exports.primFloatATanh = function(x) {+    return Math.atanh(x);+};++// Cubical primitives.+exports.primIMin = x => y => x && y;+exports.primIMax = x => y => x || y;+exports.primINeg = x => !x;+exports.primPartial = _ => _ => x => x;+exports.primPartialP = _ => _ => x => x;+exports.primPOr = _ => i => _ => _ => x => y => i ? x : y;+exports.primComp = _ => _ => _ => _ => x => x;+exports.primTransp = _ => _ => _ => x => x;+exports.primHComp = _ => _ => _ => _ => x => x;+exports.primSubOut = _ => _ => _ => _ => x => x;+exports.prim_glueU = _ => _ => _ => _ => _ => x => x;+exports.prim_unglueU = _ => _ => _ => _ => x => x;+exports.primFaceForall = f => f(true) == true && f(false) == false;++// Other stuff++// primSeq : (X, Y) -> Y+exports.primSeq = (x, y) => y;++// uprimQNameEquality : (Name, Name) -> Bool+exports.uprimQNameEquality = (x, y) => x['id'] === y['id'] && x['moduleId'] === y['moduleId'];++// primQNameEquality : Name -> Name -> Bool+exports.primQNameEquality = x => y => exports.uprimQNameEquality(x, y);++// primQNameLess : Name -> Name -> Bool+exports.primQNameLess = x => y => x['id'] === y['id'] ? x['moduleId'] < y['moduleId'] : x['id'] < y['id'];++// primShowQName : Name -> String+exports.primShowQName = x => x['name'];++// primQNameFixity : Name -> Fixity+exports.primQNameFixity = x => x['fixity'];++// Meta++// primShowMeta : Meta -> String+//   Should be kept in sync with version in `primitiveFunctions` in+//   Agda.TypeChecking.Primitive+exports.primShowMeta = x => "_" + x['id'] + "@" + x['module'];++// primMetaToNat : Meta -> Nat+//   Should be kept in sync with `metaToNat` in Agda.TypeChecking.Primitive+exports.primMetaToNat = x => x['module'] * 2^64 + x['id'];++// primMetaEquality : Meta -> Meta -> Bool+exports.primMetaEquality = x => y => x['id'] === y['id'] && x['module'] === y['module'];++// primMetaLess : Meta -> Meta -> Bool+exports.primMetaLess = x => y => x['id'] === y['id'] ? x['module'] < y['module'] : x['id'] < y['id'];++export default exports;
src/data/MAlonzo/src/MAlonzo/RTE.hs view
@@ -2,10 +2,18 @@  module MAlonzo.RTE where -import Unsafe.Coerce-import qualified GHC.Exts as GHC (Any)-import Data.Char+import Prelude+  ( Bool, Char, Double, Integer, String+  , Enum(..), Eq(..), Ord(..), Integral(..), Num(..)+  , ($), error, otherwise+  , (++), fromIntegral+  )++import Data.Char ( GeneralCategory(Surrogate), generalCategory )+import Data.Kind ( Type) import qualified Data.Word+import qualified GHC.Exts as GHC ( Any )+import Unsafe.Coerce ( unsafeCoerce )  type AgdaAny = GHC.Any @@ -109,5 +117,5 @@  -- Support for musical coinduction. -data Inf                   a = Sharp { flat :: a }-type Infinity (level :: *) a = Inf a+data Inf                      a = Sharp { flat :: a }+type Infinity (level :: Type) a = Inf a
src/data/MAlonzo/src/MAlonzo/RTE/Float.hs view
@@ -2,6 +2,15 @@  module MAlonzo.RTE.Float where +import Prelude+  ( Bool, Double, Int, Integer, Maybe(..), Ordering(..)+  , Eq(..), Ord(..), Functor(..)+  , Floating(..), Fractional(..), Integral(..), Num(..), Real(..), RealFloat(..), RealFrac(..)+  , ($), (.), otherwise, uncurry, undefined+  , (&&), fst, snd+  , (^), even, fromIntegral+  )+ import Data.Bifunctor   ( bimap, second ) import Data.Function    ( on ) import Data.Maybe       ( fromMaybe )@@ -174,8 +183,10 @@   | isNaN x   = nan   | otherwise = x -doubleToWord64 :: Double -> Word64-doubleToWord64 = castDoubleToWord64 . normaliseNaN+doubleToWord64 :: Double -> Maybe Word64+doubleToWord64 x+  | isNaN x   = Nothing+  | otherwise = Just (castDoubleToWord64 x)  -- |Denotational equality for floating point numbers, checks bitwise equality. --
src/data/emacs-mode/agda-input.el view
@@ -53,11 +53,11 @@ ;; Functions used to tweak translation pairs  (defun agda-input-compose (f g)-  "\x -> concatMap F (G x)"+  "λ x -> concatMap F (G x)"     (lambda (x) (agda-input-concat-map f (funcall g x))))  (defun agda-input-or (f g)-  "\x -> F x ++ G x"+  "λ x -> F x ++ G x"     (lambda (x) (append (funcall f x) (funcall g x))))  (defun agda-input-nonempty ()@@ -184,11 +184,12 @@    ;; Equality and similar symbols. -  ("eq"  . ,(agda-input-to-string-list "=∼∽≈≋∻∾∿≀≃⋍≂≅ ≌≊≡≣≐≑≒≓≔≕≖≗≘≙≚≛≜≝≞≟≍≎≏≬⋕"))+  ("eq"  . ,(agda-input-to-string-list "=∼∽≈≋∻∾∿≀≃⋍≂≅ ≌≊≡≣≐≑≒≓≔≕≖≗≘≙≚≛≜≝≞≟≍≎≏≬⋕＝"))   ("eqn" . ,(agda-input-to-string-list "≠≁ ≉     ≄  ≇≆  ≢                 ≭    "))                      ("=n"  . ("≠"))-  ("~"    . ("∼"))  ("~n"  . ("≁"))+  ("~"    . ,(agda-input-to-string-list "∼～"))+                    ("~n"  . ("≁"))   ("~~"   . ("≈"))  ("~~n" . ("≉"))   ("~~~"  . ("≋"))   (":~"   . ("∻"))@@ -198,6 +199,7 @@   ("~~-"  . ("≊"))   ("=="   . ("≡"))  ("==n" . ("≢"))   ("==="  . ("≣"))+  ("="    . ("＝"))   (".="   . ("≐"))  (".=." . ("≑"))   (":="   . ("≔"))  ("=:"  . ("≕"))   ("=o"   . ("≗"))@@ -211,9 +213,9 @@    ;; Inequality and similar symbols. -  ("leq"  . ,(agda-input-to-string-list "<≪⋘≤≦≲ ≶≺≼≾⊂⊆ ⋐⊏⊑ ⊰⊲⊴⋖⋚⋜⋞"))+  ("leq"  . ,(agda-input-to-string-list "<≪⋘≤≦≲ ≶≺≼≾⊂⊆⫇⫉ ⋐⊏⊑ ⊰⊲⊴⋖⋚⋜⋞＜"))   ("leqn" . ,(agda-input-to-string-list "≮  ≰≨≴⋦≸⊀ ⋨⊄⊈⊊  ⋢⋤ ⋪⋬   ⋠"))-  ("geq"  . ,(agda-input-to-string-list ">≫⋙≥≧≳ ≷≻≽≿⊃⊇ ⋑⊐⊒ ⊱⊳⊵⋗⋛⋝⋟"))+  ("geq"  . ,(agda-input-to-string-list ">≫⋙≥≧≳ ≷≻≽≿⊃⊇⫈⫊ ⋑⊐⊒ ⊱⊳⊵⋗⋛⋝⋟＞"))   ("geqn" . ,(agda-input-to-string-list "≯  ≱≩≵⋧≹⊁ ⋩⊅⊉⊋  ⋣⋥ ⋫⋭   ⋡"))    ("<="   . ("≤"))  (">="   . ("≥"))@@ -228,6 +230,8 @@   ("subn"  . ("⊄"))  ("supn"  . ("⊅"))   ("sub="  . ("⊆"))  ("sup="  . ("⊇"))   ("sub=n" . ("⊈"))  ("sup=n" . ("⊉"))+  ("sub~"  . ("⫇"))  ("sup~"  . ("⫈"))+  ("sub~~"  . ("⫉"))  ("sup~~"  . ("⫊"))    ("squb"   . ("⊏"))  ("squp"   . ("⊐"))   ("squb="  . ("⊑"))  ("squp="  . ("⊒"))@@ -252,7 +256,7 @@   ("glb" . ("⊓"))  ("lub" . ("⊔"))   ("Glb" . ("⨅"))  ("Lub" . ("⨆")) -  ;; Entailment etc.+  ;; Entailment, tacks, etc.    ("entails" . ,(agda-input-to-string-list "⊢⊣⊤⊥⊦⊧⊨⊩⊪⊫⊬⊭⊮⊯")) @@ -263,6 +267,16 @@   ("||="  . ("⊫"))  ("||=n" . ("⊯"))   ("|||-" . ("⊪")) ++  ("tack" . ,(agda-input-to-string-list "⟘⟙⟛⟝⟞⫫⫪"))+  ("Bot"  . ("⟘")) ;; similar to Glb/Lub vs. glb/lub+  ("Top"  . ("⟙"))+  ("-||-" . ("⟛"))+  ("|--"  . ("⟝"))+  ("--|"  . ("⟞"))+  ("bbot" . ("⫫")) ;; similar to bN for blackboard N+  ("btop" . ("⫪"))+   ;; Divisibility, parallelity.    ("|"  . ("∣"))  ("|n"  . ("∤"))@@ -275,6 +289,8 @@   ("exn" . ("∄"))   ("0"   . ("∅"))   ("C"   . ("∁"))+  ("uin"    . ("⟒"))+  ("din"    . ("⫙"))    ;; Corners, ceilings and floors. @@ -293,24 +309,29 @@   ("x"         . ("×"))   ("o"         . ("∘"))   ("comp"      . ("∘"))-  ("."         . ("∙"))+  ("."         . ,(agda-input-to-string-list "∙．"))   ("*"         . ("⋆"))   (".+"        . ("∔"))   (".-"        . ("∸"))   (":"         . ,(agda-input-to-string-list "∶⦂ː꞉˸፥፦：﹕︓"))   (","         . ,(agda-input-to-string-list "ʻ،⸲⸴⹁⹉、︐︑﹐﹑，､"))-  (";"         . ,(agda-input-to-string-list "؛⁏፤꛶；︔﹔⍮⸵;"))+  (";"         . ,(agda-input-to-string-list "⨾⨟⁏፤꛶；︔﹔⍮⸵;"))+  ("++"        . ("⧺"))   ("::"        . ("∷"))   ("::-"       . ("∺"))   ("-:"        . ("∹"))   ("+ "        . ("⊹"))+  ("+"         . ("＋"))+  ("sqrt"      . ("√"))+  ("surd"      . ("√"))   ("surd3"     . ("∛"))   ("surd4"     . ("∜"))   ("increment" . ("∆"))   ("inf"       . ("∞"))-  ("&"         . ("⅋"))-  ("z;"        . ("⨟"))+  ("&"         . ,(agda-input-to-string-list "⅋﹠＆"))+  ("z;"        . ,(agda-input-to-string-list "⨟⨾"))   ("z:"        . ("⦂"))+  ("at"        . ,(agda-input-to-string-list "@﹫＠"))    ;; Circled operators. @@ -322,7 +343,7 @@   ("oo"  . ("⊚"))   ("o*"  . ("⊛"))   ("o="  . ("⊜"))-  ("o-"  . ("⊝"))+  ("o-"  . ,(agda-input-to-string-list "⊝⟜"))    ("O+"  . ("⨁"))   ("Ox"  . ("⨂"))@@ -331,23 +352,61 @@    ;; Boxed operators. -  ("b+" . ("⊞"))-  ("b-" . ("⊟"))-  ("bx" . ("⊠"))-  ("b." . ("⊡"))+  ("b+"  . ("⊞"))+  ("b-"  . ("⊟"))+  ("bx"  . ("⊠"))+  ("b."  . ("⊡")) +  ("b/"  . ("⧄"))+  ("b\\" . ("⧅"))+  ("b*"  . ("⧆"))+  ("bo"  . ("⧇"))+  ("bsq" . ("⧈"))++  ;; APL boxed operators.++  ("box="       . ("⌸"))+  ("box?"       . ("⍰"))+  ("box'"       . ("⍞"))+  ("box:"       . ("⍠"))+  ("box/"       . ("⍁"))+  ("box\\"      . ("⍂"))+  ("box<"       . ("⍃"))+  ("box>"       . ("⍄"))+  ("boxo"       . ("⌻"))+  ("boxO"       . ("⌼"))++  ("boxcomp"    . ("⌻"))+  ("boxcircle"  . ("⌼"))+  ("boxeq"      . ("⌸"))+  ("boxneq"     . ("⍯"))+  ("boxeqn"     . ("⍯"))++  ("boxl"       . ("⍇"))+  ("boxr"       . ("⍈"))+  ("boxu"       . ("⍐"))+  ("boxd"       . ("⍗"))++  ("boxdi"      . ("⌺"))+  ("boxdiv"     . ("⌹"))+  ("boxwedge"   . ("⍓"))+  ("boxvee"     . ("⍌"))+  ("boxdelta"   . ("⍍"))+  ("boxnabla"   . ("⍔"))+   ;; Various symbols.    ("integral" . ,(agda-input-to-string-list "∫∬∭∮∯∰∱∲∳"))   ("angle"    . ,(agda-input-to-string-list "∟∡∢⊾⊿"))   ("join"     . ,(agda-input-to-string-list "⋈⋉⋊⋋⋌⨝⟕⟖⟗"))+  ("esh"      . ("ʃ"))    ;; Arrows. -  ("l"  . ,(agda-input-to-string-list "←⇐⇚⇇⇆↤⇦↞↼↽⇠⇺↜⇽⟵⟸↚⇍⇷ ↹     ↢↩↫⇋⇜⇤⟻⟽⤆↶↺⟲                                     "))-  ("r"  . ,(agda-input-to-string-list "→⇒⇛⇉⇄↦⇨↠⇀⇁⇢⇻↝⇾⟶⟹↛⇏⇸⇶ ↴    ↣↪↬⇌⇝⇥⟼⟾⤇↷↻⟳⇰⇴⟴⟿ ➵➸➙➔➛➜➝➞➟➠➡➢➣➤➧➨➩➪➫➬➭➮➯➱➲➳➺➻➼➽➾⊸"))-  ("u"  . ,(agda-input-to-string-list "↑⇑⟰⇈⇅↥⇧↟↿↾⇡⇞          ↰↱➦ ⇪⇫⇬⇭⇮⇯                                           "))-  ("d"  . ,(agda-input-to-string-list "↓⇓⟱⇊⇵↧⇩↡⇃⇂⇣⇟         ↵↲↳➥ ↯                                                "))+  ("l"  . ,(agda-input-to-string-list "←⇐⇚⭅⇇⇆↤⇦↞↼↽⇠⇺↜⇽⟵⟸↚⇍⇷ ↹     ↢↩↫⇋⇜⇤⟻⟽⤆↶↺⟲                                     "))+  ("r"  . ,(agda-input-to-string-list "→⇒⇛⭆⇉⇄↦⇨↠⇀⇁⇢⇻↝⇾⟶⟹↛⇏⇸⇶ ↴    ↣↪↬⇌⇝⇥⟼⟾⤇↷↻⟳⇰⇴⟴⟿ ➵➸➙➔➛➜➝➞➟➠➡➢➣➤➧➨➩➪➫➬➭➮➯➱➲➳➺➻➼➽➾⊸"))+  ("u"  . ,(agda-input-to-string-list "↑⇑⤊⟰⇈⇅↥⇧↟↿↾⇡⇞          ↰↱➦ ⇪⇫⇬⇭⇮⇯                                           "))+  ("d"  . ,(agda-input-to-string-list "↓⇓⤋⟱⇊⇵↧⇩↡⇃⇂⇣⇟         ↵↲↳➥ ↯                                                "))   ("ud" . ,(agda-input-to-string-list "↕⇕   ↨⇳                                                                    "))   ("lr" . ,(agda-input-to-string-list "↔⇔         ⇼↭⇿⟷⟺↮⇎⇹                                                        "))   ("ul" . ,(agda-input-to-string-list "↖⇖                        ⇱↸                                               "))@@ -389,6 +448,7 @@   ("r->" . ("↣"))    ("r-o" . ("⊸"))  ("-o"  . ("⊸"))+  ("l-o" . ("⟜"))    ("dz" . ("↯")) @@ -536,6 +596,112 @@   ("b8"   . ("𝟠"))   ("b9"   . ("𝟡")) +  ;; Mathematical bold letters.++  ("BA"   . ("𝐀"))+  ("BB"   . ("𝐁"))+  ("BC"   . ("𝐂"))+  ("BD"   . ("𝐃"))+  ("BE"   . ("𝐄"))+  ("BF"   . ("𝐅"))+  ("BG"   . ("𝐆"))+  ("BH"   . ("𝐇"))+  ("BI"   . ("𝐈"))+  ("BJ"   . ("𝐉"))+  ("BK"   . ("𝐊"))+  ("BL"   . ("𝐋"))+  ("BM"   . ("𝐌"))+  ("BN"   . ("𝐍"))+  ("BO"   . ("𝐎"))+  ("BP"   . ("𝐏"))+  ("BQ"   . ("𝐐"))+  ("BR"   . ("𝐑"))+  ("BS"   . ("𝐒"))+  ("BT"   . ("𝐓"))+  ("BU"   . ("𝐔"))+  ("BV"   . ("𝐕"))+  ("BW"   . ("𝐖"))+  ("BX"   . ("𝐗"))+  ("BY"   . ("𝐘"))+  ("BZ"   . ("𝐙"))+  ("Ba"   . ("𝐚"))+  ("Bb"   . ("𝐛"))+  ("Bc"   . ("𝐜"))+  ("Bd"   . ("𝐝"))+  ("Be"   . ("𝐞"))+  ("Bf"   . ("𝐟"))+  ("Bg"   . ("𝐠"))+  ("Bh"   . ("𝐡"))+  ("Bi"   . ("𝐢"))+  ("Bj"   . ("𝐣"))+  ("Bk"   . ("𝐤"))+  ("Bl"   . ("𝐥"))+  ("Bm"   . ("𝐦"))+  ("Bn"   . ("𝐧"))+  ("Bo"   . ("𝐨"))+  ("Bp"   . ("𝐩"))+  ("Bq"   . ("𝐪"))+  ("Br"   . ("𝐫"))+  ("Bs"   . ("𝐬"))+  ("Bt"   . ("𝐭"))+  ("Bu"   . ("𝐮"))+  ("Bv"   . ("𝐯"))+  ("Bw"   . ("𝐰"))+  ("Bx"   . ("𝐱"))+  ("By"   . ("𝐲"))+  ("Bz"   . ("𝐳"))++  ;; Mathematical bold Greek letters.++  ("BGA"  . ("𝚨"))+  ("BGB"  . ("𝚩"))+  ("BGC"  . ("𝚾"))+  ("BGD"  . ("𝚫"))+  ("BGE"  . ("𝚬"))+  ("BGG"  . ("𝚪"))+  ("BGH"  . ("𝚮"))+  ("BGI"  . ("𝚰"))+  ("BGK"  . ("𝚱"))+  ("BGL"  . ("𝚲"))+  ("BGM"  . ("𝚳"))+  ("BGN"  . ("𝚴"))+  ("BGO"  . ("𝛀"))+  ("BOmicron" . ("𝚶"))+  ("BGF"  . ("𝚽"))+  ("BPi"  . ("𝚷"))+  ("BGP"  . ("𝚿"))+  ("BGR"  . ("𝚸"))+  ("BGS"  . ("𝚺"))+  ("BGT"  . ("𝚻"))+  ("BGTH" . ("𝚯"))+  ("BGU"  . ("𝚼"))+  ("BGX"  . ("𝚵"))+  ("BGZ"  . ("𝚭"))+  ("BGa"  . ("𝛂"))+  ("BGb"  . ("𝛃"))+  ("BGc"  . ("𝛘"))+  ("BGd"  . ("𝛅"))+  ("BGe"  . ("𝛆"))+  ("BGg"  . ("𝛄"))+  ("BGh"  . ("𝛈"))+  ("BGi"  . ("𝛊"))+  ("BGk"  . ("𝛋"))+  ("BGl"  . ("𝛌"))+  ("BGm"  . ("𝛍"))+  ("BGn"  . ("𝛎"))+  ("BGo"  . ("𝛚"))+  ("Bomicron" . ("𝛐"))+  ("BGf"  . ("𝛗"))+  ("Bpi"  . ("𝛑"))+  ("BGp"  . ("𝛙"))+  ("BGr"  . ("𝛒"))+  ("BGs"  . ("𝛔"))+  ("BGt"  . ("𝛕"))+  ("BGth" . ("𝛉"))+  ("BGu"  . ("𝛖"))+  ("BGx"  . ("𝛏"))+  ("BGz"  . ("𝛇"))+   ;; Mathematical bold digits.    ("B0"   . ("𝟎"))@@ -549,6 +715,110 @@   ("B8"   . ("𝟖"))   ("B9"   . ("𝟗")) +  ;; Fullwidth letters.++  ("FA"   . ("Ａ"))+  ("FB"   . ("Ｂ"))+  ("FC"   . ("Ｃ"))+  ("FD"   . ("Ｄ"))+  ("FE"   . ("Ｅ"))+  ("FF"   . ("Ｆ"))+  ("FG"   . ("Ｇ"))+  ("FH"   . ("Ｈ"))+  ("FI"   . ("Ｉ"))+  ("FJ"   . ("Ｊ"))+  ("FK"   . ("Ｋ"))+  ("FL"   . ("Ｌ"))+  ("FM"   . ("Ｍ"))+  ("FN"   . ("Ｎ"))+  ("FO"   . ("Ｏ"))+  ("FP"   . ("Ｐ"))+  ("FQ"   . ("Ｑ"))+  ("FR"   . ("Ｒ"))+  ("FS"   . ("Ｓ"))+  ("FT"   . ("Ｔ"))+  ("FU"   . ("Ｕ"))+  ("FV"   . ("Ｖ"))+  ("FW"   . ("Ｗ"))+  ("FX"   . ("Ｘ"))+  ("FY"   . ("Ｙ"))+  ("FZ"   . ("Ｚ"))+  ("Fa"   . ("ａ"))+  ("Fb"   . ("ｂ"))+  ("Fc"   . ("ｃ"))+  ("Fd"   . ("ｄ"))+  ("Fe"   . ("ｅ"))+  ("Ff"   . ("ｆ"))+  ("Fg"   . ("ｇ"))+  ("Fh"   . ("ｈ"))+  ("Fi"   . ("ｉ"))+  ("Fj"   . ("ｊ"))+  ("Fk"   . ("ｋ"))+  ("Fl"   . ("ｌ"))+  ("Fm"   . ("ｍ"))+  ("Fn"   . ("ｎ"))+  ("Fo"   . ("ｏ"))+  ("Fp"   . ("ｐ"))+  ("Fq"   . ("ｑ"))+  ("Fr"   . ("ｒ"))+  ("Fs"   . ("ｓ"))+  ("Ft"   . ("ｔ"))+  ("Fu"   . ("ｕ"))+  ("Fv"   . ("ｖ"))+  ("Fw"   . ("ｗ"))+  ("Fx"   . ("ｘ"))+  ("Fy"   . ("ｙ"))+  ("Fz"   . ("ｚ"))++  ;; Fullwidth digits.++  ("F0"   . ("０"))+  ("F1"   . ("１"))+  ("F2"   . ("２"))+  ("F3"   . ("３"))+  ("F4"   . ("４"))+  ("F5"   . ("５"))+  ("F6"   . ("６"))+  ("F7"   . ("７"))+  ("F8"   . ("８"))+  ("F9"   . ("９"))++  ;; Fullwidth symbols.++  ("F!"   . ("！"))+  ("F\""  . ("＂"))+  ("F#"   . ("＃"))+  ("F$"   . ("＄"))+  ("F%"   . ("％"))+  ("F&"   . ("＆"))+  ("F'"   . ("＇"))+  ("F("   . ("（"))+  ("F)"   . ("）"))+  ("F*"   . ("＊"))+  ("F+"   . ("＋"))+  ("F,"   . ("，"))+  ("F-"   . ("－"))+  ("F."   . ("．"))+  ("F/"   . ("／"))+  ("F:"   . ("："))+  ("F;"   . ("；"))+  ("F<"   . ("＜"))+  ("F="   . ("＝"))+  ("F>"   . ("＞"))+  ("F?"   . ("？"))+  ("F@"   . ("＠"))+  ("F["   . ("［"))+  ("F\\"  . ("＼"))+  ("F]"   . ("］"))+  ("F_"   . ("＿"))+  ("F{"   . ("｛"))+  ("F|"   . ("｜"))+  ("F}"   . ("｝"))+  ("F~"   . ("～"))+  ("F(("  . ("｟"))+  ("F))"  . ("｠"))+  ("Fneg" . ("￢"))+   ;; Parentheses.    ("(" . ,(agda-input-to-string-list "([{⁅⁽₍〈⎴⟅⟦⟨⟪⦃〈《「『【〔〖〚︵︷︹︻︽︿﹁﹃﹙﹛﹝（［｛｢❪❬❰❲❴⟮⦅⦗⧼⸨❮⦇⦉"))@@ -556,8 +826,8 @@    ("[[" . ("⟦"))   ("]]" . ("⟧"))-  ("<"  . ("⟨"))-  (">"  . ("⟩"))+  ("<"  . ,(agda-input-to-string-list "⟨<≪⋘≺⊂⋐⊏⊰⊲⋖＜"))+  (">"  . ,(agda-input-to-string-list "⟩>≫⋙≻⊃⋑⊐⊱⊳⋗＞"))   ("<<" . ("⟪"))   (">>" . ("⟫"))   ("{{" . ("⦃"))@@ -575,13 +845,13 @@   ("(|" . ("⦇"))  ;; Idiom brackets   ("|)" . ("⦈")) -  ("((" . ("⦅"))  ;; Banana brackets-  ("))" . ("⦆"))+  ("((" . ,(agda-input-to-string-list "⦅｟"))  ;; Banana brackets+  ("))" . ,(agda-input-to-string-list "⦆｠"))    ;; Primes. -  ("'" . ,(agda-input-to-string-list "′″‴⁗"))-  ("`" . ,(agda-input-to-string-list "‵‶‷"))+  ("'" . ,(agda-input-to-string-list "′″‴⁗＇"))+  ("`" . ,(agda-input-to-string-list "‵‶‷｀"))    ;; Fractions. @@ -596,21 +866,25 @@    ;; Musical symbols. -  ("note" . ,(agda-input-to-string-list "♩♪♫♬"))-  ("b"    . ("♭"))-  ("#"    . ("♯"))+  ("note"    . ,(agda-input-to-string-list "♩♪♫♬"))+  ("b"       . ("♭"))+  ("#"       . ("♯"))+  ("bb"      . ("𝄫"))+  ("##"      . ("𝄪"))    ;; Other punctuation and symbols.    ("\\"         . ("\\"))   ("en"         . ("–"))   ("em"         . ("—"))+  ("!"          . ("！"))   ("!!"         . ("‼"))+  ("?"          . ("？"))   ("??"         . ("⁇"))   ("?!"         . ("‽" "⁈"))   ("!?"         . ("⁉"))   ("die"        . ,(agda-input-to-string-list "⚀⚁⚂⚃⚄⚅"))-  ("asterisk"   . ,(agda-input-to-string-list "⁎⁑⁂✢✣✤✥✱✲✳✺✻✼✽❃❉❊❋"))+  ("asterisk"   . ,(agda-input-to-string-list "⁎⁑⁂✢✣✤✥✱✲✳✺✻✼✽❃❉❊❋＊"))   ("8<"         . ("✂" "✄"))   ("tie"        . ("⁀"))   ("undertie"   . ("‿"))@@ -618,12 +892,21 @@                                                ⍉⍊⍋⍌⍍⍎⍏⍐⍑⍒⍓⍔⍕⍖⍗⍘⍙⍚⍛                                                ⍜⍝⍞⍟⍠⍡⍢⍣⍤⍥⍦⍧⍨⍩⍪⍫⍬⍭⍮                                                ⍯⍰⍱⍲⍳⍴⍵⍶⍷⍸⍹⍺⎕"))+  ("#"          . ("＃"))+  ("%"          . ("％"))+  ("&"          . ("＆"))+  ("*"          . ("＊"))+  ("/"          . ,(agda-input-to-string-list "／＼"))+  ("@"          . ("＠"))+  ("__"         . ("＿"))+  ("\""         . ("＂"))+  ("crossmark"  . ("✗"))    ;; Some combining characters.   ;;   ;; The following combining characters also have (other)   ;; translations:-  ;; ̀ ́ ̂ ̃ ̄ ̆ ̇ ̈ ̋ ̌ ̣ ̧ ̱+  ;;    ("^--" . ,(agda-input-to-string-list"̅̿"))   ("_--" . ,(agda-input-to-string-list"̲̳"))@@ -669,7 +952,7 @@   ("Gp"  . ("ψ"))  ("GP"  . ("Ψ"))   ("Go"  . ("ω"))  ("GO"  . ("Ω")) -  ;; Mathematical characters+  ;; Mathematical characters.    ("MiA" . ("𝐴"))   ("MiB" . ("𝐵"))@@ -723,6 +1006,7 @@   ("Mix" . ("𝑥"))   ("Miy" . ("𝑦"))   ("Miz" . ("𝑧"))+   ("MIA" . ("𝑨"))   ("MIB" . ("𝑩"))   ("MIC" . ("𝑪"))@@ -749,6 +1033,7 @@   ("MIX" . ("𝑿"))   ("MIY" . ("𝒀"))   ("MIZ" . ("𝒁"))+   ("MIa" . ("𝒂"))   ("MIb" . ("𝒃"))   ("MIc" . ("𝒄"))@@ -775,6 +1060,7 @@   ("MIx" . ("𝒙"))   ("MIy" . ("𝒚"))   ("MIz" . ("𝒛"))+   ("McA" . ("𝒜"))   ("McB" . ("ℬ"))   ("McC" . ("𝒞"))@@ -827,6 +1113,7 @@   ("Mcx" . ("𝓍"))   ("Mcy" . ("𝓎"))   ("Mcz" . ("𝓏"))+   ("MCA" . ("𝓐"))   ("MCB" . ("𝓑"))   ("MCC" . ("𝓒"))@@ -879,6 +1166,7 @@   ("MCx" . ("𝔁"))   ("MCy" . ("𝔂"))   ("MCz" . ("𝔃"))+   ("MfA" . ("𝔄"))   ("MfB" . ("𝔅"))   ("MfC" . ("ℭ"))@@ -932,7 +1220,7 @@   ("Mfy" . ("𝔶"))   ("Mfz" . ("𝔷")) -  ;; (Sub / Super) scripts+  ;; (Sub / Super) scripts.   ;;   ;; Unicode 12.1 omits several latin characters from sub/superscript.   ;; https://www.quora.com/Why-is-there-no-character-for-superscript-q-in-Unicode@@ -1028,13 +1316,17 @@   ;; ("^Y" . ("Y"))   ;; ("^Z" . ("Z")) +  ("^Ga" . ("ᵅ"))   ("^Gb" . ("ᵝ"))   ("^Gg" . ("ᵞ"))   ("^Gd" . ("ᵟ"))   ("^Ge" . ("ᵋ"))   ("^Gth" . ("ᶿ"))+  ("^Gi" . ("ᶥ"))   ("^Gf" . ("ᵠ"))   ("^Gc" . ("ᵡ"))++  ("^GF" . ("ᶲ"))    ;; Some ISO8859-1 characters.
src/data/emacs-mode/agda2-abbrevs.el view
@@ -1,3 +1,4 @@+;; -*- lexical-binding: t -*- ;; agda2-abbrevs.el --- Default Agda abbrevs ;; SPDX-License-Identifier: MIT License
src/data/emacs-mode/agda2-highlight.el view
@@ -1,3 +1,4 @@+;; -*- lexical-binding: t -*- ;;; agda2-highlight.el --- Syntax highlighting for Agda (version ≥ 2) ;; SPDX-License-Identifier: MIT License @@ -56,25 +57,7 @@                       :inherit        'unspecified                       :box            'unspecified                       :font           'unspecified)-  (eval `(set-face-attribute face nil ,@attrs)))--(defvar agda2-highlight-face-attributes-list-  '(:family :width :height :weight :slant :foreground :background-            :inverse-video :stipple :underline :overline :strike-through-            :inherit :box :font)-  "The attributes considered by `agda2-highlight-face-attributes'.")--(defun agda2-highlight-face-attributes (face)-  "The names and values of all attributes in FACE.-Only the attributes in `agda2-highlight-face-attributes-list' are-considered. The attributes are returned in a flat list of the-form (name1 value1 name2 value2...)."-  (apply 'append-         (mapcar (lambda (attr)-                   (let ((val (face-attribute face attr)))-                     (if (member val '(unspecified nil)) '()-                       (list attr (if (symbolp val) `',val val)))))-                 agda2-highlight-face-attributes-list)))+  (eval `(set-face-attribute ',face nil ,@attrs)))  (defun agda2-highlight-set-faces (variable group)   "Set all Agda faces according to the value of GROUP.@@ -146,71 +129,49 @@              :background "light blue")))          ((equal group 'default-faces)           (list (cons 'agda2-highlight-keyword-face-                      (agda2-highlight-face-attributes-                       font-lock-keyword-face))+                      (list :inherit font-lock-keyword-face))                 (cons 'agda2-highlight-string-face-                      (agda2-highlight-face-attributes-                       font-lock-string-face))+                      (list :inherit font-lock-string-face))                 (cons 'agda2-highlight-number-face-                      (agda2-highlight-face-attributes-                       font-lock-constant-face))+                      (list :inherit font-lock-constant-face))                 (cons 'agda2-highlight-symbol-face-                      (agda2-highlight-face-attributes-                       font-lock-keyword-face))+                      (list :inherit font-lock-keyword-face))                 (cons 'agda2-highlight-primitive-type-face-                      (agda2-highlight-face-attributes-                       font-lock-keyword-face))+                      (list :inherit font-lock-keyword-face))                 (cons 'agda2-highlight-bound-variable-face-                      (agda2-highlight-face-attributes-                       font-lock-variable-name-face))+                      (list :inherit font-lock-variable-name-face))                 (cons 'agda2-highlight-generalizable-variable-face-                      (agda2-highlight-face-attributes-                       font-lock-variable-name-face))+                      (list :inherit font-lock-variable-name-face))                 (cons 'agda2-highlight-inductive-constructor-face-                      (agda2-highlight-face-attributes-                       font-lock-type-face))+                      (list :inherit font-lock-type-face))                 (cons 'agda2-highlight-coinductive-constructor-face-                      (agda2-highlight-face-attributes-                       font-lock-type-face))+                      (list :inherit font-lock-type-face))                 (cons 'agda2-highlight-datatype-face-                      (agda2-highlight-face-attributes-                       font-lock-type-face))+                      (list :inherit font-lock-type-face))                 (cons 'agda2-highlight-field-face-                      (agda2-highlight-face-attributes-                       font-lock-variable-name-face))+                      (list :inherit font-lock-variable-name-face))                 (cons 'agda2-highlight-function-face-                      (agda2-highlight-face-attributes-                       font-lock-function-name-face))+                      (list :inherit font-lock-function-name-face))                 (cons 'agda2-highlight-module-face-                      (agda2-highlight-face-attributes-                       font-lock-type-face))+                      (list :inherit font-lock-type-face))                 (cons 'agda2-highlight-postulate-face-                      (agda2-highlight-face-attributes-                       font-lock-type-face))+                      (list :inherit font-lock-type-face))                 (cons 'agda2-highlight-primitive-face-                      (agda2-highlight-face-attributes-                       font-lock-constant-face))+                      (list :inherit font-lock-constant-face))                 (cons 'agda2-highlight-macro-face-                      (agda2-highlight-face-attributes-                       font-lock-function-name-face))+                      (list :inherit font-lock-function-name-face))                 (cons 'agda2-highlight-record-face-                      (agda2-highlight-face-attributes-                       font-lock-variable-name-face))+                      (list :inherit font-lock-variable-name-face))                 (cons 'agda2-highlight-dotted-face-                      (agda2-highlight-face-attributes-                       font-lock-variable-name-face))+                      (list :inherit font-lock-variable-name-face))                 (cons 'agda2-highlight-operator-face-                      (agda2-highlight-face-attributes-                       font-lock-function-name-face))+                      (list :inherit font-lock-function-name-face))                 (cons 'agda2-highlight-error-face-                      (agda2-highlight-face-attributes-                       font-lock-warning-face))+                      (list :inherit font-lock-warning-face))                 (cons 'agda2-highlight-typechecks-face-                      (agda2-highlight-face-attributes-                       font-lock-type-face))+                      (list :inherit font-lock-type-face))                 (cons 'agda2-highlight-typechecking-face-                      (agda2-highlight-face-attributes-                       font-lock-preprocessor-face)))))))+                      (list :inherit font-lock-preprocessor-face)))))))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Faces@@ -461,6 +422,14 @@   "The face used for catchall clauses."   :group 'agda2-highlight-faces) +(defface agda2-highlight-cosmetic-problem-face+  '((((background light))+     (:background "white smoke"))+    (((background dark))+     (:background "#404040")))+  "The face used for cosmetic problems."+  :group 'agda2-highlight-faces)+ (defface agda2-highlight-confluence-problem-face   '((((background light))      (:background "pink"))@@ -469,6 +438,14 @@   "The face used for confluence problems."   :group 'agda2-highlight-faces) +(defface agda2-highlight-instance-problem-face+  '((((background light))+     (:background "wheat"))+    (((background dark))+     (:background "#805300")))+  "The face used for instance problems."+  :group 'agda2-highlight-faces)+ (defface agda2-highlight-missing-definition-face   '((((background light))      (:background "orange"))@@ -521,6 +498,8 @@     (incompletepattern      . agda2-highlight-incomplete-pattern-face)     (catchallclause         . agda2-highlight-catchall-clause-face)     (confluenceproblem      . agda2-highlight-confluence-problem-face)+    (cosmeticproblem        . agda2-highlight-cosmetic-problem-face)+    (instanceproblem        . agda2-highlight-instance-problem-face)     (missingdefinition      . agda2-highlight-missing-definition-face)     (typechecks             . agda2-highlight-typechecks-face))   "Alist mapping code aspects to the face used when displaying them.@@ -532,6 +511,7 @@ `catchallclause'         Clause not holding definitionally. `coinductiveconstructor' Coinductive constructors. `comment'                Comments.+`cosmeticproblem'        Code that could be prettier. `coverageproblem'        Coverage problems. `datatype'               Data types. `deadcode'               Deadcode (like unreachable clauses or RHS).@@ -543,6 +523,7 @@ `generalizable'          Generalizable variables. `incompletepattern'      Incomplete patterns. `inductiveconstructor'   Inductive constructors.+`instanceproblem'        Unusable instance(argument)s. `keyword'                Keywords. `macro'                  Macros. `markup'                 Delimiters to separate the Agda code blocks
src/data/emacs-mode/agda2-mode-pkg.el view
@@ -1,3 +1,3 @@-(define-package "agda2-mode" "2.6.2.2"+(define-package "agda2-mode" "2.8.0"   "interactive development for Agda, a dependently typed functional programming language"-  '((emacs "24.3") (annotation "1.0") (eri "1.0")))+  '((emacs "24.3"))) ;; dep defs for `annotation.el` and `eri.el` are not required if they are packaged together
src/data/emacs-mode/agda2-mode.el view
@@ -1,3 +1,4 @@+;; -*- lexical-binding: t -*- ;;; agda2-mode.el --- Major mode for Agda ;; SPDX-License-Identifier: MIT License @@ -28,13 +29,12 @@  ;;; Code: -(defvar agda2-version "2.6.2.2"+(defvar agda2-version "2.8.0"   "The version of the Agda mode. Note that the same version of the Agda executable must be used.")  (require 'cl-lib) (require 'compile)-(require 'pp) (require 'time-date) (require 'eri) (require 'annotation)@@ -99,18 +99,20 @@   :type '(repeat string)   :group 'agda2) -(defvar agda2-backends '("GHC" "GHCNoMain" "JS" "LaTeX" "QuickLaTeX")+(defvar agda2-backends '("GHC" "GHCNoMain" "JS" "LaTeX" "QuickLaTeX" "HTML")   "Compilation backends.")  (defcustom agda2-backend-  ""-  "The backend used to compile Agda programs (leave blank to ask every time)."+  nil+  "The backend used to compile Agda programs (nil to ask every time)."   :type 'string   :group 'agda2) -(defcustom agda2-toplevel-module "Agda.Interaction.GhciTop"-  "The name of the Agda toplevel module."-  :type 'string :group 'agda2)+(defcustom agda2-backend-default-payload+  nil+  "The default payload for interactive backend commands (nil to ask every time)."+  :type 'string+  :group 'agda2)  (defcustom agda2-information-window-max-height   0.35@@ -223,6 +225,7 @@     (agda2-load                              "\C-c\C-l"           (global)       "Load")     (agda2-load                              "\C-c\C-x\C-l")     (agda2-compile                           "\C-c\C-x\C-c"       (global)       "Compile")+    (agda2-backend-cmd                       "\C-c\C-i"           (global)       "Run backend interaction")     (agda2-quit                              "\C-c\C-x\C-q"       (global)       "Quit")     (agda2-restart                           "\C-c\C-x\C-r"       (global)       "Kill and restart Agda")     (agda2-abort                             "\C-c\C-x\C-a"       (global)       "Abort a command")@@ -237,7 +240,7 @@     (agda2-give                              ,(kbd "C-c C-SPC")   (local)        "Give")     (agda2-elaborate-give                    ,(kbd "C-c C-m")     (local)        "Elaborate and Give")     (agda2-refine                            "\C-c\C-r"           (local)        "Refine")-    (agda2-auto-maybe-all                    "\C-c\C-a"           (local global) "Auto")+    (agda2-mimer-maybe-all                   "\C-c\C-a"           (local global) "Auto")     (agda2-make-case                         "\C-c\C-c"           (local)        "Case")     (agda2-goal-type                         "\C-c\C-t"           (local)        "Goal type")     (agda2-show-context                      "\C-c\C-e"           (local)        "Context (environment)")@@ -265,8 +268,8 @@   "Table of commands, used to build keymaps and menus. Each element has the form (CMD &optional KEYS WHERE DESC) where CMD is a command; KEYS is its key binding (if any); WHERE is a-list which should contain 'local if the command should exist in-the goal menu and 'global if the command should exist in the main+list which should contain \\='local if the command should exist in+the goal menu and \\='global if the command should exist in the main menu; and DESC is the description of the command used in the menus.") @@ -287,7 +290,7 @@ (defvar agda2-goal-map   (let ((map (make-sparse-keymap "Agda goal")))     (dolist (d (reverse agda2-command-table))-      (cl-destructuring-bind (f &optional keys kinds desc) d+      (cl-destructuring-bind (f &optional _keys kinds desc) d         (if (member 'local kinds)             (define-key map               (vector (intern desc)) (cons desc f)))))@@ -534,7 +537,7 @@ Sends the list of strings ARGS to the Agda2 interpreter, waits for output and executes the responses, if any. -If SAVE is 'save, then the buffer is saved first.+If SAVE is \\='save, then the buffer is saved first.  If HIGHLIGHT is non-nil, then the buffer's syntax highlighting may be updated. This is also the case if the Agda process is@@ -613,7 +616,7 @@   (setq agda2-highlight-in-progress nil         agda2-last-responses        nil)) -(defun agda2-output-filter (proc chunk)+(defun agda2-output-filter (_proc chunk)   "Evaluate the Agda process's commands. This filter function assumes that every line contains either some kind of error message (which cannot be parsed as a list), or@@ -763,13 +766,13 @@   contains whitespace, then the input is taken from the   minibuffer. In this case WANT is used as the prompt string. -* Otherwise (including if WANT is 'goal) the goal contents are+* Otherwise (including if WANT is \\='goal) the goal contents are   used.  If the user input is not taken from the goal, then an empty goal range is given. -If SAVE is 'save, then the buffer is saved just before the+If SAVE is \\='save, then the buffer is saved just before the command is sent to Agda (if it is sent)."   (cl-multiple-value-bind (o g) (agda2-goal-at (point))     (unless g (error "For this command, please place the cursor in a goal"))@@ -808,25 +811,38 @@             (agda2-list-quote agda2-program-args)             )) -(defun agda2-compile ()-  "Compile the current module.+(defun agda2-read-backend ()+  "Get the currently set backend from the `agda2-backend' variable,+or ask the user for input in case the variable is not set."+  (let ((name (cond+    ((equal agda2-backend "MAlonzo")       "GHC")+    ((equal agda2-backend "MAlonzoNoMain") "GHCNoMain")+    ((equal agda2-backend nil)+      (completing-read "Backend: " agda2-backends nil nil nil nil nil 'inherit-input-method))+    (t agda2-backend))))+  (when (equal name "") (error "No backend chosen"))+  name)) +(defun agda2-compile (backend)+  "Compile the current module using BACKEND.+ The variable `agda2-backend' determines which backend is used."-  (interactive)-  (let ((backend (cond ((equal agda2-backend "MAlonzo")       "GHC")-                       ((equal agda2-backend "MAlonzoNoMain") "GHCNoMain")-                       ((equal agda2-backend "")-                        (completing-read "Backend: " agda2-backends-                                         nil nil nil nil nil-                                         'inherit-input-method))-                       (t agda2-backend))))-    (when (equal backend "") (error "No backend chosen"))-    (agda2-go 'save t 'busy t "Cmd_compile"-              backend-              (agda2-string-quote (buffer-file-name))-              (agda2-list-quote agda2-program-args)-              )))+  (interactive (list (agda2-read-backend)))+  (agda2-go 'save t 'busy t "Cmd_compile"+            backend+            (agda2-string-quote (buffer-file-name))+            (agda2-list-quote agda2-program-args)+            )) +(defun agda2-backend-cmd (backend payload)+  "Run the current backend's (from variable `agda2-backend`) interaction command."+  (interactive (list (agda2-read-backend) (or agda2-backend-default-payload (read-string "Payload: "))))+  (if (agda2-goal-at (point))+     (agda2-goal-cmd "Cmd_backend_hole" nil 'goal nil backend (agda2-string-quote payload))+     (agda2-go 'save t 'busy t "Cmd_backend_top" backend (agda2-string-quote payload))+  )+)+ (defmacro agda2-maybe-forced (name comment cmd save want)   "This macro constructs a function NAME which runs CMD. COMMENT is used to build the function's comment. The function@@ -891,16 +907,6 @@       (agda2-goal-cmd "Cmd_refine_or_intro True" 'save 'goal)     (agda2-goal-cmd "Cmd_refine_or_intro False" 'save 'goal))) -(defun agda2-autoOne ()- "Simple proof search" (interactive)- (agda2-goal-cmd "Cmd_autoOne" 'save 'goal))--(defun agda2-autoAll ()-  (interactive)-  "Solves all goals by simple proof search."-  (agda2-go nil nil 'busy t "Cmd_autoAll")-)- (defun agda2-make-case ()   "Refine the pattern variables given in the goal. Assumes that <clause> = {!<variables>!} is on one line."@@ -967,8 +973,8 @@       (compilation-mode "AgdaInfo")       ;; Support for jumping to positions mentioned in the text.       (set (make-local-variable 'compilation-error-regexp-alist)-           '(("\\([\\\\/][^[:space:]]*\\):\\([0-9]+\\),\\([0-9]+\\)-\\(\\([0-9]+\\),\\)?\\([0-9]+\\)"-              1 (2 . 5) (3 . 6))))+           '(("\\([\\\\/][^[:space:]]*\\):\\([0-9]+\\)\\.\\([0-9]+\\)\\(-\\(\\([0-9]+\\)\\.\\)?\\([0-9]+\\)\\)?"+              1 (2 . 6) (3 . 7))))       ;; Do not skip errors that start in the same position as the       ;; current one.       (set (make-local-variable 'compilation-skip-to-next-location) nil)@@ -1135,7 +1141,7 @@     (when (buffer-live-p agda2-process-buffer)       (kill-buffer agda2-process-buffer)))) -(defun agda2-kill-process-buffer (&optional process event)+(defun agda2-kill-process-buffer (&optional _process _event)   "Kills the Agda process buffer, if any. But only if the Agda process does not exist or has terminated. @@ -1192,7 +1198,7 @@        ;; Those called from a goal, grab the value present there (if any)        ;; Whereas those called globally always use a prompt        (interactive ,(pcase spec-                       (`(fromgoal ,want)+                       (`(fromgoal ,_want)                         "P")                        (`(global ,prompt)                         (if prompt@@ -1306,7 +1312,8 @@  (agda2-maybe-normalised  agda2-elaborate-give- "Elaborate check the given expression against the hole's type and fill in hole with the elaborated term"+ "Elaborate check the given expression against the hole's type and fill in the+ hole with the elaborated term"  "Cmd_elaborate_give"  "expression to elaborate and give") @@ -1324,7 +1331,8 @@  (agda2-maybe-normalised  agda2-goal-and-context-and-checked- "Shows the context, the goal and check the given expression's against the hole's type"+ "Shows the context, the goal and check the given expression's against+ the hole's type"  "Cmd_goal_type_context_check"  "expression to type") @@ -1382,16 +1390,29 @@                           'agda2-solveAll)) ) -(defun agda2-auto-maybe-all ()-  "Run auto.+(defun agda2-mimer-maybe-all ()+  "Run proof search. Either only one if point is a goal, or all of them."   (interactive)   (call-interactively (if (agda2-goal-at (point))-                          'agda2-autoOne-                          'agda2-autoAll))+                          'agda2-mimer+                          'agda2-mimerAll)) ) +(agda2-maybe-normalised-asis+  agda2-mimer+  "Run proof search on a goal."+  "Cmd_autoOne"+  'goal+)+ (agda2-maybe-normalised-toplevel-asis-noprompt+  agda2-mimerAll+  "Solves all goals by simple proof search."+  "Cmd_autoAll"+)++(agda2-maybe-normalised-toplevel-asis-noprompt  agda2-show-goals  "Show all goals."  "Cmd_metas"@@ -1523,7 +1544,7 @@        ;; Don't run modification hooks: we don't want this function to        ;; trigger agda2-abort-highlighting.        (inhibit-modification-hooks t))-      ((delims() (re-search-forward "[?]\\|[{][-!]\\|[-!][}]\\|--\\|^%.*\\\\begin{code}\\|\\\\begin{code}\\|\\\\end{code}\\|```\\|\\#\\+begin_src agda2\\|\\#\\+end_src agda2" nil t))+      ((delims() (re-search-forward "[?]\\|[{][-!]\\|[-!][}]\\|--\\|^%.*\\\\begin{code}\\|\\\\begin{code}\\|\\\\end{code}\\|```\\|\\#\\+begin_src agda2\\|\\#\\+end_src" nil t))        ;; is-proper checks whether string s (e.g. "?" or "--") is proper        ;; i.e., is not part of an identifier.        ;; comment-starter is true if s starts a comment (e.g. "--")@@ -1559,7 +1580,7 @@           ("\\begin{code}"     (when (outside-code)               (pop stk)))           ("\\end{code}"       (when (not stk)                    (push 'outside stk)))           ("#+begin_src agda2" (when (outside-code)               (pop stk)))-          ("#+end_src agda2"   (when (not stk)                    (push 'outside stk)))+          ("#+end_src"         (when (not stk)                    (push 'outside stk)))           ("```"               (if   (outside-code)               (pop stk)                                (when (not stk)                    (push 'outside stk))))           ("--"                (when (and (not stk)@@ -1592,7 +1613,7 @@      (overlay-put o 'face               'highlight)      (overlay-put o 'after-string       (propertize (format "%s" n) 'face 'highlight))))) -(defun agda2-protect-goal-markers (ol action beg end &optional length)+(defun agda2-protect-goal-markers (ol action beg end &optional _length)   "Ensures that the goal markers cannot be tampered with. Except if `inhibit-read-only' is non-nil or /all/ of the goal is modified."@@ -1651,7 +1672,12 @@     (error "no process")))  (defun agda2-intersperse (sep xs)-  (let(ys)(while xs (push (pop xs) ys)(push sep ys))(pop ys)(nreverse ys)))+  (let (ys)+    (while xs+      (push (pop xs) ys)+      (push sep ys))+    (pop ys)+    (nreverse ys)))  (defun agda2-goal-Range (o)   "The Haskell Range of goal overlay O."@@ -1664,7 +1690,7 @@   (if points       (format "(intervalsToRange (Just (mkAbsolute %s)) %s)"               (agda2-string-quote (file-truename (buffer-file-name)))-              (format "[Interval %s %s]"+              (format "[Interval () %s %s]"                       (agda2-mkPos (car points))                       (agda2-mkPos (cadr points))))     "noRange"))@@ -1696,10 +1722,10 @@ Removes any text properties, escapes newlines, double quotes, etc., adds surrounding double quotes, and converts non-ASCII characters to the \\xNNNN notation used in Haskell strings."-  (let ((pp-escape-newlines t)+  (let ((print-escape-newlines t)         (s2 (copy-sequence s)))     (set-text-properties 0 (length s2) nil s2)-    (mapconcat 'agda2-char-quote (pp-to-string s2) "")))+    (mapconcat 'agda2-char-quote (prin1-to-string s2) "")))  (defun agda2-list-quote (strings)   "Convert a list of STRINGS into a string representing it in Haskell syntax."@@ -1950,23 +1976,37 @@ ;; Switching to a different version of Agda  (defun agda2-get-agda-program-versions ()-  "Get \"version strings\" of executables starting with-'agda-mode' in current path."+  "Get suffixes (\"version strings\") of executables starting with+\\='agda-\\=' in exec-path."+  (interactive) ;; for debugging purposes   (delete-dups    (mapcar (lambda (path)-             ;; strip 'agda-mode' prefix-             (replace-regexp-in-string "^agda-mode-?" ""+             ;; strip 'agda-' prefix+             (replace-regexp-in-string "^agda-?" ""                                        (file-name-nondirectory path)))            (cl-remove-if-not 'file-executable-p              ;; concatenate result              (cl-reduce 'append                      ;; for each directory in exec-path, get list of-                     ;; files whose name starts with 'agda-mode'+                     ;; files whose name starts with 'agda-'                      (mapcar (lambda (path)                                (when (file-accessible-directory-p path)-                                 (directory-files path 't "^agda-mode")))+                                 (directory-files path 't "^agda-")))                              exec-path)))))) ++(defun agda2-old-version (version)+  "Check if the given version is less that 2.8.++Agda 2.8 is the version where the agda-mode executable was deprecated.++If the version cannot be parsed, the answer is no.+So e.g. agda-fast would be interpreted as not older than+agda-2.8.0"+  ;; If the given string does not have a numeric prefix, we answer no.+  (and (string-match "^[0-9][0-9.]*" version)+       (version< (match-string 0 version) "2.8")))+ ;; Note that other versions of Agda may use different protocols, so ;; this function unloads the Emacs mode. @@ -1974,9 +2014,21 @@   "Tries to switch to Agda version VERSION.  This command assumes that the agda and agda-mode executables for-Agda version VERSION are called agda-VERSION and-agda-mode-VERSION, and that they are located on the PATH. (If-VERSION is empty, then agda and agda-mode are used instead.)"+Agda version VERSION are called agda-VERSION and agda-mode-VERSION.+It searches for these executables on the exec-path+which is often identical to PATH but can be different+depending how Emacs is configured and invoked.++Only if VERSION is numeric and less than \"2.8\"+the agda-mode executable is used to locate the respective agda2.el,+otherwise \"agda --emacs-mode locate\" is invoked.++If VERSION is empty or \"agda\", then agda is used.+A prefix \"agda-\" is stripped from VERSION,+so one can invoke this function e.g. with+\"agda-2.8.0\" instead of \"2.8.0\".++An attempt is made to preserve the default value of `agda2-mode-hook'."   (interactive    (list (completing-read "Version: " (agda2-get-agda-program-versions)))) @@ -1988,6 +2040,24 @@                       (list buf))))                 (buffer-list))) +       (default-hook (default-value 'agda2-mode-hook))++       ;; Sanitize version.+       ;; * Strip "agda-" prefix from version.+       ;; * Replace version "agda" by just "".+       ;;+       ;; Rationale:+       ;; The user might by accident enter "agda-2.8.0" instead of "2.8.0",+       ;; or "agda" instead of "".+       (version+        (cond+         ;; Strip "agda-" prefix from version.+         ((string-prefix-p "agda-" version) (substring version (length "agda-")))+         ;; Replace version "agda" by just "".+         ((equal version "agda") "")+         ;; Default.+         (t version)))+        (version-suffix (if (or (equal version "")                                (equal version nil))                            ""@@ -1996,14 +2066,16 @@        ;; Run agda-mode<version-suffix> and make sure that it returns        ;; successfully.        (coding-system-for-read 'utf-8)-       (agda-mode-prog (concat "agda-mode" version-suffix))+       (old-agda (agda2-old-version version))+       (agda-mode-prog (concat (if old-agda "agda-mode" "agda") version-suffix))        (agda-mode-path         (condition-case nil             (with-temp-buffer               (unless-                  (equal 0 (call-process agda-mode-prog-                                         nil (current-buffer) nil-                                         "locate"))+                  (equal 0+                    (if old-agda+                        (call-process agda-mode-prog nil (current-buffer) nil "locate")+                        (call-process agda-mode-prog nil (current-buffer) nil "--emacs-mode" "locate")))                 (error "%s" (concat "Error when running "                                     agda-mode-prog)))               (buffer-string))@@ -2041,6 +2113,10 @@     (load-file agda-mode-path)     (require 'agda2-mode)     (setq agda2-program-name (concat "agda" version-suffix))++    ;; Restore the Agda mode's default hook (if any).+    (when default-hook+      (set-default 'agda2-mode-hook default-hook))      ;; Restart the Agda mode in all former Agda mode buffers.     (mapc (lambda (buf)
src/data/emacs-mode/agda2-queue.el view
@@ -1,3 +1,4 @@+;; -*- lexical-binding: t -*- ;;; agda2-queue.el --- Simple FIFO character queues. ;; SPDX-License-Identifier: MIT License
src/data/emacs-mode/agda2.el view
@@ -1,3 +1,4 @@+;; -*- lexical-binding: t -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Agda mode code which should run before the first Agda file is ;; loaded
src/data/emacs-mode/annotation.el view
@@ -1,3 +1,4 @@+;; -*- lexical-binding: t -*- ;;; annotation.el --- Functions for annotating text with faces and help bubbles  ;; Version: 1.0@@ -35,7 +36,6 @@   (let (source-pos         source-window         source-buffer-        source-file-name         target)     (cond ((eventp link)            (let ((pn (event-end link)))@@ -169,25 +169,25 @@             (props nil))         (when faces           (annotation-merge-faces start end faces)-          (add-to-list 'props 'face)-          (add-to-list 'props 'annotation-faces))+          (cl-pushnew 'face props)+          (cl-pushnew 'annotation-faces props))         (when token-based           (add-text-properties start end                                `(annotation-token-based t))-          (add-to-list 'props 'annotation-token-based))+          (cl-pushnew 'annotation-token-based props))         (when (consp goto)           (add-text-properties start end                                `(annotation-goto ,goto                                  mouse-face highlight))-          (add-to-list 'props 'annotation-goto)-          (add-to-list 'props 'mouse-face))+          (cl-pushnew 'annotation-goto props)+          (cl-pushnew 'mouse-face props))         (when info           (add-text-properties start end                                `(mouse-face highlight help-echo ,info))-          (add-to-list 'props 'mouse-face)-          (add-to-list 'props 'help-echo))+          (cl-pushnew 'mouse-face props)+          (cl-pushnew 'help-echo props))         (when props-          (add-to-list 'props 'annotation-annotated)+          (cl-pushnew 'annotation-annotated props)           (let ((pos start)                 mid)             (while (< pos end)
src/data/emacs-mode/eri.el view
@@ -1,3 +1,4 @@+;; -*- lexical-binding: t -*- ;;; eri.el --- Enhanced relative indentation (eri)  ;; SPDX-License-Identifier: MIT License@@ -51,7 +52,7 @@   ^ ^ ^ ^ ^ ^ ^     ^  |                        |                        MAX"-  (let ((result))+  (let ((result nil))     (save-excursion       (save-restriction         (beginning-of-line)@@ -65,7 +66,7 @@                 (when (not (null pos))                   (let ((pos1 (- pos (line-beginning-position))))                     (when (or (null max) (< pos1 max))-                      (add-to-list 'result pos1))))+                      (cl-pushnew pos1 result))))                 (and pos                      (< (point) (line-end-position))                      (or (null max) (< (current-column) max))))))
src/data/html/Agda.css view
@@ -19,6 +19,7 @@ .Agda .Datatype               { color: #0000CD } .Agda .Field                  { color: #EE1289 } .Agda .Function               { color: #0000CD }+.Agda .Macro                  { color: #0000CD } .Agda .Module                 { color: #A020F0 } .Agda .Postulate              { color: #0000CD } .Agda .Primitive              { color: #0000CD }
src/data/html/highlight-hover.js view
@@ -1,32 +1,35 @@-// Copyright 2002-2010, Simon Marlow.  All rights reserved.-// https://github.com/haskell/haddock/blob/ghc-8.8/LICENSE-// Slightly modified by Tesla Ice Zhang+// Copyright 2023, Andreas Abel.+// Falls under the Agda license at https://github.com/agda/agda/blob/master/LICENSE -var highlight = function (on) {-  return function () {-    var links = document.getElementsByTagName('a');-    for (var i = 0; i < links.length; i++) {-      var that = links[i];+// When we hover over an Agda identifier, we highlight all occurrences of this identifier on the page.+// To this end, we create a map from identifier to all of its occurrences in the beginning. -      if (this.href != that.href) {-        continue;-      }+// A dictionary from hrefs to 'a'-elements that have this href.+const dict = new Map(); -      if (on) {-        that.classList.add("hover-highlight");-      } else {-        that.classList.remove("hover-highlight");-      }-    }+window.onload = function () {++  // Get all 'a' tags with an 'href' attribute.+  // We call those "objects".+  const objs  = document.querySelectorAll('a[href]');++  // Build a dictionary mapping a href to a set of objects that have this href.+  for (const obj of objs) {+    const key = obj.href;+    const set = dict.get(key) ?? new Set();+    set.add(obj);+    dict.set(key, set);   }-}; -window.onload = function () {-  var links = document.getElementsByTagName('a');-  for (var i = 0; i < links.length; i++) {-    var link = links[i];-    if (!link.hasAttribute("href")) continue;-    link.onmouseover = highlight(true);-    link.onmouseout = highlight(false);+  // Install 'onmouseover' and 'onmouseout' event handlers for all objects.+  for (const obj of objs) {+    // 'onmouseover' for an object adds attribute 'hover-highlight' to all objects with the same href.+    obj.onmouseover = function () {+      for (const o of dict.get(this.href)) { o.classList.add('hover-highlight'); }+    }+    // 'onmouseover' removes the added 'hover-highlight' attributes again.+    obj.onmouseout = function () {+      for (const o of dict.get(this.href)) { o.classList.remove('hover-highlight'); }+    }   } };
src/data/latex/agda.sty view
@@ -6,7 +6,7 @@ % !!! NOTE: when you make changes to this file, bump the date. !!! % !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! \ProvidesPackage{agda}-  [2021/07/14 version 2.6.2.2 Formatting LaTeX generated by Agda]+  [2021/07/14 version 2.8.0 Formatting LaTeX generated by Agda]  \RequirePackage{ifxetex, ifluatex, xifthen, xcolor, polytable, etoolbox,                 calc, environ, xparse, xkeyval}
src/data/lib/prim/Agda/Builtin/Bool.agda view
@@ -1,5 +1,5 @@-{-# OPTIONS --without-K --safe --no-universe-polymorphism-            --no-sized-types --no-guardedness  --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism+            --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Bool where
src/data/lib/prim/Agda/Builtin/Char.agda view
@@ -1,5 +1,5 @@-{-# OPTIONS --without-K --safe --no-universe-polymorphism-            --no-sized-types --no-guardedness --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism+            --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Char where
src/data/lib/prim/Agda/Builtin/Char/Properties.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Char.Properties where
src/data/lib/prim/Agda/Builtin/Coinduction.agda view
@@ -1,5 +1,5 @@-{-# OPTIONS --without-K --safe --universe-polymorphism --no-sized-types-            --guardedness --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --universe-polymorphism --no-sized-types+            --guardedness --level-universe #-}  module Agda.Builtin.Coinduction where
+ src/data/lib/prim/Agda/Builtin/Cubical/Equiv.agda view
@@ -0,0 +1,107 @@+{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-}++module Agda.Builtin.Cubical.Equiv where++open import Agda.Primitive+open import Agda.Builtin.Sigma+open import Agda.Primitive.Cubical renaming (primINeg to ~_; primIMax to _∨_; primIMin to _∧_;+                                             primHComp to hcomp; primTransp to transp; primComp to comp;+                                             itIsOne to 1=1)+open import Agda.Builtin.Cubical.Path+open import Agda.Builtin.Cubical.Sub renaming (Sub to _[_↦_])+import Agda.Builtin.Cubical.HCompU as HCompU++module Helpers = HCompU.Helpers++open Helpers+++-- We make this a record so that isEquiv can be proved using+-- copatterns. This is good because copatterns don't get unfolded+-- unless a projection is applied so it should be more efficient.+record isEquiv {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} (f : A → B) : Set (ℓ ⊔ ℓ') where+  no-eta-equality+  field+    equiv-proof : (y : B) → isContr (fiber f y)++open isEquiv public++infix 4 _≃_++_≃_ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') → Set (ℓ ⊔ ℓ')+A ≃ B = Σ (A → B) \ f → (isEquiv f)++equivFun : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} → A ≃ B → A → B+equivFun e = fst e++-- Improved version of equivProof compared to Lemma 5 in CCHM. We put+-- the (φ = i0) face in contr' making it be definitionally c in this+-- case. This makes the computational behavior better, in particular+-- for transp in Glue.+equivProof : ∀ {la lt} (T : Set la) (A : Set lt) → (w : T ≃ A) → (a : A)+           → ∀ ψ (f : Partial ψ (fiber (w .fst) a)) → fiber (w .fst) a [ ψ ↦ f ]+equivProof A B w a ψ fb =+  inS (contr' {A = fiber (w .fst) a} (w .snd .equiv-proof a) ψ fb)+  where+    contr' : ∀ {ℓ} {A : Set ℓ} → isContr A → (φ : I) → (u : Partial φ A) → A+    contr' {A = A} (c , p) φ u = hcomp (λ i → λ { (φ = i1) → p (u 1=1) i+                                                ; (φ = i0) → c }) c+++{-# BUILTIN EQUIV      _≃_        #-}+{-# BUILTIN EQUIVFUN   equivFun   #-}+{-# BUILTIN EQUIVPROOF equivProof #-}++module _ {ℓ : I → Level} (P : (i : I) → Set (ℓ i)) where+  private+    E : (i : I) → Set (ℓ i)+    E  = λ i → P i+    ~E : (i : I) → Set (ℓ (~ i))+    ~E = λ i → P (~ i)++    A = P i0+    B = P i1++    f : A → B+    f x = transp E i0 x++    g : B → A+    g y = transp ~E i0 y++    u : ∀ i → A → E i+    u i x = transp (λ j → E (i ∧ j)) (~ i) x++    v : ∀ i → B → E i+    v i y = transp (λ j → ~E ( ~ i ∧ j)) i y++    fiberPath : (y : B) → (xβ0 xβ1 : fiber f y) → xβ0 ≡ xβ1+    fiberPath y (x0 , β0) (x1 , β1) k = ω , λ j → δ (~ j) where+      module _ (j : I) where+        private+          sys : A → ∀ i → PartialP (~ j ∨ j) (λ _ → E (~ i))+          sys x i (j = i0) = v (~ i) y+          sys x i (j = i1) = u (~ i) x+        ω0 = comp ~E (sys x0) ((β0 (~ j)))+        ω1 = comp ~E (sys x1) ((β1 (~ j)))+        θ0 = fill ~E (sys x0) (inS (β0 (~ j)))+        θ1 = fill ~E (sys x1) (inS (β1 (~ j)))+      sys = λ {j (k = i0) → ω0 j ; j (k = i1) → ω1 j}+      ω = hcomp sys (g y)+      θ = hfill sys (inS (g y))+      δ = λ (j : I) → comp E+            (λ i → λ { (j = i0) → v i y ; (k = i0) → θ0 j (~ i)+                     ; (j = i1) → u i ω ; (k = i1) → θ1 j (~ i) })+             (θ j)++    γ : (y : B) → y ≡ f (g y)+    γ y j = comp E (λ i → λ { (j = i0) → v i y+                            ; (j = i1) → u i (g y) }) (g y)++  pathToisEquiv : isEquiv f+  pathToisEquiv .equiv-proof y .fst .fst = g y+  pathToisEquiv .equiv-proof y .fst .snd = sym (γ y)+  pathToisEquiv .equiv-proof y .snd = fiberPath y _++  pathToEquiv : A ≃ B+  pathToEquiv .fst = f+  pathToEquiv .snd = pathToisEquiv
src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda view
@@ -1,57 +1,10 @@-{-# OPTIONS --cubical --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Cubical.Glue where  open import Agda.Primitive-open import Agda.Builtin.Sigma-open import Agda.Primitive.Cubical renaming (primINeg to ~_; primIMax to _∨_; primIMin to _∧_;-                                             primHComp to hcomp; primTransp to transp; primComp to comp;-                                             itIsOne to 1=1)-open import Agda.Builtin.Cubical.Path-open import Agda.Builtin.Cubical.Sub renaming (Sub to _[_↦_]; primSubOut to ouc)-import Agda.Builtin.Cubical.HCompU as HCompU--module Helpers = HCompU.Helpers--open Helpers----- We make this a record so that isEquiv can be proved using--- copatterns. This is good because copatterns don't get unfolded--- unless a projection is applied so it should be more efficient.-record isEquiv {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} (f : A → B) : Set (ℓ ⊔ ℓ') where-  no-eta-equality-  field-    equiv-proof : (y : B) → isContr (fiber f y)--open isEquiv public--infix 4 _≃_---_≃_ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') → Set (ℓ ⊔ ℓ')-A ≃ B = Σ (A → B) \ f → (isEquiv f)--equivFun : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} → A ≃ B → A → B-equivFun e = fst e---- Improved version of equivProof compared to Lemma 5 in CCHM. We put--- the (φ = i0) face in contr' making it be definitionally c in this--- case. This makes the computational behavior better, in particular--- for transp in Glue.-equivProof : ∀ {la lt} (T : Set la) (A : Set lt) → (w : T ≃ A) → (a : A)-           → ∀ ψ → (Partial ψ (fiber (w .fst) a)) → fiber (w .fst) a-equivProof A B w a ψ fb = contr' {A = fiber (w .fst) a} (w .snd .equiv-proof a) ψ fb-  where-    contr' : ∀ {ℓ} {A : Set ℓ} → isContr A → (φ : I) → (u : Partial φ A) → A-    contr' {A = A} (c , p) φ u = hcomp (λ i → λ { (φ = i1) → p (u 1=1) i-                                                ; (φ = i0) → c }) c---{-# BUILTIN EQUIV      _≃_        #-}-{-# BUILTIN EQUIVFUN   equivFun   #-}-{-# BUILTIN EQUIVPROOF equivProof #-}+open import Agda.Primitive.Cubical+open import Agda.Builtin.Cubical.Equiv public  primitive     primGlue    : ∀ {ℓ ℓ'} (A : Set ℓ) {φ : I}@@ -63,59 +16,3 @@     prim^unglue : ∀ {ℓ ℓ'} {A : Set ℓ} {φ : I}       → {T : Partial φ (Set ℓ')} → {e : PartialP φ (λ o → T o ≃ A)}       → primGlue A T e → A----module _ {ℓ : I → Level} (P : (i : I) → Set (ℓ i)) where-  private-    E : (i : I) → Set (ℓ i)-    E  = λ i → P i-    ~E : (i : I) → Set (ℓ (~ i))-    ~E = λ i → P (~ i)--    A = P i0-    B = P i1--    f : A → B-    f x = transp E i0 x--    g : B → A-    g y = transp ~E i0 y--    u : ∀ i → A → E i-    u i x = transp (λ j → E (i ∧ j)) (~ i) x--    v : ∀ i → B → E i-    v i y = transp (λ j → ~E ( ~ i ∧ j)) i y--    fiberPath : (y : B) → (xβ0 xβ1 : fiber f y) → xβ0 ≡ xβ1-    fiberPath y (x0 , β0) (x1 , β1) k = ω , λ j → δ (~ j) where-      module _ (j : I) where-        private-          sys : A → ∀ i → PartialP (~ j ∨ j) (λ _ → E (~ i))-          sys x i (j = i0) = v (~ i) y-          sys x i (j = i1) = u (~ i) x-        ω0 = comp ~E (sys x0) ((β0 (~ j)))-        ω1 = comp ~E (sys x1) ((β1 (~ j)))-        θ0 = fill ~E (sys x0) (inc (β0 (~ j)))-        θ1 = fill ~E (sys x1) (inc (β1 (~ j)))-      sys = λ {j (k = i0) → ω0 j ; j (k = i1) → ω1 j}-      ω = hcomp sys (g y)-      θ = hfill sys (inc (g y))-      δ = λ (j : I) → comp E-            (λ i → λ { (j = i0) → v i y ; (k = i0) → θ0 j (~ i)-                     ; (j = i1) → u i ω ; (k = i1) → θ1 j (~ i) })-             (θ j)--    γ : (y : B) → y ≡ f (g y)-    γ y j = comp E (λ i → λ { (j = i0) → v i y-                            ; (j = i1) → u i (g y) }) (g y)--  pathToisEquiv : isEquiv f-  pathToisEquiv .equiv-proof y .fst .fst = g y-  pathToisEquiv .equiv-proof y .fst .snd = sym (γ y)-  pathToisEquiv .equiv-proof y .snd = fiberPath y _--  pathToEquiv : A ≃ B-  pathToEquiv .fst = f-  pathToEquiv .snd = pathToisEquiv
src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Cubical.HCompU where @@ -9,7 +8,7 @@                                              primHComp to hcomp; primTransp to transp; primComp to comp;                                              itIsOne to 1=1) open import Agda.Builtin.Cubical.Path-open import Agda.Builtin.Cubical.Sub renaming (Sub to _[_↦_]; primSubOut to outS; inc to inS)+open import Agda.Builtin.Cubical.Sub renaming (Sub to _[_↦_]; primSubOut to outS)  module Helpers where     -- Homogeneous filling
− src/data/lib/prim/Agda/Builtin/Cubical/Id.agda 
@@ -1,38 +0,0 @@-{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness-            --no-subtyping #-}--module Agda.Builtin.Cubical.Id where--  open import Agda.Primitive.Cubical-  open import Agda.Builtin.Cubical.Path-  open import Agda.Builtin.Cubical.Sub renaming (primSubOut to ouc; Sub to _[_↦_])--  postulate-    Id : ∀ {ℓ} {A : Set ℓ} → A → A → Set ℓ--  {-# BUILTIN ID           Id       #-}-  {-# BUILTIN CONID        conid    #-}--  -- Id x y is treated as a pair of I and x ≡ y, using "i" for the-  -- first component and "p" for the second.-  {-# COMPILE JS conid =-      _ => _ => _ => _ => i => p => { return { "i" : i, "p" : p } }-    #-}--  primitive-    primDepIMin : _-    primIdFace : ∀ {ℓ} {A : Set ℓ} {x y : A} → Id x y → I-    primIdPath : ∀ {ℓ} {A : Set ℓ} {x y : A} → Id x y → x ≡ y--  primitive-    primIdJ : ∀ {ℓ ℓ'} {A : Set ℓ} {x : A} (P : ∀ y → Id x y → Set ℓ') →-                P x (conid i1 (λ i → x)) → ∀ {y} (p : Id x y) → P y p---  primitive-    primIdElim : ∀ {a c} {A : Set a} {x : A}-                   (C : (y : A) → Id x y → Set c) →-                   ((φ : I) (y : A [ φ ↦ (λ _ → x) ])-                    (w : (x ≡ ouc y) [ φ ↦ (λ { (φ = i1) → \ _ → x}) ]) →-                    C (ouc y) (conid φ (ouc w))) →-                   {y : A} (p : Id x y) → C y p
src/data/lib/prim/Agda/Builtin/Cubical/Path.agda view
@@ -1,14 +1,9 @@-{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Cubical.Path where -  open import Agda.Primitive.Cubical--  postulate-    PathP : ∀ {ℓ} (A : I → Set ℓ) → A i0 → A i1 → Set ℓ+  open import Agda.Primitive.Cubical using (PathP) public -  {-# BUILTIN PATHP        PathP     #-}    infix 4 _≡_
src/data/lib/prim/Agda/Builtin/Cubical/Sub.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Cubical.Sub where @@ -8,12 +7,12 @@   {-# BUILTIN SUB Sub #-}    postulate-    inc : ∀ {ℓ} {A : Set ℓ} {φ} (x : A) → Sub A φ (λ _ → x)+    inS : ∀ {ℓ} {A : Set ℓ} {φ} (x : A) → Sub A φ (λ _ → x) -  {-# BUILTIN SUBIN inc #-}+  {-# BUILTIN SUBIN inS #-} -  -- Sub A φ u is treated as A.-  {-# COMPILE JS inc = _ => _ => _ => x => x #-}+  -- Sub A φ u is treated as A.+  {-# COMPILE JS inS = _ => _ => _ => x => x #-}    primitive     primSubOut : ∀ {ℓ} {A : Set ℓ} {φ : I} {u : Partial φ A} → Sub _ φ u → A
src/data/lib/prim/Agda/Builtin/Equality.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Equality where
src/data/lib/prim/Agda/Builtin/Equality/Erase.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --with-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --with-K --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Equality.Erase where
src/data/lib/prim/Agda/Builtin/Equality/Rewrite.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --rewriting --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --rewriting --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Equality.Rewrite where
src/data/lib/prim/Agda/Builtin/Float.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Float where @@ -24,7 +23,7 @@   primFloatIsNegativeZero    : Float → Bool   primFloatIsSafeInteger     : Float → Bool   -- Conversions-  primFloatToWord64          : Float → Word64+  primFloatToWord64          : Float → Maybe Word64   primNatToFloat             : Nat → Float   primIntToFloat             : Int → Float   primFloatRound             : Float → Maybe Int
src/data/lib/prim/Agda/Builtin/Float/Properties.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Float.Properties where
src/data/lib/prim/Agda/Builtin/FromNat.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.FromNat where
src/data/lib/prim/Agda/Builtin/FromNeg.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.FromNeg where
src/data/lib/prim/Agda/Builtin/FromString.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.FromString where
src/data/lib/prim/Agda/Builtin/IO.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.IO where
src/data/lib/prim/Agda/Builtin/Int.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Int where
src/data/lib/prim/Agda/Builtin/List.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.List where
src/data/lib/prim/Agda/Builtin/Maybe.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Maybe where
src/data/lib/prim/Agda/Builtin/Nat.agda view
@@ -1,5 +1,5 @@-{-# OPTIONS --without-K --safe --no-universe-polymorphism-            --no-sized-types --no-guardedness --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism+            --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Nat where
src/data/lib/prim/Agda/Builtin/Reflection.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Reflection where @@ -129,6 +128,16 @@ {-# BUILTIN ARG        Arg      #-} {-# BUILTIN ARGARG     arg      #-} +data Blocker : Set where+  blockerAny  : List Blocker → Blocker+  blockerAll  : List Blocker → Blocker+  blockerMeta : Meta → Blocker++{-# BUILTIN AGDABLOCKER     Blocker #-}+{-# BUILTIN AGDABLOCKERANY  blockerAny #-}+{-# BUILTIN AGDABLOCKERALL  blockerAll #-}+{-# BUILTIN AGDABLOCKERMETA blockerMeta #-}+ -- Name abstraction --  data Abs {a} (A : Set a) : Set a where@@ -165,6 +174,7 @@ data Pattern : Set data Clause  : Set Type = Term+Telescope = List (Σ String λ _ → Arg Type)  data Term where   var       : (x : Nat) (args : List (Arg Term)) → Term@@ -195,8 +205,8 @@   absurd : (x : Nat)     → Pattern  -- absurd patterns counts as variables  data Clause where-  clause        : (tel : List (Σ String λ _ → Arg Type)) (ps : List (Arg Pattern)) (t : Term) → Clause-  absurd-clause : (tel : List (Σ String λ _ → Arg Type)) (ps : List (Arg Pattern)) → Clause+  clause        : (tel : Telescope) (ps : List (Arg Pattern)) (t : Term) → Clause+  absurd-clause : (tel : Telescope) (ps : List (Arg Pattern)) → Clause  {-# BUILTIN AGDATERM      Term    #-} {-# BUILTIN AGDASORT      Sort    #-}@@ -237,7 +247,7 @@   function    : (cs : List Clause) → Definition   data-type   : (pars : Nat) (cs : List Name) → Definition   record-type : (c : Name) (fs : List (Arg Name)) → Definition-  data-cons   : (d : Name) → Definition+  data-cons   : (d : Name) (q : Quantity) → Definition   axiom       : Definition   prim-fun    : Definition @@ -254,11 +264,13 @@ data ErrorPart : Set where   strErr  : String → ErrorPart   termErr : Term → ErrorPart+  pattErr : Pattern → ErrorPart   nameErr : Name → ErrorPart  {-# BUILTIN AGDAERRORPART       ErrorPart #-} {-# BUILTIN AGDAERRORPARTSTRING strErr    #-} {-# BUILTIN AGDAERRORPARTTERM   termErr   #-}+{-# BUILTIN AGDAERRORPARTPATT   pattErr   #-} {-# BUILTIN AGDAERRORPARTNAME   nameErr   #-}  -- TC monad --@@ -277,46 +289,73 @@   quoteTC          : ∀ {a} {A : Set a} → A → TC Term   unquoteTC        : ∀ {a} {A : Set a} → Term → TC A   quoteωTC         : ∀ {A : Setω} → A → TC Term-  getContext       : TC (List (Arg Type))-  extendContext    : ∀ {a} {A : Set a} → Arg Type → TC A → TC A-  inContext        : ∀ {a} {A : Set a} → List (Arg Type) → TC A → TC A+  getContext       : TC Telescope+  extendContext    : ∀ {a} {A : Set a} → String → Arg Type → TC A → TC A+  inContext        : ∀ {a} {A : Set a} → Telescope → TC A → TC A   freshName        : String → TC Name   declareDef       : Arg Name → Type → TC ⊤   declarePostulate : Arg Name → Type → TC ⊤+  declareData      : Name → Nat → Type → TC ⊤+  defineData       : Name → List (Σ Name (λ _ → Σ Quantity (λ _ → Type))) → TC ⊤   defineFun        : Name → List Clause → TC ⊤   getType          : Name → TC Type   getDefinition    : Name → TC Definition-  blockOnMeta      : ∀ {a} {A : Set a} → Meta → TC A+  blockTC          : ∀ {a} {A : Set a} → Blocker → TC A   commitTC         : TC ⊤   isMacro          : Name → TC Bool+  pragmaForeign    : String → String → TC ⊤+  pragmaCompile    : String → Name → String → TC ⊤ -  -- If the argument is 'true' makes the following primitives also normalise+  -- If 'true', makes the following primitives also normalise   -- their results: inferType, checkType, quoteTC, getType, and getContext   withNormalisation : ∀ {a} {A : Set a} → Bool → TC A → TC A+  askNormalisation  : TC Bool -  -- Makes the following primitives to reconstruct hidden arguments+  -- If 'true', makes the following primitives to reconstruct hidden arguments:   -- getDefinition, normalise, reduce, inferType, checkType and getContext-  withReconstructed : ∀ {a} {A : Set a} → TC A → TC A+  withReconstructed : ∀ {a} {A : Set a} → Bool → TC A → TC A+  askReconstructed  : TC Bool +  -- Whether implicit arguments at the end should be turned into metavariables+  withExpandLast : ∀ {a} {A : Set a} → Bool → TC A → TC A+  askExpandLast  : TC Bool++  -- White/blacklist specific definitions for reduction while executing the TC computation+  -- 'true' for whitelist, 'false' for blacklist+  withReduceDefs : ∀ {a} {A : Set a} → (Σ Bool λ _ → List Name) → TC A → TC A+  askReduceDefs  : TC (Σ Bool λ _ → List Name)++  formatErrorParts : List ErrorPart → TC String   -- Prints the third argument if the corresponding verbosity level is turned   -- on (with the -v flag to Agda).   debugPrint : String → Nat → List ErrorPart → TC ⊤ -  -- Only allow reduction of specific definitions while executing the TC computation-  onlyReduceDefs : ∀ {a} {A : Set a} → List Name → TC A → TC A--  -- Don't allow reduction of specific definitions while executing the TC computation-  dontReduceDefs : ∀ {a} {A : Set a} → List Name → TC A → TC A-   -- Fail if the given computation gives rise to new, unsolved   -- "blocking" constraints.   noConstraints : ∀ {a} {A : Set a} → TC A → TC A +  -- Run the given computation at the type level, allowing use of erased things.+  workOnTypes : ∀ {a} {A : Set a} → TC A → TC A+   -- Run the given TC action and return the first component. Resets to   -- the old TC state if the second component is 'false', or keep the   -- new TC state if it is 'true'.   runSpeculative : ∀ {a} {A : Set a} → TC (Σ A λ _ → Bool) → TC A +  -- Get a list of all possible instance candidates for the given meta+  -- variable (it does not have to be an instance meta).+  getInstances : Meta → TC (List Term)++  -- Try to solve open instance constraints. When wrapped in `noConstraints`,+  -- fails if there are unsolved instance constraints left over that originate+  -- from the current macro invokation. Outside constraints are still attempted,+  -- but failure to solve them are ignored by `noConstraints`.+  solveInstanceConstraints : TC ⊤++  -- Parse and type check the given string against the given type, returning+  -- the resulting term (when successful).+  checkFromStringTC : String → Type → TC Term+ {-# BUILTIN AGDATCM                           TC                         #-} {-# BUILTIN AGDATCMRETURN                     returnTC                   #-} {-# BUILTIN AGDATCMBIND                       bindTC                     #-}@@ -336,19 +375,32 @@ {-# BUILTIN AGDATCMFRESHNAME                  freshName                  #-} {-# BUILTIN AGDATCMDECLAREDEF                 declareDef                 #-} {-# BUILTIN AGDATCMDECLAREPOSTULATE           declarePostulate           #-}+{-# BUILTIN AGDATCMDECLAREDATA                declareData                #-}+{-# BUILTIN AGDATCMDEFINEDATA                 defineData                 #-} {-# BUILTIN AGDATCMDEFINEFUN                  defineFun                  #-} {-# BUILTIN AGDATCMGETTYPE                    getType                    #-} {-# BUILTIN AGDATCMGETDEFINITION              getDefinition              #-}-{-# BUILTIN AGDATCMBLOCKONMETA                blockOnMeta                #-}+{-# BUILTIN AGDATCMBLOCK                      blockTC                    #-} {-# BUILTIN AGDATCMCOMMIT                     commitTC                   #-} {-# BUILTIN AGDATCMISMACRO                    isMacro                    #-}+{-# BUILTIN AGDATCMPRAGMAFOREIGN              pragmaForeign              #-}+{-# BUILTIN AGDATCMPRAGMACOMPILE              pragmaCompile              #-} {-# BUILTIN AGDATCMWITHNORMALISATION          withNormalisation          #-}+{-# BUILTIN AGDATCMWITHRECONSTRUCTED          withReconstructed          #-}+{-# BUILTIN AGDATCMWITHEXPANDLAST             withExpandLast             #-}+{-# BUILTIN AGDATCMWITHREDUCEDEFS             withReduceDefs             #-}+{-# BUILTIN AGDATCMASKNORMALISATION           askNormalisation           #-}+{-# BUILTIN AGDATCMASKRECONSTRUCTED           askReconstructed           #-}+{-# BUILTIN AGDATCMASKEXPANDLAST              askExpandLast              #-}+{-# BUILTIN AGDATCMASKREDUCEDEFS              askReduceDefs              #-}+{-# BUILTIN AGDATCMFORMATERRORPARTS           formatErrorParts           #-} {-# BUILTIN AGDATCMDEBUGPRINT                 debugPrint                 #-}-{-# BUILTIN AGDATCMONLYREDUCEDEFS             onlyReduceDefs             #-}-{-# BUILTIN AGDATCMDONTREDUCEDEFS             dontReduceDefs             #-}-{-# BUILTIN AGDATCMWITHRECONSPARAMS           withReconstructed          #-} {-# BUILTIN AGDATCMNOCONSTRAINTS              noConstraints              #-}+{-# BUILTIN AGDATCMWORKONTYPES                workOnTypes                #-} {-# BUILTIN AGDATCMRUNSPECULATIVE             runSpeculative             #-}+{-# BUILTIN AGDATCMGETINSTANCES               getInstances               #-}+{-# BUILTIN AGDATCMSOLVEINSTANCES             solveInstanceConstraints   #-}+{-# BUILTIN AGDATCMCHECKFROMSTRING            checkFromStringTC          #-}  -- All the TC primitives are compiled to functions that return -- undefined, rather than just undefined, in an attempt to make sure@@ -367,21 +419,68 @@ {-# COMPILE JS unquoteTC         = _ => _ => _ =>      undefined #-} {-# COMPILE JS quoteωTC          = _ => _ =>           undefined #-} {-# COMPILE JS getContext        =                     undefined #-}-{-# COMPILE JS extendContext     = _ => _ => _ => _ => undefined #-}+{-# COMPILE JS extendContext     = _ => _ => _ => _ => _ => undefined #-} {-# COMPILE JS inContext         = _ => _ => _ => _ => undefined #-} {-# COMPILE JS freshName         = _ =>                undefined #-} {-# COMPILE JS declareDef        = _ => _ =>           undefined #-} {-# COMPILE JS declarePostulate  = _ => _ =>           undefined #-}+{-# COMPILE JS declareData       = _ => _ => _ =>      undefined #-}+{-# COMPILE JS defineData        = _ => _ =>           undefined #-} {-# COMPILE JS defineFun         = _ => _ =>           undefined #-} {-# COMPILE JS getType           = _ =>                undefined #-} {-# COMPILE JS getDefinition     = _ =>                undefined #-}-{-# COMPILE JS blockOnMeta       = _ => _ => _ =>      undefined #-}+{-# COMPILE JS blockTC           = _ => _ =>           undefined #-} {-# COMPILE JS commitTC          =                     undefined #-} {-# COMPILE JS isMacro           = _ =>                undefined #-}+{-# COMPILE JS pragmaForeign     = _ => _ =>           undefined #-}+{-# COMPILE JS pragmaCompile     = _ => _ => _ =>      undefined #-} {-# COMPILE JS withNormalisation = _ => _ => _ => _ => undefined #-}-{-# COMPILE JS withReconstructed = _ => _ => _ =>      undefined #-}+{-# COMPILE JS withReconstructed = _ => _ => _ => _ => undefined #-}+{-# COMPILE JS withExpandLast    = _ => _ => _ => _ => undefined #-}+{-# COMPILE JS withReduceDefs    = _ => _ => _ => _ => undefined #-}+{-# COMPILE JS askNormalisation  =                     undefined #-}+{-# COMPILE JS askReconstructed  =                     undefined #-}+{-# COMPILE JS askExpandLast     =                     undefined #-}+{-# COMPILE JS askReduceDefs     =                     undefined #-} {-# COMPILE JS debugPrint        = _ => _ => _ =>      undefined #-}-{-# COMPILE JS onlyReduceDefs    = _ => _ => _ => _ => undefined #-}-{-# COMPILE JS dontReduceDefs    = _ => _ => _ => _ => undefined #-} {-# COMPILE JS noConstraints     = _ => _ => _ =>      undefined #-} {-# COMPILE JS runSpeculative    = _ => _ => _ =>      undefined #-}+{-# COMPILE JS getInstances      = _ =>                undefined #-}++private+  filter : (Name → Bool) → List Name → List Name+  filter p [] = []+  filter p (x ∷ xs) with p x+  ... | true  = x ∷ filter p xs+  ... | false = filter p xs++  _∈_ : Name → List Name → Bool+  n ∈ []      = false+  n ∈ (n' ∷ l) with primQNameEquality n n'+  ... | true  = true+  ... | false = n ∈ l++  _∉_ : Name → List Name → Bool+  n ∉ l with n ∈ l+  ... | true  = false+  ... | false = true++  _++_ : List Name → List Name → List Name+  [] ++ l       = l+  (x ∷ xs) ++ l = x ∷ (xs ++ l)++  combineReduceDefs : (Σ Bool λ _ → List Name) → (Σ Bool λ _ → List Name) → (Σ Bool λ _ → List Name)+  combineReduceDefs (true  , defs₁) (true  , defs₂) = (true  , filter (_∈ defs₁) defs₂)+  combineReduceDefs (false , defs₁) (true  , defs₂) = (true  , filter (_∉ defs₁) defs₂)+  combineReduceDefs (true  , defs₁) (false , defs₂) = (true  , filter (_∉ defs₂) defs₁)+  combineReduceDefs (false , defs₁) (false , defs₂) = (false , defs₁ ++ defs₂)++onlyReduceDefs dontReduceDefs : ∀ {a} {A : Set a} → List Name → TC A → TC A+onlyReduceDefs defs x = bindTC askReduceDefs (λ exDefs → withReduceDefs (combineReduceDefs (true  , defs) exDefs) x)+dontReduceDefs defs x = bindTC askReduceDefs (λ exDefs → withReduceDefs (combineReduceDefs (false , defs) exDefs) x)++blockOnMeta   : ∀ {a} {A : Set a} → Meta → TC A+blockOnMeta m = blockTC (blockerMeta m)++{-# WARNING_ON_USAGE onlyReduceDefs "DEPRECATED: Use `withReduceDefs` instead of `onlyReduceDefs`" #-}+{-# WARNING_ON_USAGE dontReduceDefs "DEPRECATED: Use `withReduceDefs` instead of `dontReduceDefs`" #-}
src/data/lib/prim/Agda/Builtin/Reflection/External.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Reflection.External where
src/data/lib/prim/Agda/Builtin/Reflection/Properties.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Reflection.Properties where
src/data/lib/prim/Agda/Builtin/Sigma.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Sigma where
src/data/lib/prim/Agda/Builtin/Size.agda view
@@ -1,5 +1,5 @@-{-# OPTIONS --without-K --no-universe-polymorphism --sized-types-            --no-guardedness --no-subtyping #-}+{-# OPTIONS --cubical-compatible --no-universe-polymorphism --sized-types+            --no-guardedness --level-universe #-}  module Agda.Builtin.Size where
src/data/lib/prim/Agda/Builtin/Strict.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Strict where
src/data/lib/prim/Agda/Builtin/String.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.String where @@ -34,4 +33,4 @@ {-# COMPILE JS primStringEquality = function(x) { return function(y) { return x===y; }; } #-} {-# COMPILE JS primShowChar = function(x) { return JSON.stringify(x); } #-} {-# COMPILE JS primShowString = function(x) { return JSON.stringify(x); } #-}-{-# COMPILE JS primShowNat = function(x) { return JSON.stringify(x); } #-}+{-# COMPILE JS primShowNat = function(x) { return x.toString(); } #-}
src/data/lib/prim/Agda/Builtin/String/Properties.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.String.Properties where
src/data/lib/prim/Agda/Builtin/TrustMe.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --no-sized-types --no-guardedness --no-subtyping #-}+{-# OPTIONS --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.TrustMe where
src/data/lib/prim/Agda/Builtin/Unit.agda view
@@ -1,5 +1,5 @@-{-# OPTIONS --without-K --safe --no-universe-polymorphism-            --no-sized-types --no-guardedness --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism+            --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Unit where
src/data/lib/prim/Agda/Builtin/Word.agda view
@@ -1,5 +1,5 @@-{-# OPTIONS --without-K --safe --no-universe-polymorphism-            --no-sized-types --no-guardedness --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism+            --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Word where
src/data/lib/prim/Agda/Builtin/Word/Properties.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness --level-universe #-}  module Agda.Builtin.Word.Properties where
src/data/lib/prim/Agda/Primitive.agda view
@@ -1,6 +1,6 @@ -- The Agda primitives (preloaded). -{-# OPTIONS --without-K --no-subtyping --no-import-sorts #-}+{-# OPTIONS --cubical-compatible --no-import-sorts --level-universe #-}  module Agda.Primitive where @@ -10,17 +10,21 @@  infixl 6 _⊔_ -{-# BUILTIN TYPE Set #-}-{-# BUILTIN PROP Prop #-}-{-# BUILTIN SETOMEGA Setω #-}-{-# BUILTIN STRICTSET      SSet  #-}-{-# BUILTIN STRICTSETOMEGA SSetω #-}+{-# BUILTIN PROP           Prop      #-}+{-# BUILTIN TYPE           Set       #-}+{-# BUILTIN STRICTSET      SSet      #-} +{-# BUILTIN PROPOMEGA      Propω     #-}+{-# BUILTIN SETOMEGA       Setω      #-}+{-# BUILTIN STRICTSETOMEGA SSetω     #-}++{-# BUILTIN LEVELUNIV      LevelUniv #-}+ -- Level is the first thing we need to define. -- The other postulates can only be checked if built-in Level is known.  postulate-  Level : Set+  Level : LevelUniv  -- MAlonzo compiles Level to (). This should be safe, because it is -- not possible to pattern match on levels.
src/data/lib/prim/Agda/Primitive/Cubical.agda view
@@ -1,8 +1,9 @@-{-# OPTIONS --erased-cubical --no-subtyping #-}+{-# OPTIONS --erased-cubical #-}  module Agda.Primitive.Cubical where -{-# BUILTIN INTERVAL I  #-}  -- I : Setω+{-# BUILTIN CUBEINTERVALUNIV IUniv #-}  -- IUniv : SSet₁+{-# BUILTIN INTERVAL I  #-}  -- I : IUniv  {-# BUILTIN IZERO    i0 #-} {-# BUILTIN IONE     i1 #-}@@ -69,3 +70,9 @@ primitive   primTransp : ∀ {ℓ} (A : (i : I) → Set (ℓ i)) (φ : I) (a : A i0) → A i1   primHComp  : ∀ {ℓ} {A : Set ℓ} {φ : I} (u : ∀ i → Partial φ A) (a : A) → A+++postulate+  PathP : ∀ {ℓ} (A : I → Set ℓ) → A i0 → A i1 → Set ℓ++{-# BUILTIN PATHP        PathP     #-}
+ src/data/lib/prim/agda-builtins.agda-lib view
@@ -0,0 +1,2 @@+name: agda-builtins+include: .
− src/full/Agda/Auto/Auto.hs 
@@ -1,507 +0,0 @@--module Agda.Auto.Auto-      (auto-      , AutoResult(..)-      , AutoProgress(..)-      ) where--import Prelude hiding (null)--import Control.Monad          ( filterM, forM, guard, join, when )-import Control.Monad.Except-import Control.Monad.IO.Class ( MonadIO(..) )-import Control.Monad.State--import qualified Data.List as List-import qualified Data.Map as Map-import Data.IORef-import qualified System.Timeout-import Data.Maybe-import qualified Data.Traversable as Trav-import qualified Data.HashMap.Strict as HMap--import Agda.Utils.Permutation (permute, takeP)-import Agda.TypeChecking.Monad hiding (withCurrentModule)-import Agda.TypeChecking.Telescope-import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Abstract.Pretty (prettyA)-import qualified Agda.Syntax.Concrete.Name as C-import qualified Text.PrettyPrint as PP-import qualified Agda.TypeChecking.Pretty as TCM-import Agda.Syntax.Position-import qualified Agda.Syntax.Internal as I-import Agda.Syntax.Translation.InternalToAbstract-import Agda.Syntax.Translation.AbstractToConcrete (abstractToConcreteScope, abstractToConcrete_, runAbsToCon, toConcrete)-import Agda.Interaction.Base-import Agda.Interaction.BasicOps hiding (refine)-import Agda.TypeChecking.Reduce (normalise)-import Agda.Syntax.Common-import qualified Agda.Syntax.Scope.Base as Scope-import Agda.Syntax.Scope.Monad (withCurrentModule)-import qualified Agda.Syntax.Abstract.Name as AN-import qualified Agda.TypeChecking.Monad.Base as TCM-import Agda.TypeChecking.EtaContract (etaContract)--import Agda.Auto.Options-import Agda.Auto.Convert-import Agda.Auto.NarrowingSearch-import Agda.Auto.Syntax-import Agda.Auto.SearchControl-import Agda.Auto.Typecheck--import Agda.Auto.CaseSplit--import Agda.Utils.Functor-import Agda.Utils.Impossible-import Agda.Utils.Lens-import Agda.Utils.Maybe-import Agda.Utils.Null-import Agda.Utils.Pretty ( prettyShow )-import Agda.Utils.Tuple---insertAbsurdPattern :: String -> String-insertAbsurdPattern [] = []-insertAbsurdPattern s@(_:_) | take (length abspatvarname) s == abspatvarname = "()" ++ drop (length abspatvarname) s-insertAbsurdPattern (c:s) = c : insertAbsurdPattern s--getHeadAsHint :: A.Expr -> Maybe Hint-getHeadAsHint (A.ScopedExpr _ e) = getHeadAsHint e-getHeadAsHint (A.Def qname)      = Just $ Hint False qname-getHeadAsHint (A.Proj _ qname)   = Just $ Hint False $ AN.headAmbQ qname-getHeadAsHint (A.Con qname)      = Just $ Hint True  $ AN.headAmbQ qname-getHeadAsHint _ = Nothing---- | Result type: Progress & potential Message for the user------   The  of the Auto tactic can be one of the following three:------   1. @Solutions [(ii,s)]@---      A list of solutions @s@ for interaction ids @ii@.---      In particular, @Solutions []@ means Agsy found no solution.------   2. @FunClauses cs@---      A list of clauses for the interaction id @ii@ in which Auto---      was invoked with case-splitting turned on.------   3. @Refinement s@---      A refinement for the interaction id @ii@ in which Auto was invoked.--data AutoProgress =-    Solutions  [(InteractionId, String)]-  | FunClauses [String]-  | Refinement String--data AutoResult = AutoResult-  { autoProgress :: AutoProgress-  , autoMessage  :: Maybe String-  }--stopWithMsg :: String -> TCM AutoResult-stopWithMsg msg = return $ AutoResult (Solutions []) (Just msg)---- | Entry point for Auto tactic (Agsy).------   If the @autoMessage@ part of the result is set to @Just msg@, the---   message @msg@ produced by Agsy should be displayed to the user.--{-# SPECIALIZE auto :: InteractionId -> Range -> String -> TCM AutoResult #-}-auto-  :: MonadTCM tcm-  => InteractionId-  -> Range-  -> String-  -> tcm AutoResult-auto ii rng argstr = liftTCM $ locallyTC eMakeCase (const True) $ do--  -- Parse hints and other configuration.-  let autoOptions = parseArgs argstr-  let hints    = autoOptions ^. aoHints-  let timeout  = autoOptions ^. aoTimeOut-  let pick     = autoOptions ^. aoPick-  let mode     = autoOptions ^. aoMode-  let hintmode = autoOptions ^. aoHintMode-  ahints <- case mode of-    MRefine{} -> return []-    _         -> mapM (parseExprIn ii rng) hints-  let failHints = stopWithMsg "Hints must be a list of constant names"--  eqstuff <- getEqCombinators ii rng--  caseMaybe (mapM getHeadAsHint ahints) failHints $ \ ehints -> do--    -- Get the meta variable for the interaction point we are trying to fill.-    -- Add the @autohints@ for that meta to the hints collection.-    mi <- lookupInteractionId ii-    thisdefinfo <- findClauseDeep ii-    ehints <- (ehints ++) <$> do autohints hintmode mi $ fmap fst3 thisdefinfo--    -- If @thisdefinfo /= Nothing@ get the its type (normalized).-    mrectyp <- maybeToList <$> do-      Trav.forM thisdefinfo $ \ (def, _, _) -> do-        normalise =<< do TCM.defType <$> getConstInfo def--    (myhints', mymrectyp, tccons, eqcons, cmap) <- tomy mi (ehints ++ eqstuff) mrectyp--    let (myhints, c1to6) = splitAt (length myhints' - length eqstuff) myhints'-        meqr = ifNull eqstuff Nothing $ \ _ -> {- else -}-                 let [c1, c2, c3, c4, c5, c6] = c1to6-                 in  Just $ EqReasoningConsts c1 c2 c3 c4 c5 c6---    let tcSearchSC isdep ctx typ trm = caseMaybe meqr a $ \ eqr ->-          mpret $ Sidecondition (calcEqRState eqr trm) a-          where a = tcSearch isdep ctx typ trm--    let (mainm, _, _, _) = tccons Map.! mi-    case mode of-     MNormal listmode disprove -> do-        let numsols = if listmode then 10 else 1-          -- Andreas, 2015-05-17 Issue 1504:-          -- wish to produce several solutions, as-          -- the first one might be ill-typed.-          -- However, currently changing the 1 to something higher makes Agsy loop.-        sols <- liftIO $ newIORef ([] :: [[I.Term]])-        nsol <- liftIO $ newIORef $ pick + numsols-        let hsol = do-             nsol' <- readIORef nsol-             let cond = nsol' <= numsols-             when cond $ do-               trms <- runExceptT-                       $ mapM (\ (m , _, _, _) -> convert (Meta m) :: MOT I.Term)-                       $ Map.elems tccons-               case trms of-                 Left{}     -> writeIORef nsol $! nsol' + 1-                 Right trms -> modifyIORef sols (trms :)-                 -- Right trms -> if listmode then modifyIORef sols (trms :)-                 --                           else writeIORef sols [trms]-        ticks <- liftIO $ newIORef 0--        let exsearch initprop recinfo defdfv =-             liftIO $ System.Timeout.timeout (getTimeOut timeout * 1000)-                    $ loop 0-             where-               loop d = do-                 let rechint x = case recinfo of-                                  Nothing -> x-                                  Just (_, recdef) -> (recdef, HMRecCall) : x-                     env = RIEnv { rieHints             = rechint $ map (,HMNormal) myhints-                                 , rieDefFreeVars       = defdfv-                                 , rieEqReasoningConsts = meqr-                                 }-                 depreached <- topSearch ticks nsol hsol env (initprop) d costIncrease-                 nsol' <- readIORef nsol-                 if nsol' /= 0 && depreached then loop (d + costIncrease) else return depreached--        let getsols :: [I.Term] -> TCM [(MetaId, A.Expr)]-            getsols sol = do-             exprs <- forM (zip (Map.keys tccons) sol) $ \ (mi, e) -> do-               mv   <- lookupMeta mi-               e    <- etaContract e-               expr <- modifyAbstractExpr <$> do withMetaInfo (getMetaInfo mv) $ reify e-               return (mi, expr)--             let loop :: I.MetaId -> StateT [I.MetaId] TCM [(I.MetaId, A.Expr)]-                 loop midx = do-                   let (m, _, _, deps) = tccons Map.! midx-                   asolss <- mapM loop deps-                   dones  <- get-                   asols  <- if midx `elem` dones then return [] else do-                     put (midx : dones)-                     return [(midx, fromMaybe __IMPOSSIBLE__ $ lookup midx exprs)]-                   return $ concat asolss ++ asols-             (asols, _) <- runStateT (loop mi) []-             return asols--        if disprove then-          case eqcons of-           [] -> case Map.elems tccons of-            (m, mytype, mylocalVars, _) : [] -> do-                defdfv <- case thisdefinfo of-                           Just (def, _, _) -> getdfv mi def-                           Nothing -> return 0-                ee <- liftIO $ newIORef $ ConstDef {cdname = "T", cdorigin = __IMPOSSIBLE__, cdtype = NotM $ Sort (Set 0), cdcont = Postulate, cddeffreevars = 0}-                let (restargs, modargs) = splitAt (length mylocalVars - defdfv) mylocalVars-                    mytype' = foldl (\x y -> NotM $ Pi Nothing NotHidden (freeIn 0 y) y (Abs NoId x)) mytype restargs-                    htyp = negtype ee mytype'-                    sctx = (Id "h", closify htyp) : map (\x -> (NoId, closify x)) modargs-                    ntt = closify (NotM $ App Nothing (NotM OKVal) (Const ee) (NotM ALNil))-                res <- exsearch (tcSearchSC False sctx ntt (Meta m)) Nothing defdfv-                rsols <- fmap reverse $ liftIO $ readIORef sols-                if null rsols then do-                  nsol' <- liftIO $ readIORef nsol-                  stopWithMsg $ insuffsols (pick + numsols - nsol')-                 else do-                  aexprss <- mapM getsols rsols-                  cexprss <- forM aexprss $ mapM $ \(mi, e) -> do-                    mv <- lookupMeta mi-                    withMetaInfo (getMetaInfo mv) $ do-                      (mi,) <$> abstractToConcrete_ e-                  let ss = dropWhile (== ' ') . dropWhile (/= ' ') . prettyShow-                      disp [(_, cexpr)] = ss cexpr-                      disp cexprs = concatMap (\ (mi, cexpr) -> ss cexpr ++ " ") cexprs-                  ticks <- liftIO $ readIORef ticks-                  stopWithMsg $ unlines $-                    ("Listing disproof(s) " ++ show pick ++ "-" ++ show (pick + length rsols - 1)) :-                    for (zip cexprss [pick..]) (\ (x, y) -> show y ++ "  " ++ disp x)-            _ -> stopWithMsg "Metavariable dependencies not allowed in disprove mode"-           _ -> stopWithMsg "Metavariable dependencies not allowed in disprove mode"-         else do-          (recinfo, defdfv) <--           case thisdefinfo of-            Just (def, clause, _) -> do-             let [rectyp'] = mymrectyp-             defdfv <- getdfv mi def-             myrecdef <- liftIO $ newIORef $ ConstDef {cdname = "", cdorigin = (Nothing, def), cdtype = rectyp', cdcont = Postulate, cddeffreevars = defdfv}-             (_, pats) <- constructPats cmap mi clause-             defdfv <- getdfv mi def-             return $ if contains_constructor pats then-               (Just (pats, myrecdef), defdfv)-              else-               (Nothing, defdfv)-            Nothing -> return (Nothing, 0)-          let tc (m, mytype, mylocalVars) isdep = tcSearchSC isdep (map (\x -> (NoId, closify x)) mylocalVars) (closify mytype) (Meta m)-              initprop =-                foldl (\x (ineq, e, i) -> mpret $ And Nothing x (comp' ineq (closify e) (closify i)))-                 (foldl (\x (m, mt, mlv, _) ->-                   if hequalMetavar m mainm then-                    case recinfo of-                     Just (recpats, recdef) ->-                      mpret $ Sidecondition (localTerminationSidecond (localTerminationEnv recpats) recdef (Meta m))-                                            (tc (m, mt, mlv) False)-                     Nothing -> mpret $ And Nothing x (tc (m, mt, mlv) False)-                   else-                    mpret $ And Nothing x (tc (m, mt, mlv) True)-                  )-                  (mpret OK)-                  (Map.elems tccons)-                 ) eqcons-          res <- exsearch initprop recinfo defdfv-          riis <- map swap <$> getInteractionIdsAndMetas-          let timeoutString | isNothing res = " after timeout (" ++ show timeout ++ "ms)"-                            | otherwise     = ""-          if listmode then do-            rsols <- fmap reverse $ liftIO $ readIORef sols-            if null rsols then do-              nsol' <- liftIO $ readIORef nsol-              stopWithMsg $ insuffsols (pick + numsols - nsol') ++ timeoutString-             else do-              aexprss <- mapM getsols rsols-              -- cexprss <- mapM (mapM (\(mi, e) -> lookupMeta mi >>= \mv -> withMetaInfo (getMetaInfo mv) $ abstractToConcrete_ e >>= \e' -> return (mi, e'))) aexprss-              cexprss <- forM aexprss $ do-                mapM $ \ (mi, e) -> do-                  mv <- lookupMeta mi-                  withMetaInfo (getMetaInfo mv) $ do-                    e' <- abstractToConcrete_ e-                    return (mi, e')-              let disp [(_, cexpr)] = prettyShow cexpr-                  disp cexprs = concat $ for cexprs $ \ (mi, cexpr) ->-                    maybe (show mi) show (lookup mi riis)-                      ++ " := " ++ prettyShow cexpr ++ " "-              ticks <- liftIO $ readIORef ticks-              stopWithMsg $ "Listing solution(s) " ++ show pick ++ "-" ++ show (pick + length rsols - 1) ++ timeoutString ++-                        "\n" ++ unlines (zipWith (\x y -> show y ++ "  " ++ disp x) cexprss [pick..])-           else {- not listmode -}-            case res of-             Nothing -> do-              nsol' <- liftIO $ readIORef nsol-              stopWithMsg $ insuffsols (pick + numsols - nsol') ++ timeoutString-             Just depthreached -> do-              ticks <- liftIO $ readIORef ticks-              rsols <- liftIO $ readIORef sols-              case rsols of-                [] -> do-                  nsol' <- liftIO $ readIORef nsol-                  stopWithMsg $ insuffsols (pick + numsols - nsol')-                terms -> loop terms where-                  -- Andreas, 2015-05-17  Issue 1504-                  -- If giving a solution failed (e.g. ill-typed)-                  -- we could try the next one.-                  -- However, currently @terms@ is always a singleton list.-                  -- Thus, the following @loop@ is not doing something very-                  -- meaningful.-                  loop :: [[I.Term]] -> TCM AutoResult-                  loop [] = return $ AutoResult (Solutions []) (Just "")-                  loop (term : terms') = do-                    -- On exception, try next solution-                    flip catchError (\ e -> do reportSDoc "auto" 40 $ "Solution failed:" TCM.<?> TCM.prettyTCM e-                                               loop terms') $ do-                      exprs <- getsols term-                      reportSDoc "auto" 20 $ "Trying solution " TCM.<+> TCM.prettyTCM exprs-                      giveress <- forM exprs $ \ (mi, expr0) -> do-                        let expr = killRange expr0-                        case lookup mi riis of-                         Nothing ->-                          -- catchError-                           (giveExpr WithoutForce Nothing mi expr >> return (Nothing, Nothing))-                           -- (const retry)-                           -- (\_ -> return (Nothing, Just ("Failed to give expr for side solution of " ++ show mi)))-                         Just ii' -> do ae <- give WithoutForce ii' Nothing expr-                                        mv <- lookupMeta mi-                                        let scope = getMetaScope mv-                                        ce <- abstractToConcreteScope scope ae-                                        let cmnt = if ii' == ii then agsyinfo ticks else ""-                                        return (Just (ii', prettyShow ce ++ cmnt), Nothing)-                           -- Andreas, 2015-05-17, Issue 1504-                           -- When Agsy produces an ill-typed solution, return nothing.-                           -- TODO: try other solution.-                           -- `catchError` const retry -- (return (Nothing, Nothing))-                      let msg = if length exprs == 1 then-                                 Nothing-                                else-                                 Just $ "Also gave solution(s) for hole(s)" ++-                                         concatMap (\(mi', _) ->-                                          if mi' == mi then "" else (" " ++ case lookup mi' riis of {Nothing -> show mi'; Just ii -> show ii})-                                         ) exprs-                      let msgs = catMaybes $ msg : map snd giveress-                          msg' = unlines msgs <$ guard (not $ null msgs)-                      return $ AutoResult (Solutions $ mapMaybe fst giveress) msg'--     MCaseSplit -> do-      case thisdefinfo of-       Just (def, clause, True) ->-        case Map.elems tccons of-         [(m, mytype, mylocalVars, _)] | null eqcons -> do-          (ids, pats) <- constructPats cmap mi clause-          let ctx = zipWith (\(hid, id) t -> HI hid (id, t)) ids mylocalVars-          ticks <- liftIO $ newIORef 0-          let [rectyp'] = mymrectyp-          defdfv <- getdfv mi def-          myrecdef <- liftIO $ newIORef $ ConstDef {cdname = "", cdorigin = (Nothing, def), cdtype = rectyp', cdcont = Postulate, cddeffreevars = defdfv}-          sols <- liftIO $ System.Timeout.timeout (getTimeOut timeout * 1000) (-             let r d = do-                  sols <- liftIO $ caseSplitSearch ticks __IMPOSSIBLE__ myhints meqr __IMPOSSIBLE__ d myrecdef ctx mytype pats-                  case sols of-                   [] -> r (d + costIncrease)-                   (_:_) -> return sols-             in r 0)-          case sols of-           Just (cls : _) -> withInteractionId ii $ do-            cls' <- liftIO $ runExceptT (mapM frommyClause cls)-            case cls' of-             Left{} -> stopWithMsg "No solution found"-             Right cls' -> do-              cls'' <- forM cls' $ \ (I.Clause _ _ tel ps body t catchall exact recursive reachable ell) -> do-                withCurrentModule (AN.qnameModule def) $ do-                 -- Normalise the dot patterns-                 ps <- addContext tel $ normalise ps-                 body <- etaContract body-                 fmap modifyAbstractClause $ inTopContext $ reify $ AN.QNamed def $ I.Clause noRange noRange tel ps body t catchall exact recursive reachable ell-              moduleTel <- lookupSection (AN.qnameModule def)-              pcs <- withInteractionId ii $ inTopContext $ addContext moduleTel $ mapM prettyA cls''-              ticks <- liftIO $ readIORef ticks---              return $ AutoResult (FunClauses $ map (insertAbsurdPattern . PP.renderStyle (PP.style { PP.mode = PP.OneLineMode })) pcs) Nothing--           Just [] -> stopWithMsg "No solution found" -- case not possible at the moment because case split doesnt care about search exhaustiveness-           Nothing -> stopWithMsg $ "No solution found at time out (" ++ show timeout ++ "s)"-         _ -> stopWithMsg "Metavariable dependencies not allowed in case split mode"-       _ -> stopWithMsg "Metavariable is not at top level of clause RHS"--     MRefine listmode -> do-      mv <- lookupMeta mi-      let tt = jMetaType $ mvJudgement mv-          minfo = getMetaInfo mv-      targettyp <- withMetaInfo minfo $ do-       vs <- getContextArgs-       targettype <- tt `piApplyM` permute (takeP (length vs) $ mvPermutation mv) vs-       normalise targettype-      let tctx = length $ envContext $ clEnv minfo--      hits <- if "-a" `elem` hints then do-        st <- liftTCM $ join $ pureTCM $ \st _ -> return st-        let defs = st^.stSignature.sigDefinitions-            idefs = st^.stImports.sigDefinitions-            alldefs = HMap.keys defs ++ HMap.keys idefs-        catMaybes <$> mapM (\n ->-          case thisdefinfo of-           Just (def, _, _) | def == n -> return Nothing-           _ -> do-            cn <- withMetaInfo minfo $ runAbsToCon $ toConcrete n-            if C.isInScope cn == C.NotInScope then-              return Nothing-            else do-              c <- getConstInfo n-              ctyp <- normalise $ defType c-              cdfv <- withMetaInfo minfo $ getDefFreeVars n-              return $ case matchType cdfv tctx ctyp targettyp of-               Nothing -> Nothing-               Just score -> Just (prettyShow cn, score)-         ) alldefs-       else do-        let scopeinfo = clScope (getMetaInfo mv)-            namespace = Scope.everythingInScope scopeinfo-            names = Scope.nsNames namespace-            qnames = map (\(x, y) -> (x, Scope.anameName $ head y)) $ Map.toList names-            modnames = case thisdefinfo of-                        Just (def, _, _) -> filter (\(_, n) -> n /= def) qnames-                        Nothing -> qnames-        catMaybes <$> mapM (\(cn, n) -> do-          c <- getConstInfo n-          ctyp <- normalise $ defType c-          cdfv <- withMetaInfo minfo $ getDefFreeVars n-          return $ case matchType cdfv tctx ctyp targettyp of-           Nothing -> Nothing-           Just score -> Just (prettyShow cn, score)-         ) modnames--      let sorthits = List.sortBy (\(_, (pa1, pb1)) (_, (pa2, pb2)) -> case compare pa2 pa1 of {EQ -> compare pb1 pb2; o -> o}) hits-      if listmode || pick == (-1) then-        let pick' = max 0 pick-        in if pick' >= length sorthits then-             stopWithMsg $ insuffcands $ length sorthits-            else-             let showhits = take 10 $ drop pick' sorthits-             in stopWithMsg $ "Listing candidate(s) " ++ show pick' ++ "-" ++ show (pick' + length showhits - 1) ++ " (found " ++ show (length sorthits) ++ " in total)\n" ++-                           unlines (zipWith (\i (cn, _) -> show i ++ "  " ++ cn) [pick'..pick' + length showhits - 1] showhits)-       else-        if pick >= length sorthits then-         stopWithMsg $ insuffcands $ length sorthits-        else-         return $ AutoResult (Refinement $ fst $ sorthits !! pick) Nothing-  where-    agsyinfo ticks = ""---- Get the functions and axioms defined in the same module as @def@.-autohints :: AutoHintMode -> I.MetaId -> Maybe AN.QName -> TCM [Hint]-autohints AHMModule mi (Just def) = do-  scope <- clScope . getMetaInfo <$> lookupMeta mi-  let names     = Scope.nsNames $ Scope.everythingInScope scope-      qnames    = map (Scope.anameName . head) $ Map.elems names-      modnames  = filter (\n -> AN.qnameModule n == AN.qnameModule def && n /= def) qnames-  map (Hint False) <$> do-    (`filterM` modnames) $ \ n -> do-      c <- getConstInfo n-      case theDef c of-        Axiom{}    -> return True-        AbstractDefn{} -> return True-        Function{} -> return True-        _          -> return False--autohints _ _ _ = return []------ | Names for the equality reasoning combinators---   Empty if any of these names is not defined.--getEqCombinators :: InteractionId -> Range -> TCM [Hint]-getEqCombinators ii rng = do-  let eqCombinators = ["_≡_", "begin_", "_≡⟨_⟩_", "_∎", "sym", "cong"]-  raw <- mapM (parseExprIn ii rng) eqCombinators `catchError` const (pure [])-  return $ fromMaybe [] $ mapM getHeadAsHint raw---- | Templates for error messages--genericNotEnough :: String -> Int -> String-genericNotEnough str n = unwords $ case n of-  0 -> ["No", str, "found"]-  1 -> ["Only 1", str, "found"]-  _ -> ["Only", show n, str ++ "s", "found"]--insuffsols :: Int -> String-insuffsols  = genericNotEnough "solution"--insuffcands :: Int -> String-insuffcands = genericNotEnough "candidate"
− src/full/Agda/Auto/CaseSplit.hs 
@@ -1,665 +0,0 @@--module Agda.Auto.CaseSplit where--import Control.Monad.State as St hiding (lift)-import Control.Monad.Reader as Rd hiding (lift)-import qualified Control.Monad.State as St-import Control.Monad.IO.Class ( MonadIO(..) )--import Data.Function-import Data.IORef-import Data.Tuple (swap)-import Data.List (elemIndex)--- Import of <> needed for 8.2.2, but redundant in 8.8.3-import Data.Monoid ((<>), Sum(..))-import qualified Data.Set    as Set-import qualified Data.IntMap as IntMap--import Agda.Syntax.Common (Hiding(..))-import Agda.Auto.NarrowingSearch-import Agda.Auto.Syntax--import Agda.Auto.SearchControl-import Agda.Auto.Typecheck--import Agda.Utils.Impossible-import Agda.Utils.Monad (or2M)-import Agda.Utils.List (last1)--abspatvarname :: String-abspatvarname = "\0absurdPattern"--costCaseSplitVeryHigh, costCaseSplitHigh, costCaseSplitLow, costAddVarDepth-  :: Cost-costCaseSplitVeryHigh = 10000-costCaseSplitHigh     = 5000-costCaseSplitLow      = 2000-costAddVarDepth       = 1000--data HI a = HI Hiding a--drophid :: [HI a] -> [a]-drophid = map (\(HI _ x) -> x)--type CSPat o = HI (CSPatI o)-type CSCtx o = [HI (MId, MExp o)]--data CSPatI o = CSPatConApp (ConstRef o) [CSPat o]-              | CSPatVar Nat-              | CSPatExp (MExp o)-              | CSWith (MExp o) -- always an App-              | CSAbsurd--              | CSOmittedArg-type Sol o = [(CSCtx o, [CSPat o], Maybe (MExp o))]--caseSplitSearch ::-  forall o . IORef Int -> Int -> [ConstRef o] ->-  Maybe (EqReasoningConsts o) -> Int -> Cost -> ConstRef o ->-  CSCtx o -> MExp o -> [CSPat o] -> IO [Sol o]-caseSplitSearch ticks nsolwanted chints meqr depthinterval depth recdef ctx tt pats = do- let branchsearch :: Cost -> CSCtx o -> MExp o ->-                     ([Nat], Nat, [Nat]) -> IO (Maybe (MExp o))-     branchsearch depth ctx tt termcheckenv = do--      nsol <- newIORef 1-      m <- initMeta-      sol <- newIORef Nothing-      let trm = Meta m-          hsol = do trm' <- expandMetas trm-                    writeIORef sol (Just trm')-          initcon = mpret-                  $ Sidecondition-                    (localTerminationSidecond termcheckenv recdef trm)-                  $ (case meqr of-                        Nothing  -> id-                        Just eqr -> mpret . Sidecondition (calcEqRState eqr trm)-                     ) $ tcSearch False (map (fmap closify) (drophid ctx))-                         (closify tt) trm-      recdefd <- readIORef recdef-      let env = RIEnv { rieHints = (recdef, HMRecCall) : map (, HMNormal) chints-                      , rieDefFreeVars = cddeffreevars recdefd-                      , rieEqReasoningConsts = meqr-                      }-      depreached <- topSearch ticks nsol hsol env initcon depth (depth + 1)-      readIORef sol-     ctx' = ff 1 ctx-     ff _ [] = []-     ff n (HI hid (id, t) : ctx) = HI hid (id, lift n t) : ff (n + 1) ctx- caseSplitSearch' branchsearch depthinterval depth recdef ctx' tt pats--caseSplitSearch' :: forall o .-  (Cost -> CSCtx o -> MExp o -> ([Nat], Nat, [Nat]) -> IO (Maybe (MExp o))) ->-  Int -> Cost -> ConstRef o -> CSCtx o -> MExp o -> [CSPat o] -> IO [Sol o]-caseSplitSearch' branchsearch depthinterval depth recdef ctx tt pats = do-  recdefd <- readIORef recdef-  rc depth (cddeffreevars recdefd) ctx tt pats- where-  rc :: Cost -> Int -> CSCtx o -> MExp o -> [CSPat o] -> IO [Sol o]-  rc depth _ _ _ _ | depth < 0 = return []-  rc depth nscrutavoid ctx tt pats = do--    mblkvar <- getblks tt-    fork-     mblkvar-   where-   fork :: [Nat] -> IO [Sol o]-   fork mblkvar = do-    sols1 <- dobody-    case sols1 of-     (_:_) -> return sols1-     [] -> do-      let r :: [Nat] -> IO [Sol o]-          r [] = return []-          r (v:vs) = do-           sols2 <- splitvar mblkvar v-           case sols2 of-            (_:_) -> return sols2-            [] -> r vs-      r [nv - x | x <- [0..nv]] -- [0..length ctx - 1 - nscrutavoid]-    where nv = length ctx - 1-   dobody :: IO [Sol o]-   dobody = do-    case findperm (map snd (drophid ctx)) of-     Just perm -> do-      let (ctx', tt', pats') = applyperm perm ctx tt pats-      res <- branchsearch depth ctx' tt' (localTerminationEnv pats')-      return $ case res of-       Just trm -> [[(ctx', pats', Just trm)]]-       Nothing -> []-     Nothing -> __IMPOSSIBLE__ -- no permutation found-   splitvar :: [Nat] -> Nat -> IO [Sol o]-   splitvar mblkvar scrut = do-    let scruttype = infertypevar ctx scrut-    case rm __IMPOSSIBLE__ scruttype of-     App _ _ (Const c) _ -> do-      cd <- readIORef c-      case cdcont cd of-       Datatype cons _ -> do-         sols <- dobranches cons-         return $ map (\sol -> case sol of-          [] ->-           case findperm (map snd (drophid ctx)) of-            Just perm ->-             let HI scrhid(_, scrt) = ctx !! scrut-                 ctx1 = take scrut ctx ++ (HI scrhid (Id abspatvarname, scrt)) : drop (scrut + 1) ctx-                 (ctx', _, pats') = applyperm perm ctx1 tt ({-map (replacep scrut 1 CSAbsurd __IMPOSSIBLE__) -}pats)-             in [(ctx', pats', Nothing)]-            Nothing -> __IMPOSSIBLE__ -- no permutation found-          _ -> sol-          ) sols-        where-         dobranches :: [ConstRef o] -> IO [Sol o]-         dobranches [] = return [[]]-         dobranches (con : cons) = do-          cond <- readIORef con-          let ff t = case rm __IMPOSSIBLE__ t of-                        Pi _ h _ it (Abs id ot) ->-                         let (xs, inft) = ff ot-                         in (((h, scrut + length xs), id, lift (scrut + length xs + 1) it) : xs, inft)-                        _ -> ([], lift scrut t)-              (newvars, inftype) = ff (cdtype cond)-              constrapp = NotM $ App Nothing (NotM OKVal) (Const con) (foldl (\xs ((h, v), _, _) -> NotM $ ALCons h (NotM $ App Nothing (NotM OKVal) (Var v) (NotM ALNil)) xs) (NotM ALNil) (reverse newvars))-              pconstrapp = CSPatConApp con (map (\((hid, v), _, _) -> HI hid (CSPatVar v)) newvars)-              thesub = replace scrut (length newvars) constrapp-              Id newvarprefix = fst $ (drophid ctx) !! scrut-              ctx1 = map (\(HI hid (id, t)) -> HI hid (id, thesub t)) (take scrut ctx) ++-                     reverse (zipWith (\((hid, _), id, t) i ->-                       HI hid (Id (case id of {NoId -> newvarprefix{- ++ show i-}; Id id -> id}), t)-                      ) newvars [0..]) ++-                     map (\(HI hid (id, t)) -> HI hid (id, thesub t)) (drop (scrut + 1) ctx)-              tt' = thesub tt-              pats' = map (replacep scrut (length newvars) pconstrapp constrapp) pats-              scruttype' = thesub scruttype  -- scruttype shouldn't really refer to scrutvar so lift is enough, but what if circular ref has been created and this is not detected until case split is done-          case unifyexp inftype scruttype' of-           Nothing -> do-            res <- notequal scrut (length newvars) scruttype' inftype-            if res then -- branch absurd-              dobranches cons-             else -- branch dont know-              return []-           Just unif ->-            do-             let (ctx2, tt2, pats2) = removevar ctx1 tt' pats' unif-                 --cost = if elem scrut mblkvar then costCaseSplit - (costCaseSplit - costCaseSplitFollow) `div` (length mblkvar) else costCaseSplit-                 cost-                   | null mblkvar && scrut < length ctx - nscrutavoid && nothid-                                                                = costCaseSplitLow +-                                                                  costAddVarDepth *-                                                                  Cost (depthofvar scrut pats)-                   | null mblkvar                               = costCaseSplitVeryHigh-                   | scrut `elem` mblkvar                       = costCaseSplitLow-                   | scrut < length ctx - nscrutavoid && nothid = costCaseSplitHigh-                   | otherwise                                  = costCaseSplitVeryHigh--                 nothid = let HI hid _ = ctx !! scrut-                          in hid == NotHidden---             sols <- rc (depth - cost) (length ctx - 1 - scrut) ctx2 tt2 pats2-             case sols of-              [] -> return []-              _ -> do-               sols2 <- dobranches cons-               return $ concatMap (\sol -> map (\sol2 -> sol ++ sol2) sols2) sols-       _ -> return [] -- split failed "scrut type is not datatype"-     _ -> return [] -- split failed "scrut type is not datatype"--infertypevar :: CSCtx o -> Nat -> MExp o-infertypevar ctx v = snd $ (drophid ctx) !! v--class Replace t u where-  type ReplaceWith t u-  replace' :: Nat -> MExp (ReplaceWith t u) -> t -> Reader (Nat, Nat) u--replace :: Replace t u => Nat -> Nat -> MExp (ReplaceWith t u) -> t -> u-replace sv nnew e t = replace' 0 e t `runReader` (sv, nnew)--instance Replace t u => Replace (Abs t) (Abs u) where-  type ReplaceWith (Abs t) (Abs u) = ReplaceWith t u-  replace' n re (Abs mid b) = Abs mid <$> replace' (n + 1) re b--instance Replace (Exp o) (MExp o) where-  type ReplaceWith (Exp o) (MExp o) = o-  replace' n re = \case-    App uid ok elr@(Var v) args -> do-      ih         <- NotM <$> replace' n re args-      (sv, nnew) <- ask-      return $-        if v >= n-        then if v - n == sv-             then betareduce (lift n re) ih-             else if v - n > sv-                  then NotM $ App uid ok (Var (v + nnew - 1)) ih-                  else NotM $ App uid ok elr ih-        else NotM $ App uid ok elr ih-    App uid ok elr@Const{} args ->-      NotM . App uid ok elr . NotM <$> replace' n re args-    Lam hid b -> NotM . Lam hid <$> replace' (n + 1) re b-    Pi uid hid possdep it b ->-      fmap NotM $ Pi uid hid possdep <$> replace' n re it <*> replace' n re b-    e@Sort{} -> return $ NotM e-    e@AbsurdLambda{} -> return $ NotM e--instance Replace t u => Replace (MM t (RefInfo o)) u where-  type ReplaceWith (MM t (RefInfo o)) u = ReplaceWith t u-  replace' n re = replace' n re . rm __IMPOSSIBLE__--instance Replace (ArgList o) (ArgList o) where-  type ReplaceWith (ArgList o) (ArgList o) = o-  replace' n re args = case args of-    ALNil           -> return ALNil-    ALCons hid a as ->-      ALCons hid <$> replace' n re a <*> (NotM <$> replace' n re as)-    ALProj{}        -> __IMPOSSIBLE__-    ALConPar as     -> ALConPar . NotM <$> replace' n re as---betareduce :: MExp o -> MArgList o -> MExp o-betareduce e args = case rm __IMPOSSIBLE__ args of- ALNil -> e- ALCons _ a rargs -> case rm __IMPOSSIBLE__ e of-  App uid ok elr eargs -> NotM $ App uid ok elr (concatargs eargs args)-  Lam _ (Abs _ b) -> betareduce (replace 0 0 a b) rargs-  _ -> __IMPOSSIBLE__ -- not type correct if this happens- ALProj{} -> __IMPOSSIBLE__- ALConPar as -> __IMPOSSIBLE__--concatargs :: MArgList o -> MArgList o -> MArgList o-concatargs xs ys = case rm __IMPOSSIBLE__ xs of-  ALNil -> ys--  ALCons hid x xs -> NotM $ ALCons hid x (concatargs xs ys)--  ALProj{} -> __IMPOSSIBLE__--  ALConPar as -> NotM $ ALConPar (concatargs xs ys)--replacep :: forall o. Nat -> Nat -> CSPatI o -> MExp o -> CSPat o -> CSPat o-replacep sv nnew rp re = r- where-  r :: CSPat o -> CSPat o-  r (HI hid (CSPatConApp c ps)) = HI hid (CSPatConApp c (map r ps))-  r (HI hid (CSPatVar v)) | v == sv   = HI hid rp-                          | v > sv    = HI hid (CSPatVar (v + nnew - 1))-                          | otherwise = HI hid (CSPatVar v)-  r (HI hid (CSPatExp e)) = HI hid (CSPatExp $ replace sv nnew re e)--  r p@(HI _ CSOmittedArg) = p--  r _ = __IMPOSSIBLE__ -- other constructors dont appear in indata Pats------ Unification takes two values of the same type and generates a list--- of assignments making the two terms equal.--type Assignments o = [(Nat, Exp o)]--class Unify t where-  type UnifiesTo t-  unify'    :: t -> t -> StateT (Assignments (UnifiesTo t)) Maybe ()-  notequal' :: t -> t -> ReaderT (Nat, Nat) (StateT (Assignments (UnifiesTo t)) IO) Bool--unify :: Unify t => t -> t -> Maybe (Assignments (UnifiesTo t))-unify t u = unify' t u `execStateT` []--notequal :: Unify t => Nat -> Nat -> t -> t -> IO Bool-notequal fstnew nbnew t1 t2 = notequal' t1 t2 `runReaderT` (fstnew, nbnew)-                                              `evalStateT` []--instance (Unify t, o ~ UnifiesTo t) => Unify (MM t (RefInfo o)) where-  type UnifiesTo (MM t (RefInfo o)) = o--  unify' = unify' `on` rm __IMPOSSIBLE__--  notequal' = notequal' `on` rm __IMPOSSIBLE__--unifyVar :: Nat -> Exp o -> StateT (Assignments o) Maybe ()-unifyVar v e = do-  unif <- get-  case lookup v unif of-    Nothing -> modify ((v, e) :)-    Just e' -> unify' e e'--instance Unify t => Unify (Abs t) where-  type UnifiesTo (Abs t) = UnifiesTo t-  unify' (Abs _ b1) (Abs _ b2) = unify' b1 b2--  notequal' (Abs _ b1) (Abs _ b2) = notequal' b1 b2--instance Unify (Exp o) where-  type UnifiesTo (Exp o) = o--  unify' e1 e2 = case (e1, e2) of-   (App _ _ elr1 args1, App _ _ elr2 args2) | elr1 == elr2 -> unify' args1 args2-   (Lam hid1 b1, Lam hid2 b2)               | hid1 == hid2 -> unify' b1 b2-   (Pi _ hid1 _ a1 b1, Pi _ hid2 _ a2 b2)   | hid1 == hid2 -> unify' a1 a2-                                                           >> unify' b1 b2-   (Sort _, Sort _) -> return () -- a bit sloppy-   (App _ _ (Var v) (NotM ALNil), _)-     | v `Set.member` (freeVars e2) -> St.lift Nothing -- Occurs check-   (_, App _ _ (Var v) (NotM ALNil))-     | v `Set.member` (freeVars e1) -> St.lift Nothing -- Occurs check-   (App _ _ (Var v) (NotM ALNil), _) -> unifyVar v e2-   (_, App _ _ (Var v) (NotM ALNil)) -> unifyVar v e1-   _ -> St.lift Nothing--  notequal' e1 e2 = do-    (fstnew, nbnew) <- ask-    unifier         <- get-    case (e1, e2) of-      (App _ _ elr1 es1, App _ _ elr2 es2) | elr1 == elr2 -> notequal' es1 es2-      (_, App _ _ (Var v2) (NotM ALNil)) -- why is this not symmetric?!-        | fstnew <= v2 && v2 < fstnew + nbnew ->-        case lookup v2 unifier of-          Nothing  -> modify ((v2, e1):) >> return False-          Just e2' -> notequal' e1 e2'-{--  GA: Skipped these: Not sure why we'd claim they're impossible-      (_, App _ _ (Var v2) (NotM ALProj{})) -> __IMPOSSIBLE__-      (_, App _ _ (Var v2) (NotM ALConPar{})) -> __IMPOSSIBLE__--}-      (App _ _ (Const c1) es1, App _ _ (Const c2) es2) -> do-        cd1 <- liftIO $ readIORef c1-        cd2 <- liftIO $ readIORef c2-        case (cdcont cd1, cdcont cd2) of-          (Constructor{}, Constructor{}) -> if c1 == c2 then notequal' es1 es2-                                            else return True-          _ -> return False-{- GA: Why don't we have a case for distinct heads after all these-       unification cases for vars with no spines & metas that can-       be looked up?-      (App _ _ elr1 _, App _ _ elr2 _) | elr1 <> elr2 -> return True--}-      _ -> return False--instance Unify (ArgList o) where-  type UnifiesTo (ArgList o) = o--  unify' args1 args2 = case (args1, args2) of-   (ALNil, ALNil) -> pure ()-   (ALCons hid1 a1 as1, ALCons hid2 a2 as2) | hid1 == hid2 -> unify' a1 a2-                                                           >> unify' as1 as2-   (ALConPar as1, ALCons _ _ as2) -> unify' as1 as2-   (ALCons _ _ as1, ALConPar as2) -> unify' as1 as2-   (ALConPar as1, ALConPar as2)   -> unify' as1 as2-   _ -> St.lift Nothing--  notequal' args1 args2 = case (args1, args2) of-    (ALCons _ e es, ALCons _ f fs) -> notequal' e f `or2M` notequal' es fs-    (ALConPar es1, ALConPar es2)   -> notequal' es1 es2-    _                              -> return False---- This definition is only here to respect the previous interface.-unifyexp :: MExp o -> MExp o -> Maybe ([(Nat, MExp o)])-unifyexp e1 e2 = fmap (NotM <$>) <$> unify e1 e2--class Lift t where-  lift' :: Nat -> Nat -> t -> t--lift :: Lift t => Nat -> t -> t-lift 0 = id-lift n = lift' n 0--instance Lift t => Lift (Abs t) where-  lift' n j (Abs mid b) = Abs mid (lift' n (j + 1) b)--instance Lift t => Lift (MM t r) where-  lift' n j = NotM . lift' n j . rm __IMPOSSIBLE__--instance Lift (Exp o) where-  lift' n j = \case-    App uid ok elr args -> case elr of-      Var v | v >= j -> App uid ok (Var (v + n)) (lift' n j args)-      _ -> App uid ok elr (lift' n j args)-    Lam hid b -> Lam hid (lift' n j b)-    Pi uid hid possdep it b -> Pi uid hid possdep (lift' n j it) (lift' n j b)-    e@Sort{} -> e-    e@AbsurdLambda{} -> e--instance Lift (ArgList o) where-  lift' n j args = case args of-    ALNil           -> ALNil-    ALCons hid a as -> ALCons hid (lift' n j a) (lift' n j as)-    ALProj{}        -> __IMPOSSIBLE__-    ALConPar as     -> ALConPar (lift' n j as)---removevar :: CSCtx o -> MExp o -> [CSPat o] -> [(Nat, MExp o)] -> (CSCtx o, MExp o, [CSPat o])-removevar ctx tt pats [] = (ctx, tt, pats)-removevar ctx tt pats ((v, e) : unif) =- let-  e2 = replace v 0 __IMPOSSIBLE__ {- occurs check failed -} e-  thesub = replace v 0 e2-  ctx1 = map (\(HI hid (id, t)) -> HI hid (id, thesub t)) (take v ctx) ++-         map (\(HI hid (id, t)) -> HI hid (id, thesub t)) (drop (v + 1) ctx)-  tt' = thesub tt-  pats' = map (replacep v 0 (CSPatExp e2) e2) pats-  unif' = map (\(uv, ue) -> (if uv > v then uv - 1 else uv, thesub ue)) unif- in-  removevar ctx1 tt' pats' unif'--findperm :: [MExp o] -> Maybe [Nat]-findperm ts =- let-  frees = map freevars ts-  m = IntMap.fromList $-      map (\i -> (i, length (filter (elem i) frees)))-          [0..length ts - 1]-  r _ perm 0 = Just $ reverse perm-  r m perm n =-   case lookup 0 (map swap (IntMap.toList m)) of-    Nothing -> Nothing-    Just i -> r (foldl (flip $ IntMap.adjust (subtract 1))-                       (IntMap.insert i (-1) m)-                       (frees !! i))-                 (i : perm) (n - 1)- in r m [] (length ts)---freevars :: FreeVars t => t -> [Nat]-freevars = Set.toList . freeVars--applyperm :: [Nat] -> CSCtx o -> MExp o -> [CSPat o] ->-             (CSCtx o, MExp o, [CSPat o])-applyperm perm ctx tt pats =- let ctx1 = map (\(HI hid (id, t)) -> HI hid (id, rename (ren perm) t)) ctx-     ctx2 = map (\i -> ctx1 !! i) perm-     ctx3 = seqctx ctx2-     tt' = rename (ren perm) tt-     pats' = map (rename (ren perm)) pats- in (ctx3, tt', pats')--ren :: [Nat] -> Nat -> Int-ren n i = let Just j = elemIndex i n in j--instance Renaming t => Renaming (HI t) where-  renameOffset j ren (HI hid t) = HI hid $ renameOffset j ren t--instance Renaming (CSPatI o) where-  renameOffset j ren = \case-    CSPatConApp c pats -> CSPatConApp c $ map (renameOffset j ren) pats-    CSPatVar i         -> CSPatVar $ j + ren i-    CSPatExp e         -> CSPatExp $ renameOffset j ren e-    e@CSOmittedArg     -> e-    _                  -> __IMPOSSIBLE__--seqctx :: CSCtx o -> CSCtx o-seqctx = r (-1)- where-  r _ [] = []-  r n (HI hid (id, t) : ctx) = HI hid (id, lift n t) : r (n - 1) ctx--- ----------------------depthofvar :: Nat -> [CSPat o] -> Nat-depthofvar v pats =- let [depth] = concatMap (f 0) (drophid pats)-     f d (CSPatConApp _ pats) = concatMap (f (d + 1)) (drophid pats)-     f d (CSPatVar v') = [d | v == v']-     f _ _ = []- in depth---- ----------------------- | Speculation: Type class computing the size (?) of a pattern---   and collecting the vars it introduces-class LocalTerminationEnv a where-  sizeAndBoundVars :: a -> (Sum Nat, [Nat])--instance LocalTerminationEnv a => LocalTerminationEnv (HI a) where-  sizeAndBoundVars (HI _ p) = sizeAndBoundVars p--instance LocalTerminationEnv (CSPatI o) where-  sizeAndBoundVars = \case-    CSPatConApp _ ps -> (1, []) <> sizeAndBoundVars ps-    CSPatVar n       -> (0, [n])-    CSPatExp e       -> sizeAndBoundVars e-    _                -> (0, [])--instance LocalTerminationEnv a => LocalTerminationEnv [a] where-  sizeAndBoundVars = foldMap sizeAndBoundVars--instance LocalTerminationEnv (MExp o) where---  sizeAndBoundVars e = case rm __IMPOSSIBLE__ e of--- GA: 2017 06 27: Not actually impossible! (cf. #2620)-  sizeAndBoundVars Meta{} = (0, [])--- Does this default behaviour even make sense? The catchall in the--- following match seems to suggest it does-  sizeAndBoundVars (NotM e) = case e of-    App _ _ (Var v) _      -> (0, [v])-    App _ _ (Const _) args -> (1, []) <> sizeAndBoundVars args-    _                      -> (0, [])--instance (LocalTerminationEnv a, LocalTerminationEnv b) => LocalTerminationEnv (a, b) where-  sizeAndBoundVars (a, b) = sizeAndBoundVars a <> sizeAndBoundVars b--instance LocalTerminationEnv (MArgList o) where-  sizeAndBoundVars as = case rm __IMPOSSIBLE__ as of-    ALNil         -> (0, [])-    ALCons _ a as -> sizeAndBoundVars (a, as)-    ALProj{}      -> __IMPOSSIBLE__-    ALConPar as   -> sizeAndBoundVars as----- | Take a list of patterns and returns (is, size, vars) where (speculation):----  * the is are the pattern indices the vars are contained in---   * size is total number of constructors removed (?) to access vars-localTerminationEnv :: [CSPat o] -> ([Nat], Nat, [Nat])-localTerminationEnv pats = (is, getSum s, vs) where--  (is , s , vs) = g 0 pats--  g :: Nat -> [CSPat o] -> ([Nat], Sum Nat, [Nat])-  g _ [] = ([], 0, [])-  g i (hp@(HI _ p) : ps) = case p of-    CSPatConApp{} -> let (size, vars) = sizeAndBoundVars hp-                     in ([i], size, vars) <> g (i + 1) ps-    _ -> g (i + 1) ps--localTerminationSidecond :: ([Nat], Nat, [Nat]) -> ConstRef o -> MExp o -> EE (MyPB o)-localTerminationSidecond (is, size, vars) reccallc b =-  ok b- where-     ok e = mmpcase (False, prioNo, Nothing) e $ \e -> case e of-      App _ _ elr args -> mpret $ Sidecondition-       (oks args)-       (case elr of-          Const c | c == reccallc -> if size == 0 then mpret (Error "localTerminationSidecond: no size to decrement") else okcall 0 size vars args-          _ -> mpret OK-       )-      Lam _ (Abs _ e) -> ok e-      Pi _ _ _ it (Abs _ ot) -> mpret $ Sidecondition-       (ok it)-       (ok ot)-      Sort{} -> mpret OK--      AbsurdLambda{} -> mpret OK---     oks as = mmpcase (False, prioNo, Nothing) as $ \as -> case as of-      ALNil -> mpret OK-      ALCons _ a as -> mpret $ Sidecondition-       (ok a)-       (oks as)--      ALProj eas _ _ as -> mpret $ Sidecondition (oks eas) (oks as)---      ALConPar as -> oks as--     okcall i size vars as = mmpcase (False, prioNo, Nothing) as $ \as -> case as of-      ALNil -> mpret OK-      ALCons _ a as | i `elem` is ->-       mbpcase prioNo Nothing (he size vars a) $ \x -> case x of-        Nothing -> mpret $ Error "localTerminationSidecond: reccall not ok"-        Just (size', vars') -> okcall (i + 1) size' vars' as-      ALCons _ a as -> okcall (i + 1) size vars as--      ALProj{} -> mpret OK---      ALConPar as -> __IMPOSSIBLE__--     he size vars e = mmcase e $ \e -> case e of-      App _ _ (Var v) _ ->-       case remove v vars of-        Nothing -> mbret Nothing-        Just vars' -> mbret $ Just (size, vars')-      App _ _ (Const c) args -> do-       cd <- readIORef c-       case cdcont cd of-        Constructor{} ->-         if size == 1 then-          mbret Nothing-         else-          hes (size - 1) vars args-        _ -> mbret Nothing-      _ -> mbret Nothing-     hes size vars as = mmcase as $ \as -> case as of-      ALNil -> mbret $ Just (size, vars)-      ALCons _ a as ->-       mbcase (he size vars a) $ \x -> case x of-        Nothing -> mbret Nothing-        Just (size', vars') -> hes size' vars' as--      ALProj{} -> __IMPOSSIBLE__---      ALConPar as -> __IMPOSSIBLE__--     remove _ [] = Nothing-     remove x (y : ys) | x == y = Just ys-     remove x (y : ys) = case remove x ys of {Nothing -> Nothing; Just ys' -> Just (y : ys')}---- ------------------------------getblks :: MExp o -> IO [Nat]-getblks tt = do- NotB (hntt, blks) <- hnn_blks (Clos [] tt)- case f blks of-  Just v -> return [v]-  Nothing -> case rawValue hntt of-   HNApp (Const c) args -> do-    cd <- readIORef c-    case cdcont cd of-     Datatype{} -> g [] args-     _ -> return []-   _ -> return []- where-  f blks = case blks of-             (b : bs) -> case rawValue (last1 b bs) of-              HNApp (Var v) _ -> Just v-              _ -> Nothing-             _ -> Nothing-  g vs args = do-   NotB hnargs <- hnarglist args-   case hnargs of-    HNALCons _ a as -> do-     NotB (_, blks) <- hnn_blks a-     let vs' = case f blks of-                Just v | v `notElem` vs -> v : vs-                _ -> vs-     g vs' as-    _ -> return vs--- ---------------------------
− src/full/Agda/Auto/Convert.hs 
@@ -1,770 +0,0 @@--module Agda.Auto.Convert where--import Control.Monad          ( when )-import Control.Monad.Except-import Control.Monad.IO.Class ( MonadIO(..) )-import Control.Monad.State--import Data.Bifunctor (first)-import Data.IORef-import Data.Maybe (catMaybes)-import Data.Map (Map)-import qualified Data.Map as Map--import Agda.Syntax.Common (Hiding(..), getHiding, Arg)-import Agda.Syntax.Concrete (exprFieldA)-import qualified Agda.Syntax.Internal as I-import Agda.Syntax.Internal (Dom'(..),domInfo,unDom)-import qualified Agda.Syntax.Internal.Pattern as IP-import qualified Agda.Syntax.Common as Cm-import qualified Agda.Syntax.Abstract.Name as AN-import qualified Agda.Syntax.Abstract as A-import qualified Agda.Syntax.Position as SP--import qualified Agda.TypeChecking.Monad.Base as MB--import Agda.TypeChecking.Monad.Signature (getConstInfo, getDefFreeVars, ignoreAbstractMode)-import Agda.TypeChecking.Level (reallyUnLevelView)-import Agda.TypeChecking.Monad.Base (mvJudgement, mvPermutation, getMetaInfo, envContext, clEnv)-import Agda.TypeChecking.Monad.MetaVars (lookupMeta, withMetaInfo, lookupInteractionPoint)-import Agda.TypeChecking.Monad.Context (getContextArgs)-import Agda.TypeChecking.Monad.Constraints (getAllConstraints)-import Agda.TypeChecking.Substitute (applySubst, renamingR)-import Agda.TypeChecking.Telescope (piApplyM)-import qualified Agda.TypeChecking.Substitute as I (absBody)-import Agda.TypeChecking.Reduce (normalise, instantiate)-import Agda.TypeChecking.EtaContract (etaContract)-import Agda.TypeChecking.Monad.Builtin (constructorForm)-import Agda.TypeChecking.Free as Free (freeIn)--import Agda.Interaction.MakeCase (getClauseZipperForIP)--import Agda.Auto.NarrowingSearch-import Agda.Auto.Syntax hiding (getConst)--import Agda.Auto.CaseSplit hiding (lift)--import Agda.Utils.Either-import Agda.Utils.Lens-import Agda.Utils.Monad       ( forMaybeMM )-import Agda.Utils.Permutation ( Permutation(Perm), permute, takeP, compactP )-import Agda.Utils.Pretty      ( prettyShow )--import Agda.Utils.Impossible---data Hint = Hint-  { hintIsConstructor :: Bool-  , hintQName         :: I.QName-  }--type O = (Maybe (Int, [Arg AN.QName]),AN.QName)-  -- Nothing - Def-  -- Just npar - Con with npar parameters which don't appear in Agda--data TMode = TMAll -- can be extended to distinguish between different modes (all, only def)- deriving Eq--type MapS a b = (Map a b, [a])--initMapS :: MapS a b-initMapS = (Map.empty, [])--popMapS :: (S -> (a, [b])) -> ((a, [b]) -> S -> S) -> TOM (Maybe b)-popMapS r w = do (m, xs) <- gets r-                 case xs of-                  [] -> return Nothing-                  (x:xs) -> do-                   modify (w (m, xs))-                   return $ Just x--data S = S {sConsts :: MapS AN.QName (TMode, ConstRef O),-            sMetas :: MapS I.MetaId (Metavar (Exp O) (RefInfo O), Maybe (MExp O, [MExp O]), [I.MetaId]),-            sEqs :: MapS Int (Maybe (Bool, MExp O, MExp O)),-            sCurMeta :: Maybe I.MetaId,-            sMainMeta :: I.MetaId-           }--type TOM = StateT S MB.TCM-type MOT = ExceptT String IO--tomy :: I.MetaId -> [Hint] -> [I.Type] ->-        MB.TCM ([ConstRef O]-               , [MExp O]-               , Map I.MetaId (Metavar (Exp O) (RefInfo O), MExp O, [MExp O], [I.MetaId])-               , [(Bool, MExp O, MExp O)]-               , Map AN.QName (TMode, ConstRef O))-tomy imi icns typs = do- eqs <- getEqs- let-  r :: [AN.QName] -> TOM [AN.QName]-  r projfcns = do-   nxt <- popMapS sConsts (\x y -> y {sConsts = x})-   case nxt of-    Just cn -> do-     cmap <- gets (fst . sConsts)-     let (mode, c) = cmap Map.! cn-     def <- lift $ getConstInfo cn-     let typ = MB.defType def-         defn = MB.theDef def-     typ <- lift $ normalise typ-     typ' <- convert typ-     let clausesToDef clauses = do-           clauses' <- convert clauses-           let narg = case clauses of-                        [] -> 0-                        I.Clause {I.namedClausePats = xs} : _ -> length xs-           return (Def narg clauses' Nothing Nothing, [])-     (cont, projfcns2) <- case defn of-      MB.Axiom {} -> return (Postulate, [])-      MB.DataOrRecSig{} -> return (Postulate, [])-      MB.GeneralizableVar{} -> __IMPOSSIBLE__-      MB.AbstractDefn{} -> return (Postulate, [])-      MB.Function {MB.funClauses = clauses} -> clausesToDef clauses-      -- MB.Primitive {MB.primClauses = []} -> throwError $ strMsg "Auto: Primitive functions are not supported" -- Andreas, 2013-06-17 breaks interaction/AutoMisc-      MB.Primitive {MB.primClauses = clauses} -> clausesToDef clauses-      MB.PrimitiveSort{} -> __IMPOSSIBLE__-      MB.Datatype {MB.dataCons = cons} -> do-       cons2 <- mapM (\con -> getConst True con TMAll) cons-       return (Datatype cons2 [], [])-      MB.Record {MB.recFields = fields, MB.recTel = tel} -> do -- the value of recPars seems unreliable or don't know what it signifies-       let pars n (I.El _ (I.Pi it typ)) = Cm.Arg (I.domInfo it) (I.var n) :-                                           pars (n - 1) (I.unAbs typ)-           pars _ (I.El _ _) = []-           contyp npar I.EmptyTel = I.El (I.mkType 0 {- arbitrary -}) $-                                      I.Def cn $ map I.Apply $ pars (npar - 1) typ-           contyp npar (I.ExtendTel it (I.Abs v tel)) = I.El (I.mkType 0 {- arbitrary -}) (I.Pi it (I.Abs v (contyp (npar + 1) tel)))-           contyp npar (I.ExtendTel it I.NoAbs{})     = __IMPOSSIBLE__-       contyp' <- convert $ contyp 0 tel-       cc <- lift $ liftIO $ readIORef c-       let Datatype [con] [] = cdcont cc-       lift $ liftIO $ modifyIORef con (\cdef -> cdef {cdtype = contyp'})--       projfcns <- mapM (\ dom -> getConst False (I.unDom dom) TMAll) fields-       -- Equivalently projfcns <- mapM (($ TMAll) . getConst False . I.unDom) fields--       return (Datatype [con] projfcns, []{-map snd fields-})-      MB.Constructor {MB.conData = dt} -> do-       _ <- getConst False dt TMAll -- make sure that datatype is included-       cc <- lift $ liftIO $ readIORef c-       let (Just (nomi,_), _) = cdorigin cc-       return (Constructor (nomi - cddeffreevars cc), [])-     lift $ liftIO $ modifyIORef c (\cdef -> cdef {cdtype = typ', cdcont = cont})-     r $ projfcns2 ++ projfcns-    Nothing -> do-     nxt <- popMapS sMetas (\x y -> y {sMetas = x})-     case nxt of-      Just mi -> do-       mapM_ (\((_, e, i), eqi) -> do-         when (fmExp mi e || fmExp mi i) $ do-          (eqsm, eqsl) <- gets sEqs-          when (Map.notMember eqi eqsm) $ do-           modify $ \s -> s {sEqs = (Map.insert eqi Nothing eqsm, eqi : eqsl)}-        ) (zip eqs [0..])-       mv <- lift $ lookupMeta mi-       msol <- case MB.mvInstantiation mv of-                     MB.InstV{} ->-                      lift $ withMetaInfo (getMetaInfo mv) $ do-                       args <- getContextArgs-                       --sol <- norm (I.MetaV mi args)-                       sol <- instantiate $ I.MetaV mi $ map I.Apply $ permute (takeP (length args) $ mvPermutation mv) args-                       return $ Just sol-                     _ -> return Nothing-       case msol of-        Nothing -> return ()-        Just sol -> do-         m <- getMeta mi-         sol' <- convert sol-         modify $ \s -> s {sEqs = first (Map.insert (Map.size (fst $ sEqs s)) (Just (False, Meta m, sol'))) (sEqs s)}-       let tt = MB.jMetaType $ mvJudgement mv-           minfo = getMetaInfo mv-           localVars = map (snd . I.unDom) . envContext . clEnv $ minfo-       (targettype, localVars) <- lift $ withMetaInfo minfo $ do-        vs <- getContextArgs-        targettype <- tt `piApplyM` permute (takeP (length vs) $ mvPermutation mv) vs-        targettype <- normalise targettype-        localVars <- mapM normalise localVars-        return (targettype, localVars)-       modify (\s -> s {sCurMeta = Just mi})-       typ' <- convert targettype-       ctx' <- mapM convert localVars-       modify (\s -> s {sCurMeta = Nothing})-       modify (\s -> s {sMetas = first (Map.adjust (\(m, _, deps) -> (m, Just (typ', ctx'), deps)) mi) (sMetas s)})-       r projfcns-      Nothing -> do-       nxt <- popMapS sEqs (\x y -> y {sEqs = x})-       case nxt of-        Just eqi -> do-         let (ineq, e, i) = eqs !! eqi-         e' <- convert e-         i' <- convert i-         modify (\s -> s {sEqs = first (Map.adjust (\_ -> Just (ineq, e', i')) eqi) (sEqs s)})-         r projfcns-        Nothing ->-         return projfcns- ((icns', typs'), s) <- runStateT-  (do _ <- getMeta imi-      icns' <- mapM (\ (Hint iscon name) -> getConst iscon name TMAll) icns-      typs' <- mapM convert typs-      projfcns <- r []-      projfcns' <- mapM (\name -> getConst False name TMAll) projfcns-      [] <- r []-      return (projfcns' ++ icns', typs')-  ) (S {sConsts = initMapS, sMetas = initMapS, sEqs = initMapS, sCurMeta = Nothing, sMainMeta = imi})- lift $ liftIO $ mapM_ categorizedecl icns'- return (icns', typs', Map.map flatten (fst (sMetas s)), map fromJust $ Map.elems (fst (sEqs s)), fst (sConsts s))- where- flatten (x, Just (y, z), w) = (x, y, z, w)- flatten (x, Nothing, w) = __IMPOSSIBLE__-- fromJust (Just x) = x- fromJust Nothing = __IMPOSSIBLE__--getConst :: Bool -> AN.QName -> TMode -> TOM (ConstRef O)-getConst iscon name mode = do- def <- lift $ getConstInfo name- case MB.theDef def of-  MB.Record {MB.recConHead = con} -> do-   let conname = I.conName con-       conflds = I.conFields con-   cmap <- gets (fst . sConsts)-   case Map.lookup name cmap of-    Just (mode', c) ->-     if iscon then do-      cd <- lift $ liftIO $ readIORef c-      let Datatype [con] _ = cdcont cd-      return con-     else-      return c-    Nothing -> do-     mainm <- gets sMainMeta-     dfv <- lift $ getdfv mainm name-     let nomi = I.arity (MB.defType def)-     ccon <- lift $ liftIO $ newIORef (ConstDef {cdname = prettyShow name ++ ".CONS", cdorigin = (Just (nomi,conflds), conname), cdtype = __IMPOSSIBLE__, cdcont = Constructor (nomi - dfv), cddeffreevars = dfv}) -- ?? correct value of deffreevars for records?-     c <- lift $ liftIO $ newIORef (ConstDef {cdname = prettyShow name, cdorigin = (Nothing, name), cdtype = __IMPOSSIBLE__, cdcont = Datatype [ccon] [], cddeffreevars = dfv}) -- ?? correct value of deffreevars for records?-     modify (\s -> s {sConsts = (Map.insert name (mode, c) cmap, name : snd (sConsts s))})-     return $ if iscon then ccon else c-  _ -> do-   cmap <- gets (fst . sConsts)-   case Map.lookup name cmap of-    Just (mode', c) ->-     return c-    Nothing -> do-     (miscon, sname) <- if iscon then do-       let MB.Constructor {MB.conPars = npar, MB.conData = dname, MB.conSrcCon = ch} = MB.theDef def-       return (Just (npar,I.conFields ch), prettyShow dname ++ "." ++ prettyShow (I.qnameName name))-      else-       return (Nothing, prettyShow name)-     mainm <- gets sMainMeta-     dfv <- lift $ getdfv mainm name-     c <- lift $ liftIO $ newIORef (ConstDef {cdname = sname, cdorigin = (miscon, name), cdtype = __IMPOSSIBLE__, cdcont = __IMPOSSIBLE__, cddeffreevars = dfv})-     modify (\s -> s {sConsts = (Map.insert name (mode, c) cmap, name : snd (sConsts s))})-     return c--getdfv :: I.MetaId -> A.QName -> MB.TCM Cm.Nat-getdfv mainm name = do- mv <- lookupMeta mainm- withMetaInfo (getMetaInfo mv) $ getDefFreeVars name--getMeta :: I.MetaId -> TOM (Metavar (Exp O) (RefInfo O))-getMeta name = do- mmap <- gets (fst . sMetas)- case Map.lookup name mmap of-  Just (m, _, _) ->-   return m-  Nothing -> do-   m <- lift $ liftIO initMeta-   modify $ \ s -> s { sMetas = (Map.insert name (m, Nothing, []) mmap, name : snd (sMetas s)) }-   return m--getEqs :: MB.TCM [(Bool, I.Term, I.Term)]-getEqs = forMaybeMM getAllConstraints $ \ eqc -> do-  neqc <- normalise eqc-  case MB.clValue $ MB.theConstraint neqc of-    MB.ValueCmp ineq _ i e -> do-      ei <- etaContract i-      ee <- etaContract e-      return $ Just (tomyIneq ineq, ee, ei)-    _ -> return Nothing--copatternsNotImplemented :: MB.TCM a-copatternsNotImplemented = MB.typeError $ MB.NotImplemented $-  "The Agda synthesizer (Agsy) does not support copatterns yet"--literalsNotImplemented :: MB.TCM a-literalsNotImplemented = MB.typeError $ MB.NotImplemented $-  "The Agda synthesizer (Agsy) does not support literals yet"--hitsNotImplemented :: MB.TCM a-hitsNotImplemented = MB.typeError $ MB.NotImplemented $-  "The Agda synthesizer (Agsy) does not support HITs yet"--class Conversion m a b where-  convert :: a -> m b--instance Conversion TOM [I.Clause] [([Pat O], MExp O)] where-  convert = fmap catMaybes . mapM convert--instance Conversion TOM I.Clause (Maybe ([Pat O], MExp O)) where-  convert cl = do-    let -- Jesper, 2016-07-28:-     -- I can't figure out if this should be the old or new-     -- clause body (i.e. relative to the positions of pattern variables or-     -- relative to the clauseTel). Both options pass the test suite, so I-     -- have the impression it doesn't actually matter.-     -- ALTERNATIVE CODE:-     -- perm = fromMaybe __IMPOSSIBLE__ $ IP.clausePerm cl-     -- body = applySubst (renamingR perm) $ I.clauseBody cl-        body = I.clauseBody cl-        pats = I.clausePats cl-    pats' <- mapM convert (IP.unnumberPatVars pats :: [Cm.Arg I.Pattern])-    body' <- traverse convert =<< lift (normalise body)-    return $ (pats',) <$> body'--instance Conversion TOM (Cm.Arg I.Pattern) (Pat O) where-  convert p = case Cm.unArg p of-    I.IApplyP _ _ _ n  -> return $ PatVar (prettyShow n)-    I.VarP _ n  -> return $ PatVar (prettyShow n)-    I.DotP _ _  -> return $ PatVar "_"-      -- because Agda includes these when referring to variables in the body-    I.ConP con _ pats -> do-      let n = I.conName con-      c     <- getConst True n TMAll-      pats' <- mapM (convert . fmap Cm.namedThing) pats-      def   <- lift $ getConstInfo n-      cc    <- lift $ liftIO $ readIORef c-      let Just (npar,_) = fst $ cdorigin cc-      return $ PatConApp c (replicate npar PatExp ++ pats')--    -- UNSUPPORTED CASES-    I.ProjP{}   -> lift copatternsNotImplemented-    I.LitP{}    -> lift literalsNotImplemented-    I.DefP{}    -> lift hitsNotImplemented--instance Conversion TOM I.Type (MExp O) where-  convert (I.El _ t) = convert t -- sort info is thrown away--instance Conversion TOM I.Term (MExp O) where-  convert v0 =-    case I.unSpine v0 of-      I.Var v es -> do-        let Just as = I.allApplyElims es-        as' <- convert as-        return $ NotM $ App Nothing (NotM OKVal) (Var v) as'-      I.Lam info b -> do-        b' <- convert (I.absBody b)-        return $ NotM $ Lam (getHiding info) (Abs (Id $ I.absName b) b')-      t@I.Lit{} -> do-        t <- lift $ constructorForm t-        case t of-          I.Lit{} -> lift literalsNotImplemented-          _       -> convert t-      I.Level l -> convert =<< lift (reallyUnLevelView l)-      I.Def name es -> do-        let Just as = I.allApplyElims es-        c   <- getConst False name TMAll-        as' <- convert as-        return $ NotM $ App Nothing (NotM OKVal) (Const c) as'-      I.Con con ci es -> do-        let Just as = I.allApplyElims es-        let name = I.conName con-        c   <- getConst True name TMAll-        as' <- convert as-        def <- lift $ getConstInfo name-        cc  <- lift $ liftIO $ readIORef c-        let Just (npar,_) = fst $ cdorigin cc-        return $ NotM $ App Nothing (NotM OKVal) (Const c) (foldl (\x _ -> NotM $ ALConPar x) as' [1..npar])-      I.Pi (I.Dom{domInfo = info, unDom = x}) b -> do-        let y    = I.absBody b-            name = I.absName b-        x' <- convert x-        y' <- convert y-        return $ NotM $ Pi Nothing (getHiding info) (Free.freeIn 0 y) x' (Abs (Id name) y')-      I.Sort (I.Type (I.ClosedLevel l)) -> return $ NotM $ Sort $ Set $ fromIntegral l-      I.Sort _ -> return $ NotM $ Sort UnknownSort-      I.Dummy{}-> return $ NotM $ Sort UnknownSort-      t@I.MetaV{} -> do-        t <- lift $ instantiate t-        case t of-          I.MetaV mid _ -> do-            mcurmeta <- gets sCurMeta-            case mcurmeta of-              Nothing -> return ()-              Just curmeta ->-                modify $ \ s -> s { sMetas = first (Map.adjust (\(m, x, deps) -> (m, x, mid : deps)) curmeta) (sMetas s) }-            m <- getMeta mid-            return $ Meta m-          _ -> convert t-      I.DontCare _ -> return $ NotM dontCare--instance Conversion TOM a b => Conversion TOM (Cm.Arg a) (Hiding, b) where-  convert (Cm.Arg info a) = (getHiding info,) <$> convert a--instance Conversion TOM I.Args (MM (ArgList O) (RefInfo O)) where-  convert as = NotM . foldr (\ (hid,t) -> ALCons hid t . NotM) ALNil-               <$> mapM convert as--tomyIneq :: MB.Comparison -> Bool-tomyIneq MB.CmpEq = False-tomyIneq MB.CmpLeq = True---- -----------------------------------------------fmType :: I.MetaId -> I.Type -> Bool-fmType m (I.El _ t) = fmExp m t--fmExp :: I.MetaId -> I.Term -> Bool-fmExp m (I.Var _ as) = fmExps m $ I.argsFromElims as-fmExp m (I.Lam _ b) = fmExp m (I.unAbs b)-fmExp m (I.Lit _) = False-fmExp m (I.Level (I.Max _ as)) = any (fmLevel m) as-fmExp m (I.Def _ as) = fmExps m $ I.argsFromElims as-fmExp m (I.Con _ ci as) = fmExps m $ I.argsFromElims as-fmExp m (I.Pi x y)  = fmType m (I.unDom x) || fmType m (I.unAbs y)-fmExp m (I.Sort _) = False-fmExp m (I.MetaV mid _) = mid == m-fmExp m (I.DontCare _) = False-fmExp _ I.Dummy{} = False--fmExps :: I.MetaId -> I.Args -> Bool-fmExps m as = any (fmExp m . Cm.unArg) as--fmLevel :: I.MetaId -> I.PlusLevel -> Bool-fmLevel m (I.Plus _ l) = fmExp m l---- -----------------------------------------------icnvh :: Hiding -> Cm.ArgInfo-icnvh h = Cm.setHiding h $-          Cm.setOrigin o $-          Cm.defaultArgInfo-    where-    -- Andreas, 2017-01-18, issue #819.-    -- Visible arguments are made UserWritten,-    -- otherwise they might not be printed in patterns.-    o = case h of-          NotHidden  -> Cm.UserWritten-          Instance{} -> Cm.Inserted-          Hidden     -> Cm.Inserted---- -----------------------------------------------instance Conversion MOT a b => Conversion MOT (MM a (RefInfo O)) b where-  convert meta = case meta of-    NotM a -> convert a-    Meta m -> do-      ma <- lift $ readIORef $ mbind m-      case ma of-        Nothing -> throwError "meta not bound"-        Just a  -> convert a--instance Conversion MOT a b => Conversion MOT (Abs a) (I.Abs b) where-  convert (Abs mid t) = I.Abs id <$> convert t where-    id = case mid of-           NoId  -> "x"-           Id id -> id--instance Conversion MOT (Exp O) I.Type where-  convert e = I.El (I.mkType 0) <$> convert e-              -- 0 is arbitrary, sort not read by Agda when reifying--instance Conversion MOT (Exp O) I.Term where-  convert = \case-    App _ _ (Var v) as -> frommyExps 0 as (I.Var v [])-    App _ _ (Const c) as -> do-      cdef <- lift $ readIORef c-      let (iscon, name) = cdorigin cdef-{--   case iscon of-      Just n -> do-        v <- getConTerm name -- We are not in TCM-        frommyExps n as v--}-          (ndrop, h) = case iscon of-                         Just (n,fs) -> (n, \ q -> I.Con (I.ConHead q I.IsData Cm.Inductive fs) Cm.ConOSystem)-                         Nothing -> (0, \ f vs -> I.Def f vs)-      frommyExps ndrop as (h name [])-    Lam hid t -> I.Lam (icnvh hid) <$> convert t-    Pi _ hid _ x y -> do-      x' <- convert x-      let dom = (I.defaultDom x') {domInfo = icnvh hid}-      I.Pi dom <$> convert y-   -- maybe have case for Pi where possdep is False which produces Fun (and has to unweaken y), return $ I.Fun (Cm.Arg (icnvh hid) x') y'-    Sort (Set l) -> return $ I.Sort (I.mkType (fromIntegral l))-    Sort Type -> __IMPOSSIBLE__-    Sort UnknownSort -> return $ I.Sort (I.mkType 0) -- hoping it's thrown away--    AbsurdLambda hid -> return $ I.Lam (icnvh hid)-                               $ I.Abs abslamvarname (I.Var 0 [])--frommyExps :: Nat -> MArgList O -> I.Term -> ExceptT String IO I.Term-frommyExps ndrop (Meta m) trm = do- bind <- lift $ readIORef $ mbind m- case bind of-  Nothing -> throwError "meta not bound"-  Just e -> frommyExps ndrop (NotM e) trm-frommyExps ndrop (NotM as) trm =- case as of-  ALNil -> return trm-  ALCons _ _ xs | ndrop > 0 -> frommyExps (ndrop - 1) xs trm-  ALCons hid x xs -> do-   x' <- convert x-   frommyExps ndrop xs (addend (Cm.Arg (icnvh hid) x') trm)--  -- Andreas, 2013-10-19 TODO: restore postfix projections-  ALProj eas idx hid xs -> do-   idx <- lift $ expandbind idx-   c <- case idx of-            NotM c -> return c-            Meta{} -> throwError "meta not bound"-   cdef <- lift $ readIORef c-   let name = snd $ cdorigin cdef-   trm2 <- frommyExps 0 eas (I.Def name [])-   frommyExps 0 xs (addend (Cm.Arg (icnvh hid) trm) trm2)--  ALConPar xs | ndrop > 0 -> frommyExps (ndrop - 1) xs trm-  ALConPar _ -> __IMPOSSIBLE__- where-  addend x (I.Var h xs) = I.Var h (xs ++ [I.Apply x])-  addend x (I.Con h ci xs) = I.Con h ci (xs ++ [I.Apply x])-  addend x (I.Def h xs) = I.Def h (xs ++ [I.Apply x])-  addend _ _ = __IMPOSSIBLE__---- ----------------------------------abslamvarname :: String-abslamvarname = "\0absurdlambda"--modifyAbstractExpr :: A.Expr -> A.Expr-modifyAbstractExpr = f- where-  f (A.App i e1 (Cm.Arg info (Cm.Named n e2))) =-        A.App i (f e1) (Cm.Arg info (Cm.Named n (f e2)))-  f (A.Lam i (A.DomainFree _ x) _)-     | A.Binder _ (A.BindName{unBind = n}) <- Cm.namedArg x-     , prettyShow (A.nameConcrete n) == abslamvarname =-        A.AbsurdLam i $ Cm.getHiding x-  f (A.Lam i b e) = A.Lam i b (f e)-  f (A.Rec i xs) = A.Rec i (map (mapLeft (over exprFieldA f)) xs)-  f (A.RecUpdate i e xs) = A.RecUpdate i (f e) (map (over exprFieldA f) xs)-  f (A.ScopedExpr i e) = A.ScopedExpr i (f e)-  f e = e--modifyAbstractClause :: A.Clause -> A.Clause-modifyAbstractClause (A.Clause lhs spats (A.RHS e mc) decls catchall) =-  A.Clause lhs spats (A.RHS (modifyAbstractExpr e) mc) decls catchall-modifyAbstractClause cl = cl---- ------------------------------------constructPats :: Map AN.QName (TMode, ConstRef O) -> I.MetaId -> I.Clause -> MB.TCM ([(Hiding, MId)], [CSPat O])-constructPats cmap mainm clause = do- let cnvps ns [] = return (ns, [])-     cnvps ns (p : ps) = do-      (ns', ps') <- cnvps ns ps-      (ns'', p') <- cnvp ns' p-      return (ns'', p' : ps')-     cnvp ns p =-      let hid = getHiding $ Cm.argInfo p-      in case Cm.namedArg p of-       I.VarP _ n -> return ((hid, Id n) : ns, HI hid (CSPatVar $ length ns))-       I.IApplyP _ _ _ n -> return ((hid, Id n) : ns, HI hid (CSPatVar $ length ns))-       I.ConP con _ ps -> do-        let c = I.conName con-        (c2, _) <- runStateT (getConst True c TMAll) (S {sConsts = (cmap, []), sMetas = initMapS, sEqs = initMapS, sCurMeta = Nothing, sMainMeta = mainm})-        (ns', ps') <- cnvps ns ps-        cc <- liftIO $ readIORef c2-        let Just (npar,_) = fst $ cdorigin cc-        return (ns', HI hid (CSPatConApp c2 (replicate npar (HI Hidden CSOmittedArg) ++ ps')))-       I.DotP _ t -> do-        (t2, _) <- runStateT (convert t) (S {sConsts = (cmap, []), sMetas = initMapS, sEqs = initMapS, sCurMeta = Nothing, sMainMeta = mainm})-        return (ns, HI hid (CSPatExp t2))-       I.ProjP{} -> copatternsNotImplemented-       I.LitP{} -> literalsNotImplemented-       I.DefP{} -> hitsNotImplemented-- (names, pats) <- cnvps [] (IP.unnumberPatVars $ I.namedClausePats clause)- return (reverse names, pats)---frommyClause :: (CSCtx O, [CSPat O], Maybe (MExp O)) -> ExceptT String IO I.Clause-frommyClause (ids, pats, mrhs) = do- let ctel [] = return I.EmptyTel-     ctel (HI hid (mid, t) : ctx) = do-      let Id id = mid-      tel <- ctel ctx-      t' <- convert t-      let dom = (I.defaultDom t') {domInfo = icnvh hid}-      return $ I.ExtendTel dom (I.Abs id tel)- tel <- ctel $ reverse ids- let getperms 0 [] perm nv = return (perm, nv)-     getperms n [] _ _ = __IMPOSSIBLE__-     getperms 0 (p : ps) perm nv = do-      (perm, nv) <- getperm p perm nv-      getperms 0 ps perm nv-     getperms n (HI _ CSPatExp{} : ps) perm nv = getperms (n - 1) ps perm nv-     getperms n (HI _ CSOmittedArg{} : ps) perm nv = getperms (n - 1) ps perm nv-     getperms n (_ : _) _ _ = __IMPOSSIBLE__-     getperm (HI _ p) perm nv =-      case p of-       --CSPatVar v -> return (length ids + nv - 1 - v : perm, nv)-       CSPatVar v -> return ((length ids - 1 - v, nv) : perm, nv + 1)-       CSPatConApp c ps -> do-        cdef <- lift $ readIORef c-        let (Just (ndrop,_), _) = cdorigin cdef-        getperms ndrop ps perm nv-       CSPatExp e -> return (perm, nv + 1)-       _ -> __IMPOSSIBLE__- (rperm, nv) <- getperms 0 pats [] 0- let --perm = reverse rperm-     perm = map (\i -> let Just x = lookup i rperm in x) [0..length ids - 1]-     --renperm = map (\i -> length ids + nv - 1 - i) rperm-     --renm = rename (\i -> renperm !! i)-     cnvps 0 [] = return []-     cnvps n [] = __IMPOSSIBLE__-     cnvps 0 (p : ps) = do-      p' <- cnvp p-      ps' <- cnvps 0 ps-      return (p' : ps')-     cnvps n (HI _ CSPatExp{} : ps) = cnvps (n - 1) ps-     cnvps n (HI _ CSOmittedArg{} : ps) = cnvps (n - 1) ps-     cnvps n (_ : _) = __IMPOSSIBLE__-     cnvp (HI hid p) = do-      p' <- case p of-       CSPatVar v -> return (I.varP $ let HI _ (Id n, _) = ids !! v in n)-       CSPatConApp c ps -> do-        cdef <- lift $ readIORef c-        let (Just (ndrop,_), name) = cdorigin cdef-        ps' <- cnvps ndrop ps-        let con = I.ConHead name I.IsData Cm.Inductive [] -- TODO: restore DataOrRecord and record fields!-        return (I.ConP con I.noConPatternInfo ps')-       CSPatExp e -> do-        e' <- convert e {- renm e -} -- renaming before adding to clause below-        return (I.dotP e')-       CSAbsurd -> __IMPOSSIBLE__ -- CSAbsurd not used-       _ -> __IMPOSSIBLE__-      return $ Cm.Arg (icnvh hid) $ Cm.unnamed p'   -- TODO: recover names- ps <- cnvps 0 pats- body <- case mrhs of-          Nothing -> return $ Nothing-          Just e -> Just <$> convert e- let cperm =  Perm nv perm- return $ I.Clause-   { I.clauseLHSRange  = SP.noRange-   , I.clauseFullRange = SP.noRange-   , I.clauseTel       = tel-   , I.namedClausePats = IP.numberPatVars __IMPOSSIBLE__ cperm $ applySubst (renamingR $ compactP cperm) ps-   , I.clauseBody  = body-   , I.clauseType  = Nothing -- TODO: compute clause type-   , I.clauseCatchall = False-   , I.clauseExact       = Nothing -- TODO-   , I.clauseRecursive   = Nothing -- TODO: Don't know here whether recursive or not !?-   , I.clauseUnreachable = Nothing -- TODO: Don't know here whether reachable or not !?-   , I.clauseEllipsis = Cm.NoEllipsis-   }--contains_constructor :: [CSPat O] -> Bool-contains_constructor = any f- where-  f (HI _ p) = case p of-         CSPatConApp{} -> True-         _ -> False---- -----------------------------------freeIn :: Nat -> MExp o -> Bool-freeIn = f- where-  mr x = let NotM x' = x in x'-  f v e = case mr e of-   App _ _ elr args -> case elr of-    Var v' | v' == v -> False-    _ -> fs v args-   Lam _ (Abs _ b) -> f (v + 1) b-   Pi _ _ _ it (Abs _ ot) -> f v it && f (v + 1) ot-   Sort{} -> True--   AbsurdLambda{} -> True---  fs v es = case mr es of-   ALNil -> True-   ALCons _ a as -> f v a && fs v as--   ALProj{} -> __IMPOSSIBLE__---   ALConPar as -> fs v as---negtype :: ConstRef o -> MExp o -> MExp o-negtype ee = f (0 :: Int)- where-  mr x = let NotM x' = x in x'-  f n e = case mr e of-   Pi uid hid possdep it (Abs id ot) -> NotM $ Pi uid hid possdep it (Abs id (f (n + 1) ot))-   _ -> NotM $ Pi Nothing NotHidden False (NotM $ Pi Nothing NotHidden False e (Abs NoId (NotM $ Pi Nothing NotHidden True (NotM $ Sort (Set 0)) (Abs NoId (NotM $ App Nothing (NotM OKVal) (Var 0) (NotM ALNil)))))) (Abs NoId (NotM $ App Nothing (NotM OKVal) (Const ee) (NotM ALNil)))---- -----------------------------------------findClauseDeep :: Cm.InteractionId -> MB.TCM (Maybe (AN.QName, I.Clause, Bool))-findClauseDeep ii = ignoreAbstractMode $ do  -- Andreas, 2016-09-04, issue #2162-  MB.InteractionPoint { MB.ipClause = ipCl} <- lookupInteractionPoint ii-  case ipCl of-    MB.IPNoClause -> return Nothing-    MB.IPClause f clauseNo _ _ _ _ _ -> do-      (_, (_, c, _)) <- getClauseZipperForIP f clauseNo-      return $ Just (f, c, maybe __IMPOSSIBLE__ toplevel $ I.clauseBody c)-  where-    toplevel e =-     case e of-      I.MetaV{} -> True-      _ -> False---- -----------------------------------------matchType :: Int -> Int -> I.Type -> I.Type -> Maybe (Nat, Nat) -- Nat is deffreevars of const, Nat is ctx length of target type, left arg is const type, right is target type-matchType cdfv tctx ctyp ttyp = trmodps cdfv ctyp- where-  trmodps 0 ctyp = tr 0 0 ctyp-  trmodps n ctyp = case I.unEl ctyp of-   I.Pi _ ot -> trmodps (n - 1) (I.absBody ot)-   _ -> __IMPOSSIBLE__-  tr narg na ctyp =-   case ft 0 0 Just ctyp ttyp of-    Just n -> Just (n, narg)-    Nothing -> case I.unEl ctyp of-     I.Pi _ (I.Abs _ ot) -> tr (narg + 1) (na + 1) ot-     I.Pi _ (I.NoAbs _ ot) -> tr (narg + 1) na ot-     _ -> Nothing-   where-    ft nl n c (I.El _ e1) (I.El _ e2) = f nl n c e1 e2-    f nl n c e1 e2 = case e1 of-     I.Var v1 as1 | v1 < nl -> case e2 of-      I.Var v2 as2 | v1 == v2 -> fes nl (n + 1) c as1 as2-      _ -> Nothing-     I.Var v1 _ | v1 < nl + na -> c n -- unify vars with no args?-     I.Var v1 as1 -> case e2 of-      I.Var v2 as2 | cdfv + na + nl - v1 == tctx + nl - v2 -> fes nl (n + 1) c as1 as2-      _ -> Nothing-     _ -> case (e1, e2) of-      (I.MetaV{}, _) -> c n-      (_, I.MetaV{}) -> c n-      (I.Lam hid1 b1, I.Lam hid2 b2) | hid1 == hid2 -> f (nl + 1) n c (I.absBody b1) (I.absBody b2)-      (I.Lit lit1, I.Lit lit2) | lit1 == lit2 -> c (n + 1)-      (I.Def n1 as1, I.Def n2 as2) | n1 == n2 -> fes nl (n + 1) c as1 as2-      (I.Con n1 _ as1, I.Con n2 _ as2) | n1 == n2 -> fs nl (n + 1) c as1 as2-      (I.Pi (I.Dom{domInfo = info1, unDom = it1})  ot1, I.Pi (I.Dom{domInfo = info2, unDom = it2})  ot2) | Cm.argInfoHiding info1 == Cm.argInfoHiding info2 -> ft nl n (\n -> ft (nl + 1) n c (I.absBody ot1) (I.absBody ot2)) it1 it2-      (I.Sort{}, I.Sort{}) -> c n -- sloppy-      _ -> Nothing-    fs nl n c es1 es2 = case (es1, es2) of-     ([], []) -> c n-     (I.Apply (Cm.Arg info1 e1) : es1, I.Apply (Cm.Arg info2 e2) : es2) | Cm.argInfoHiding info1 == Cm.argInfoHiding info2 -> f nl n (\n -> fs nl n c es1 es2) e1 e2-     _ -> Nothing-    fes nl n c es1 es2 = case (es1, es2) of-     ([], []) -> c n-     (I.Proj _ f : es1, I.Proj _ f' : es2) | f == f' -> fes nl n c es1 es2-     (I.Apply (Cm.Arg info1 e1) : es1, I.Apply (Cm.Arg info2 e2) : es2) | Cm.argInfoHiding info1 == Cm.argInfoHiding info2 -> f nl n (\n -> fes nl n c es1 es2) e1 e2-     _ -> Nothing
− src/full/Agda/Auto/NarrowingSearch.hs 
@@ -1,669 +0,0 @@--module Agda.Auto.NarrowingSearch where--import Control.Monad       ( foldM, when )-import Control.Monad.State ( MonadState(..), modify, StateT, evalStateT, runStateT )-import Control.Monad.Trans ( lift )--import Data.IORef hiding (writeIORef, modifyIORef)-import qualified Data.IORef as NoUndo (writeIORef, modifyIORef)--import Agda.Utils.Impossible-import Agda.Utils.Empty--newtype Prio = Prio { getPrio :: Int }- deriving (Eq, Ord, Num)--class Trav a where-  type Block a-  trav :: Monad m => (forall b. TravWith b (Block a) => MM b (Block b) -> m ()) -> a -> m ()---- | Trav instance 'a' with block type 'blk'-type TravWith a blk = (Trav a, Block a ~ blk)--instance TravWith a blk => Trav (MM a blk) where-  type Block (MM a blk) = blk-  trav f me = f me--data Term blk = forall a. TravWith a blk => Term a---- | Result of type-checking.-data Prop blk-  = OK-    -- ^ Success.-  | Error String-    -- ^ Definite failure.-  | forall a . AddExtraRef String (Metavar a blk) (Move' blk a)-    -- ^ Experimental.-  | And (Maybe [Term blk]) (MetaEnv (PB blk)) (MetaEnv (PB blk))-    -- ^ Parallel conjunction of constraints.-  | Sidecondition (MetaEnv (PB blk)) (MetaEnv (PB blk))-    -- ^ Experimental, related to 'mcompoint'.-    -- First arg is sidecondition.-  | Or Prio (MetaEnv (PB blk)) (MetaEnv (PB blk))-    -- ^ Forking proof on something that is not part of the term language.-    --   E.g. whether a term will reduce or not.-  | ConnectHandle (OKHandle blk) (MetaEnv (PB blk))-    -- ^ Obsolete.--data OKVal = OKVal-type OKHandle blk = MM OKVal blk-type OKMeta blk = Metavar OKVal blk---- | Agsy's meta variables.------   @a@ the type of the metavariable (what it can be instantiated with).---   @blk@ the search control information (e.g. the scope of the meta).--data Metavar a blk = Metavar-  { mbind :: IORef (Maybe a)-    -- ^ Maybe an instantiation (refinement).  It is usually shallow,-    --   i.e., just one construct(or) with arguments again being metas.-  , mprincipalpresent :: IORef Bool-    -- ^ Does this meta block a principal constraint-    --   (i.e., a type-checking constraint).-  , mobs :: IORef [(QPB a blk, Maybe (CTree blk))]-    -- ^ List of observers, i.e., constraints blocked by this meta.-  , mcompoint :: IORef [SubConstraints blk]-    -- ^ Used for experiments with independence of subproofs.-  , mextrarefs :: IORef [Move' blk a]-    -- ^ Experimental.-  }--hequalMetavar :: Metavar a1 blk1 -> Metavar a2 bkl2 -> Bool-hequalMetavar m1 m2 = mprincipalpresent m1 == mprincipalpresent m2--instance Eq (Metavar a blk) where- x == y = hequalMetavar x y--newMeta :: IORef [SubConstraints blk] -> IO (Metavar a blk)-newMeta mcompoint = do- bind <- newIORef Nothing- pp <- newIORef False- obs <- newIORef []- erefs <- newIORef []- return $ Metavar bind pp obs mcompoint erefs--initMeta :: IO (Metavar a blk)-initMeta = do- cp <- newIORef []- newMeta cp--data CTree blk = CTree- {ctpriometa :: IORef (PrioMeta blk),-  ctsub :: IORef (Maybe (SubConstraints blk)),-  ctparent :: IORef (Maybe (CTree blk)), -- Nothing - root-  cthandles :: IORef [OKMeta blk]- }--data SubConstraints blk = SubConstraints- {scflip :: IORef Bool,-  sccomcount :: IORef Int,-  scsub1 :: CTree blk,-  scsub2 :: CTree blk- }---newCTree :: Maybe (CTree blk) -> IO (CTree blk)-newCTree parent = do- priometa <- newIORef (NoPrio False)- sub <- newIORef Nothing- rparent <- newIORef parent- handles <- newIORef []- return $ CTree priometa sub rparent handles--newSubConstraints :: CTree blk -> IO (SubConstraints blk)-newSubConstraints node = do- flip <- newIORef True -- False -- initially (and always) True, trying out prefer rightmost subterm when none have priority- comcount <- newIORef 0- sub1 <- newCTree $ Just node- sub2 <- newCTree $ Just node- return $ SubConstraints flip comcount sub1 sub2---data PrioMeta blk = forall a . Refinable a blk => PrioMeta Prio (Metavar a blk)-                  | NoPrio Bool -- True if subconstraint is done (all OK)--instance Eq (PrioMeta blk) where- NoPrio d1 == NoPrio d2 = d1 == d2- PrioMeta p1 m1 == PrioMeta p2 m2 = p1 == p2 && hequalMetavar m1 m2- _ == _ = False---- -------------------------data Restore = forall a . Restore (IORef a) a--type Undo = StateT [Restore] IO--ureadIORef :: IORef a -> Undo a-ureadIORef ptr = lift $ readIORef ptr--uwriteIORef :: IORef a -> a -> Undo ()-uwriteIORef ptr newval = do- oldval <- ureadIORef ptr- modify (Restore ptr oldval :)- lift $ NoUndo.writeIORef ptr newval--umodifyIORef :: IORef a -> (a -> a) -> Undo ()-umodifyIORef ptr f = do- oldval <- ureadIORef ptr- modify (Restore ptr oldval :)- lift $ NoUndo.writeIORef ptr (f oldval)--ureadmodifyIORef :: IORef a -> (a -> a) -> Undo a-ureadmodifyIORef ptr f = do- oldval <- ureadIORef ptr- modify (Restore ptr oldval :)- lift $ NoUndo.writeIORef ptr (f oldval)- return oldval--runUndo :: Undo a -> IO a-runUndo x = do- (res, restores) <- runStateT x []- mapM_ (\(Restore ptr oldval) -> NoUndo.writeIORef ptr oldval) restores- return res---- -------------------------newtype RefCreateEnv blk a = RefCreateEnv-  { runRefCreateEnv :: StateT ((IORef [SubConstraints blk]), Int) IO a }--instance Functor (RefCreateEnv blk) where-  fmap f = RefCreateEnv . fmap f . runRefCreateEnv--instance Applicative (RefCreateEnv blk) where-  pure    = RefCreateEnv . pure-  f <*> t = RefCreateEnv $ runRefCreateEnv f <*> runRefCreateEnv t--instance Monad (RefCreateEnv blk) where-  return = pure-  t >>= f = RefCreateEnv $ runRefCreateEnv t >>= runRefCreateEnv . f---newtype Cost = Cost { getCost :: Int }-  deriving (Num, Eq, Ord)--data Move' blk a = Move-  { moveCost :: Cost-  , moveNext :: RefCreateEnv blk a-  }--class Refinable a blk where- refinements :: blk -> [blk] -> Metavar a blk -> IO [Move' blk a]---newPlaceholder :: RefCreateEnv blk (MM a blk)-newPlaceholder = RefCreateEnv $ do- (mcompoint, c) <- get- m <- lift $ newMeta mcompoint- put (mcompoint, (c + 1))- return $ Meta m--newOKHandle :: RefCreateEnv blk (OKHandle blk)-newOKHandle = RefCreateEnv $ do- (e, c) <- get- cp <- lift $ newIORef []- m  <- lift $ newMeta cp- put (e, (c + 1))- return $ Meta m--dryInstantiate :: RefCreateEnv blk a -> IO a-dryInstantiate bind = evalStateT (runRefCreateEnv bind) (__IMPOSSIBLE__, 0)--type BlkInfo blk = (Bool, Prio, Maybe blk) -- Bool - is principal--data MM a blk = NotM a-              | Meta (Metavar a blk)--rm :: Empty -> MM a b -> a-rm _ (NotM x) = x-rm e Meta{}   = absurd e--type MetaEnv = IO---data MB a blk = NotB a-              | forall b . Refinable b blk => Blocked (Metavar b blk) (MetaEnv (MB a blk))-              | Failed String--data PB blk = NotPB (Prop blk)-            | forall b . Refinable b blk => PBlocked (Metavar b blk) (BlkInfo blk) (MetaEnv (PB blk))-            | forall b1 b2 . (Refinable b1 blk, Refinable b2 blk) => PDoubleBlocked (Metavar b1 blk) (Metavar b2 blk) (MetaEnv (PB blk))--data QPB b blk = QPBlocked (BlkInfo blk) (MetaEnv (PB blk))-               | QPDoubleBlocked (IORef Bool) (MetaEnv (PB blk)) -- flag set True by first observer that continues--mmcase :: Refinable a blk => MM a blk -> (a -> MetaEnv (MB b blk)) -> MetaEnv (MB b blk)-mmcase x f = case x of- NotM x -> f x- x@(Meta m) -> do-  bind <- readIORef $ mbind m-  case bind of-   Just x -> f x-   Nothing -> return $ Blocked m (mmcase x f)--mmmcase :: MM a blk -> MetaEnv (MB b blk) -> (a -> MetaEnv (MB b blk)) -> MetaEnv (MB b blk)-mmmcase x fm f = case x of- NotM x -> f x- Meta m -> do-  bind <- readIORef $ mbind m-  maybe fm f bind--mmpcase :: Refinable a blk => BlkInfo blk -> MM a blk -> (a -> MetaEnv (PB blk)) -> MetaEnv (PB blk)-mmpcase blkinfo x f = case x of- NotM x -> f x- x@(Meta m) -> do-  bind <- readIORef $ mbind m-  case bind of-   Just x -> f x-   Nothing -> return $ PBlocked m blkinfo (mmpcase __IMPOSSIBLE__ x f) -- blkinfo not needed because will be notb next time--doubleblock :: (Refinable a blk, Refinable b blk) => MM a blk -> MM b blk -> MetaEnv (PB blk) -> MetaEnv (PB blk)-doubleblock (Meta m1) (Meta m2) cont = return $ PDoubleBlocked m1 m2 cont-doubleblock _ _ _ = __IMPOSSIBLE__--mbcase :: MetaEnv (MB a blk) -> (a -> MetaEnv (MB b blk)) -> MetaEnv (MB b blk)-mbcase x f = do- x' <- x- case x' of-  NotB x -> f x-  Blocked m x -> return $ Blocked m (mbcase x f)-  Failed msg -> return $ Failed msg--mbpcase :: Prio -> Maybe blk -> MetaEnv (MB a blk) -> (a -> MetaEnv (PB blk)) -> MetaEnv (PB blk)-mbpcase prio bi x f = do- x' <- x- case x' of-  NotB x -> f x-  Blocked m x -> return $ PBlocked m (False, prio, bi) (mbpcase prio bi x f)-  Failed msg -> return $ NotPB $ Error msg--mmbpcase :: MetaEnv (MB a blk) -> (forall b . Refinable b blk => MM b blk -> MetaEnv (PB blk)) -> (a -> MetaEnv (PB blk)) -> MetaEnv (PB blk)-mmbpcase x fm f = do- x' <- x- case x' of-  NotB x -> f x-  Blocked m _ -> fm (Meta m)-  Failed msg -> return $ NotPB $ Error msg--waitok :: OKHandle blk -> MetaEnv (MB b blk) -> MetaEnv (MB b blk)-waitok okh f =- mmcase okh $ \ OKVal -> f -- principle constraint is never present for okhandle so it will not be refined--mbret :: a -> MetaEnv (MB a blk)-mbret x = return $ NotB x--mbfailed :: String -> MetaEnv (MB a blk)-mbfailed msg = return $ Failed msg--mpret :: Prop blk -> MetaEnv (PB blk)-mpret p = return $ NotPB p--expandbind :: MM a blk -> MetaEnv (MM a blk)-expandbind x = case x of- NotM{} -> return x- Meta m -> do-  bind <- readIORef $ mbind m-  case bind of-   Just x -> return $ NotM x-   Nothing -> return x----- -------------------------type HandleSol = IO ()---type SRes = Either Bool Int--topSearch :: forall blk . IORef Int -> IORef Int -> HandleSol -> blk -> MetaEnv (PB blk) -> Cost -> Cost -> IO Bool-topSearch ticks nsol hsol envinfo p searchdepth depthinterval = do- depthreached <- newIORef False--- mainroot <- newCTree Nothing-- let-  searchSubProb :: [(CTree blk, Maybe (IORef Bool))] -> Cost -> IO SRes-  searchSubProb [] depth = do-   when (depth < depthinterval) $ do---    hsol-    n <- readIORef nsol-    NoUndo.writeIORef nsol $! n - 1---   return $ Left True-  searchSubProb ((root, firstdone) : restprobs) depth =-   let-    search :: Cost -> IO SRes-    search depth = do-     pm <- readIORef $ ctpriometa root-     case pm of-      NoPrio False -> return $ Left False -- nothing to refine but not done, this can happen when eq constraints are passed along with main constraint in agdaplugin-      NoPrio True ->-       searchSubProb restprobs depth -- ?? what should depth be-      PrioMeta _ m -> do-       let carryon = fork m depth-       sub <- readIORef $ ctsub root-       case sub of-        Nothing -> carryon-        Just sc -> do-         let sub1 = scsub1 sc-             sub2 = scsub2 sc-         pm1 <- readIORef $ ctpriometa sub1-         pm2 <- readIORef $ ctpriometa sub2-         let split = carryon -- split disabled-         case pm1 of-          NoPrio True -> split-          _ ->-           case pm2 of-            NoPrio True -> split-            _ -> do-             comc <- readIORef $ sccomcount sc-             case comc of-              0 -> split-              _ -> carryon--    fork :: forall a. Refinable a blk => Metavar a blk -> Cost -> IO SRes-    fork m depth = do-      blkinfos <- extractblkinfos m-      refs <- refinements envinfo blkinfos m-      f refs-     where-      f :: [Move' blk a] -> IO SRes-      f [] = do-       erefs <- readIORef $ mextrarefs m-       case erefs of-        [] -> return (Left False)-        _ -> do-         NoUndo.writeIORef (mextrarefs m) []-         f erefs-      f (Move cost bind : binds) = hsres (refine m bind (depth - cost)) (f binds)-    hsres :: IO SRes -> IO SRes -> IO SRes-    hsres x1 x2 = do-     res <- x1-     case res of-      Right _ -> return res-      Left found -> do-       n <- readIORef nsol-       if n == 0 then-         return res-        else do-         res2 <- x2-         case res2 of-          Right _ -> if found then __IMPOSSIBLE__ else return res2-          Left found2 -> return $ Left (found || found2)--    refine :: Metavar a blk -> RefCreateEnv blk a -> Cost -> IO SRes--    refine _ _ depthleft | depthleft < 0 = do-     NoUndo.writeIORef depthreached True-     return $ Left False---    refine m bind depthleft = runUndo $-     do t <- ureadIORef ticks-        lift $ NoUndo.writeIORef ticks $! t + 1---        (bind, (_, nnewmeta)) <- lift $ runStateT (runRefCreateEnv bind) (mcompoint m, 0)-        uwriteIORef (mbind m) (Just bind)-        mcomptr <- ureadIORef $ mcompoint m-        mapM_ (\comptr ->-          umodifyIORef (sccomcount comptr) (+ (nnewmeta - 1))-          -- umodifyIORef (scflip comptr) not -- don't flip now since trying prefer rightmost subterm if non have prio-         ) mcomptr-        obs <- ureadIORef (mobs m)-        res <- recalcs obs-        if res-          then-            return $ Left False     -- failed-          else-            lift $ search depthleft -- succeeded--    doit = do-     res <- search depth-     return $ case res of-      Right n ->-       case firstdone of-        Nothing ->-         if n == 0 then-          Left False-         else-          Right (n - 1)-        Just _ ->-         Right (n + 1)-      res@(Left True) -> res-      res@(Left False) ->-       case firstdone of-        Nothing -> res-        Just _ -> Right 0-   in-    case firstdone of-     Nothing -> doit-     Just rdone -> do-      done <- readIORef rdone-      if done then-        searchSubProb restprobs depth-       else do-        NoUndo.writeIORef rdone True-        doit-- runUndo $ do-  res <- reccalc p (Just mainroot)-  if res -- failed immediately-    then-        return False-    else-      do-        Left _solFound <- lift $ searchSubProb [(mainroot, Nothing)] searchdepth-        lift $ readIORef depthreached---extractblkinfos :: Metavar a blk -> IO [blk]-extractblkinfos m = do- obs <- readIORef $ mobs m- return $ f obs- where-  f [] = []-  f ((QPBlocked (_,_,mblkinfo) _, _) : cs) =-   case mblkinfo of-    Nothing -> f cs-    Just blkinfo -> blkinfo : f cs-  f ((QPDoubleBlocked{}, _) : cs) = f cs--recalcs :: [(QPB a blk, Maybe (CTree blk))] -> Undo Bool-recalcs cs = foldr (seqc . recalc) (return False) cs--seqc :: Undo Bool -> Undo Bool -> Undo Bool-seqc x y = do- res1 <- x- case res1 of-  res1@True -> return res1-  False -> y--recalc :: (QPB a blk, Maybe (CTree blk)) -> Undo Bool-recalc (con, node) = case con of-  QPBlocked       _    cont -> reccalc cont node-  QPDoubleBlocked flag cont -> do-    fl <- ureadIORef flag-    if fl-      then return False-      else do-        uwriteIORef flag True-        reccalc cont node--reccalc :: MetaEnv (PB blk) -> Maybe (CTree blk) -> Undo Bool-reccalc cont node = do-  res <- calc cont node-  case res of-    Nothing -> return True-    Just pendhandles ->-      foldM-        ( \res1 h ->-            if res1-              then return res1-              else do-                uwriteIORef (mbind h) $ Just OKVal-                obs <- ureadIORef (mobs h)-                recalcs obs-        )-        False-        pendhandles--calc :: forall blk . MetaEnv (PB blk) -> Maybe (CTree blk) -> Undo (Maybe [OKMeta blk])-calc cont node = do-  res <- donewp node cont-  case res of-   Just (_, pendhandles) -> do-    pendhandles2 <- case node of-     Just node -> propagatePrio node-     Nothing -> return []-    return $ Just (pendhandles ++ pendhandles2)-   Nothing -> return Nothing- where-  storeprio (Just node) pm pendhandles = do-   pendhandles' <- case pm of-    NoPrio True -> do-     handles <- ureadIORef (cthandles node)-     return $ handles ++ pendhandles-    _ -> return pendhandles-   uwriteIORef (ctpriometa node) pm-   return $ Just (pm, pendhandles')-  storeprio Nothing _ _ =-   return $ Just (NoPrio False, [])-  donewp node p = do-   bp <- lift p-   case bp of-    NotPB p ->-     doprop node p-    PBlocked m blkinfo cont -> do-     oldobs <- ureadmodifyIORef (mobs m) ((QPBlocked blkinfo cont, node) :)-     let (princ, prio, _) = blkinfo-     pp <- ureadIORef (mprincipalpresent m)-     when (princ && not pp) $ do-      uwriteIORef (mprincipalpresent m) True-      mapM_ (\(qpb, node) -> case node of-         Just node ->-          case qpb of-           QPBlocked (_, prio, _) _ -> do---            uwriteIORef (ctpriometa node) (PrioMeta prio m)-            propagatePrio node-           QPDoubleBlocked _flag _ ->-            return []-         Nothing -> return []-       ) oldobs-     if pp || princ then-       storeprio node (PrioMeta prio m) []-      else-       storeprio node (NoPrio False) []-    PDoubleBlocked m1 m2 cont -> do-     flag <- lift $ newIORef False--     let newobs :: forall b. [(QPB b blk, Maybe (CTree blk))]-                          -> [(QPB b blk, Maybe (CTree blk))]-         newobs = ((QPDoubleBlocked flag cont, node) :)-     umodifyIORef (mobs m1) newobs-     umodifyIORef (mobs m2) newobs-     storeprio node (NoPrio False) []-  doprop node p =-   case p of-    OK -> storeprio node (NoPrio True) []-    Error _ -> return Nothing---    AddExtraRef _ m eref -> do-     lift $ NoUndo.modifyIORef (mextrarefs m) (eref :)-     return Nothing-    And coms p1 p2 -> do-     let Just jnode = node-     sc <- lift $ newSubConstraints jnode---     uwriteIORef (ctsub jnode) $ Just sc-     ndep <- case coms of-      Nothing -> return 1 -- no metas pointing to it so will never decrement to 0-      Just _coms  -> return 1 -- dito-     lift $ NoUndo.writeIORef (sccomcount sc) ndep -- OK since sc was just created-     resp1 <- donewp (Just $ scsub1 sc) p1-     case resp1 of-      Just (pm1, phs1) -> do-       resp2 <- donewp (Just $ scsub2 sc) p2-       case resp2 of-        Just (pm2, phs2) ->-         storeprio node (choosePrioMeta False pm1 pm2) (phs1 ++ phs2)-        resp2@Nothing -> return resp2-      resp1@Nothing -> return resp1-    Sidecondition sidep mainp -> do-     resp1 <- donewp Nothing sidep-     case resp1 of-      Just{} -> do-       resp2 <- donewp node mainp-       case resp2 of-        Just (pm2, phs2) ->-         storeprio node pm2 phs2-        resp2@Nothing -> return resp2-      resp1@Nothing -> return resp1-    Or prio p1 p2 -> do-     cm <- lift $ initMeta-     donewp node (choose (Meta cm) prio p1 p2)-    ConnectHandle (Meta handle) p' -> do-     let Just jnode = node-     umodifyIORef (cthandles jnode) (handle :)-     donewp node p'-    ConnectHandle (NotM _) _ -> __IMPOSSIBLE__--choosePrioMeta :: Bool -> PrioMeta blk -> PrioMeta blk -> PrioMeta blk-choosePrioMeta flip pm1@(PrioMeta p1 _) pm2@(PrioMeta p2 _)-  | p1 > p2 = pm1-  | p2 > p1 = pm2-  | flip = pm2-  | otherwise = pm1-choosePrioMeta _ pm@(PrioMeta _ _) (NoPrio _) = pm-choosePrioMeta _ (NoPrio _) pm@(PrioMeta _ _) = pm-choosePrioMeta _ (NoPrio d1) (NoPrio d2) = NoPrio (d1 && d2)--propagatePrio :: CTree blk -> Undo [OKMeta blk]-propagatePrio node = do-  parent <- lift $ readIORef $ ctparent node-  case parent of-    Nothing     -> return []-    Just parent -> do-      Just sc <- ureadIORef (ctsub parent)-      pm1     <- ureadIORef $ ctpriometa $ scsub1 sc-      pm2     <- ureadIORef $ ctpriometa $ scsub2 sc-      flip    <- ureadIORef $ scflip sc-      let pm = choosePrioMeta flip pm1 pm2-      opm <- ureadIORef (ctpriometa parent)-      if (pm /= opm)-        then do-          uwriteIORef (ctpriometa parent) pm-          phs <- case pm of-            NoPrio True -> ureadIORef (cthandles parent)-            _           -> return []-          phs2 <- propagatePrio parent-          return $ phs ++ phs2-        else-          return []--data Choice = LeftDisjunct | RightDisjunct--choose :: MM Choice blk -> Prio -> MetaEnv (PB blk) -> MetaEnv (PB blk) -> MetaEnv (PB blk)-choose c prio p1 p2 =- mmpcase (True, prio, Nothing) c $ \c -> case c of-  LeftDisjunct -> p1-  RightDisjunct -> p2--instance Refinable Choice blk where- refinements _ _ _ = return $ Move 0 . return <$> [LeftDisjunct, RightDisjunct]---instance Refinable OKVal blk where- refinements _ _ _ = __IMPOSSIBLE__ -- OKVal should never be refined----- ------------------------------------
− src/full/Agda/Auto/Options.hs 
@@ -1,120 +0,0 @@-module Agda.Auto.Options where--import Data.Char-import Control.Monad.State-import Agda.Utils.Lens--data Mode = MNormal Bool Bool -- true if list mode, true if disprove--          | MCaseSplit--          | MRefine Bool -- true if list mode---data AutoHintMode = AHMNone-                  | AHMModule--type Hints = [String]--newtype TimeOut = TimeOut { getTimeOut :: Int } -- in ms--instance Show TimeOut where-  show = show . getTimeOut---- | Options for Auto, default value and lenses--data AutoOptions = AutoOptions-  { autoHints    :: Hints-  , autoTimeOut  :: TimeOut-  , autoPick     :: Int-  , autoMode     :: Mode-  , autoHintMode :: AutoHintMode-  }--initAutoOptions :: AutoOptions-initAutoOptions = AutoOptions-  { autoHints    = []-  , autoTimeOut  = TimeOut 1000-  , autoPick     = 0-  , autoMode     = MNormal False False-  , autoHintMode = AHMNone-  }--aoHints :: Lens' Hints AutoOptions-aoHints f s =-  f (autoHints s) <&>-  \x -> s {autoHints = x}--aoTimeOut :: Lens' TimeOut AutoOptions-aoTimeOut f s =-  f (autoTimeOut s) <&>-  \x -> s {autoTimeOut = x}--aoPick :: Lens' Int AutoOptions-aoPick f s =-  f (autoPick s) <&>-  \x -> s {autoPick = x}--aoMode :: Lens' Mode AutoOptions-aoMode f s =-  f (autoMode s) <&>-  \x -> s {autoMode = x}--aoHintMode :: Lens' AutoHintMode AutoOptions-aoHintMode f s =-  f (autoHintMode s) <&>-  \x -> s {autoHintMode = x}---- | Tokenising the input (makes `parseArgs` cleaner)--data AutoToken =-    M | C | R | D | L-  | T String | S Int | H String--autoTokens :: [String] -> [AutoToken]-autoTokens []              = []-autoTokens ("-t" : t : ws) = T t        : autoTokens ws-autoTokens ("-s" : s : ws) = S (read s) : autoTokens ws-autoTokens ("-l"     : ws) = L          : autoTokens ws-autoTokens ("-d"     : ws) = D          : autoTokens ws-autoTokens ("-m"     : ws) = M          : autoTokens ws-autoTokens ("-c"     : ws) = C          : autoTokens ws-autoTokens ("-r"     : ws) = R          : autoTokens ws-autoTokens (h        : ws) = H h        : autoTokens ws--parseTime :: String -> Int-parseTime [] = 0-parseTime xs = read ds * modifier + parseTime r where-  (ds , modr) = span isDigit xs-  (mod , r)   = break isDigit modr--  modifier = case mod of-    "ms" -> 1-    "cs" -> 10-    "ds" -> 100-    "s"  -> 1000-    _    -> 1000--parseArgs :: String -> AutoOptions-parseArgs s = mapM_ step (autoTokens $ words s)-              `execState` initAutoOptions where--  step :: AutoToken -> State AutoOptions ()-  step M     = aoHintMode .= AHMModule-  step C     = aoMode     .= MCaseSplit-  step R     = aoPick     .= (-1)-            >> aoMode     .= MRefine False-  step (T t) = aoTimeOut  .= TimeOut (parseTime t)-  step (S p) = aoPick     .= p-  step (H h) = aoHints    %= (h :)-  step D     = do-    mode <- use aoMode-    case mode of-      MNormal lm _ -> aoMode .= MNormal lm True-      _            -> return ()-  step L     = do-    mode <- use aoMode-    case mode of-      MNormal _ dp -> aoMode .= MNormal True dp-      MRefine _    -> aoMode .= MRefine True-      _            -> return ()
− src/full/Agda/Auto/SearchControl.hs 
@@ -1,443 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Agda.Auto.SearchControl where--import Control.Monad-import Data.IORef-import Control.Monad.State-import Data.Maybe (mapMaybe, fromMaybe)--import Agda.Syntax.Common (Hiding(..))-import Agda.Auto.NarrowingSearch-import Agda.Auto.Syntax--import Agda.Utils.Impossible--instance Refinable (ArgList o) (RefInfo o) where- refinements _ infos _ = return $ fmap (Move 0) $-   [ return ALNil, cons NotHidden, cons Hidden ]-   ++ if getIsDep infos then []-      else [ proj NotHidden, proj Hidden ]--   where--    getIsDep :: [RefInfo o] -> Bool-    getIsDep (x : xs) = case x of-      RICheckElim isDep -> isDep-      _                 -> getIsDep xs-    getIsDep _ = __IMPOSSIBLE__--    proj :: Hiding -> RefCreateEnv (RefInfo o) (ArgList o)-    proj hid = ALProj <$> newPlaceholder <*> newPlaceholder-                      <*> return hid     <*> newPlaceholder--    cons :: Hiding -> RefCreateEnv (RefInfo o) (ArgList o)-    cons hid = ALCons hid <$> newPlaceholder <*> newPlaceholder---data ExpRefInfo o = ExpRefInfo-  { eriMain           :: Maybe (RefInfo o)-  , eriUnifs          :: [RefInfo o]-  , eriInfTypeUnknown :: Bool-  , eriIsEliminand    :: Bool-  , eriUsedVars       :: Maybe ([UId o], [Elr o])-  , eriIotaStep       :: Maybe Bool-  , eriPickSubsVar    :: Bool-  , eriEqRState       :: Maybe EqReasoningState-  }--initExpRefInfo :: ExpRefInfo o-initExpRefInfo = ExpRefInfo-  { eriMain           = Nothing-  , eriUnifs          = []-  , eriInfTypeUnknown = False-  , eriIsEliminand    = False-  , eriUsedVars       = Nothing-  , eriIotaStep       = Nothing-  , eriPickSubsVar    = False-  , eriEqRState       = Nothing-  }--getinfo :: [RefInfo o] -> ExpRefInfo o-getinfo = foldl step initExpRefInfo where--  step :: ExpRefInfo o -> RefInfo o -> ExpRefInfo o-  step eri x@RIMainInfo{}           = eri { eriMain  = Just x }-  step eri x@RIUnifInfo{}           = eri { eriUnifs = x : eriUnifs eri }-  step eri RIInferredTypeUnknown    = eri { eriInfTypeUnknown = True }-  step eri RINotConstructor         = eri { eriIsEliminand = True }-  step eri (RIUsedVars nuids nused) = eri { eriUsedVars = Just (nuids, nused) }-  step eri (RIIotaStep semif)       = eri { eriIotaStep = Just iota' } where-    iota' = semif || (Just True ==) (eriIotaStep eri)-  step eri RIPickSubsvar            = eri { eriPickSubsVar = True }-  step eri (RIEqRState s)           = eri { eriEqRState = Just s }-  step eri _ = __IMPOSSIBLE__----- | @univar sub v@ figures out what the name of @v@ "outside" of---   the substitution @sub@ ought to be, if anything.--univar :: [CAction o] -> Nat -> Maybe Nat-univar cl v = getOutsideName cl v 0 where--  getOutsideName :: [CAction o] -> Nat -> Nat -> Maybe Nat-  -- @v@ is offset by @v'@ binders-  getOutsideName []            v v' = Just (v' + v)-  -- @v@ was introduced by the weakening: disappears-  getOutsideName (Weak n : _)  v v' | v < n = Nothing-  -- @v@ was introduced before the weakening: strengthened-  getOutsideName (Weak n : xs) v v' = getOutsideName xs (v - n) v'-  -- Name of @v@ before the substitution was pushed in-  -- had to be offset by 1-  getOutsideName (Sub _  : xs) v v' = getOutsideName xs v (v' + 1)-  -- If this is the place where @v@ was bound, it used to-  -- be called 0 + offset of all the vars substituted for-  getOutsideName (Skip   : _)  0 v' = Just v'-  -- Going over a binder: de Bruijn name of @v@ decreased-  -- but offset increased-  getOutsideName (Skip   : xs) v v' = getOutsideName xs (v - 1) (v' + 1)---- | List of the variables instantiated by the substitution-subsvars :: [CAction o] -> [Nat]-subsvars = f 0 where--  f :: Nat -> [CAction o] -> [Nat]-  f n []            = []-  f n (Weak _ : xs) = f n xs -- why?-  f n (Sub _  : xs) = n : f (n + 1) xs-  f n (Skip   : xs) = f (n + 1) xs---- | Moves---   A move is composed of a @Cost@ together with an action---   computing the refined problem.--type Move o = Move' (RefInfo o) (Exp o)---- | New constructors---   Taking a step towards a solution consists in picking a---   constructor and filling in the missing parts with---   placeholders to be discharged later on.--newAbs :: MId -> RefCreateEnv blk (Abs (MM a blk))-newAbs mid = Abs mid <$> newPlaceholder--newLam :: Hiding -> MId -> RefCreateEnv (RefInfo o) (Exp o)-newLam hid mid = Lam hid <$> newAbs mid--newPi :: UId o -> Bool -> Hiding -> RefCreateEnv (RefInfo o) (Exp o)-newPi uid dep hid = Pi (Just uid) hid dep <$> newPlaceholder <*> newAbs NoId--foldArgs :: [(Hiding, MExp o)] -> MArgList o-foldArgs = foldr (\ (h, a) sp -> NotM $ ALCons h a sp) (NotM ALNil)---- | New spine of arguments potentially using placeholders--newArgs' :: [Hiding] -> [MExp o] -> RefCreateEnv (RefInfo o) (MArgList o)-newArgs' h tms = foldArgs . zip h . (++ tms) <$> replicateM size newPlaceholder-  where size = length h - length tms--newArgs :: [Hiding] -> RefCreateEnv (RefInfo o) (MArgList o)-newArgs h = newArgs' h []---- | New @App@lication node using a new spine of arguments---   respecting the @Hiding@ annotation--newApp' :: UId o -> ConstRef o -> [Hiding] -> [MExp o] ->-           RefCreateEnv (RefInfo o) (Exp o)-newApp' meta cst hds tms =-  App (Just meta) <$> newOKHandle <*> return (Const cst) <*> newArgs' hds tms--newApp :: UId o -> ConstRef o -> [Hiding] -> RefCreateEnv (RefInfo o) (Exp o)-newApp meta cst hds = newApp' meta cst hds []---- | Equality reasoning steps---   The begin token is accompanied by two steps because---   it does not make sense to have a derivation any shorter---   than that.--eqStep :: UId o -> EqReasoningConsts o -> Move o-eqStep meta eqrc = Move costEqStep $ newApp meta (eqrcStep eqrc)-  [Hidden, Hidden, NotHidden, Hidden, Hidden, NotHidden, NotHidden]--eqEnd :: UId o -> EqReasoningConsts o -> Move o-eqEnd meta eqrc = Move costEqEnd $ newApp meta (eqrcEnd eqrc)-  [Hidden, Hidden, NotHidden]--eqCong :: UId o -> EqReasoningConsts o -> Move o-eqCong meta eqrc = Move costEqCong $ newApp meta (eqrcCong eqrc)-  [Hidden, Hidden, Hidden, Hidden, NotHidden, Hidden, Hidden, NotHidden]--eqSym :: UId o -> EqReasoningConsts o -> Move o-eqSym meta eqrc = Move costEqSym $ newApp meta (eqrcSym eqrc)-  [Hidden, Hidden, Hidden, Hidden, NotHidden]--eqBeginStep2 :: UId o -> EqReasoningConsts o -> Move o-eqBeginStep2 meta eqrc = Move costEqStep $ do-  e1 <- newApp meta (eqrcStep eqrc)-          [Hidden, Hidden, NotHidden, Hidden, Hidden, NotHidden, NotHidden]-  e2 <- newApp' meta (eqrcStep eqrc)-          [Hidden, Hidden, NotHidden, Hidden, Hidden, NotHidden, NotHidden]-          [NotM e1]-  newApp' meta (eqrcBegin eqrc) [Hidden, Hidden, Hidden, Hidden, NotHidden]-    [NotM e2]----- | Pick the first unused UId amongst the ones you have seen (GA: ??)---   Defaults to the head of the seen ones.--pickUid :: forall o. [UId o] -> [Maybe (UId o)] -> (Maybe (UId o), Bool)-pickUid used seen = maybe (head seen, False) (, True) $ firstUnused seen where-  {- ?? which uid to pick -}--  firstUnused :: [Maybe (UId o)] -> Maybe (Maybe (UId o))-  firstUnused []                 = Nothing-  firstUnused (Nothing     : _)  = Just Nothing-  firstUnused (mu@(Just u) : us) =-    if u `elem` used then firstUnused us else Just mu--instance Refinable (Exp o) (RefInfo o) where- refinements envinfo infos meta =-  let-   hints = rieHints envinfo-   deffreevars = rieDefFreeVars envinfo--   meqr = rieEqReasoningConsts envinfo--   ExpRefInfo { eriMain  = Just (RIMainInfo n tt iotastepdone)-              , eriUnifs = unis-              , eriInfTypeUnknown = inftypeunknown-              , eriIsEliminand = iseliminand -- TODO:: Defined but not used-              , eriUsedVars = Just (uids, usedvars)-              , eriIotaStep = iotastep-              , eriPickSubsVar = picksubsvar -- TODO:: Defined but not used-              , eriEqRState = meqrstate-              } = getinfo infos--   eqrstate = fromMaybe EqRSNone meqrstate--   set l = return $ Sort (Set l)-  in case unis of-   [] ->-    let--     eqr = fromMaybe __IMPOSSIBLE__ meqr-     eq_end         = eqEnd  meta eqr-     eq_step        = eqStep meta eqr-     eq_cong        = eqCong meta eqr-     eq_sym         = eqSym  meta eqr-     eq_begin_step2 = eqBeginStep2 meta eqr--     adjustCost i = if inftypeunknown then costInferredTypeUnkown else i-     varcost v | v < n - deffreevars = adjustCost $-       if v `elem` (mapMaybe getVar usedvars)-       then costAppVarUsed else costAppVar-     varcost v | otherwise           = adjustCost costAppHint-     varapps  = map (\ v -> Move (varcost v) $ app n meta Nothing (Var v)) [0..n - 1]-     hintapps = map (\(c, hm) -> Move (cost c hm) (app n meta Nothing (Const c))) hints-       where-         cost :: ConstRef o -> HintMode -> Cost-         cost c hm = adjustCost $ case (iotastep , hm) of-           (Just _  , _       ) -> costIotaStep-           (Nothing , HMNormal) ->-             if c `elem` (mapMaybe getConst usedvars)-             then costAppHintUsed else costAppHint-           (Nothing , HMRecCall) ->-             if c `elem` (mapMaybe getConst usedvars)-             then costAppRecCallUsed else costAppRecCall-     generics = varapps ++ hintapps-    in case rawValue tt of--     _ | eqrstate == EqRSChain ->-      return [eq_end, eq_step]--     HNPi hid _ _ (Abs id _) -> return $-         Move (adjustCost (if iotastepdone then costLamUnfold else costLam)) (newLam hid id)-       : Move costAbsurdLam (return $ AbsurdLambda hid)-       : generics--     HNSort (Set l) -> return $-          map (Move (adjustCost costSort) . set) [0..l - 1]-       ++ map (Move (adjustCost costPi) . newPi meta True) [NotHidden, Hidden]-       ++ generics---     HNApp (Const c) _ -> do-      cd <- readIORef c-      return $ case cdcont cd of--       Datatype cons _ | eqrstate == EqRSNone ->-         map (\c -> Move (adjustCost $ case iotastep of-                                         Just True -> costUnification-                                         _ -> if length cons <= 1-                                              then costAppConstructorSingle-                                              else costAppConstructor)-                         $ app n meta Nothing (Const c)) cons-         ++ generics-         ++ (guard (maybe False ((c ==) . eqrcId) meqr)-            *> [eq_sym, eq_cong, eq_begin_step2])--       _ | eqrstate == EqRSPrf1 -> generics ++ [eq_sym, eq_cong]-       _ | eqrstate == EqRSPrf2 -> generics ++ [eq_cong]--       _ -> generics-     _ -> return generics-   (RIUnifInfo cl hne : _) ->-    let-     subsvarapps = map (Move costUnification . app n meta Nothing . Var) (subsvars cl)-     mlam = case rawValue tt of-      HNPi hid _ _ (Abs id _) -> [Move costUnification (newLam hid id)]-      _ -> []-     generics = mlam ++ subsvarapps--    in-     return $ case rawValue hne of-      HNApp (Var v) _ ->-       let (uid, isunique) = pickUid uids $ seenUIds hne-           uni = case univar cl v of-                  Just v | v < n -> [Move (costUnificationIf isunique) $ app n meta uid (Var v)]-                  _ -> []-       in uni ++ generics-      HNApp (Const c) _ ->-       let (uid, isunique) = pickUid uids $ seenUIds hne-       in Move (costUnificationIf isunique) (app n meta uid (Const c)) : generics-      HNLam{} -> generics-      HNPi hid possdep _ _ ->-       let (uid, isunique) = pickUid uids $ seenUIds hne-       in Move (costUnificationIf isunique) (newPi (fromMaybe meta uid) possdep hid) : generics-      HNSort (Set l) -> map (Move costUnification . set) [0..l] ++ generics-      HNSort _ -> generics-   _ -> __IMPOSSIBLE__--  where--    app :: Nat -> UId o -> Maybe (UId o) -> Elr o ->-           RefCreateEnv (RefInfo o) (Exp o)-    app n meta muid elr = do-      p <- newPlaceholder-      p <- case elr of-        Var{}   -> return p-        Const c -> do-          cd <- RefCreateEnv $ lift $ readIORef c-          let dfvapp 0 _ = p-              dfvapp i n = NotM $ ALCons NotHidden-                          (NotM $ App Nothing (NotM $ OKVal) (Var n) (NotM ALNil))-                          (dfvapp (i - 1) (n - 1))-         -- NotHidden is ok because agda reification throws these arguments-         -- away and agsy skips typechecking them-          return $ dfvapp (cddeffreevars cd) (n - 1)-      okh <- newOKHandle-      return $ App (Just $ fromMaybe meta muid) okh elr p---extraref :: UId o -> [Maybe (UId o)] -> ConstRef o -> Move o-extraref meta seenuids c = Move costAppExtraRef $ app (head seenuids) (Const c)- where-   app muid elr = App (Just $ fromMaybe meta muid)-              <$> newOKHandle <*> return elr <*> newPlaceholder--instance Refinable (ICExp o) (RefInfo o) where- refinements _ infos _ =-  let (RICopyInfo e : _) = infos-  in return [Move 0 (return e)]---instance Refinable (ConstRef o) (RefInfo o) where- refinements _ [RICheckProjIndex projs] _ = return $ map (Move 0 . return) projs- refinements _ _ _ = __IMPOSSIBLE__----- -----------------------------------costIncrease, costUnificationOccurs, costUnification, costAppVar,-  costAppVarUsed, costAppHint, costAppHintUsed, costAppRecCall,-  costAppRecCallUsed, costAppConstructor, costAppConstructorSingle,-  costAppExtraRef, costLam, costLamUnfold, costPi, costSort, costIotaStep,-  costInferredTypeUnkown, costAbsurdLam-  :: Cost--costUnificationIf :: Bool -> Cost-costUnificationIf b = if b then costUnification else costUnificationOccurs--costIncrease = 1000-costUnificationOccurs = 100 -- 1000001 -- 1 -- 100-costUnification = 0000-costAppVar = 0000 -- 0, 1-costAppVarUsed = 1000 -- 5-costAppHint = 3000 -- 2, 5-costAppHintUsed = 5000-costAppRecCall = 0 -- 1000?-costAppRecCallUsed = 10000 -- 1000?-costAppConstructor = 1000-costAppConstructorSingle = 0000-costAppExtraRef = 1000-costLam = 0000 -- 1, 0-costLamUnfold = 1000 -- 1, 0-costPi = 1000003 -- 100 -- 5-costSort = 1000004 -- 0-costIotaStep = 3000 -- 1000005 -- 2 -- 100-costInferredTypeUnkown = 1000006 -- 100-costAbsurdLam = 0--costEqStep, costEqEnd, costEqSym, costEqCong :: Cost-costEqStep = 2000-costEqEnd = 0-costEqSym = 0-costEqCong = 500--prioNo, prioTypeUnknown, prioTypecheckArgList, prioInferredTypeUnknown,-  prioCompBeta, prioCompBetaStructured, prioCompareArgList, prioCompIota,-  prioCompChoice, prioCompUnif, prioCompCopy, prioNoIota, prioAbsurdLambda,-  prioProjIndex-  :: Prio-prioNo = (-1)-prioTypeUnknown = 0-prioTypecheckArgList = 3000-prioInferredTypeUnknown = 4000-prioCompBeta = 4000-prioCompBetaStructured = 4000-prioCompIota = 4000-prioCompChoice = 5000 -- 700 -- 5000-prioCompUnif = 6000 -- 2-prioCompCopy = 8000-prioCompareArgList = 7000 -- 5 -- 2-prioNoIota = 500 -- 500-prioAbsurdLambda = 1000--prioProjIndex = 3000--prioTypecheck :: Bool -> Prio-prioTypecheck False = 1000-prioTypecheck True = 0---- -----------------------------------instance Trav a => Trav [a] where-  type Block [a] = Block a-  trav _ []     = return ()-  trav f (x:xs) = trav f x >> trav f xs--instance Trav (MId, CExp o) where-  type Block (MId, CExp o) = RefInfo o-  trav f (_, ce) = trav f ce--instance Trav (TrBr a o) where-  type Block (TrBr a o) = RefInfo o-  trav f (TrBr es _) = trav f es--instance Trav (Exp o) where-  type Block (Exp o) = RefInfo o-  trav f = \case-    App _ _ _ args         -> trav f args-    Lam _ (Abs _ b)        -> trav f b-    Pi _ _ _ it (Abs _ ot) -> trav f it >> trav f ot-    Sort _                 -> return ()-    AbsurdLambda{}         -> return ()--instance Trav (ArgList o) where-  type Block (ArgList o) = RefInfo o-  trav _ ALNil               = return ()-  trav f (ALCons _ arg args) = trav f arg >> trav f args-  trav f (ALProj eas _ _ as) = trav f eas >> trav f as-  trav f (ALConPar args)     = trav f args---- ---------------------------------
− src/full/Agda/Auto/Syntax.hs 
@@ -1,464 +0,0 @@--module Agda.Auto.Syntax where--import Data.IORef-import qualified Data.Set as Set--import Agda.Syntax.Common (Hiding)-import Agda.Auto.NarrowingSearch--import Agda.Utils.Impossible---- | Unique identifiers for variable occurrences in unification.-type UId o = Metavar (Exp o) (RefInfo o)--data HintMode = HMNormal-              | HMRecCall--data EqReasoningConsts o = EqReasoningConsts-  { eqrcId    -- "_≡_"-  , eqrcBegin -- "begin_"-  , eqrcStep  -- "_≡⟨_⟩_"-  , eqrcEnd   -- "_∎"-  , eqrcSym   -- "sym"-  , eqrcCong  -- "cong"-  :: ConstRef o-  }--data EqReasoningState = EqRSNone | EqRSChain | EqRSPrf1 | EqRSPrf2 | EqRSPrf3- deriving (Eq, Show)---- | The concrete instance of the 'blk' parameter in 'Metavar'.---   I.e., the information passed to the search control.--data RefInfo o-  = RIEnv-    { rieHints :: [(ConstRef o, HintMode)]-    , rieDefFreeVars :: Nat-      -- ^ Nat - deffreevars-      --   (to make cost of using module parameters correspond to that of hints).-    , rieEqReasoningConsts :: Maybe (EqReasoningConsts o)-    }-  | RIMainInfo-    { riMainCxtLength :: Nat-      -- ^ Size of typing context in which meta was created.-    , riMainType      :: HNExp o-      -- ^ Head normal form of type of meta.-    , riMainIota      :: Bool-       -- ^ True if iota steps performed when normalising target type-       --   (used to put cost when traversing a definition-       --    by construction instantiation).-    }-  | RIUnifInfo [CAction o] (HNExp o)-    -- meta environment, opp hne-  | RICopyInfo (ICExp o)-  | RIIotaStep Bool -- True - semiflex-  | RIInferredTypeUnknown-  | RINotConstructor-  | RIUsedVars [UId o] [Elr o]-  | RIPickSubsvar--  | RIEqRState EqReasoningState---  | RICheckElim Bool -- isdep-  | RICheckProjIndex [ConstRef o] -- noof proj functions---type MyPB o = PB (RefInfo o)-type MyMB a o = MB a (RefInfo o)--type Nat = Int--data MId = Id String-         | NoId---- | Abstraction with maybe a name.------   Different from Agda, where there is also info---   whether function is constant.-data Abs a = Abs MId a---- | Constant signatures.--data ConstDef o = ConstDef-  { cdname        :: String-    -- ^ For debug printing.-  , cdorigin      :: o-    -- ^ Reference to the Agda constant.-  , cdtype        :: MExp o-    -- ^ Type of constant.-  , cdcont        :: DeclCont o-    -- ^ Constant definition.-  , cddeffreevars :: Nat-    -- ^ Free vars of the module where the constant is defined..-  } -- contains no metas---- | Constant definitions.--data DeclCont o-  = Def Nat [Clause o] (Maybe Nat) -- maybe an index to elimand argument-                       (Maybe Nat) -- maybe index to elim arg if semiflex-  | Datatype [ConstRef o] -- constructors-             [ConstRef o] -- projection functions (in case it is a record)--  | Constructor Nat -- number of omitted args-  | Postulate--type Clause o = ([Pat o], MExp o)--data Pat o-  = PatConApp (ConstRef o) [Pat o]-  | PatVar String-  | PatExp-    -- ^ Dot pattern.-{- TODO: projection patterns.-  | PatProj (ConstRef o)-    -- ^ Projection pattern.--}--type ConstRef o = IORef (ConstDef o)---- | Head of application (elimination).-data Elr o-  = Var Nat-  | Const (ConstRef o)-  deriving (Eq)--getVar :: Elr o -> Maybe Nat-getVar (Var n) = Just n-getVar Const{} = Nothing--getConst :: Elr o -> Maybe (ConstRef o)-getConst (Const c) = Just c-getConst Var{}     = Nothing--data Sort-  = Set Nat-  | UnknownSort-  | Type---- | Agsy's internal syntax.-data Exp o-  = App-    { appUId   :: Maybe (UId o)-      -- ^ Unique identifier of the head.-    , appOK    :: OKHandle (RefInfo o)-      -- ^ This application has been type-checked.-    , appHead  :: Elr o-      -- ^ Head.-    , appElims :: MArgList o-      -- ^ Arguments.-    }-  | Lam Hiding (Abs (MExp o))-    -- ^ Lambda with hiding information.-  | Pi (Maybe (UId o)) Hiding Bool (MExp o) (Abs (MExp o))-    -- ^ @True@ if possibly dependent (var not known to not occur).-    --   @False@ if non-dependent.-  | Sort Sort-  | AbsurdLambda Hiding-    -- ^ Absurd lambda with hiding information.--dontCare :: Exp o-dontCare = Sort UnknownSort---- | "Maybe expression":  Expression or reference to meta variable.-type MExp o = MM (Exp o) (RefInfo o)--data ArgList o-  = ALNil-    -- ^ No more eliminations.-  | ALCons Hiding (MExp o) (MArgList o)-    -- ^ Application and tail.--  | ALProj (MArgList o) (MM (ConstRef o) (RefInfo o)) Hiding (MArgList o)-    -- ^ proj pre args, projfcn idx, tail--  | ALConPar (MArgList o)-    -- ^ Constructor parameter (missing in Agda).-    --   Agsy has monomorphic constructors.-    --   Inserted to cover glitch of polymorphic constructor-    --   applications coming from Agda--type MArgList o = MM (ArgList o) (RefInfo o)--data WithSeenUIds a o = WithSeenUIds-  { seenUIds :: [Maybe (UId o)]-  , rawValue :: a-  }--type HNExp o = WithSeenUIds (HNExp' o) o--data HNExp' o =-    HNApp  (Elr o) (ICArgList o)-  | HNLam  Hiding (Abs (ICExp o))-  | HNPi   Hiding Bool (ICExp o) (Abs (ICExp o))-  | HNSort Sort---- | Head-normal form of 'ICArgList'.  First entry is exposed.------   Q: Why are there no projection eliminations?-data HNArgList o = HNALNil-                 | HNALCons Hiding (ICExp o) (ICArgList o)-                 | HNALConPar (ICArgList o)---- | Lazy concatenation of argument lists under explicit substitutions.-data ICArgList o = CALNil-                 | CALConcat (Clos (MArgList o) o) (ICArgList o)---- | An expression @a@ in an explicit substitution @[CAction a]@.-type ICExp o  = Clos (MExp o) o-data Clos a o = Clos [CAction o] a--type CExp o   = TrBr (ICExp o) o-data TrBr a o = TrBr [MExp o] a---- | Entry of an explicit substitution.------   An explicit substitution is a list of @CAction@s.---   This is isomorphic to the usual presentation where---   @Skip@ and @Weak@ would be constructors of exp. substs.--data CAction o-  = Sub (ICExp o)-    -- ^ Instantation of variable.-  | Skip-    -- ^ For going under a binder, often called "Lift".-  | Weak Nat-    -- ^ Shifting substitution (going to a larger context).--type Ctx o = [(MId, CExp o)]--type EE = IO---- ---------------------------------------------detecteliminand :: [Clause o] -> Maybe Nat-detecteliminand cls =- case map cleli cls of-  [] -> Nothing-  (i:is) -> if all (i ==) is then i else Nothing- where-  cleli (pats, _) = pateli 0 pats-  pateli i (PatConApp _ args : pats) = if all notcon (args ++ pats) then Just i else Nothing-  pateli i (_ : pats) = pateli (i + 1) pats-  pateli i [] = Nothing-  notcon PatConApp{} = False-  notcon _ = True--detectsemiflex :: ConstRef o -> [Clause o] -> IO Bool-detectsemiflex _ _ = return False -- disabled--categorizedecl :: ConstRef o -> IO ()-categorizedecl c = do- cd <- readIORef c- case cdcont cd of-  Def narg cls _ _ -> do-   semif <- detectsemiflex c cls-   let elim = detecteliminand cls-       semifb = case (semif, elim) of-                 (True, Just i) -> Just i -- just copying val of elim arg. this should be changed-                 (_, _) -> Nothing-   writeIORef c (cd {cdcont = Def narg cls elim semifb})-  _ -> return ()---- ---------------------------------------------class MetaliseOKH t where-  metaliseOKH :: t -> IO t--instance MetaliseOKH t => MetaliseOKH (MM t a) where-  metaliseOKH = \case-    Meta m -> return $ Meta m-    NotM e -> NotM <$> metaliseOKH e--instance MetaliseOKH t => MetaliseOKH (Abs t) where-  metaliseOKH (Abs id b) = Abs id <$> metaliseOKH b--instance MetaliseOKH (Exp o) where-  metaliseOKH = \case-    App uid okh elr args ->-      (\ m -> App uid m elr) <$> (Meta <$> initMeta) <*> metaliseOKH args-    Lam hid b -> Lam hid <$> metaliseOKH b-    Pi uid hid dep it ot ->-      Pi uid hid dep <$> metaliseOKH it <*> metaliseOKH ot-    e@Sort{} -> return e-    e@AbsurdLambda{} -> return e--instance MetaliseOKH (ArgList o) where-  metaliseOKH = \case-    ALNil -> return ALNil-    ALCons hid a as -> ALCons hid <$> metaliseOKH a <*> metaliseOKH as-    ALProj eas idx hid as ->-      (\ eas -> ALProj eas idx hid) <$> metaliseOKH eas <*> metaliseOKH as-    ALConPar as -> ALConPar <$> metaliseOKH as--metaliseokh :: MExp o -> IO (MExp o)-metaliseokh = metaliseOKH---- ---------------------------------------------class ExpandMetas t where-  expandMetas :: t -> IO t--instance ExpandMetas t => ExpandMetas (MM t a) where-  expandMetas = \case-    NotM e -> NotM <$> expandMetas e-    Meta m -> do-      mb <- readIORef (mbind m)-      case mb of-        Nothing -> return $ Meta m-        Just e  -> NotM <$> expandMetas e--instance ExpandMetas t => ExpandMetas (Abs t) where-  expandMetas (Abs id b) = Abs id <$> expandMetas b--instance ExpandMetas (Exp o) where-  expandMetas = \case-    App uid okh elr args -> App uid okh elr <$> expandMetas args-    Lam hid b -> Lam hid <$> expandMetas b-    Pi uid hid dep it ot ->-      Pi uid hid dep <$> expandMetas it <*> expandMetas ot-    t@Sort{} -> return t-    t@AbsurdLambda{} -> return t--instance ExpandMetas (ArgList o) where-  expandMetas = \case-    ALNil -> return ALNil-    ALCons hid a as -> ALCons hid <$> expandMetas a <*> expandMetas as-    ALProj eas idx hid as ->-      (\ a b -> ALProj a b hid) <$> expandMetas eas-      <*> expandbind idx <*> expandMetas as-    ALConPar as -> ALConPar <$> expandMetas as---- -----------------------------------addtrailingargs :: Clos (MArgList o) o -> ICArgList o -> ICArgList o-addtrailingargs newargs CALNil = CALConcat newargs CALNil-addtrailingargs newargs (CALConcat x xs) = CALConcat x (addtrailingargs newargs xs)---- -----------------------------------closify :: MExp o -> CExp o-closify e = TrBr [e] (Clos [] e)--sub :: MExp o -> CExp o -> CExp o--- sub e (Clos [] x) = Clos [Sub e] x-sub e (TrBr trs (Clos (Skip : as) x)) = TrBr (e : trs) (Clos (Sub (Clos [] e) : as) x)-{-sub e (Clos (Weak n : as) x) = if n == 1 then-                                Clos as x-                               else-                                Clos (Weak (n - 1) : as) x-}-sub _ _ = __IMPOSSIBLE__--subi :: MExp o -> ICExp o -> ICExp o-subi e (Clos (Skip : as) x) = Clos (Sub (Clos [] e) : as) x-subi _ _ = __IMPOSSIBLE__--weak :: Weakening t => Nat -> t -> t-weak 0 = id-weak n = weak' n--class Weakening t where-  weak' :: Nat -> t -> t--instance Weakening a => Weakening (TrBr a o) where-  weak' n (TrBr trs e) = TrBr trs (weak' n e)--instance Weakening (Clos a o) where-  weak' n (Clos as x) = Clos (Weak n : as) x--instance Weakening (ICArgList o) where-  weak' n = \case-    CALNil         -> CALNil-    CALConcat a as -> CALConcat (weak' n a) (weak' n as)--instance Weakening (Elr o) where-  weak' n = rename (n+)---- | Substituting for a variable.-doclos :: [CAction o] -> Nat -> Either Nat (ICExp o)-doclos = f 0- where-  -- ns is the number of weakenings-  f ns []            i = Left (ns + i)-  f ns (Weak n : xs) i = f (ns + n) xs i-  f ns (Sub s  : _ ) 0 = Right (weak ns s)-  f ns (Skip   : _ ) 0 = Left ns-  f ns (Skip   : xs) i = f (ns + 1) xs (i - 1)-  f ns (Sub _  : xs) i = f ns xs (i - 1)----- | FreeVars class and instances--freeVars :: FreeVars t => t -> Set.Set Nat-freeVars = freeVarsOffset 0--class FreeVars t where-  freeVarsOffset :: Nat -> t -> Set.Set Nat--instance (FreeVars a, FreeVars b) => FreeVars (a, b) where-  freeVarsOffset n (a, b) = Set.union (freeVarsOffset n a) (freeVarsOffset n b)--instance FreeVars t => FreeVars (MM t a) where-  freeVarsOffset n e = freeVarsOffset n (rm __IMPOSSIBLE__ e)--instance FreeVars t => FreeVars (Abs t) where-  freeVarsOffset n (Abs id e) = freeVarsOffset (n + 1) e--instance FreeVars (Elr o) where-  freeVarsOffset n = \case-    Var v   -> Set.singleton (v - n)-    Const{} -> Set.empty--instance FreeVars (Exp o) where-  freeVarsOffset n = \case-   App _ _ elr args -> freeVarsOffset n (elr, args)-   Lam _ b          -> freeVarsOffset n b-   Pi _ _ _ it ot   -> freeVarsOffset n (it, ot)-   Sort{}           -> Set.empty-   AbsurdLambda{}   -> Set.empty--instance FreeVars (ArgList o) where-  freeVarsOffset n es = case es of-    ALNil         -> Set.empty-    ALCons _ e es -> freeVarsOffset n (e, es)-    ALConPar es   -> freeVarsOffset n es-    ALProj{}      -> __IMPOSSIBLE__----- | Renaming Typeclass and instances-rename :: Renaming t => (Nat -> Nat) -> t -> t-rename = renameOffset 0--class Renaming t where-  renameOffset :: Nat -> (Nat -> Nat) -> t -> t--instance (Renaming a, Renaming b) => Renaming (a, b) where-  renameOffset j ren (a, b) = (renameOffset j ren a, renameOffset j ren b)--instance Renaming t => Renaming (MM t a) where-  renameOffset j ren e = NotM $ renameOffset j ren (rm __IMPOSSIBLE__ e)--instance Renaming t => Renaming (Abs t) where-  renameOffset j ren (Abs id e) = Abs id $ renameOffset (j + 1) ren e--instance Renaming (Elr o) where-  renameOffset j ren = \case-    Var v | v >= j -> Var (ren (v - j) + j)-    e              -> e--instance Renaming (Exp o) where-  renameOffset j ren = \case-    App uid ok elr args -> uncurry (App uid ok) $ renameOffset j ren (elr, args)-    Lam hid e -> Lam hid (renameOffset j ren e)-    Pi a b c it ot -> uncurry (Pi a b c) $ renameOffset j ren (it, ot)-    e@Sort{}         -> e-    e@AbsurdLambda{} -> e--instance Renaming (ArgList o) where-  renameOffset j ren = \case-    ALNil           -> ALNil-    ALCons hid a as -> uncurry (ALCons hid) $ renameOffset j ren (a, as)-    ALConPar as     -> ALConPar (renameOffset j ren as)-    ALProj{}        -> __IMPOSSIBLE__
− src/full/Agda/Auto/Typecheck.hs 
@@ -1,817 +0,0 @@--module Agda.Auto.Typecheck where--import Data.IORef--import Agda.Syntax.Common (Hiding (..))-import Agda.Auto.NarrowingSearch-import Agda.Auto.Syntax-import Agda.Auto.SearchControl--import Agda.Utils.Impossible---- ------------------------------------- | Typechecker drives the solution of metas.-tcExp :: Bool -> Ctx o -> CExp o -> MExp o -> EE (MyPB o)-tcExp isdep ctx typ@(TrBr typtrs ityp@(Clos _ itypexp)) trm =-  mbpcase prioTypeUnknown Nothing (hnn_checkstep ityp) $ \(hntyp, iotastepdone) ->-  mmpcase (True, prioTypecheck isdep, Just (RIMainInfo (length ctx) hntyp iotastepdone)) trm $ \trm -> case trm of-   App _ okh elr args -> case rawValue hntyp of-    HNPi{} | isdep -> mpret $ Error "tcExp, dep terms should be eta-long"-    _ -> do-     (ityp, sc) <- case elr of-              Var v -> -- assuming within scope-               return (weak (v + 1) (snd $ ctx !! v), id)-              Const c -> do-               cdef <- readIORef c-               return (closify (cdtype cdef), \x -> mpret $ And (Just [Term args]) (noiotastep_term c args) x)--     ndfv <- case elr of-              Var{} -> return 0-              Const c -> readIORef c >>= \cd -> return (cddeffreevars cd)---     isconstructor <- case elr of-      Var{} -> return False-      Const c -> do-       cdef <- readIORef c-       return $ case cdcont cdef of {Constructor{} -> True; _ -> False}--     sc $ tcargs ndfv isdep ctx ityp args (NotM $ App Nothing (NotM OKVal) elr (NotM ALNil)) isconstructor $ \ityp _ -> mpret $ ConnectHandle okh (comp' True typ ityp)-   Lam hid (Abs id1 b) -> case rawValue hntyp of-    HNPi hid2 _ it (Abs id2 ot) | hid == hid2 ->-     tcExp isdep ((pickid id1 id2, t it) : ctx) (t ot) b-    _ -> mpret $ Error "tcExp, type of lam should be fun or pi (and same hid)"-   Pi _ _ _ it (Abs id ot) -> case rawValue hntyp of-    HNSort s ->-     mpret $ And (Just [Term ctx, Term it])-      (tcExp True ctx (closify (NotM $ Sort s)) it)-      (tcExp isdep ((id, closify it) : ctx) (closify (NotM $ Sort s)) ot)-    _ -> mpret $ Error "tcExp, type of pi should be set"-   Sort (Set i) -> case rawValue hntyp of-    HNSort s2 -> case s2 of-     Set j -> mpret $ if i < j then OK else Error "tcExp, type of set should be larger set"--     UnknownSort -> mpret OK -- mpret $ Error "tcExp, type of set i unknown sort" -- OK instead? (prev __IMPOSSIBLE__)--     Type -> mpret OK-    _ -> mpret $ Error "tcExp, type of set should be set"--   Sort UnknownSort -> __IMPOSSIBLE__--   Sort Type -> __IMPOSSIBLE__--   AbsurdLambda hid -> case rawValue hntyp of-    HNPi hid2 _ it _ | hid == hid2 ->-     mbpcase prioAbsurdLambda Nothing (getDatatype it) $ \res -> case res of-      Just (indeces, cons) ->-       foldl (\p con -> mpret $ And Nothing p (-        constructorImpossible indeces con-       )) (mpret OK) cons-      Nothing -> mpret $ Error "tcExp, absurd lambda, datatype needed"-    _ -> mpret $ Error "tcExp, type of absurd lam should be fun or pi (and same hid)"---  where-   t = TrBr typtrs---getDatatype :: ICExp o -> EE (MyMB (Maybe (ICArgList o, [ConstRef o])) o)-getDatatype t =- mbcase (hnn t) $ \hnt -> case rawValue hnt of-  HNApp (Const c) args -> do-   cd <- readIORef c-   case cdcont cd of-    Datatype cons _ -> mbret $ Just (args, cons) -- ?? check that lenth args corresponds to type of datatype-    _ -> mbret Nothing-  _ -> mbret Nothing--constructorImpossible :: ICArgList o -> ConstRef o -> EE (MyPB o)-constructorImpossible args c = do- cd <- readIORef c- mbpcase prioAbsurdLambda Nothing (traversePi (-1) (Clos [] $ cdtype cd)) $ \hnot ->-  case rawValue hnot of-   HNApp _ args2 -> unequals args args2 (\_ -> mpret $ Error "not unequal") []-   _ -> mpret $ Error "constructorImpossible 1"--unequals :: ICArgList o -> ICArgList o -> ([(Nat, HNExp o)] -> EE (MyPB o)) -> [(Nat, HNExp o)] -> EE (MyPB o)-unequals es1 es2 cont unifier2 =- mbpcase prioAbsurdLambda Nothing (hnarglist es1) $ \hnes1 ->- mbpcase prioAbsurdLambda Nothing (hnarglist es2) $ \hnes2 ->- case (hnes1, hnes2) of-  (HNALCons _ e1 es1, HNALCons _ e2 es2) -> unequal e1 e2 (unequals es1 es2 cont) unifier2--  (HNALConPar es1, HNALConPar es2) -> unequals es1 es2 cont unifier2--  _ -> cont unifier2--unequal :: ICExp o -> ICExp o -> ([(Nat, HNExp o)] -> EE (MyPB o)) -> [(Nat, HNExp o)] -> EE (MyPB o)-unequal e1 e2 cont unifier2 =- mbpcase prioAbsurdLambda Nothing (hnn e1) $ \hne1 ->- mbpcase prioAbsurdLambda Nothing (hnn e2) $ \hne2 ->-  case rawValue hne2 of-   HNApp (Var v2) es2 | v2 < 0 ->-    mbpcase prioAbsurdLambda Nothing (hnarglist es2) $ \hnes2 -> case hnes2 of-     HNALNil ->-      case lookup v2 unifier2 of-       Nothing -> cont ((v2, hne1) : unifier2)-       Just hne2' -> cc hne1 hne2'-     HNALCons{} -> cont unifier2--     HNALConPar{} -> __IMPOSSIBLE__--   _ -> cc hne1 hne2- where-  cc hne1 hne2 = case (rawValue hne1, rawValue hne2) of-   (HNApp (Const c1) es1, HNApp (Const c2) es2) -> do-    cd1 <- readIORef c1-    cd2 <- readIORef c2-    case (cdcont cd1, cdcont cd2) of-     (Constructor{}, Constructor{}) ->-      if c1 == c2 then-       unequals es1 es2 cont unifier2-      else-       mpret OK-     _ -> cont unifier2-   _ -> cont unifier2--traversePi :: Int -> ICExp o -> EE (MyMB (HNExp o) o)-traversePi v t =- mbcase (hnn t) $ \hnt ->- case rawValue hnt of-  HNPi _ _ _ (Abs _ ot) -> traversePi (v - 1) $ subi (NotM $ App Nothing (NotM OKVal) (Var v) (NotM ALNil)) ot-  _ -> mbret hnt--tcargs :: Nat -> Bool -> Ctx o -> CExp o -> MArgList o -> MExp o -> Bool ->-          (CExp o -> MExp o -> EE (MyPB o)) -> EE (MyPB o)-tcargs ndfv isdep ctx ityp@(TrBr ityptrs iityp) args elimtrm isconstructor cont = mmpcase (True, prioTypecheckArgList, (Just $ RICheckElim $ isdep || isconstructor)) args $ \args' -> case args' of- ALNil -> cont ityp elimtrm- ALCons hid a as ->-  mbpcase prioInferredTypeUnknown (Just RIInferredTypeUnknown) (hnn iityp) $ \hnityp -> case rawValue hnityp of-   HNPi hid2 possdep it (Abs _ ot)-     | ndfv > 0 || copyarg a || hid == hid2 -> mpret $-    And (Just ([Term a | possdep] ++ [Term ctx, Term ityptrs]))-        (if ndfv > 0 then mpret OK else tcExp (isdep || possdep) ctx (t it) a)-        (tcargs (ndfv - 1) isdep ctx (sub a (t ot)) as (addend hid a elimtrm) isconstructor cont)-   _ -> mpret $ Error "tcargs, inf type should be fun or pi (and same hid)"--- ALProj{} | ndfv > 0 -> __IMPOSSIBLE__-- ALProj preas projidx hid as ->-  mbpcase prioInferredTypeUnknown (Just RIInferredTypeUnknown) (hnn iityp) $ \hnityp -> case rawValue hnityp of-   HNApp (Const dd) _ -> do-    dddef <- readIORef dd-    case cdcont dddef of-     Datatype _ projs ->-      mmpcase (True, prioProjIndex, Just (RICheckProjIndex projs)) projidx $-      \projidx -> do-       projd <- readIORef projidx-       tcargs (cddeffreevars projd) isdep ctx (closify $ cdtype projd) preas (NotM $ App Nothing (NotM OKVal) (Const projidx) (NotM ALNil)) True $-        \ityp2@(TrBr ityp2trs iityp2) elimtrm2 ->-         case iityp2 of-          Clos _ (NotM (Pi _ _ _ (NotM (App _ _ (Const dd2) _)) _)) | dd2 == dd ->-           mbpcase prioInferredTypeUnknown (Just RIInferredTypeUnknown) (hnn iityp2) $ \hnityp2 -> case rawValue hnityp2 of-            HNPi hid2 possdep it (Abs _ ot) | hid == hid2 -> mpret $-             And Nothing-                 (comp' True (TrBr ityp2trs it) ityp)-                 (tcargs 0 isdep ctx (sub elimtrm (t ot)) as (addend hid elimtrm elimtrm2) isconstructor cont)-            _ -> mpret $ Error "proj function type is not a Pi"-          _ -> mpret $ Error "proj function type is not correct"-     _ -> mpret $ Error "proj, not a datatype"-   _ -> mpret $ Error "proj, not a const app"--- ALConPar _ -> __IMPOSSIBLE__-- where-  t = TrBr ityptrs--addend :: Hiding -> MExp o -> MM (Exp o) blk -> MM (Exp o) blk-addend hid a (NotM (App uid okh elr as)) = NotM $ App uid okh elr (f as)- where-   f (NotM ALNil)             = NotM $ ALCons hid a (NotM $ ALNil)-   f (NotM (ALCons hid a as)) = NotM $ ALCons hid a (f as)-   f _                        = __IMPOSSIBLE__-addend _ _ _ = __IMPOSSIBLE__--copyarg :: MExp o -> Bool-copyarg _ = False---- -----------------------------------type HNNBlks o = [HNExp o]--noblks :: HNNBlks o-noblks = []--addblk :: HNExp o -> HNNBlks o -> HNNBlks o-addblk = (:)--hnn :: ICExp o -> EE (MyMB (HNExp o) o)-hnn e = mbcase (hnn_blks e) $ \(hne, _) -> mbret hne--hnn_blks :: ICExp o -> EE (MyMB (HNExp o, HNNBlks o) o)-hnn_blks e = hnn' e CALNil--hnn_checkstep :: ICExp o -> EE (MyMB (HNExp o, Bool) o)-hnn_checkstep e =- mbcase (hnb e CALNil) $ \hne ->-  mbcase (iotastep True hne) $ \res -> case res of-   Right _ -> mbret (hne, False)-   Left (e, as) ->-    mbcase (hnn' e as) $ \(hne, _) -> mbret (hne, True)---hnn' :: ICExp o -> ICArgList o -> EE (MyMB (HNExp o, HNNBlks o) o)-hnn' e as =- mbcase (hnb e as) $ \hne ->-  mbcase (iotastep True hne) $ \res -> case res of-   Right blks -> mbret (hne, blks)-   Left (e, as) -> hnn' e as--hnb :: ICExp o -> ICArgList o -> EE (MyMB (HNExp o) o)-hnb e as = mbcase (hnc False e as []) $ \res -> case res of-            HNDone _ hne -> mbret hne-            HNMeta{} -> __IMPOSSIBLE__--data HNRes o = HNDone (Maybe (Metavar (Exp o) (RefInfo o))) (HNExp o)-             | HNMeta (ICExp o) (ICArgList o) [Maybe (UId o)]--hnc :: Bool -> ICExp o -> ICArgList o -> [Maybe (UId o)] -> EE (MyMB (HNRes o) o)-hnc haltmeta = loop- where-  loop ce@(Clos cl e) cargs seenuids =-   (if haltmeta then mmmcase e (mbret $ HNMeta ce cargs seenuids) else mmcase e) $-   \ee -> case ee of-    App uid okh elr args ->-     let ncargs = CALConcat (Clos cl args) cargs-     in case elr of-      Var v -> case doclos cl v of-       Left v' -> mbret $ HNDone expmeta-                        $ WithSeenUIds (uid : seenuids)-                        $ HNApp (Var v') ncargs-       Right f -> loop f ncargs (uid : seenuids)-      Const _ -> mbret $ HNDone expmeta-                       $ WithSeenUIds (uid : seenuids)-                       $ HNApp elr ncargs-    Lam hid (Abs id b) ->-     mbcase (hnarglist cargs) $ \hncargs -> case hncargs of-      HNALNil -> mbret $ HNDone expmeta-                       $ WithSeenUIds seenuids-                       $ HNLam hid (Abs id (Clos (Skip : cl) b))-      HNALCons _ arg cargs' -> loop (Clos (Sub arg : cl) b) cargs' seenuids--      HNALConPar{} -> __IMPOSSIBLE__--    Pi uid hid possdep it (Abs id ot) ->-       checkNoArgs cargs $ mbret $ HNDone expmeta-         $ WithSeenUIds (uid : seenuids)-         $ HNPi hid possdep (Clos cl it) (Abs id (Clos (Skip : cl) ot))-    Sort s -> checkNoArgs cargs $ mbret-            $ HNDone expmeta $ WithSeenUIds [] $ HNSort s--    AbsurdLambda{} -> mbfailed "hnc: encountered absurdlambda"---   where expmeta = case e of {Meta m -> Just m; NotM _ -> Nothing}-  checkNoArgs cargs c =-   mbcase (hnarglist cargs) $ \hncargs -> case hncargs of-    HNALNil -> c-    HNALCons{} -> mbfailed "hnc: there should be no args"--    HNALConPar{} -> __IMPOSSIBLE__---hnarglist :: ICArgList o -> EE (MyMB (HNArgList o) o)-hnarglist args =- case args of-  CALNil -> mbret HNALNil-  CALConcat (Clos cl args) args2 ->-   mmcase args $ \args -> case args of-    ALNil -> hnarglist args2-    ALCons hid arg argsb -> mbret $ HNALCons hid (Clos cl arg) (CALConcat (Clos cl argsb) args2)--    ALProj{} -> mbret HNALNil -- dirty hack to make check of no-iota in term work---    ALConPar args -> mbret $ HNALConPar (CALConcat (Clos cl args) args2)--- -------------------------------getNArgs :: Nat -> ICArgList o -> EE (MyMB (Maybe ([ICExp o], ICArgList o)) o)-getNArgs 0 args = mbret $ Just ([], args)-getNArgs narg args =- mbcase (hnarglist args) $ \hnargs -> case hnargs of-  HNALNil -> mbret Nothing-  HNALCons _ arg args' ->-   mbcase (getNArgs (narg - 1) args') $ \res -> case res of-    Nothing -> mbret Nothing-    Just (pargs, rargs) -> mbret $ Just (arg : pargs, rargs)--  HNALConPar{} -> __IMPOSSIBLE__---getAllArgs :: ICArgList o -> EE (MyMB [ICExp o] o)-getAllArgs args =- mbcase (hnarglist args) $ \hnargs -> case hnargs of-  HNALNil -> mbret []-  HNALCons _ arg args' ->-   mbcase (getAllArgs args') $ \args'' ->-    mbret (arg : args'')--  HNALConPar args2 ->-   mbcase (getAllArgs args2) $ \args3 -> mbret (__IMPOSSIBLE__ : args3)---data PEval o = PENo (ICExp o)-             | PEConApp (ICExp o) (ConstRef o) [PEval o]--iotastep :: Bool -> HNExp o -> EE (MyMB (Either (ICExp o, ICArgList o) (HNNBlks o)) o)-iotastep smartcheck e = case rawValue e of- HNApp (Const c) args -> do-  cd <- readIORef c-  case cdcont cd of-   Def narg cls _ _ ->-    mbcase (getNArgs narg args) $ \res -> case res of-     Nothing -> mbret (Right noblks)-     Just (pargs, rargs) ->-      mbcase (dorules cls (map PENo pargs)) $ \res -> case res of-       Right blks -> mbret (Right blks)-       Left rhs -> mbret $ Left (rhs, rargs)-   _ -> mbret $ Right noblks- _ -> mbret $ Right noblks- where- dorules :: [Clause o] -> [PEval o] -> EE (MyMB (Either (ICExp o) (HNNBlks o)) o)- dorules [] _ = mbret $ Right noblks- dorules (rule:rules') as =-  mbcase (dorule rule as) $ \x -> case x of-   Left (Left as') -> dorules rules' as'-   Left (Right blks) -> mbret (Right blks)-   Right rhs -> mbret $ Left rhs-- dorule :: Clause o -> [PEval o] -> EE (MyMB (Either (Either [PEval o] (HNNBlks o)) (ICExp o)) o)- dorule (pats, rhs) as =-  mbcase (dopats pats as) $ \x -> case x of-   Right (_, ss) -> mbret $ Right (Clos (map Sub ss) rhs)-   Left hnas -> mbret $ Left hnas-- dopats :: [Pat o] -> [PEval o] -> EE (MyMB (Either (Either [PEval o] (HNNBlks o)) ([PEval o], [ICExp o])) o)- dopats [] [] = mbret $ Right ([], [])- dopats (p:ps') (a:as') =-  mbcase (dopat p a) $ \x -> case x of-   Right (hna, ss) ->-    mbcase (dopats ps' as') $ \x -> case x of-     Right (hnas, ss2) -> mbret $ Right (hna : hnas, ss2 ++ ss)-     Left (Right blks) -> mbret $ Left (Right blks)-     Left (Left hnas) -> mbret $ Left $ Left (hna : hnas)-   Left (Right blks) -> mbret $ Left (Right blks)-   Left (Left hna) -> mbret $ Left $ Left (hna : as')- dopats _ _ = mbfailed "bad patterns"-- dopat :: Pat o -> PEval o -> EE (MyMB (Either (Either (PEval o) (HNNBlks o)) (PEval o, [ICExp o])) o)- dopat (PatConApp c pas) a =-  case a of-   PENo a ->-    if smartcheck then-     mbcase (meta_not_constructor a) $ \notcon -> if notcon then mbret $ Left $ Right noblks else qq -- to know more often if iota step is possible-    else-     qq-    where-     qq =-      mbcase (hnn_blks a) $ \(hna, blks) -> case rawValue hna of-       HNApp (Const c') as ->-        if c == c' then-         mbcase (getAllArgs as) $ \as' ->-          if length as' == length pas then-           mbcase (dopats pas (map PENo as')) $ \x -> case x of-            Right (hnas, ss) -> mbret $ Right (PEConApp a c' hnas, ss)-            Left (Right blks) -> mbret $ Left (Right blks)-            Left (Left hnas) -> mbret $ Left $ Left (PEConApp a c' hnas)-          else-           mbfailed "dopat: wrong amount of args"-        else do-         cd <- readIORef c'-         case cdcont cd of-          Constructor{} -> mbcase (getAllArgs as) $ \as' ->-           mbret $ Left (Left (PEConApp a c' (map PENo as')))-          _ -> mbret $ Left (Right (addblk hna blks))-       _ -> mbret $ Left (Right (addblk hna blks))-   aa@(PEConApp a c' as) ->-    if c == c' then-     if length as == length pas then-      mbcase (dopats pas as) $ \x -> case x of-       Right (hnas, ss) -> mbret $ Right (PEConApp a c' hnas, ss)-       Left (Right blks) -> mbret $ Left (Right blks)-       Left (Left hnas) -> mbret $ Left $ Left (PEConApp a c' hnas)-     else-      mbfailed "dopat: wrong amount of args"-    else-     mbret $ Left (Left aa)- dopat PatVar{} a@(PENo a') = mbret $ Right (a, [a'])- dopat PatVar{} a@(PEConApp a' _ _) = mbret $ Right (a, [a'])- dopat PatExp a = mbret $ Right (a, [])---- -------------------------------noiotastep :: HNExp o -> EE (MyPB o)-noiotastep hne =- mbpcase prioNoIota Nothing (iotastep False hne) $ \res -> case res of-  Left _ -> mpret $ Error "iota step possible contrary to assumed"-  Right _ -> mpret OK--noiotastep_term :: ConstRef o -> MArgList o -> EE (MyPB o)-noiotastep_term c args = do-  cd <- readIORef c-  case cdcont cd of-    Def _ [(pats, _)] _ _ -> mpret OK-      -- all (\pat -> case pat of {PatConApp{} -> False; _ -> True}) pats-    _ -> noiotastep $ WithSeenUIds []-                    $ HNApp (Const c) $ CALConcat (Clos [] args) CALNil--data CMode o = CMRigid (Maybe (Metavar (Exp o) (RefInfo o))) (HNExp o)-             | forall b . Refinable b (RefInfo o) => CMFlex (MM b (RefInfo o)) (CMFlex o)-data CMFlex o = CMFFlex (ICExp o) (ICArgList o) [Maybe (UId o)]-              | CMFSemi (Maybe (Metavar (Exp o) (RefInfo o))) (HNExp o)-              | CMFBlocked (Maybe (Metavar (Exp o) (RefInfo o))) (HNExp o)--comp' :: forall o . Bool -> CExp o -> CExp o -> EE (MyPB o)-comp' ineq lhs@(TrBr trs1 e1) rhs@(TrBr trs2 e2) = comp ineq e1 e2- where-  comp :: Bool -> ICExp o -> ICExp o -> EE (MyPB o)-  comp ineq e1 e2 =-   proc e1 e2--   where-    proc e1 e2 = f True e1 CALNil [] $ \res1 -> f True e2 CALNil [] $ \res2 -> g res1 res2-    f semifok e as seenuids cont =-     mbpcase prioCompBeta Nothing (hnc True e as seenuids) $ \res ->-      case res of-       HNDone mexpmeta hne -> fhn semifok mexpmeta hne cont--       HNMeta ce@(Clos cl m) cargs seenuids -> do-        b1 <- boringClos cl-        b2 <- boringArgs cargs-        if b1 && b2 then-          cont $ CMFlex m (CMFFlex ce cargs seenuids)-         else-          mbpcase prioCompBetaStructured Nothing (hnc False ce cargs seenuids) $ \res ->-           case res of-            HNDone mexpmeta hne -> cont $ CMFlex m (CMFBlocked mexpmeta hne)-            HNMeta{} -> __IMPOSSIBLE__---    fhn semifok mexpmeta hne cont =-     mmbpcase (iotastep True hne)-      (\m -> do-        let sf = False {- semiflex hne -}-        if semifok && sf then-          cont (CMFlex m (CMFSemi mexpmeta hne))-         else-          cont (CMFlex m (CMFBlocked mexpmeta hne))-      )-      (\res -> case res of-        Right _ -> cont (CMRigid mexpmeta hne)-        Left (e, as) -> f semifok e as [] cont-      )-    g res1 res2 =-     case (res1, res2) of-      (CMRigid mexpmeta1 hne1, CMRigid mexpmeta2 hne2) -> comphn ineq mexpmeta1 hne1 mexpmeta2 hne2-      (CMFlex m1 (CMFBlocked mexpmeta1 hne1), _) -> mstp False mexpmeta1 hne1 $ \res1 -> g res1 res2-      (_, CMFlex m2 (CMFBlocked mexpmeta2 hne2)) -> mstp False mexpmeta2 hne2 $ \res2 -> g res1 res2-      (CMRigid mexpmeta1 hne1, CMFlex _ fl2) -> unif True mexpmeta1 hne1 fl2-      (CMFlex _ fl1, CMRigid mexpmeta2 hne2) -> unif False mexpmeta2 hne2 fl1---      (CMFlex m1 fl1, CMFlex m2 fl2) -> doubleblock m1 m2 $ fcm fl1 $ \res1 -> fcm fl2 $ \res2 -> g res1 res2-    fcm (CMFFlex ce cargs seenuids) = f True ce cargs seenuids-    fcm (CMFSemi mexpmeta hne) = fhn True mexpmeta hne-    fcm (CMFBlocked _ hne) = __IMPOSSIBLE__ -- not used. if so should be: fhn False hne-    mstp semif mexpmeta hne cont =-     mpret $ Or prioCompChoice-      (mpret $ And (Just [Term lhs, Term rhs])-       (noiotastep hne)-       (cont (CMRigid mexpmeta hne))-      )-      (stp semif hne cont)-    stp semif hne cont =-     mbpcase prioCompIota (Just $ RIIotaStep semif) (iotastep True hne) $ \res -> case res of-      Right _ -> mpret $ Error "no iota step possible, contrary to assumed"-      Left (e, as) -> f semif e as [] cont-    unif oppis1 oppmexpmeta opphne res =-     let iter res = if oppis1 then-                     g (CMRigid oppmexpmeta opphne) res-                    else-                     g res (CMRigid oppmexpmeta opphne)-     in case res of-      CMFFlex ce cargs seenuids -> do-       poss <- iotapossmeta ce cargs-       maybeor poss prioCompChoice-        (loop ce cargs seenuids)--- (mbpcase prioCompBeta (Just $ RIIotaStep False) (hnb ce cargs) $ \hne ->-        (mbpcase prioCompBeta (Just $ RIIotaStep False) (hnc False ce cargs seenuids) $ \res ->-          -- RIIotaStep here on beta-norm to make cost high when guessing elim const in type par-          case res of-           HNDone mexpmeta hne -> stp False hne iter-           HNMeta{} -> __IMPOSSIBLE__-        )-       where-        loop ce@(Clos cl m) cargs seenuids =-         mmpcase (False, prioCompUnif, Just (RIUnifInfo cl opphne)) m $ \_ ->-         mbpcase prioCompBeta Nothing (hnc True ce cargs seenuids) $ \res -> case res of-          HNDone mexpmeta hne ->-           mpret $ And (Just [Term lhs, Term rhs])-            (noiotastep hne)-            (iter (CMRigid mexpmeta hne))-          HNMeta ce cargs seenuids -> loop ce cargs seenuids-      CMFSemi _ hne ->-       __IMPOSSIBLE__ -- CMFSemi disabled, if used should be: stp True hne iter-      CMFBlocked{} -> __IMPOSSIBLE__-    comphn :: Bool -> Maybe (Metavar (Exp o) (RefInfo o)) -> HNExp o -> Maybe (Metavar (Exp o) (RefInfo o)) -> HNExp o -> EE (MyPB o)-    comphn ineq mexpmeta1 hne1 mexpmeta2 hne2 =-     case (rawValue hne1, rawValue hne2) of-      (HNApp elr1 args1, HNApp elr2 args2) ->-       let ce = case (elr1, elr2) of-                 (Var v1, Var v2) ->-                     if v1 == v2 then Nothing-                     else Just "comphn, elr, vars not equal"-                 (Const c1, Const c2) ->-                    if c1 == c2 then Nothing-                    else Just "comphn, elr, consts not equal"-                 (_, _) -> Just "comphn, elrs not equal"-       in case ce of-            Nothing -> compargs args1 args2-            Just msg -> mpret $ Error msg-      (HNLam hid1 (Abs id1 b1), HNLam hid2 (Abs id2 b2)) -> comp False b1 b2-      (HNLam _ (Abs _ b1), HNApp elr2 args2) ->-       f True b1 CALNil (seenUIds hne1) $ \res1 ->-       fhn True mexpmeta2 (WithSeenUIds (seenUIds hne2) $ HNApp (weak 1 elr2) (addtrailingargs (Clos [] $ NotM $ ALCons NotHidden{- arbitrary -} (NotM $ App Nothing (NotM OKVal) (Var 0) (NotM ALNil)) (NotM ALNil)) (weak 1 args2))) $ \res2 -> g res1 res2-      (HNApp elr1 args1, HNLam _ (Abs _ b2)) ->-       fhn True mexpmeta1 (WithSeenUIds (seenUIds hne1) $ HNApp (weak 1 elr1) (addtrailingargs (Clos [] $ NotM $ ALCons NotHidden{- arbitrary -} (NotM $ App Nothing (NotM OKVal) (Var 0) (NotM ALNil)) (NotM ALNil)) (weak 1 args1))) $ \res1 -> f True b2 CALNil (seenUIds hne2) $ \res2 -> g res1 res2-{--      (HNLam _ (Abs _ b1), HNApp uid2 elr2 args2) ->-       f True b1 CALNil $ \res1 -> g res1-        (CMRigid mexpmeta2 (HNApp uid2 (weak 1 elr2) (addtrailingargs (Clos [] $ NotM $ ALCons NotHidden{- arbitrary -} (NotM $ App Nothing (NotM OKVal) (Var 0) (NotM ALNil)) (NotM ALNil)) (weak 1 args2))))-      (HNApp uid1 elr1 args1, HNLam _ (Abs _ b2)) ->-       f True b2 CALNil $ \res2 -> g-        (CMRigid mexpmeta1 (HNApp uid1 (weak 1 elr1) (addtrailingargs (Clos [] $ NotM $ ALCons NotHidden{- arbitrary -} (NotM $ App Nothing (NotM OKVal) (Var 0) (NotM ALNil)) (NotM ALNil)) (weak 1 args1))))-        res2--}-      (HNPi hid1 _ it1 (Abs id1 ot1), HNPi hid2 _ it2 (Abs id2 ot2)) -> mpret $-       And (Just [Term trs1, Term trs2]) (comp False it1 it2) (comp ineq ot1 ot2)-      (HNSort s1, HNSort s2) -> mpret $-       case (s1, s2) of-        (Set i1, Set i2) -> if i1 == i2 || ineq && i1 > i2 then OK else Error "comphn, set levels not matching"-        (Set _, UnknownSort) -> OK-        (UnknownSort, Set _) -> OK-        (UnknownSort, UnknownSort) -> OK-        (Type, Set _) | ineq -> OK-        (Type, UnknownSort) | ineq -> OK-        _ -> __IMPOSSIBLE__-      (HNApp (Const c1) _, _) -> case mexpmeta2 of-       Nothing -> mpret $ Error "comphn, not equal (2)"-       Just m2 -> mpret $ AddExtraRef "comphn: not equal, adding extra ref"-                          m2 (extraref m2 (seenUIds hne1) c1)-      (_, HNApp (Const c2) _) -> case mexpmeta1 of-       Nothing -> mpret $ Error "comphn, not equal (3)"-       Just m1 -> mpret $ AddExtraRef "comphn: not equal, adding extra ref"-                          m1 (extraref m1 (seenUIds hne2) c2)-      (_, _) -> mpret $ Error "comphn, not equal"--    compargs :: ICArgList o -> ICArgList o -> EE (MyPB o)-    compargs args1 args2 =-     mbpcase prioCompareArgList Nothing (hnarglist args1) $ \hnargs1 ->-     mbpcase prioCompareArgList Nothing (hnarglist args2) $ \hnargs2 ->-     case (hnargs1, hnargs2) of-      (HNALNil, HNALNil) -> mpret OK-      (HNALCons hid1 arg1 args1b, HNALCons hid2 arg2 args2b) -> mpret $-       And (Just [Term trs1, Term trs2]) (comp False arg1 arg2) (compargs args1b args2b)--      (HNALConPar args1b, HNALCons _ _ args2b) -> compargs args1b args2b-      (HNALCons _ _ args1b, HNALConPar args2b) -> compargs args1b args2b-      (HNALConPar args1', HNALConPar args2') -> compargs args1' args2'--      (_, _) -> mpret $ Error $ "comphnargs, not equal"---    boringExp :: ICExp o -> EE Bool-    boringExp (Clos cl e) = do-     e <- expandbind e-     case e of-      Meta{} -> boringClos cl-      NotM e -> case e of-       App _ _ (Var v) as -> do-        as <- expandbind as-        case as of-         Meta{} -> return False-         NotM as -> case as of-          ALNil -> case doclos cl v of-           Left _ -> return True-           Right e -> boringExp e-          ALCons{} -> return False-          ALProj{} -> return False-          ALConPar{} -> return False--       _ -> return False--    boringClos :: [CAction o] -> EE Bool-    boringClos cl = and <$> mapM f cl-     where f (Sub e) = boringExp e-           f Skip = return True-           f (Weak _) = return True--    boringArgs :: ICArgList o -> EE Bool-    boringArgs CALNil = return True-    boringArgs (CALConcat (Clos cl as) as2) = do-     b1 <- f cl as-     b2 <- boringArgs as2-     return $ b1 && b2-     where-      f cl as = do-       as <- expandbind as-       case as of-        Meta{} -> return False-        NotM as -> case as of-         ALNil -> return True-         ALCons _ a as -> do-          b1 <- boringExp (Clos cl a)-          b2 <- f cl as-          return $ b1 && b2--         ALProj{} -> return False  -- Not impossible: #2966---         ALConPar as -> f cl as--- -----------------------------------checkeliminand :: MExp o -> EE (MyPB o)-checkeliminand = f [] []- where-  f uids used e =-   mmpcase (False, prioNo, Just (RIUsedVars uids used)) e $ \e -> case e of-    App uid _ elr@(Var{}) args -> fs (adduid uid uids) (elr : used) args-    App uid _ elr@(Const c) args -> do-     cd <- readIORef c-     case cdcont cd of-      Def _ _ (Just i) _ -> mpret $ Sidecondition (fs (adduid uid uids) (elr : used) args) (g i args)-       where-        g i as = mmpcase (False, prioNo, Nothing) as $ \as -> case as of-                  ALNil -> mpret OK-                  ALCons _ a as -> case i of-                   0 -> mmpcase (False, prioNo, Just RINotConstructor) a $ \_ ->-                         mpret OK-                   _ -> g (i - 1) as--                  ALProj eas _ _ as -> mpret OK---                  ALConPar as -> case i of-                   0 -> __IMPOSSIBLE__-                   _ -> g (i - 1) as--      _ -> fs (adduid uid uids) (elr : used) args-    Lam _ (Abs _ e) -> f uids (w used) e-    Pi uid _ _ e1 (Abs _ e2) -> mpret $ Sidecondition (f (adduid uid uids) used e1) (f (adduid uid uids) (w used) e2)-    Sort _ -> mpret OK--    AbsurdLambda{} -> mpret OK---  fs uids used as =-   mmpcase (False, prioNo, Nothing) as $ \as -> case as of-    ALNil -> mpret OK-    ALCons _ a as -> mpret $ Sidecondition (f uids used a) (fs uids used as)--    ALProj eas _ _ as -> mpret $ Sidecondition (fs uids used eas) (fs uids used as)---    ALConPar as -> fs uids used as--  w = map (\x -> case x of {Var v -> Var (v + 1); Const{} -> x})-  adduid (Just uid) uids = uid : uids-  adduid Nothing uids = uids---- -----------------------------------maybeor :: Bool -> Prio -> IO (PB (RefInfo o)) -> IO (PB (RefInfo o)) ->-           IO (PB (RefInfo o))-maybeor _ _ mainalt _ = mainalt--iotapossmeta :: ICExp o -> ICArgList o -> EE Bool-iotapossmeta ce@(Clos cl _) cargs = do- xs <- mapM ncaction cl- y <- nccargs cargs- return $ not (and xs && y)- where-  ncaction (Sub ce) = nonconstructor ce-  ncaction Skip = return True-  ncaction (Weak{}) = return True-  nccargs CALNil = return True-  nccargs (CALConcat (Clos cl margs) cargs) = do-   x <- ncmargs cl margs-   y <- nccargs cargs-   return $ x && y-  ncmargs cl (Meta m) = do-   mb <- readIORef (mbind m)-   case mb of-    Nothing -> return False-    Just x -> ncargs cl x-  ncmargs cl (NotM args) = ncargs cl args-  ncargs cl ALNil = return True-  ncargs cl (ALCons _ a args) = do-   x <- nonconstructor (Clos cl a)-   y <- ncmargs cl args-   return $ x && y--  ncargs _ (ALProj{}) = __IMPOSSIBLE__---  ncargs cl (ALConPar args) = ncmargs cl args--  nonconstructor :: ICExp o -> EE Bool-  nonconstructor ce = do-   res <- hnc True ce CALNil []-   case res of-    Blocked{} -> return False-    Failed{} -> return False-    NotB res -> case res of-     HNMeta ce _ _ -> do-      let (Clos _ (Meta m)) = ce-      infos <- extractblkinfos m-      if any (\info -> case info of {RINotConstructor -> True; _ -> False}) infos then do-        return True-       else-        return False-      -- return False -- return True -- ?? removes completeness - Yes, in DavidW1.additionRight-     HNDone{} -> do-      res <- hnn ce-      case res of-       NotB hne -> case rawValue hne of-        HNApp (Const c) _ -> do-         cd <- readIORef c-         case cdcont cd of-          Constructor{} -> return False-          _ -> return True-        _ -> return True-       Blocked m _ -> return False -- not necessary to do check here because already done by hnn (!! if it's known that m stands for an eliminator then it cannot be constructor so True instead)-       Failed _ -> return False--meta_not_constructor :: ICExp o -> EE (MB Bool (RefInfo o))-meta_not_constructor a =- mbcase (hnc True a CALNil []) $ \res -> case res of-  HNMeta ce _ _ -> do-    let (Clos _ (Meta m)) = ce-    infos <- extractblkinfos m-    if any (\info -> case info of {RINotConstructor -> True; _ -> False}) infos then do-      b <- iotapossmeta ce CALNil-      mbret $ not b-     else-      mbret False-  HNDone{} -> mbret False---- -----------------------------------calcEqRState :: EqReasoningConsts o -> MExp o -> EE (MyPB o)-calcEqRState cs = f EqRSNone- where-  f s e =-   mmpcase (False, prioNo, Just (RIEqRState s)) e $ \e -> case e of-    App _ _ (Const c) args -> case () of-     _ | c == eqrcBegin cs -> fs [EqRSNone, EqRSNone, EqRSNone, EqRSNone, EqRSChain] args-     _ | c == eqrcStep cs -> fs [EqRSNone, EqRSNone, EqRSNone, EqRSNone, EqRSNone, EqRSPrf1, EqRSChain] args-     _ | c == eqrcSym cs -> fs [EqRSNone, EqRSNone, EqRSNone, EqRSNone, EqRSPrf2] args-     _ | c == eqrcCong cs -> fs [EqRSNone, EqRSNone, EqRSNone, EqRSNone, EqRSNone, EqRSNone, EqRSNone, EqRSPrf3] args-     _ -> fs [] args-    App _ _ (Var{}) args -> fs [] args-    Lam _ (Abs _ b) -> f EqRSNone b-    Pi _ _ _ it (Abs _ ot) -> mpret $ Sidecondition (f EqRSNone it) (f EqRSNone ot)-    Sort{} -> mpret OK--    AbsurdLambda{} -> mpret OK---  fs ss args =-   mmpcase (False, prioNo, Nothing) args $ \args -> case (ss, args) of-    (_, ALNil) -> mpret OK-    (s : ss, ALCons _ a args) -> mpret $ Sidecondition (f s a) (fs ss args)-    ([], ALCons _ a args) -> mpret $ Sidecondition (f EqRSNone a) (fs [] args)--    (_, ALProj eas _ _ as) -> mpret $ Sidecondition (fs [] eas) (fs [] as) -- when eqr-hint is given manually, ss can be non-empty here---    (_ : ss, ALConPar args) -> fs ss args-    ([], ALConPar args) -> fs [] args---- -----------------------------------pickid :: MId -> MId -> MId-pickid mid1@(Id _) _ = mid1-pickid _ mid2 = mid2---- -----------------------------------tcSearch :: Bool -> Ctx o -> CExp o -> MExp o -> EE (MyPB o)-tcSearch isdep ctx typ trm = mpret $ Sidecondition (checkeliminand trm)-                              (tcExp isdep ctx typ trm)---- ----------------------------
src/full/Agda/Benchmarking.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# OPTIONS_GHC -fno-warn-orphans #-}  -- | Agda-specific benchmarking structure.@@ -13,13 +15,12 @@  import System.IO.Unsafe -import Agda.Syntax.Concrete.Name (TopLevelModuleName)-import Agda.Syntax.Concrete.Pretty () --instance only import Agda.Syntax.Abstract.Name+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName) import Agda.Utils.Benchmark (MonadBench(..)) import qualified Agda.Utils.Benchmark as B import Agda.Utils.Null-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty  -- | Phases to allocate CPU time to. data Phase@@ -48,7 +49,11 @@   | Serialization     -- ^ Writing interface files.   | DeadCode-    -- ^ Deac code elimination.+    -- ^ Dead code elimination.+  | InterfaceInstantiateFull+    -- ^ Unfolding all metas before serialization.+  | DeadCodeReachable+    -- ^ Dead code reachable definitions subphase.   | Graph     -- ^ Subphase for 'Termination'.   | RecCheck@@ -91,11 +96,22 @@     -- ^ Subphase for 'Typing': generalizing over `variable`s   | InstanceSearch     -- ^ Subphase for 'Typing': solving instance goals+  | Reflection+    -- ^ Subphase for 'Typing': evaluating elaborator reflection+  | InitialCandidates+    -- ^ Subphase for 'InstanceSearch': collecting initial candidates+  | FilterCandidates+    -- ^ Subphase for 'InstanceSearch': checking candidates for validity+  | OrderCandidates+    -- ^ Subphase for 'InstanceSearch': ordering candidates for specificity+  | CheckOverlap+    -- ^ Subphase for 'InstanceSearch': reducing overlapping instances   | UnifyIndices     -- ^ Subphase for 'CheckLHS': unification of the indices   | InverseScopeLookup     -- ^ Pretty printing names.   | TopModule TopLevelModuleName+  | Typeclass QName   | Definition QName   deriving (Eq, Ord, Show, Generic) @@ -144,3 +160,4 @@ -- | Benchmark a pure computation and bill it to the given account. billToPure :: Account -> a -> a billToPure acc a = unsafePerformIO $ billToIO acc $ return a+{-# NOINLINE billToPure #-}
src/full/Agda/Compiler/Backend.hs view
@@ -1,171 +1,99 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PolyKinds #-}-+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Interface for compiler backend writers. module Agda.Compiler.Backend-  ( Backend(..), Backend'(..), Recompile(..), IsMain(..)+  ( module Agda.Compiler.Backend.Base+  , Recompile(..), IsMain(..)   , Flag   , toTreeless   , module Agda.Syntax.Treeless   , module Agda.TypeChecking.Monad   , module CheckResult-  , activeBackendMayEraseType     -- For Agda.Main   , backendInteraction   , parseBackendOptions     -- For InteractionTop   , callBackend-    -- Tools-  , lookupBackend-  , activeBackend+  , callBackendInteractTop+  , callBackendInteractHole   ) where -import Control.DeepSeq-import Control.Monad              ( (<=<) )-import Control.Monad.Trans        ( lift )-import Control.Monad.Trans.Maybe+import Prelude hiding (null) -import qualified Data.List as List-import Data.Maybe+import Control.DeepSeq -import Data.Map (Map) import qualified Data.Map as Map--import GHC.Generics (Generic)+import qualified Data.Set as Set -import System.Console.GetOpt+import Agda.Utils.GetOpt -import Agda.Syntax.Treeless-import Agda.TypeChecking.Errors (getAllWarnings)--- Agda.TypeChecking.Monad.Base imports us, relying on the .hs-boot file to--- resolve the circular dependency. Fine. However, ghci loads the module after--- compilation, so it brings in all of the symbols. That causes .Base to see--- getBenchmark (defined in Agda.TypeChecking.Monad.State) *and* the one--- defined in Agda.Utils.Benchmark, which causes an error. So we explicitly--- hide it here to prevent it from being seen there and causing an error.-import Agda.TypeChecking.Monad hiding (getBenchmark)-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Pretty as P+import Agda.Compiler.Backend.Base+import Agda.Compiler.Common+import Agda.Compiler.ToTreeless  import Agda.Interaction.Options import Agda.Interaction.FindFile import Agda.Interaction.Imports as CheckResult (CheckResult(CheckResult), crInterface, crWarnings, crMode)++import Agda.Syntax.Common (BackendName)+import Agda.Syntax.Treeless++import Agda.TypeChecking.Errors (getAllWarnings)+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Pretty import Agda.TypeChecking.Warnings +import Agda.Utils.CallStack (HasCallStack) import Agda.Utils.FileName import Agda.Utils.Functor import Agda.Utils.IndexedList import Agda.Utils.Lens import Agda.Utils.Monad--import Agda.Compiler.ToTreeless-import Agda.Compiler.Common+import Agda.Utils.Null+import Agda.Utils.Maybe+import Agda.Syntax.Common (InteractionId)+import Agda.Syntax.Position (Range) -import Agda.Utils.Impossible+import Agda.Interaction.Command (CommandM)  -- Public interface ------------------------------------------------------- -data Backend where-  Backend :: NFData opts => Backend' opts env menv mod def -> Backend--data Backend' opts env menv mod def = Backend'-  { backendName      :: String-  , backendVersion   :: Maybe String-      -- ^ Optional version information to be printed with @--version@.-  , options          :: opts-      -- ^ Default options-  , commandLineFlags :: [OptDescr (Flag opts)]-      -- ^ Backend-specific command-line flags. Should at minimum contain a-      --   flag to enable the backend.-  , isEnabled        :: opts -> Bool-      -- ^ Unless the backend has been enabled, @runAgda@ will fall back to-      --   vanilla Agda behaviour.-  , preCompile       :: opts -> TCM env-      -- ^ Called after type checking completes, but before compilation starts.-  , postCompile      :: env -> IsMain -> Map ModuleName mod -> TCM ()-      -- ^ Called after module compilation has completed. The @IsMain@ argument-      --   is @NotMain@ if the @--no-main@ flag is present.-  , preModule        :: env -> IsMain -> ModuleName -> Maybe FilePath -> TCM (Recompile menv mod)-      -- ^ Called before compilation of each module. Gets the path to the-      --   @.agdai@ file to allow up-to-date checking of previously written-      --   compilation results. Should return @Skip m@ if compilation is not-      --   required. Will be @Nothing@ if only scope checking.-  , postModule       :: env -> menv -> IsMain -> ModuleName -> [def] -> TCM mod-      -- ^ Called after all definitions of a module have been compiled.-  , compileDef       :: env -> menv -> IsMain -> Definition -> TCM def-      -- ^ Compile a single definition.-  , scopeCheckingSuffices :: Bool-      -- ^ True if the backend works if @--only-scope-checking@ is used.-  , mayEraseType     :: QName -> TCM Bool-      -- ^ The treeless compiler may ask the Backend if elements-      --   of the given type maybe possibly erased.-      --   The answer should be 'False' if the compilation of the type-      --   is used by a third party, e.g. in a FFI binding.-  }-  deriving Generic+-- | Call the 'compilerMain' function of the given backend.+callBackend :: BackendName -> IsMain -> CheckResult -> TCM ()+callBackend name iMain checkResult =+  withKnownBackend name $ \(Backend b) ->+    compilerMain b iMain checkResult -data Recompile menv mod = Recompile menv | Skip mod+-- | Call the 'backendInteractTop' function of the given backend.+callBackendInteractTop :: BackendName -> String -> CommandM ()+callBackendInteractTop name cmd =+  withKnownBackend name $ \(Backend b) ->+    whenJust (backendInteractTop b) \bi ->+      bi cmd --- | Call the 'compilerMain' function of the given backend.+-- | Call the 'backendInteractHole' function of the given backend.+callBackendInteractHole ::+  BackendName -> String -> InteractionId -> Range -> String -> CommandM ()+callBackendInteractHole name cmd ii rng s =+  withKnownBackend name $ \(Backend b) ->+    whenJust (backendInteractHole b) \bi ->+      bi cmd ii rng s -callBackend :: String -> IsMain -> CheckResult -> TCM ()-callBackend name iMain checkResult = lookupBackend name >>= \case-  Just (Backend b) -> compilerMain b iMain checkResult-  Nothing -> do-    backends <- useTC stBackends-    genericError $-      "No backend called '" ++ name ++ "' " ++-      "(installed backends: " ++-      List.intercalate ", "-        (List.sort $ otherBackends ++-                     [ backendName b | Backend b <- backends ]) ++-      ")"+-- | Run a monadic action given an existing backend.+-- Throws an error if the user requested an unknown backend.+withKnownBackend ::+  (MonadTCError m, ReadTCState m) => BackendName -> (Backend -> m ()) -> m ()+withKnownBackend name k = ifJustM (lookupBackend name) k $ do+  backends <- useTC stBackends+  let backendSet = otherBackends ++ [ backendName b | Backend b <- backends ]+  typeError $ UnknownBackend name (Set.fromList backendSet)  -- | Backends that are not included in the state, but still available --   to the user.--otherBackends :: [String]+otherBackends :: [BackendName] otherBackends = ["GHCNoMain", "QuickLaTeX"] --- | Look for a backend of the given name.--lookupBackend :: BackendName -> TCM (Maybe Backend)-lookupBackend name = useTC stBackends <&> \ backends ->-  listToMaybe [ b | b@(Backend b') <- backends, backendName b' == name ]---- | Get the currently active backend (if any).--activeBackend :: TCM (Maybe Backend)-activeBackend = runMaybeT $ do-  bname <- MaybeT $ asksTC envActiveBackendName-  lift $ fromMaybe __IMPOSSIBLE__ <$> lookupBackend bname---- | Ask the active backend whether a type may be erased.---   See issue #3732.--activeBackendMayEraseType :: QName -> TCM Bool-activeBackendMayEraseType q = do-  Backend b <- fromMaybe __IMPOSSIBLE__ <$> activeBackend-  mayEraseType b q--instance NFData Backend where-  rnf (Backend b) = rnf b--instance NFData opts => NFData (Backend' opts env menv mod def) where-  rnf (Backend' a b c d e f g h i j k l) =-    rnf a `seq` rnf b `seq` rnf c `seq` rnf' d `seq` rnf e `seq`-    rnf f `seq` rnf g `seq` rnf h `seq` rnf i `seq` rnf j `seq`-    rnf k `seq` rnf l-    where-    rnf' []                   = ()-    rnf' (Option a b c d : e) =-      rnf a `seq` rnf b `seq` rnf'' c `seq` rnf d `seq` rnf' e--    rnf'' (NoArg a)    = rnf a-    rnf'' (ReqArg a b) = rnf a `seq` rnf b-    rnf'' (OptArg a b) = rnf a `seq` rnf b- -- Internals --------------------------------------------------------------  data BackendWithOpts opts where@@ -180,13 +108,13 @@ forgetOpts :: BackendWithOpts opts -> Backend forgetOpts (BackendWithOpts backend) = Backend backend -bOptions :: Lens' opts (BackendWithOpts opts)+bOptions :: Lens' (BackendWithOpts opts) opts bOptions f (BackendWithOpts b) = f (options b) <&> \ opts -> BackendWithOpts b{ options = opts } -embedFlag :: Lens' a b -> Flag a -> Flag b+embedFlag :: Lens' b a -> Flag a -> Flag b embedFlag l flag = l flag -embedOpt :: Lens' a b -> OptDescr (Flag a) -> OptDescr (Flag b)+embedOpt :: Lens' b a -> OptDescr (Flag a) -> OptDescr (Flag b) embedOpt l = fmap (embedFlag l)  parseBackendOptions :: [Backend] -> [String] -> CommandLineOptions -> OptM ([Backend], CommandLineOptions)@@ -211,25 +139,22 @@   checkResult <- check mainFile    -- reset warnings-  stTCWarnings `setTCLens` []+  stTCWarnings `setTCLens` empty    noMain <- optCompileNoMain <$> pragmaOptions   let isMain | noMain    = NotMain              | otherwise = IsMain -  unlessM (optAllowUnsolved <$> pragmaOptions) $ do-    let ws = crWarnings checkResult-        mode = crMode checkResult-    -- Possible warnings, but only scope checking: ok.-    -- (Compatibility with scope checking done during options validation).-    unless (mode == ModuleScopeChecked || null ws) $-      genericError $ "You can only compile modules without unsolved metavariables."-   sequence_ [ compilerMain backend isMain checkResult | Backend backend <- backends ]    -- print warnings that might have accumulated during compilation-  ws <- filter (not . isUnsolvedWarning . tcWarning) <$> getAllWarnings AllWarnings-  unless (null ws) $ reportSDoc "warning" 1 $ P.vcat $ P.prettyTCM <$> ws+  ws <- filter (not . isUnsolvedWarning . tcWarning) . Set.toAscList <$> getAllWarnings AllWarnings+  unless (null ws) $ alwaysReportSDoc "warning" 1 $+    -- Andreas, 2024-09-06 start warning list by a newline+    -- since type checker warnings are also newline separated.+    -- See e.g. test/Succeed/CompileBuiltinListWarning.warn.+    -- Also separate warnings by newlines (issue #6919).+    vcat $ concatMap (\ w -> [ "", prettyTCM w ]) ws   compilerMain :: Backend' opts env menv mod def -> IsMain -> CheckResult -> TCM ()@@ -238,15 +163,13 @@     -- BEWARE: Do not use @optOnlyScopeChecking@ here; it does not authoritatively describe the type-checking mode!     -- InteractionTop currently may invoke type-checking with scope checking regardless of that flag.     when (not (scopeCheckingSuffices backend) && crMode checkResult == ModuleScopeChecked) $-      genericError $-        "The --only-scope-checking flag cannot be combined with " ++-        backendName backend ++ "."+      typeError $ BackendDoesNotSupportOnlyScopeChecking $ backendName backend -    let i = crInterface checkResult+    !i <- instantiateFull $ crInterface checkResult     -- Andreas, 2017-08-23, issue #2714     -- If the backend is invoked from Emacs, we can only get the --no-main     -- pragma option now, coming from the interface file.-    isMain <- ifM (optCompileNoMain <$> pragmaOptions)+    !isMain <- ifM (optCompileNoMain <$> pragmaOptions)       {-then-} (return NotMain)       {-else-} (return isMain0) @@ -254,28 +177,30 @@     mods <- doCompile         -- This inner function is called for both `Agda.Primitive` and the module in question,         -- and all (distinct) imported modules. So avoid shadowing "isMain" or "i".-        (\ifaceIsMain iface -> Map.singleton (iModuleName iface) <$> compileModule backend env ifaceIsMain iface)+        (\ifaceIsMain iface ->+          Map.singleton (iTopLevelModuleName iface) <$>+          compileModule backend env ifaceIsMain iface)         isMain i     -- Note that `doCompile` calls `setInterface` for each distinct module in the graph prior to calling into     -- `compileModule`. This last one is just to ensure it's reset to _this_ module.     setInterface i     postCompile backend env isMain mods -compileModule :: Backend' opts env menv mod def -> env -> IsMain -> Interface -> TCM mod+compileModule :: HasCallStack => Backend' opts env menv mod def -> env -> IsMain -> Interface -> TCM mod compileModule backend env isMain i = do-  mName <- toTopLevelModuleName <$> curMName+  mName <- curMName   -- The interface file will only exist if performing af full type-check, vs scoping.   -- FIXME: Expecting backends to read the timestamp of the output path of the interface   --        file for dirtiness checking is very roundabout and heavily couples backend   --        implementations to the filesystem as the source of cache state.   mifile <- (Just . filePath . intFilePath =<<) <$> findInterfaceFile mName-  r      <- preModule backend env isMain (iModuleName i) mifile+  r      <- preModule backend env isMain (iTopLevelModuleName i) mifile   case r of     Skip m         -> return m     Recompile menv -> do       defs <- map snd . sortDefs <$> curDefs-      res  <- mapM (compileDef' backend env menv isMain <=< instantiateFull) defs-      postModule backend env menv isMain (iModuleName i) res+      res  <- mapM (compileDef' backend env menv isMain) defs+      postModule backend env menv isMain (iTopLevelModuleName i) res  compileDef' :: Backend' opts env menv mod def -> env -> menv -> IsMain -> Definition -> TCM def compileDef' backend env menv isMain def =
− src/full/Agda/Compiler/Backend.hs-boot 
@@ -1,33 +0,0 @@--module Agda.Compiler.Backend-  ( module Agda.Syntax.Treeless-  , Backend-  , activeBackendMayEraseType-  , lookupBackend-  )-  where--import Control.DeepSeq---- Explicitly adding the Agda.Syntax.Treeless import to the .hs-boot file--- so that the `Args` symbol can be hidden by the `SOURCE` import in--- TypeChecking.Monad.Base.------ Without exporting it here, a `hiding` clause there causes a compilation--- error. But without hiding it there, the name conflicts with the one--- imported from Agda.Syntax.Internal.------ This is only a problem with ghci, which will load a fully-compiled module if--- available; but that module will contain more symbols than just the few in--- the .hs-boot-import Agda.Syntax.Treeless (TTerm, Args)--import Agda.Syntax.Abstract.Name (QName)-import {-# SOURCE #-} Agda.TypeChecking.Monad.Base (TCM, BackendName)--data Backend--instance NFData Backend--activeBackendMayEraseType :: QName -> TCM Bool-lookupBackend :: BackendName -> TCM (Maybe Backend)
+ src/full/Agda/Compiler/Backend/Base.hs view
@@ -0,0 +1,102 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Compiler.Backend.Base where++import Control.DeepSeq (NFData, rnf)+import Data.Map (Map)+import Data.Text (Text)+import GHC.Generics (Generic)++import Agda.Syntax.Abstract.Name (QName)+import Agda.Syntax.Common (BackendName, IsMain, InteractionId)+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName)+import Agda.Syntax.Position (Range)++import Agda.Interaction.Base (CommandM')+import Agda.Interaction.Options (ArgDescr(..), OptDescr(..), Flag)++type BackendVersion = Text++data Backend_boot definition tcm where+  Backend :: NFData opts => Backend'_boot definition tcm opts env menv mod def -> Backend_boot definition tcm++data Backend'_boot definition tcm opts env menv mod def = Backend'+  { backendName      :: BackendName+      -- ^ the name of the backend+  , backendVersion   :: Maybe BackendVersion+      -- ^ Optional version information to be printed with @--version@.+  , options          :: opts+      -- ^ Default options+  , commandLineFlags :: [OptDescr (Flag opts)]+      -- ^ Backend-specific command-line flags. Should at minimum contain a+      --   flag to enable the backend.+  , isEnabled        :: opts -> Bool+      -- ^ Unless the backend has been enabled, @runAgda@ will fall back to+      --   vanilla Agda behaviour.+  , preCompile       :: opts -> tcm env+      -- ^ Called after type checking completes, but before compilation starts.+  , postCompile      :: env -> IsMain -> Map TopLevelModuleName mod ->+                        tcm ()+      -- ^ Called after module compilation has completed. The @IsMain@ argument+      --   is @NotMain@ if the @--no-main@ flag is present.+  , preModule        :: env -> IsMain -> TopLevelModuleName ->+                        Maybe FilePath -> tcm (Recompile menv mod)+      -- ^ Called before compilation of each module. Gets the path to the+      --   @.agdai@ file to allow up-to-date checking of previously written+      --   compilation results. Should return @Skip m@ if compilation is not+      --   required. Will be @Nothing@ if only scope checking.+  , postModule       :: env -> menv -> IsMain -> TopLevelModuleName ->+                        [def] -> tcm mod+      -- ^ Called after all definitions of a module have been compiled.+  , compileDef       :: env -> menv -> IsMain -> definition -> tcm def+      -- ^ Compile a single definition.+  , scopeCheckingSuffices :: Bool+      -- ^ True if the backend works if @--only-scope-checking@ is used.+  , mayEraseType     :: QName -> tcm Bool+      -- ^ The treeless compiler may ask the Backend if elements+      --   of the given type maybe possibly erased.+      --   The answer should be 'False' if the compilation of the type+      --   is used by a third party, e.g. in a FFI binding.+  , backendInteractTop  :: Maybe (BackendCommandTop tcm)+      -- ^ Backend-specific top-level interactive command.+  , backendInteractHole :: Maybe (BackendCommandHole tcm)+      -- ^ Backend-specific hole-level interactive command.+  }+  deriving Generic++data Recompile menv mod = Recompile menv | Skip mod++-- | For the sake of flexibility, we parametrize interactive commands with an+-- arbitrary string payload, e.g. to allow extra user input, or have backends+-- provide multiple commands with a single record field.+type CommandPayload = String++-- | The type of top-level backend interactive commmands.+type BackendCommandTop tcm+   = CommandPayload -- ^ arbitrary user payload+  -> CommandM' tcm ()++-- | The type of top-level backend interactive commmands.+type BackendCommandHole tcm+   = CommandPayload -- ^ arbitrary user payload+  -> InteractionId  -- ^ the hole's ID+  -> Range          -- ^ the hole's range+  -> String         -- ^ the hole's contents+  -> CommandM' tcm ()++instance NFData (Backend_boot definition tcm) where+  rnf (Backend b) = rnf b++instance NFData opts => NFData (Backend'_boot definition tcm opts env menv mod def) where+  rnf (Backend' a b c d e f g h i j k l m n) =+    rnf a `seq` rnf b `seq` rnf c `seq` rnf' d `seq` rnf e `seq`+    rnf f `seq` rnf g `seq` rnf h `seq` rnf i `seq` rnf j `seq`+    rnf k `seq` rnf l `seq` rnf m `seq` rnf n+    where+    rnf' []                   = ()+    rnf' (Option a b c d : e) =+      rnf a `seq` rnf b `seq` rnf'' c `seq` rnf d `seq` rnf' e++    rnf'' (NoArg a)    = rnf a+    rnf'' (ReqArg a b) = rnf a `seq` rnf b+    rnf'' (OptArg a b) = rnf a `seq` rnf b
src/full/Agda/Compiler/Builtin.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-|   Built-in backends. -}
− src/full/Agda/Compiler/Builtin.hs-boot 
@@ -1,5 +0,0 @@-module Agda.Compiler.Builtin where--import {-# SOURCE #-} Agda.Compiler.Backend--builtinBackends :: [Backend]
src/full/Agda/Compiler/CallCompiler.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  ------------------------------------------------------------------------ -- | A command which calls a compiler@@ -32,18 +33,21 @@      -- ^ The path to the compiler   -> [String]      -- ^ Command-line arguments.+  -> Maybe FilePath+     -- ^ The working directory that should be used when the compiler+     -- is invoked. The default is the current working directory.   -> Maybe TextEncoding      -- ^ Use the given text encoding, if any, when reading the output      -- from the process (stdout and stderr).   -> TCM ()-callCompiler doCall cmd args enc =+callCompiler doCall cmd args cwd enc =   if doCall then do-    merrors <- callCompiler' cmd args enc+    merrors <- callCompiler' cmd args cwd enc     case merrors of       Nothing     -> return ()       Just errors -> typeError (CompilationError errors)   else-    reportSLn "compile.cmd" 1 $ "NOT calling: " ++ unwords (cmd : args)+    alwaysReportSLn "compile.cmd" 1 $ "NOT calling: " ++ unwords (cmd : args)  -- | Generalisation of @callCompiler@ where the raised exception is -- returned.@@ -52,16 +56,20 @@      -- ^ The path to the compiler   -> [String]      -- ^ Command-line arguments.+  -> Maybe FilePath+     -- ^ The working directory that should be used when the compiler+     -- is invoked. The default is the current working directory.   -> Maybe TextEncoding      -- ^ Use the given text encoding, if any, when reading the output      -- from the process (stdout and stderr).   -> TCM (Maybe String)-callCompiler' cmd args enc = do-  reportSLn "compile.cmd" 1 $ "Calling: " ++ unwords (cmd : args)+callCompiler' cmd args cwd enc = do+  alwaysReportSLn "compile.cmd" 1 $ "Calling: " ++ unwords (cmd : args)   (_, out, err, p) <-     liftIO $ createProcess                (proc cmd args) { std_err = CreatePipe                                , std_out = CreatePipe+                               , cwd     = cwd                                }    -- In -v0 mode we throw away any progress information printed to@@ -75,7 +83,7 @@         Nothing  -> return ()         Just enc -> liftIO $ hSetEncoding out enc       progressInfo <- liftIO $ hGetContents out-      mapM_ (reportSLn "compile.output" 1) $ lines progressInfo+      mapM_ (alwaysReportSLn "compile.output" 1) $ lines progressInfo    errors <- liftIO $ case err of     Nothing  -> __IMPOSSIBLE__
src/full/Agda/Compiler/Common.hs view
@@ -1,60 +1,64 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-} -module Agda.Compiler.Common where+module Agda.Compiler.Common+  ( module Agda.Compiler.Common+  , IsMain(..)+  )+  where -import Data.List as List+import Prelude hiding ((!!))++import Data.List (sortBy, isPrefixOf) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import qualified Data.HashMap.Strict as HMap import Data.Char-import Data.Function-#if __GLASGOW_HASKELL__ < 804-import Data.Semigroup-#endif+import Data.Function (on)  import Control.Monad import Control.Monad.State  import Agda.Syntax.Common-import qualified Agda.Syntax.Concrete.Name as C import Agda.Syntax.Internal as I+import Agda.Syntax.TopLevelModuleName -import Agda.Interaction.FindFile ( srcFilePath ) import Agda.Interaction.Options-import Agda.Interaction.Imports ( CheckResult, crInterface, crSource, Source(..) )+import Agda.Interaction.Imports  ( CheckResult, crInterface, crSource, Source(..) )+import Agda.Interaction.Library -import Agda.TypeChecking.Monad+import Agda.TypeChecking.Monad as TCM  import Agda.Utils.FileName import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.List1          ( pattern (:|) ) import Agda.Utils.Maybe-import Agda.Utils.Pretty+import Agda.Utils.WithDefault    ( lensCollapseDefault )  import Agda.Utils.Impossible -data IsMain = IsMain | NotMain-  deriving (Eq, Show)---- | Conjunctive semigroup ('NotMain' is absorbing).-instance Semigroup IsMain where-  NotMain <> _ = NotMain-  _       <> NotMain = NotMain-  IsMain  <> IsMain = IsMain--instance Monoid IsMain where-  mempty = IsMain-  mappend = (<>)- doCompile :: Monoid r => (IsMain -> Interface -> TCM r) -> IsMain -> Interface -> TCM r doCompile f isMain i = do-  -- The Agda.Primitive module is implicitly assumed to be always imported,-  -- even though it not necesseraly occurs in iImportedModules.-  -- TODO: there should be a better way to get hold of Agda.Primitive?-  [agdaPrimInter] <- filter (("Agda.Primitive"==) . prettyShow . iModuleName)-    . map miInterface . Map.elems-      <$> getVisitedModules-  flip evalStateT Set.empty $ mappend <$> doCompile' f NotMain agdaPrimInter <*> doCompile' f isMain i+  flip evalStateT Set.empty $ compilePrim $ doCompile' f isMain i+  where+  -- The Agda.Primitive module is only loaded if the --no-load-primitives flag was not given,+  -- thus, only try to compile it if we have visited it.+  compilePrim cont = do+    agdaPrim <- lift $ do+      agdaPrim <- TCM.topLevelModuleName agdaPrim+      Map.lookup agdaPrim <$> getVisitedModules+    case agdaPrim of+      Nothing   -> cont+      Just prim ->+        mappend <$> doCompile' f NotMain (miInterface prim) <*> cont+    where+    agdaPrim = RawTopLevelModuleName+      { rawModuleNameRange = mempty+      , rawModuleNameParts = "Agda" :| "Primitive" : []+      , rawModuleNameInferred = False+      }+      -- N.B. The Range in TopLevelModuleName is ignored for Ord, so we can set it to mempty.  -- This helper function is called for both `Agda.Primitive` and the module in question. -- It's also called for each imported module, recursively. (Avoiding duplicates).@@ -66,7 +70,7 @@   if alreadyDone then return mempty else do     imps <- lift $       map miInterface . catMaybes <$>-        mapM (getVisitedModule . toTopLevelModuleName . fst) (iImportedModules i)+        mapM (getVisitedModule . fst) (iImportedModules i)     ri <- mconcat <$> mapM (doCompile' f NotMain) imps     lift $ setInterface i     r <- lift $ f isMain i@@ -78,16 +82,21 @@   opts <- getsTC (stPersistentOptions . stPersistentState)   setCommandLineOptions opts   mapM_ setOptionsFromPragma (iDefaultPragmaOptions i ++ iFilePragmaOptions i)-  stImportedModules `setTCLens` Set.fromList (map fst $ iImportedModules i)-  stCurrentModule   `setTCLens` Just (iModuleName i)+  -- One could perhaps make the following command lazy. Note, however,+  -- that it doesn't suffice to replace setTCLens' with setTCLens,+  -- because the stPreImportedModules field is strict.+  stImportedModules `setTCLens'`+    Set.fromList (map fst (iImportedModules i))+  stCurrentModule `setTCLens'`+    Just (iModuleName i, iTopLevelModuleName i)  curIF :: ReadTCState m => m Interface curIF = do   name <- curMName-  maybe __IMPOSSIBLE__ miInterface <$> getVisitedModule (toTopLevelModuleName name)+  maybe __IMPOSSIBLE__ miInterface <$> getVisitedModule name -curMName :: ReadTCState m => m ModuleName-curMName = fromMaybe __IMPOSSIBLE__ <$> useTC stCurrentModule+curMName :: ReadTCState m => m TopLevelModuleName+curMName = maybe __IMPOSSIBLE__ snd <$> useTC stCurrentModule  curDefs :: ReadTCState m => m Definitions curDefs = HMap.filter (not . defNoCompilation) . (^. sigDefinitions) . iSignature <$> curIF@@ -97,7 +106,7 @@   -- The list is sorted to ensure that the order of the generated   -- definitions does not depend on things like the number of bits   -- in an Int (see Issue 1900).-  List.sortBy (compare `on` fst) $+  sortBy (compare `on` fst) $   HMap.toList defs  compileDir :: HasOptions m => m FilePath@@ -131,13 +140,13 @@     -- the current pragma options persistent when we setCommandLineOptions     -- below.     opts <- getsTC $ stPersistentOptions . stPersistentState-    let compileDir = case optCompileDir opts of-          Just dir -> dir-          Nothing  ->-            -- The default output directory is the project root.-            let tm = toTopLevelModuleName $ iModuleName mainI-                f  = srcFilePath $ srcOrigin checkedSource-            in filePath $ C.projectRoot f tm+    compileDir <- case optCompileDir opts of+        Just dir -> pure dir+        Nothing  -> do+          -- The default output directory is the project root.+          let tm = iTopLevelModuleName mainI+          f <- srcFilePath $ srcOrigin checkedSource+          pure $ filePath $ projectRoot f tm     setCommandLineOptions $       opts { optCompileDir = Just compileDir } @@ -145,16 +154,17 @@     -- Unfortunately, a pragma option is stored in the interface file as     -- just a list of strings, thus, the solution is a bit of hack:     -- We match on whether @["--no-main"]@ is one of the stored options.-    when (["--no-main"] `elem` iFilePragmaOptions mainI) $-      stPragmaOptions `modifyTCLens` \ o -> o { optCompileNoMain = True }+    let iFilePragmaStrings = map pragmaStrings . iFilePragmaOptions+    when (["--no-main"] `elem` iFilePragmaStrings mainI) $+      setTCLens (stPragmaOptions . lensOptCompileMain . lensCollapseDefault) False      -- Perhaps all pragma options from the top-level module should be     -- made available to the compiler in a suitable way. Here are more     -- hacks:-    when (any ("--cubical" `elem`) (iFilePragmaOptions mainI)) $-      stPragmaOptions `modifyTCLens` \ o -> o { optCubical = Just CFull }-    when (any ("--erased-cubical" `elem`) (iFilePragmaOptions mainI)) $-      stPragmaOptions `modifyTCLens` \ o -> o { optCubical = Just CErased }+    when (any ("--cubical" `elem`) $ iFilePragmaStrings mainI) $+      setTCLens (stPragmaOptions . lensOptCubical) $ Just CFull+    when (any ("--erased-cubical" `elem`) $ iFilePragmaStrings mainI) $+      setTCLens (stPragmaOptions . lensOptCubical) $ Just CErased      setScope (iInsideScope mainI) -- so that compiler errors don't use overly qualified names     ignoreAbstractMode cont@@ -163,16 +173,18 @@   stTCWarnings `setTCLens` newWarnings   return a -topLevelModuleName :: ReadTCState m => ModuleName -> m ModuleName+topLevelModuleName ::+  ReadTCState m => ModuleName -> m TopLevelModuleName topLevelModuleName m = do-  -- get the names of the visited modules-  visited <- List.map (iModuleName . miInterface) . Map.elems <$>-    getVisitedModules+  -- Interfaces of visited modules.+  visited <- map miInterface . Map.elems <$> getVisitedModules   -- find the module with the longest matching prefix to m-  let ms = sortBy (compare `on` (length . mnameToList)) $-       List.filter (\ m' -> mnameToList m' `isPrefixOf` mnameToList m) visited-  case ms of-    (m' : _) -> return m'+  let is = sortBy (compare `on` (length . mnameToList . iModuleName)) $+           filter (\i -> mnameToList (iModuleName i) `isPrefixOf`+                         mnameToList m)+             visited+  case is of+    (i : _) -> return (iTopLevelModuleName i)     -- if we did not get anything, it may be because m is a section     -- (a module _ ), see e.g. #1866     []       -> curMName
src/full/Agda/Compiler/JS/Compiler.hs view
@@ -9,7 +9,9 @@  import Data.Char     ( isSpace ) import Data.Foldable ( forM_ )-import Data.List     ( dropWhileEnd, findIndex, intercalate, partition )+import Data.Functor  ( (<&>) )+import Data.List     ( dropWhileEnd, elemIndex, intercalate, partition )+import Data.Maybe    ( listToMaybe ) import Data.Set      ( Set )  import qualified Data.Set as Set@@ -23,19 +25,20 @@ import System.FilePath    ( splitFileName, (</>) ) import System.Process     ( callCommand ) -import Paths_Agda+import Agda.Setup         ( getDataDir )  import Agda.Interaction.Options  import Agda.Syntax.Common import Agda.Syntax.Concrete.Name ( isNoName ) import Agda.Syntax.Abstract.Name-  ( ModuleName, QName,+  ( QName,     mnameToList, qnameName, qnameModule, nameId ) import Agda.Syntax.Internal   ( Name, Type   , nameFixity, unDom, telToList ) import Agda.Syntax.Literal       ( Literal(..) )+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName, TopLevelModuleName'(..)) import Agda.Syntax.Treeless      ( ArgUsage(..), filterUsed ) import qualified Agda.Syntax.Treeless as T @@ -44,6 +47,7 @@ import Agda.TypeChecking.Substitute as TC ( TelV(..), raise, subst ) import Agda.TypeChecking.Pretty import Agda.TypeChecking.Telescope ( telViewPath )+import Agda.TypeChecking.Warnings  ( warning )  import Agda.Utils.FileName ( isNewerThan ) import Agda.Utils.Function ( iterate' )@@ -51,22 +55,23 @@ import Agda.Utils.List1 ( List1, pattern (:|) ) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe ( boolToMaybe, catMaybes, caseMaybeM, fromMaybe, whenNothing )-import Agda.Utils.Monad ( ifM, when )+import Agda.Utils.Monad ( ifM, when, whenM ) import Agda.Utils.Null  ( null )-import Agda.Utils.Pretty (prettyShow, render)-import qualified Agda.Utils.Pretty as P+import Agda.Syntax.Common.Pretty (prettyShow, render)+import qualified Agda.Syntax.Common.Pretty as P import Agda.Utils.IO.Directory import Agda.Utils.IO.UTF8 ( writeFile ) import Agda.Utils.Singleton ( singleton )+import Agda.Utils.Size (size) -import Agda.Compiler.Common+import Agda.Compiler.Common as CC import Agda.Compiler.ToTreeless import Agda.Compiler.Treeless.EliminateDefaults import Agda.Compiler.Treeless.EliminateLiteralPatterns import Agda.Compiler.Treeless.GuardsToPrims-import Agda.Compiler.Treeless.Erase ( computeErasedConstructorArgs )+import Agda.Compiler.Treeless.Erase ( computeErasedConstructorArgs, isErasable ) import Agda.Compiler.Treeless.Subst ()-import Agda.Compiler.Backend (Backend(..), Backend'(..), Recompile(..))+import Agda.Compiler.Backend (Backend,Backend_boot(..), Backend',Backend'_boot(..), Recompile(..))  import Agda.Compiler.JS.Syntax   ( Exp(Self,Local,Global,Undefined,Null,String,Char,Integer,Double,Lambda,Object,Array,Apply,Lookup,If,BinOp,PlainJS),@@ -75,8 +80,9 @@   , JSQName   ) import Agda.Compiler.JS.Substitution-  ( curriedLambda, curriedApply, emp, apply )+  ( curriedLambda, curriedApply, emp, apply, substShift ) import qualified Agda.Compiler.JS.Pretty as JSPretty+import Agda.Compiler.JS.Pretty (JSModuleStyle(..))  import Agda.Utils.Impossible (__IMPOSSIBLE__) @@ -106,6 +112,8 @@       -- @data@/@record@, you might want to tell the treeless compiler       -- not to erase these types even if they have no content,       -- to get a stable interface.+  , backendInteractTop    = Nothing+  , backendInteractHole   = Nothing   }  --- Options ---@@ -117,9 +125,12 @@       -- ^ Remove spaces etc. See https://en.wikipedia.org/wiki/Minification_(programming).   , optJSVerify   :: Bool       -- ^ Run generated code through interpreter.+  , optJSModuleStyle :: JSModuleStyle   }   deriving Generic +instance NFData JSModuleStyle+ instance NFData JSOptions  defaultJSOptions :: JSOptions@@ -128,6 +139,7 @@   , optJSOptimize = False   , optJSMinify   = False   , optJSVerify   = False+  , optJSModuleStyle = JSCJS   }  jsCommandLineFlags :: [OptDescr (Flag JSOptions)]@@ -137,31 +149,29 @@     -- Minification is described at https://en.wikipedia.org/wiki/Minification_(programming)     , Option [] ["js-minify"] (NoArg enableMin) "minify generated JS code"     , Option [] ["js-verify"] (NoArg enableVerify) "except for main module, run generated JS modules through `node` (needs to be in PATH)"+    , Option [] ["js-es6"] (NoArg setES6) "use ES6 module style for JS"+    , Option [] ["js-cjs"] (NoArg setCJS) "use CommonJS module style (default)"+    , Option [] ["js-amd"] (NoArg setAMD) "use AMD module style for JS"     ]   where     enable       o = pure o{ optJSCompile  = True }     enableOpt    o = pure o{ optJSOptimize = True }     enableMin    o = pure o{ optJSMinify   = True }     enableVerify o = pure o{ optJSVerify   = True }+    setES6       o = pure o{ optJSModuleStyle = JSES6 }+    setCJS       o = pure o{ optJSModuleStyle = JSCJS }+    setAMD       o = pure o{ optJSModuleStyle = JSAMD }  --- Top-level compilation ---  jsPreCompile :: JSOptions -> TCM JSOptions-jsPreCompile opts = do-  cubical <- optCubical <$> pragmaOptions-  let notSupported s =-        typeError $ GenericError $-          "Compilation of code that uses " ++ s ++ " is not supported."-  case cubical of-    Nothing      -> return ()-    Just CErased -> return ()-    Just CFull   -> notSupported "--cubical"--  return opts+jsPreCompile opts = opts <$ do+  mapM_ (typeError . CubicalCompilationNotSupported) =<< cubicalOption  -- | After all modules have been compiled, copy RTE modules and verify compiled modules. -jsPostCompile :: JSOptions -> IsMain -> Map.Map ModuleName Module -> TCM ()+jsPostCompile ::+  JSOptions -> IsMain -> Map.Map TopLevelModuleName Module -> TCM () jsPostCompile opts _ ms = do    -- Copy RTE modules.@@ -169,8 +179,13 @@   compDir  <- compileDir   liftIO $ do     dataDir <- getDataDir-    let srcDir = dataDir </> "JS"-    copyDirContent srcDir compDir+    let fname = case optJSModuleStyle opts of+          JSCJS -> "agda-rts.js"+          JSAMD -> "agda-rts.amd.js"+          JSES6 -> "agda-rts.mjs"+        srcPath = dataDir </> "JS" </> fname+        compPath = compDir </> fname+    copyIfChanged srcPath compPath    -- Verify generated JS modules (except for main). @@ -181,7 +196,7 @@     liftIO $ setEnv "NODE_PATH" compDir      forM_ ms $ \ Module{ modName, callMain } -> do-      jsFile <- outFile modName+      jsFile <- outFile (optJSModuleStyle opts) modName       reportSLn "compile.js.verify" 30 $ unwords [ "Considering JS module:" , jsFile ]        -- Since we do not run a JS program for real, we skip all modules that could@@ -189,18 +204,12 @@       -- Atm, modules whose compilation was skipped are also skipped during verification       -- (they appear here as main modules).       whenNothing callMain $ do-        let cmd = unwords [ "node", "-", "<", jsFile ]+        -- node needs to see whether the extension is .js or .mjs,+        -- so we pass input explicitly, not via stdin+        let cmd = unwords [ "node", jsFile ]         reportSLn "compile.js.verify" 20 $ unwords [ "calling:", cmd ]         liftIO $ callCommand cmd --mergeModules :: Map.Map ModuleName Module -> [(GlobalId, Export)]-mergeModules ms-    = [ (jsMod n, e)-      | (n, Module _ _ es _) <- Map.toList ms-      , e <- es-      ]- --- Module compilation ---  data JSModuleEnv = JSModuleEnv@@ -209,9 +218,11 @@     -- ^ Should this module be compiled?   } -jsPreModule :: JSOptions -> IsMain -> ModuleName -> Maybe FilePath -> TCM (Recompile JSModuleEnv Module)-jsPreModule _opts _ m mifile = do-  cubical <- optCubical <$> pragmaOptions+jsPreModule ::+  JSOptions -> IsMain -> TopLevelModuleName -> Maybe FilePath ->+  TCM (Recompile JSModuleEnv Module)+jsPreModule opts _ m mifile = do+  cubical <- cubicalOption   let compile = case cubical of         -- Code that uses --cubical is not compiled.         Just CFull   -> False@@ -219,6 +230,10 @@         Nothing      -> True   ifM uptodate noComp (yesComp compile)   where+    outFile_ = do+      m <- curMName+      outFile (optJSModuleStyle opts) (jsMod m)+     uptodate = case mifile of       Nothing -> pure False       Just ifile -> liftIO =<< isNewerThan <$> outFile_ <*> pure ifile@@ -234,19 +249,21 @@     yesComp compile = do       m   <- prettyShow <$> curMName       out <- outFile_-      reportSLn "compile.js" 1 $ repl [m, ifileDesc, out] "Compiling <<0>> in <<1>> to <<2>>"+      alwaysReportSLn "compile.js" 1 $ repl [m, ifileDesc, out] "Compiling <<0>> in <<1>> to <<2>>"       kit <- coinductionKit       return $ Recompile $ JSModuleEnv         { jsCoinductionKit = kit         , jsCompile        = compile         } -jsPostModule :: JSOptions -> JSModuleEnv -> IsMain -> ModuleName -> [Maybe Export] -> TCM Module+jsPostModule ::+  JSOptions -> JSModuleEnv -> IsMain -> TopLevelModuleName ->+  [Maybe Export] -> TCM Module jsPostModule opts _ isMain _ defs = do-  m             <- jsMod <$> curMName-  is            <- map (jsMod . fst) . iImportedModules <$> curIF+  m  <- jsMod <$> curMName+  is <- map (jsMod . fst) . iImportedModules <$> curIF   let mod = Module m is (reorder es) callMain-  writeModule (optJSMinify opts) mod+  writeModule (optJSMinify opts) (optJSModuleStyle opts) mod   return mod   where   es       = catMaybes defs@@ -269,11 +286,13 @@ prefix :: [Char] prefix = "jAgda" -jsMod :: ModuleName -> GlobalId-jsMod m = GlobalId (prefix : map prettyShow (mnameToList m))+jsMod :: TopLevelModuleName -> GlobalId+jsMod m =+  GlobalId (prefix : map T.unpack (List1.toList (moduleNameParts m))) -jsFileName :: GlobalId -> String-jsFileName (GlobalId ms) = intercalate "." ms ++ ".js"+jsFileName :: JSModuleStyle -> GlobalId -> String+jsFileName JSES6 (GlobalId ms) = intercalate "." ms ++ ".mjs" -- Hint that file is ES6, not old js+jsFileName _     (GlobalId ms) = intercalate "." ms ++  ".js"  jsMember :: Name -> MemberId jsMember n@@ -285,17 +304,17 @@  global' :: QName -> TCM (Exp, JSQName) global' q = do-  i <- iModuleName <$> curIF-  modNm <- topLevelModuleName (qnameModule q)+  i   <- iTopLevelModuleName <$> curIF+  top <- CC.topLevelModuleName (qnameModule q)   let     -- Global module prefix     qms = mnameToList $ qnameModule q     -- File-local module prefix-    localms = drop (length $ mnameToList modNm) qms+    localms = drop (size top) qms     nm = fmap jsMember $ List1.snoc localms $ qnameName q-  if modNm == i+  if top == i     then return (Self, nm)-    else return (Global (jsMod modNm), nm)+    else return (Global (jsMod top), nm)  global :: QName -> TCM (Exp, JSQName) global q = do@@ -378,11 +397,15 @@ -- | Ensure that there is at most one pragma for a name. checkCompilerPragmas :: QName -> TCM () checkCompilerPragmas q =-  caseMaybeM (getUniqueCompilerPragma jsBackendName q) (return ()) $ \ (CompilerPragma r s) ->-  setCurrentRange r $ case words s of-    "=" : _ -> return ()-    _       -> genericDocError $ P.sep [ "Badly formed COMPILE JS pragma. Expected",-                                         "{-# COMPILE JS <name> = <js> #-}" ]+  caseMaybeM (getUniqueCompilerPragma jsBackendName q) (return ()) $ \ (CompilerPragma r s) -> do+  setCurrentRange r do+    -- Issue #3545: Warn user about ignored COMPILE pragma for defined functions.+    getConstInfo q <&> theDef >>= \case+      FunctionDefn{} -> whenM (isErasable q) $ warning $ PragmaCompileErased jsBackendName q+      _ -> return()+    -- If the pragma is not of the form "q = bla", complain.+    when (listToMaybe (words s) /= Just "=") do+      typeError $ JSBackendError BadCompilePragma  defJSDef :: Definition -> Maybe String defJSDef def =@@ -419,7 +442,8 @@     Function{} | otherwise -> do        reportSDoc "compile.js" 5 $ "compiling fun:" <+> prettyTCM q-      caseMaybeM (toTreeless T.EagerEvaluation q) (pure Nothing) $ \ treeless -> do+      let mTreeless = toTreeless T.EagerEvaluation q+      caseMaybeM mTreeless (pure Nothing) $ \ treeless -> do         used <- fromMaybe [] <$> getCompiledArgUse q         funBody <- eliminateCaseDefaults =<<           eliminateLiteralPatterns@@ -427,21 +451,7 @@         reportSDoc "compile.js" 30 $ " compiled treeless fun:" <+> pretty funBody         reportSDoc "compile.js" 40 $ " argument usage:" <+> (text . show) used -        let (body, given) = lamView funBody-              where-                lamView :: T.TTerm -> (T.TTerm, Int)-                lamView (T.TLam t) = (+1) <$> lamView t-                lamView t = (t, 0)--            -- number of eta expanded args-            etaN = length $ dropWhileEnd (== ArgUsed) $ drop given used--            unusedN = length $ filter (== ArgUnused) used--        funBody' <- compileTerm kit-                  $ iterate' (given + etaN - unusedN) T.TLam-                  $ eraseLocalVars (map (== ArgUnused) used)-                  $ T.mkTApp (raise etaN body) (T.TVar <$> downFrom etaN)+        funBody' <- compileTerm kit funBody          reportSDoc "compile.js" 30 $ " compiled JS fun:" <+> (text . show) funBody'         return $@@ -456,7 +466,7 @@         -- The string prim^unglueU is not a valid JS name.         plainJS "agdaRTS.prim_unglueU"       | p `Set.member` primitives ->-        plainJS $ "agdaRTS." ++ p+        plainJS $ "agdaRTS." ++ getBuiltinId p       | Just e <- defJSDef d ->         plainJS e       | otherwise ->@@ -471,41 +481,73 @@         return Nothing      Constructor{} | Just e <- defJSDef d -> plainJS e+    -- Implements Scott-Encoding of constructor definitions+    -- (see the note "Implementing data types")     Constructor{conData = p, conPars = nc} -> do       TelV tel _ <- telViewPath t-      let np = length (telToList tel) - nc-      erased <- getErasedConArgs q-      let nargs = np - length (filter id erased)+      let nargs = length (telToList tel) - nc           args = [ Local $ LocalId $ nargs - i | i <- [0 .. nargs-1] ]       d <- getConstInfo p       let l = List1.last ls-      case theDef d of-        Record { recFields = flds } -> ret $ curriedLambda nargs $-          if optJSOptimize (fst kit)-            then Lambda 1 $ Apply (Local (LocalId 0)) args-            else Object $ Map.singleton l $ Lambda 1 $ Apply (Lookup (Local (LocalId 0)) l) args-        dt -> do-          i <- index-          ret $ curriedLambda (nargs + 1) $ Apply (Lookup (Local (LocalId 0)) i) args-          where-            index :: TCM MemberId-            index-              | Datatype{} <- dt-              , optJSOptimize (fst kit) = do-                  q  <- canonicalName q-                  cs <- mapM canonicalName $ defConstructors dt-                  case findIndex (q ==) cs of-                    Just i  -> return $ MemberIndex i (mkComment l)-                    Nothing -> __IMPOSSIBLE_VERBOSE__ $ unwords [ "Constructor", prettyShow q, "not found in", prettyShow cs ]-              | otherwise = return l-            mkComment (MemberId s) = Comment s-            mkComment _ = mempty+      ret+        $ curriedLambda nargs+        $ (case theDef d of+              Record {} -> Object . Map.singleton l+              dt -> id)+        $  Lambda 1 $ Apply (Lookup (Local (LocalId 0)) l) args      AbstractDefn{} -> __IMPOSSIBLE__   where     ret = return . Just . Export ls-    plainJS = return . Just . Export ls . PlainJS+    plainJS = ret . PlainJS +-- Implementing data types+--------------------------++-- Data types are implemented using a variant of Scott Encoding,+-- which uses JavaScript dicts instead of some lambda-expressions++-- For example, given the data type+--+--      data Foo : Set where+--        c1 : Foo+--        c2 : X -> Y -> Foo+--        c3 : Foo -> Foo+--+-- here is how "Foo" is compiled:+--+--  * A constructor definition, e.g.+--+--        c2 : X -> Y -> Foo+--+--    compiles to+--+--        exports["Foo"]["c2"] = x => y => k => k["c2"](x,y)+--+--  * A constructor application, e.g.+--+--        c2 x y+--+--    compiles to+--+--        exports["Foo"]["c2"](x)(y)+--+--  * A case split, e.g.+--+--        case p of+--          (c1    ) -> E1+--          (c2 x y) -> E2+--          (c3 f  ) -> E3+--+--    compiles to+--+--        p(+--          { "c1": ()    => E1+--          , "c2": (x,y) => E2+--          , "c3": f     => E3+--          })++ compileTerm :: EnvWithOpts -> T.TTerm -> TCM Exp compileTerm kit t = go t   where@@ -534,47 +576,32 @@         return $ Object $ Map.fromListWith __IMPOSSIBLE__           [(flatName, PlainJS evalThunk)           ,(MemberId "__flat_helper", Lambda 0 x)]-      T.TApp t' xs | Just f <- getDef t' -> do-        used <- case f of-          Left  q -> fromMaybe [] <$> getCompiledArgUse q-          Right c -> map (\ b -> if b then ArgUnused else ArgUsed) <$> getErasedConArgs c-            -- Andreas, 2021-02-10 NB: could be @map (bool ArgUsed ArgUnused)@-            -- but I find it unintuitive that 'bool' takes the 'False'-branch first.-        let given = length xs--            -- number of eta expanded args-            etaN = length $ dropWhile (== ArgUsed) $ reverse $ drop given used--            args = filterUsed used $-                     raise etaN xs ++ (T.TVar <$> downFrom etaN)--        curriedLambda etaN <$> (curriedApply <$> go (raise etaN t') <*> mapM go args)-       T.TApp t xs -> do             curriedApply <$> go t <*> mapM go xs       T.TLam t -> Lambda 1 <$> go t-      -- TODO This is not a lazy let, but it should be...-      T.TLet t e -> apply <$> (Lambda 1 <$> go e) <*> traverse go [t]+      -- `let x = t in e` is compiled to `(x => e[x()/x])(() => t)` so that `t`+      -- is only evaluated inside the body+      T.TLet t e -> do+        t' <- Lambda 0 <$> go t+        e' <- substShift 1 1 [Apply (Local (LocalId 0)) []] <$> go e+        return $ Apply (Lambda 1 e') [t']       T.TLit l -> return $ literal l-      T.TCon q -> do-        d <- getConstInfo q-        qname q-      T.TCase sc ct def alts | T.CTData _ dt <- T.caseType ct -> do+      -- Implements Scott-Encoding of constructor applications+      -- (see the note "Implementing data types")+      T.TCon q -> qname q+    -- Implements Scott-Encoding of case splits+    -- (see the note "Implementing data types")+      T.TCase sc ct def alts | T.CTData dt <- T.caseType ct -> do         dt <- getConstInfo dt         alts' <- traverse (compileAlt kit) alts         let cs  = defConstructors $ theDef dt-            obj = Object $ Map.fromListWith __IMPOSSIBLE__ [(snd x, y) | (x, y) <- alts']-            arr = mkArray [headWithDefault (mempty, Null) [(Comment s, y) | ((c', MemberId s), y) <- alts', c' == c] | c <- cs]+            obj = Object $ Map.fromListWith __IMPOSSIBLE__ alts'         case (theDef dt, defJSDef dt) of           (_, Just e) -> do             return $ apply (PlainJS e) [Local (LocalId sc), obj]-          (Record{}, _) | optJSOptimize (fst kit) -> do-            return $ apply (Local $ LocalId sc) [snd $ headWithDefault __IMPOSSIBLE__ alts']           (Record{}, _) -> do             memId <- visitorName $ recCon $ theDef dt             return $ apply (Lookup (Local $ LocalId sc) memId) [obj]-          (Datatype{}, _) | optJSOptimize (fst kit) -> do-            return $ curriedApply (Local (LocalId sc)) [arr]           (Datatype{}, _) -> do             return $ curriedApply (Local (LocalId sc)) [obj]           _ -> __IMPOSSIBLE__@@ -596,7 +623,7 @@     unit = return Null      mkArray xs-        | 2 * length (filter ((==Null) . snd) xs) <= length xs = Array xs+        | 2 * length (filter ((== Null) . snd) xs) <= length xs = Array xs         | otherwise = Object $ Map.fromListWith __IMPOSSIBLE__             [ (MemberIndex i c, x) | (i, (c, x)) <- zip [0..] xs, x /= Null ] @@ -630,24 +657,18 @@         unOp js  = curriedLambda 1 $ apply (PlainJS js) [local 0]         primEq   = curriedLambda 2 $ BinOp (local 1) "===" (local 0) --compileAlt :: EnvWithOpts -> T.TAlt -> TCM ((QName, MemberId), Exp)+-- Implements Scott-Encoding of case split cases+-- (see the note "Implementing data types")+compileAlt :: EnvWithOpts -> T.TAlt -> TCM (MemberId, Exp) compileAlt kit = \case-  T.TACon con ar body -> do-    erased <- getErasedConArgs con-    let nargs = ar - length (filter id erased)+  T.TACon con nargs body -> do     memId <- visitorName con-    body <- Lambda nargs <$> compileTerm kit (eraseLocalVars erased body)-    return ((con, memId), body)+    body <- Lambda nargs <$> compileTerm kit body+    return (memId, body)   _ -> __IMPOSSIBLE__ -eraseLocalVars :: [Bool] -> T.TTerm -> T.TTerm-eraseLocalVars [] x = x-eraseLocalVars (False: es) x = eraseLocalVars es x-eraseLocalVars (True: es) x = eraseLocalVars es (TC.subst (length es) T.TErased x)- visitorName :: QName -> TCM MemberId-visitorName q = do (m,ls) <- global q; return (List1.last ls)+visitorName q = List1.last . snd <$> global q  flatName :: MemberId flatName = MemberId "flat"@@ -668,7 +689,7 @@   (LitString x) -> String  x   (LitChar   x) -> Char    x   (LitQName  x) -> litqname x-  LitMeta{}     -> __IMPOSSIBLE__+  (LitMeta _ m) -> litmeta m  litqname :: QName -> Exp litqname q =@@ -695,153 +716,151 @@     litPrec Unrelated   = String "unrelated"     litPrec (Related l) = Double l +litmeta :: MetaId -> Exp+litmeta (MetaId m h) =+  Object $ Map.fromListWith __IMPOSSIBLE__+    [ (MemberId "id", Integer $ fromIntegral m)+    , (MemberId "module", Integer $ fromIntegral $ moduleNameHash h) ]++ -------------------------------------------------- -- Writing out an ECMAScript module -------------------------------------------------- -writeModule :: Bool -> Module -> TCM ()-writeModule minify m = do-  out <- outFile (modName m)-  liftIO (writeFile out (JSPretty.prettyShow minify m))+writeModule :: Bool -> JSModuleStyle -> Module -> TCM ()+writeModule minify ms m = do+  out <- outFile ms (modName m)+  liftIO (writeFile out (JSPretty.prettyShow minify ms m)) -outFile :: GlobalId -> TCM FilePath-outFile m = do+outFile :: JSModuleStyle -> GlobalId -> TCM FilePath+outFile ms m = do   mdir <- compileDir-  let (fdir, fn) = splitFileName (jsFileName m)+  let (fdir, fn) = splitFileName (jsFileName ms m)   let dir = mdir </> fdir       fp  = dir </> fn   liftIO $ createDirectoryIfMissing True dir   return fp -outFile_ :: TCM FilePath-outFile_ = do-  m <- curMName-  outFile (jsMod m)- -- | Primitives implemented in the JS Agda RTS. -- -- TODO: Primitives that are not part of this set, and for which -- 'defJSDef' does not return anything, are silently compiled to -- 'Undefined'. A better approach might be to list exactly those -- primitives which should be compiled to 'Undefined'.-primitives :: Set String+primitives :: Set PrimitiveId primitives = Set.fromList-  [  "primShowInteger"+  [ PrimShowInteger    -- Natural number functions-  -- , "primNatPlus"                 -- missing-  , "primNatMinus"-  -- , "primNatTimes"                -- missing-  -- , "primNatDivSucAux"            -- missing-  -- , "primNatModSucAux"            -- missing-  -- , "primNatEquality"             -- missing-  -- , "primNatLess"                 -- missing-  -- , "primShowNat"                 -- missing+  -- , PrimNatPlus                 -- missing+  , PrimNatMinus+  -- , PrimNatTimes                -- missing+  -- , PrimNatDivSucAux            -- missing+  -- , PrimNatModSucAux            -- missing+  -- , PrimNatEquality             -- missing+  -- , PrimNatLess                 -- missing+  -- , PrimShowNat                 -- missing    -- Machine words-  , "primWord64ToNat"-  , "primWord64FromNat"-  -- , "primWord64ToNatInjective"    -- missing+  , PrimWord64ToNat+  , PrimWord64FromNat+  -- , PrimWord64ToNatInjective    -- missing    -- Level functions-  -- , "primLevelZero"               -- missing-  -- , "primLevelSuc"                -- missing-  -- , "primLevelMax"                -- missing--  -- Sorts-  -- , "primSetOmega"                -- missing-  -- , "primStrictSetOmega"          -- missing+  -- , PrimLevelZero               -- missing+  -- , PrimLevelSuc                -- missing+  -- , PrimLevelMax                -- missing    -- Floating point functions-  , "primFloatEquality"-  , "primFloatInequality"-  , "primFloatLess"-  , "primFloatIsInfinite"-  , "primFloatIsNaN"-  , "primFloatIsNegativeZero"-  , "primFloatIsSafeInteger"-  , "primFloatToWord64"-  -- , "primFloatToWord64Injective"  -- missing-  , "primNatToFloat"-  , "primIntToFloat"-  -- , "primFloatRound"              -- in Agda.Builtin.Float-  -- , "primFloatFloor"              -- in Agda.Builtin.Float-  -- , "primFloatCeiling"            -- in Agda.Builtin.Float-  -- , "primFloatToRatio"            -- in Agda.Builtin.Float-  , "primRatioToFloat"-  -- , "primFloatDecode"             -- in Agda.Builtin.Float-  -- , "primFloatEncode"             -- in Agda.Builtin.Float-  , "primShowFloat"-  , "primFloatPlus"-  , "primFloatMinus"-  , "primFloatTimes"-  , "primFloatNegate"-  , "primFloatDiv"-  , "primFloatSqrt"-  , "primFloatExp"-  , "primFloatLog"-  , "primFloatSin"-  , "primFloatCos"-  , "primFloatTan"-  , "primFloatASin"-  , "primFloatACos"-  , "primFloatATan"-  , "primFloatATan2"-  , "primFloatSinh"-  , "primFloatCosh"-  , "primFloatTanh"-  , "primFloatASinh"-  , "primFloatACosh"-  , "primFloatATanh"-  , "primFloatPow"+  , PrimFloatEquality+  , PrimFloatInequality+  , PrimFloatLess+  , PrimFloatIsInfinite+  , PrimFloatIsNaN+  , PrimFloatIsNegativeZero+  , PrimFloatIsSafeInteger+  , PrimFloatToWord64+  -- , PrimFloatToWord64Injective  -- missing+  , PrimNatToFloat+  , PrimIntToFloat+  -- , PrimFloatRound              -- in Agda.Builtin.Float+  -- , PrimFloatFloor              -- in Agda.Builtin.Float+  -- , PrimFloatCeiling            -- in Agda.Builtin.Float+  -- , PrimFloatToRatio            -- in Agda.Builtin.Float+  , PrimRatioToFloat+  -- , PrimFloatDecode             -- in Agda.Builtin.Float+  -- , PrimFloatEncode             -- in Agda.Builtin.Float+  , PrimShowFloat+  , PrimFloatPlus+  , PrimFloatMinus+  , PrimFloatTimes+  , PrimFloatNegate+  , PrimFloatDiv+  , PrimFloatSqrt+  , PrimFloatExp+  , PrimFloatLog+  , PrimFloatSin+  , PrimFloatCos+  , PrimFloatTan+  , PrimFloatASin+  , PrimFloatACos+  , PrimFloatATan+  , PrimFloatATan2+  , PrimFloatSinh+  , PrimFloatCosh+  , PrimFloatTanh+  , PrimFloatASinh+  , PrimFloatACosh+  , PrimFloatATanh+  , PrimFloatPow    -- Character functions-  -- , "primCharEquality"            -- missing-  -- , "primIsLower"                 -- missing-  -- , "primIsDigit"                 -- missing-  -- , "primIsAlpha"                 -- missing-  -- , "primIsSpace"                 -- missing-  -- , "primIsAscii"                 -- missing-  -- , "primIsLatin1"                -- missing-  -- , "primIsPrint"                 -- missing-  -- , "primIsHexDigit"              -- missing-  -- , "primToUpper"                 -- missing-  -- , "primToLower"                 -- missing-  -- , "primCharToNat"               -- missing-  -- , "primCharToNatInjective"      -- missing-  -- , "primNatToChar"               -- missing-  -- , "primShowChar"                -- in Agda.Builtin.String+  -- , PrimCharEquality            -- missing+  -- , PrimIsLower                 -- missing+  -- , PrimIsDigit                 -- missing+  -- , PrimIsAlpha                 -- missing+  -- , PrimIsSpace                 -- missing+  -- , PrimIsAscii                 -- missing+  -- , PrimIsLatin1                -- missing+  -- , PrimIsPrint                 -- missing+  -- , PrimIsHexDigit              -- missing+  -- , PrimToUpper                 -- missing+  -- , PrimToLower                 -- missing+  -- , PrimCharToNat               -- missing+  -- , PrimCharToNatInjective      -- missing+  -- , PrimNatToChar               -- missing+  -- , PrimShowChar                -- in Agda.Builtin.String    -- String functions-  -- , "primStringToList"            -- in Agda.Builtin.String-  -- , "primStringToListInjective"   -- missing-  -- , "primStringFromList"          -- in Agda.Builtin.String-  -- , "primStringFromListInjective" -- missing-  -- , "primStringAppend"            -- in Agda.Builtin.String-  -- , "primStringEquality"          -- in Agda.Builtin.String-  -- , "primShowString"              -- in Agda.Builtin.String-  -- , "primStringUncons"            -- in Agda.Builtin.String+  -- , PrimStringToList            -- in Agda.Builtin.String+  -- , PrimStringToListInjective   -- missing+  -- , PrimStringFromList          -- in Agda.Builtin.String+  -- , PrimStringFromListInjective -- missing+  -- , PrimStringAppend            -- in Agda.Builtin.String+  -- , PrimStringEquality          -- in Agda.Builtin.String+  -- , PrimShowString              -- in Agda.Builtin.String+  -- , PrimStringUncons            -- in Agda.Builtin.String    -- Other stuff-  -- , "primEraseEquality"           -- missing-  -- , "primForce"                   -- missing-  -- , "primForceLemma"              -- missing-  , "primQNameEquality"-  , "primQNameLess"-  , "primShowQName"-  , "primQNameFixity"-  -- , "primQNameToWord64s"          -- missing-  -- , "primQNameToWord64sInjective" -- missing-  -- , "primMetaEquality"            -- missing-  -- , "primMetaLess"                -- missing-  -- , "primShowMeta"                -- missing-  -- , "primMetaToNat"               -- missing-  -- , "primMetaToNatInjective"      -- missing+  -- , PrimEraseEquality           -- missing+  -- , PrimForce                   -- missing+  -- , PrimForceLemma              -- missing+  , PrimQNameEquality+  , PrimQNameLess+  , PrimShowQName+  , PrimQNameFixity+  -- , PrimQNameToWord64s          -- missing+  -- , PrimQNameToWord64sInjective -- missing+  , PrimMetaEquality+  , PrimMetaLess+  , PrimShowMeta+  , PrimMetaToNat+  -- , PrimMetaToNatInjective      -- missing   , builtinIMin   , builtinIMax   , builtinINeg-  , "primPartial"-  , "primPartialP"+  , PrimPartial+  , PrimPartialP   , builtinPOr   , builtinComp   , builtinTrans@@ -850,11 +869,6 @@   , builtin_glueU   , builtin_unglueU   , builtinFaceForall-  , "primDepIMin"-  , "primIdFace"-  , "primIdPath"-  , "primIdJ"-  , builtinIdElim   -- , builtinGlue                   -- missing   -- , builtin_glue                  -- missing   -- , builtin_unglue                -- missing
src/full/Agda/Compiler/JS/Pretty.hs view
@@ -1,16 +1,19 @@ module Agda.Compiler.JS.Pretty where +import GHC.Generics (Generic)+ import Data.Char ( isAsciiLower, isAsciiUpper, isDigit ) import Data.List ( intercalate ) import Data.String ( IsString (fromString) ) import Data.Semigroup ( Semigroup, (<>) )-import Data.Set ( Set, toList, singleton, insert, member )+import Data.Set ( Set, toList, insert, member ) import qualified Data.Set as Set-import Data.Map ( Map, toAscList, empty, null )+import Data.Map ( Map, toAscList ) import qualified Data.Text as T  import Agda.Syntax.Common ( Nat ) +import Agda.Utils.Function ( applyWhen ) import Agda.Utils.Hash import Agda.Utils.List ( indexWithDefault ) import Agda.Utils.List1 ( List1, pattern (:|), (<|) )@@ -34,6 +37,9 @@ --  standard pretty printers. --- This library code is only used in this module, and it is specialized to pretty --- print JavaScript code for the Agda backend, so I think its best place is in this module.+data JSModuleStyle = JSES6 | JSCJS | JSAMD+  deriving Generic+ data Doc     = Doc String     | Indent Int Doc@@ -51,7 +57,7 @@ render minify = intercalate "\n" . joinLines . map (uncurry mkIndent) . go 0   where     joinLines :: [String] -> [String]-    joinLines = if minify then chunks 0 [] else id+    joinLines = applyWhen minify $ chunks 0 []       where         chunks len acc [] = [concat (reverse acc)]         chunks len acc (s: ss)@@ -76,12 +82,12 @@      punctuation = (`elem` ("(){}[];:, " :: String)) -    go i Space = if minify then [] else [(i, " ")]+    go i Space = [(i, " ") | not minify]     go i Empty = []     go i (Doc s) = [(i, s)]     go i (Beside d d') = joinBy (\(i, s) (_, s') -> [(i, s ++ s')]) (go i d) (go i d')     go i (Above d d') = joinBy overlay (go i d) (go i d')-    go i (Indent j d) = go (i+j) d+    go i (Indent j d) = go (i + j) d     go i (Enclose open close d) = go i $ Group $ Above open $ Above d close     go i (Group d)         | size ss < 40 = compact ss@@ -137,7 +143,7 @@  indentBy :: Int -> Doc -> Doc indentBy i Empty = Empty-indentBy i (Indent j d) = Indent (i+j) d+indentBy i (Indent j d) = Indent (i + j) d indentBy i d = Indent i d  enclose :: Doc -> Doc -> Doc -> Doc@@ -198,13 +204,19 @@ --   if b is true then the output is minified  class Pretty a where-    pretty :: (Nat, Bool) -> a -> Doc+    pretty :: (Nat, Bool, JSModuleStyle) -> a -> Doc+    prettyPrec :: Int -> (Nat, Bool, JSModuleStyle) -> a -> Doc -prettyShow :: Pretty a => Bool -> a -> String-prettyShow minify = render minify . pretty (0, minify)+    pretty = prettyPrec 0+    prettyPrec = const pretty +    {-# MINIMAL pretty | prettyPrec #-}++prettyShow :: Pretty a => Bool -> JSModuleStyle -> a -> String+prettyShow minify ms = render minify . pretty (0, minify, ms)+ instance Pretty a => Pretty (Maybe a) where-  pretty n = maybe mempty (pretty n)+  prettyPrec p n = maybe mempty (prettyPrec p n)  instance (Pretty a, Pretty b) => Pretty (a,b) where   pretty n (x,y) = pretty n x <> ":" <+> pretty n y@@ -212,7 +224,7 @@ -- Pretty-print collections  class Pretties a where-    pretties :: (Nat, Bool) -> a -> [Doc]+    pretties :: (Nat, Bool, JSModuleStyle) -> a -> [Doc]  instance Pretty a => Pretties [a] where   pretties n = map (pretty n)@@ -226,7 +238,7 @@ -- Pretty print identifiers  instance Pretty LocalId where-  pretty (n, _) (LocalId x) = text $ indexWithDefault __IMPOSSIBLE__ vars (n - x - 1)+  pretty (n, _, _) (LocalId x) = text $ indexWithDefault __IMPOSSIBLE__ vars (n - x - 1)     where       vars = ("": map show [0..]) >>= \s -> map (:s) ['a'..'z'] @@ -239,44 +251,45 @@  instance Pretty Comment where   pretty _ (Comment "") = mempty-  pretty (_, True) _ = mempty+  pretty (_, True, _) _ = mempty   pretty _ (Comment s) = text $ "/* " ++ s ++ " */"  -- Pretty print expressions  instance Pretty Exp where-  pretty n (Self)            = "exports"-  pretty n (Local x)         = pretty n x-  pretty n (Global m)        = pretty n m-  pretty n (Undefined)       = "undefined"-  pretty n (Null)            = "null"-  pretty n (String s)        = "\"" <> unescapes (T.unpack s) <> "\""-  pretty n (Char c)          = "\"" <> unescapes [c] <> "\""-  pretty n (Integer x)       = "agdaRTS.primIntegerFromString(\"" <> text (show x) <> "\")"-  pretty n (Double x)        = text $ show x-  pretty (n, min) (Lambda x e) =-    mparens (x /= 1) (punctuate "," (pretties (n+x, min) (map LocalId [x-1, x-2 .. 0])))-    <+> "=>" <+> block (n+x, min) e-  pretty n (Object o)        = braces $ punctuate "," $ pretties n o-  pretty n (Array es)        = brackets $ punctuate "," [pretty n c <> pretty n e | (c, e) <- es]-  pretty n (Apply f es)      = pretty n f <> parens (punctuate "," $ pretties n es)-  pretty n (Lookup e l)      = pretty n e <> brackets (pretty n l)-  pretty n (If e f g)        = parens $ pretty n e <> "?" <+> pretty n f <> ":" <+> pretty n g-  pretty n (PreOp op e)      = parens $ text op <> " " <> pretty n e-  pretty n (BinOp e op f)    = parens $ pretty n e <> " " <> text op <> " " <> pretty n f-  pretty n (Const c)         = text c-  pretty n (PlainJS js)      = text js+  prettyPrec p n (Self)         = "exports"+  prettyPrec p n (Local x)      = pretty n x+  prettyPrec p n (Global m)     = pretty n m+  prettyPrec p n (Undefined)    = "undefined"+  prettyPrec p n (Null)         = "null"+  prettyPrec p n (String s)     = "\"" <> unescapes (T.unpack s) <> "\""+  prettyPrec p n (Char c)       = "\"" <> unescapes [c] <> "\""+  prettyPrec p n (Integer x)    = "agdaRTS.primIntegerFromString(\"" <> text (show x) <> "\")"+  prettyPrec p n (Double x)     = text $ show x+  prettyPrec p (n, min, ms) (Lambda x e) = mparens (p > 2) $+    mparens (x /= 1) (punctuate "," (pretties (n + x, min, ms) (map LocalId [x-1, x-2 .. 0])))+    <+> "=>" <+> block (n + x, min, ms) e+  prettyPrec p n (Object o)     = braces $ punctuate "," $ pretties n o+  prettyPrec p n (Array es)     = brackets $ punctuate "," [pretty n c <> pretty n e | (c, e) <- es]+  prettyPrec p n (Apply f es)   = prettyPrec 17 n f <> parens (punctuate "," $ pretties n es)+  prettyPrec p n (Lookup e l)   = prettyPrec 17 n e <> brackets (pretty n l)+  prettyPrec p n (If e f g)     = mparens (p > 2) $+    prettyPrec 3 n e <> "?" <+> prettyPrec 3 n f <> ":" <+> prettyPrec 2 n g+  prettyPrec p n (PreOp op e)   = parens $ text op <> " " <> prettyPrec 17 n e+  prettyPrec p n (BinOp e op f) = parens $ prettyPrec 17 n e <> " " <> text op <> " " <> prettyPrec 17 n f+  prettyPrec p n (Const c)      = text c+  prettyPrec p n (PlainJS js)   = text js -block :: (Nat, Bool) -> Exp -> Doc-block n e = mparens (doNest e) $ pretty n e+block :: (Nat, Bool, JSModuleStyle) -> Exp -> Doc+block n e = mparens (doNest e) $ prettyPrec 2 n e   where     doNest Object{} = True     doNest _ = False  modname :: GlobalId -> Doc-modname (GlobalId ms) = text $ "\"" ++ intercalate "." ms ++ "\""+modname (GlobalId ms) = text $ intercalate "." ms -exports :: (Nat, Bool) -> Set JSQName -> [Export] -> Doc+exports :: (Nat, Bool, JSModuleStyle) -> Set JSQName -> [Export] -> Doc exports n lss [] = Empty exports n lss es0@(Export ls e : es)   -- If the parent of @ls@ is already defined (or no parent exists), @ls@ can be defined@@ -295,19 +308,50 @@            | (g, Export ls e) <- es ]  instance Pretty Module where-  pretty n (Module m is es callMain) = vsep-    [ importRTS+  pretty opt@(n, min, JSES6) (Module m is es callMain) = vsep+    [ "import agdaRTS from \"./agda-rts.mjs\";"     , imports-    , exports n Set.empty es-    , pretty n callMain+    , "const exports = {};"+    , exports opt Set.empty es+    , pretty opt callMain+    , ";export default exports;"     ]-    $+$ "" -- Final newline+    $+$ ""     where-      importRTS = "var agdaRTS" <+> "=" <+> "require(\"agda-rts\");"-      imports   = vcat-        [ "var " <> indent (pretty n e) <+> "=" <+> "require(" <> modname e <> ");"+      imports = vcat [+        "import " <> indent (pretty opt e) <+> " from \"./" <> modname e <> ".mjs\";"         | e <- toList (globals es <> Set.fromList is)         ]+      les = toList (globals es <> Set.fromList is)+  pretty opt@(n, min, JSCJS) (Module m is es callMain) = vsep+    [ "var agdaRTS" <+> "=" <+> "require(\"agda-rts\");"+    , imports+    , exports opt Set.empty es+    , pretty opt callMain+    ]+    $+$ ""+    where+      imports = vcat [+        "var " <> indent (pretty opt e) <+> "=" <+> "require(\"" <> modname e <> "\");"+        | e <- toList (globals es <> Set.fromList is)+        ]+      les = toList (globals es <> Set.fromList is)+  pretty opt@(n, min, JSAMD) (Module m is es callMain) = vsep+    [ "define(['agda-rts'"+      <+> hcat [ ", " <+> ("\"" <> modname e <> "\"") | e <- les ]+      <+> "],"+    , "function(agdaRTS"+      <+> hcat [ ", " <+> pretty opt e | e <- les ]+      <+> ") {"+    , "var exports = {};"+    , exports opt Set.empty es+    , pretty opt callMain+    , "; return exports; });"+    ]+    $+$ "" -- Final newline+    where+      les = toList (globals es <> Set.fromList is)+  variableName :: String -> String variableName s = if isValidJSIdent s then "z_" ++ s else "h_" ++ show (hashString s)
src/full/Agda/Compiler/JS/Substitution.hs view
@@ -11,7 +11,6 @@   ( Exp(Self,Undefined,Local,Lambda,Object,Array,Apply,Lookup,If,BinOp,PreOp),     MemberId, LocalId(LocalId) ) import Agda.Utils.Function ( iterate' )-import Agda.Utils.List ( indexWithDefault )  -- Map for expressions @@ -50,6 +49,9 @@ substituter n es m (LocalId i) | i < m       = Local (LocalId i) substituter n es m (LocalId i) | (i - m) < n = shift m (genericIndex (es ++ repeat Undefined) (n - (i + 1 - m))) substituter n es m (LocalId i) | otherwise   = Local (LocalId (i - n))++substShift :: Nat -> Nat -> [Exp] -> Exp -> Exp+substShift m n es = subst m es . shiftFrom m n  -- A variant on substitution which performs beta-reduction
src/full/Agda/Compiler/MAlonzo/Coerce.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Compiler.MAlonzo.Coerce (addCoercions, erasedArity) where
src/full/Agda/Compiler/MAlonzo/Compiler.hs view
@@ -1,9 +1,12 @@ -module Agda.Compiler.MAlonzo.Compiler where+module Agda.Compiler.MAlonzo.Compiler+  ( ghcBackend+  , ghcInvocationStrings+  )+  where  import Control.Arrow (second) import Control.DeepSeq-import Control.Monad import Control.Monad.Except   ( throwError ) import Control.Monad.IO.Class ( MonadIO(..) ) import Control.Monad.Reader   ( MonadReader(..), asks, ReaderT, runReaderT, withReaderT)@@ -45,20 +48,19 @@ import Agda.Compiler.Treeless.Erase import Agda.Compiler.Backend -import Agda.Interaction.Imports import Agda.Interaction.Options  import Agda.Syntax.Common-import qualified Agda.Syntax.Abstract.Name as A+import Agda.Syntax.Common.Pretty (prettyShow, render) import Agda.Syntax.Internal as I import Agda.Syntax.Internal.Names (namesIn) import qualified Agda.Syntax.Treeless as T import Agda.Syntax.Literal+import Agda.Syntax.TopLevelModuleName  import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Primitive (getBuiltinName)-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Pretty hiding ((<>))+import Agda.TypeChecking.Pretty import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope import Agda.TypeChecking.Warnings@@ -70,14 +72,13 @@ import Agda.Utils.IO.Directory import Agda.Utils.Lens import Agda.Utils.List+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad-import Agda.Utils.Pretty (prettyShow, render) import Agda.Utils.Singleton import qualified Agda.Utils.IO.UTF8 as UTF8-import Agda.Utils.String -import Paths_Agda+import Agda.Setup ( getDataDir )  import Agda.Utils.Impossible @@ -100,6 +101,8 @@   , compileDef            = ghcCompileDef   , scopeCheckingSuffices = False   , mayEraseType          = ghcMayEraseType+  , backendInteractTop    = Nothing+  , backendInteractHole   = Nothing   }  --- Command-line flags ---@@ -129,10 +132,18 @@   , flagGhcStrict     = False   } +-- | The option to activate the GHC backend.+--+ghcInvocationFlag :: OptDescr (Flag GHCFlags)+ghcInvocationFlag =+      Option ['c']  ["compile", "ghc"] (NoArg enable)+                    "compile program using the GHC backend"+  where+    enable      o = pure o{ flagGhcCompile    = True }+ ghcCommandLineFlags :: [OptDescr (Flag GHCFlags)] ghcCommandLineFlags =-    [ Option ['c']  ["compile", "ghc"] (NoArg enable)-                    "compile program using the GHC backend"+    [ ghcInvocationFlag     , Option []     ["ghc-dont-call-ghc"] (NoArg dontCallGHC)                     "don't call GHC, just write the GHC Haskell files."     , Option []     ["ghc-flag"] (ReqArg ghcFlag "GHC-FLAG")@@ -145,7 +156,6 @@                     "make functions strict"     ]   where-    enable      o = pure o{ flagGhcCompile    = True }     dontCallGHC o = pure o{ flagGhcCallGhc    = False }     ghcFlag f   o = pure o{ flagGhcFlags      = flagGhcFlags o ++ [f] }     strictData  o = pure o{ flagGhcStrictData = True }@@ -158,6 +168,16 @@  Nothing -> pure o { flagGhcBin = Just fp }  Just{}  -> throwError "only one compiler path allowed" +-- | Option strings to activate the GHC backend.+--+ghcInvocationStrings :: [String]+ghcInvocationStrings = optionStrings ghcInvocationFlag++-- | Get all flags that activate the given option.+--+optionStrings :: OptDescr a -> [String]+optionStrings (Option short long _ _) = map (\ c -> '-' : c : []) short ++ long+ --- Context types ---  -- | Monads that can read @GHCOptions@@@ -192,21 +212,16 @@   , ghcDefDecls      :: [HS.Decl]   , ghcDefDefinition :: Definition   , ghcDefMainDef    :: Maybe MainFunctionDef-  , ghcDefImports    :: Set ModuleName+  , ghcDefImports    :: Set TopLevelModuleName   }  --- Top-level compilation ---  ghcPreCompile :: GHCFlags -> TCM GHCEnv ghcPreCompile flags = do-  cubical <- optCubical <$> pragmaOptions-  let notSupported s =-        typeError $ GenericError $-          "Compilation of code that uses " ++ s ++ " is not supported."-  case cubical of-    Nothing      -> return ()-    Just CErased -> return ()-    Just CFull   -> notSupported "--cubical"+  whenJustM cubicalOption \case+    CErased -> pure ()+    CFull   -> typeError $ CubicalCompilationNotSupported CFull    outDir <- compileDir   let ghcOpts = GHCOptions@@ -244,8 +259,6 @@   mpathp      <- getBuiltinName builtinPathP   msub        <- getBuiltinName builtinSub   msubin      <- getBuiltinName builtinSubIn-  mid         <- getBuiltinName builtinId-  mconid      <- getBuiltinName builtinConId    istcbuiltin <- do     builtins <- mapM getBuiltinName@@ -267,26 +280,47 @@       , builtinAgdaTCMFreshName       , builtinAgdaTCMDeclareDef       , builtinAgdaTCMDeclarePostulate+      , builtinAgdaTCMDeclareData+      , builtinAgdaTCMDefineData       , builtinAgdaTCMDefineFun       , builtinAgdaTCMGetType       , builtinAgdaTCMGetDefinition-      , builtinAgdaTCMBlockOnMeta+      , builtinAgdaTCMBlock       , builtinAgdaTCMCommit       , builtinAgdaTCMIsMacro       , builtinAgdaTCMWithNormalisation-      , builtinAgdaTCMWithReconsParams+      , builtinAgdaTCMWithReconstructed+      , builtinAgdaTCMWithExpandLast+      , builtinAgdaTCMWithReduceDefs+      , builtinAgdaTCMAskNormalisation+      , builtinAgdaTCMAskReconstructed+      , builtinAgdaTCMAskExpandLast+      , builtinAgdaTCMAskReduceDefs+      , builtinAgdaTCMFormatErrorParts       , builtinAgdaTCMDebugPrint-      , builtinAgdaTCMOnlyReduceDefs-      , builtinAgdaTCMDontReduceDefs       , builtinAgdaTCMNoConstraints+      , builtinAgdaTCMWorkOnTypes       , builtinAgdaTCMRunSpeculative       , builtinAgdaTCMExec+      , builtinAgdaTCMCheckFromString+      , builtinAgdaTCMGetInstances+      , builtinAgdaTCMSolveInstances+      , builtinAgdaTCMPragmaForeign+      , builtinAgdaTCMPragmaCompile+      , builtinAgdaBlocker+      , builtinAgdaBlockerAll+      , builtinAgdaBlockerAny+      , builtinAgdaBlockerMeta       ]     return $       flip HashSet.member $       HashSet.fromList $       catMaybes builtins +  let defArity q = arity . defType <$> getConstInfo q+  listArity <- traverse defArity mlist+  maybeArity <- traverse defArity mmaybe+   return $ GHCEnv     { ghcEnvOpts        = ghcOpts     , ghcEnvBool        = mbool@@ -315,18 +349,20 @@     , ghcEnvPathP       = mpathp     , ghcEnvSub         = msub     , ghcEnvSubIn       = msubin-    , ghcEnvId          = mid-    , ghcEnvConId       = mconid     , ghcEnvIsTCBuiltin = istcbuiltin+    , ghcEnvListArity   = listArity+    , ghcEnvMaybeArity  = maybeArity     } -ghcPostCompile :: GHCEnv -> IsMain -> Map ModuleName GHCModule -> TCM ()+ghcPostCompile ::+  GHCEnv -> IsMain -> Map TopLevelModuleName GHCModule -> TCM () ghcPostCompile _cenv _isMain mods = do   -- FIXME: @curMName@ and @curIF@ are evil TCM state, but there does not appear to be   --------- another way to retrieve the compilation root ("main" module or interaction focused).   rootModuleName <- curMName-  rootModule <- ifJust (Map.lookup rootModuleName mods) pure-                $ genericError $ "Module " <> prettyShow rootModuleName <> " was not compiled!"+  -- Mario, 2024-10-16: cannot trigger this error:+  -- genericError $ "Module " <> prettyShow rootModuleName <> " was not compiled!"+  let rootModule = Map.findWithDefault __IMPOSSIBLE__ rootModuleName mods   flip runReaderT rootModule $ do     copyRTEModules     callGHC@@ -336,13 +372,13 @@ ghcPreModule   :: GHCEnv   -> IsMain      -- ^ Are we looking at the main module?-  -> ModuleName+  -> TopLevelModuleName   -> Maybe FilePath    -- ^ Path to the @.agdai@ file.   -> TCM (Recompile GHCModuleEnv GHCModule)                  -- ^ Could we confirm the existence of a main function? ghcPreModule cenv isMain m mifile =   (do let check = ifM uptodate noComp yesComp-      cubical <- optCubical <$> pragmaOptions+      cubical <- cubicalOption       case cubical of         -- Code that uses --cubical is not compiled.         Just CFull   -> noComp@@ -356,7 +392,8 @@     ifileDesc = fromMaybe "(memory)" mifile      noComp = do-      reportSLn "compile.ghc" 2 . (++ " : no compilation is needed.") . prettyShow . A.mnameToConcrete =<< curMName+      reportSLn "compile.ghc" 2 .+        (++ " : no compilation is needed.") . prettyShow =<< curMName       menv <- ask       mainDefs <- ifM curIsMainModule                          (mainFunctionDefs <$> curIF)@@ -364,16 +401,16 @@       return . Skip $ GHCModule menv mainDefs      yesComp = do-      m   <- prettyShow . A.mnameToConcrete <$> curMName+      m   <- prettyShow <$> curMName       out <- curOutFile-      reportSLn "compile.ghc" 1 $ repl [m, ifileDesc, out] "Compiling <<0>> in <<1>> to <<2>>"+      alwaysReportSLn "compile.ghc" 1 $ repl [m, ifileDesc, out] "Compiling <<0>> in <<1>> to <<2>>"       asks Recompile  ghcPostModule   :: GHCEnv   -> GHCModuleEnv   -> IsMain        -- ^ Are we looking at the main module?-  -> ModuleName+  -> TopLevelModuleName   -> [GHCDefinition]   -- ^ Compiled module content.   -> TCM GHCModule ghcPostModule _cenv menv _isMain _moduleName ghcDefs = do@@ -396,9 +433,9 @@     hsModuleName <- curHsMod     writeModule $ HS.Module       hsModuleName-      (map HS.OtherPragma headerPragmas)+      (map HS.OtherPragma $ List.nub headerPragmas)       imps-      (map fakeDecl (hsImps ++ code) ++ decls)+      (map fakeDecl (List.nub hsImps ++ code) ++ decls)    return $ GHCModule menv mainDefs @@ -421,7 +458,9 @@  -- Compilation ------------------------------------------------------------ -imports :: BuiltinThings PrimFun -> Set ModuleName -> [Definition] -> [HS.ImportDecl]+imports ::+  BuiltinThings -> Set TopLevelModuleName -> [Definition] ->+  [HS.ImportDecl] imports builtinThings usedModules defs = hsImps ++ imps where   hsImps :: [HS.ImportDecl]   hsImps = [unqualRTE, decl mazRTE]@@ -442,11 +481,11 @@   decl :: HS.ModuleName -> HS.ImportDecl   decl m = HS.ImportDecl m True Nothing -  mnames :: [ModuleName]+  mnames :: [TopLevelModuleName]   mnames = Set.elems usedModules    uniq :: [HS.ModuleName] -> [HS.ModuleName]-  uniq = List.map head . List.group . List.sort+  uniq = List.map List1.head . List1.group . List.sort  -- Should we import MAlonzo.RTE.Float newtype UsesFloat = UsesFloat Bool deriving (Eq, Show)@@ -473,9 +512,6 @@  definition :: Definition -> HsCompileM (UsesFloat, [HS.Decl], Maybe CheckedMainFunctionDef) -- ignore irrelevant definitions-{- Andreas, 2012-10-02: Invariant no longer holds-definition kit (Defn NonStrict _ _  _ _ _ _ _ _) = __IMPOSSIBLE__--} definition Defn{defArgInfo = info, defName = q} | not $ usableModality info = do   reportSDoc "compile.ghc.definition" 10 $     ("Not compiling" <+> prettyTCM q) <> "."@@ -494,11 +530,7 @@   (uncurry (,,typeCheckedMainDef)) . second ((mainDecl ++) . infodecl q) <$>     case d of -      _ | Just (HsDefn r hs) <- pragma -> setCurrentRange r $-          if is ghcEnvFlat-          then genericError-                "\"COMPILE GHC\" pragmas are not allowed for the FLAT builtin."-          else do+      _ | Just (HsDefn r hs) <- pragma -> setCurrentRange r $ do             -- Make sure we have imports for all names mentioned in the type.             hsty <- haskellType q             mapM_ (`xqual` HS.Ident "_") (namesIn ty :: Set QName)@@ -512,7 +544,7 @@        -- Compiling Bool       Datatype{} | is ghcEnvBool -> do-        _ <- sequence_ [primTrue, primFalse] -- Just to get the proper error for missing TRUE/FALSE+        sequence_ [primTrue, primFalse] -- Just to get the proper error for missing TRUE/FALSE         let d = dname q         Just true  <- getBuiltinName builtinTrue         Just false <- getBuiltinName builtinFalse@@ -523,9 +555,8 @@        -- Compiling List       Datatype{ dataPars = np } | is ghcEnvList -> do-        _ <- sequence_ [primNil, primCons] -- Just to get the proper error for missing NIL/CONS-        caseMaybe pragma (return ()) $ \ p -> setCurrentRange p $ warning . GenericWarning =<< do-          fsep $ pwords "Ignoring GHC pragma for builtin lists; they always compile to Haskell lists."+        sequence_ [primNil, primCons] -- Just to get the proper error for missing NIL/CONS+        whenJust pragma $ \ p -> setCurrentRange p $ warning PragmaCompileList         let d = dname q             t = unqhname TypeK q         Just nil  <- getBuiltinName builtinNil@@ -538,9 +569,8 @@        -- Compiling Maybe       Datatype{ dataPars = np } | is ghcEnvMaybe -> do-        _ <- sequence_ [primNothing, primJust] -- Just to get the proper error for missing NOTHING/JUST-        caseMaybe pragma (return ()) $ \ p -> setCurrentRange p $ warning . GenericWarning =<< do-          fsep $ pwords "Ignoring GHC pragma for builtin maybe; they always compile to Haskell lists."+        sequence_ [primNothing, primJust] -- Just to get the proper error for missing NOTHING/JUST+        whenJust pragma $ \ p -> setCurrentRange p $ warning PragmaCompileMaybe         let d = dname q             t = unqhname TypeK q         Just nothing <- getBuiltinName builtinNothing@@ -568,7 +598,7 @@       -- The interval is compiled as the type of booleans: 0 is       -- compiled as False and 1 as True.       Axiom{} | is ghcEnvInterval -> do-        _       <- sequence_ [primIZero, primIOne]+        sequence_ [primIZero, primIOne]         Just i0 <- getBuiltinName builtinIZero         Just i1 <- getBuiltinName builtinIOne         cs      <- mapM (compiledcondecl (Just 0)) [i0, i1]@@ -621,7 +651,7 @@       -- PathP is compiled as a function from the interval (booleans)       -- to the underlying type.       Axiom{} | is ghcEnvPathP -> do-        _        <- sequence_ [primInterval]+        sequence_ [primInterval]         Just int <- getBuiltinName builtinInterval         int      <- xhqn TypeK int         retDecls $@@ -655,38 +685,6 @@                  emptyBinds]           ] -      -- Id x y is compiled as a pair of a boolean and whatever-      -- Path x y is compiled to.-      Axiom{} | is ghcEnvId -> do-        _        <- sequence_ [primInterval]-        Just int <- getBuiltinName builtinInterval-        int      <- xhqn TypeK int-        retDecls $-          [ HS.TypeDecl (unqhname TypeK q)-              [HS.UnkindedVar (ihname A i) | i <- [0..3]]-              (HS.TyApp (HS.FakeType "(,) Bool")-                 (HS.TyFun (HS.TyCon int) mazAnyType))-          , HS.FunBind-              [HS.Match (dname q) []-                 (HS.UnGuardedRhs (HS.FakeExp "\\_ _ _ _ -> ()"))-                 emptyBinds]-          ]--      -- conid.-      Axiom{} | is ghcEnvConId -> do-        strict <- optGhcStrictData <$> askGhcOpts-        let var = (if strict then HS.PBangPat else id) . HS.PVar-        retDecls $-          [ HS.FunBind-              [HS.Match (dname q)-                 [ var (ihname A i) | i <- [0..1] ]-                 (HS.UnGuardedRhs $-                  HS.App (HS.App (HS.FakeExp "(,)")-                            (HS.Var (HS.UnQual (ihname A 0))))-                    (HS.Var (HS.UnQual (ihname A 1))))-                 emptyBinds]-          ]-       -- TC builtins are compiled to erased, which is an ∞-ary       -- function.       Axiom{} | ghcEnvIsTCBuiltin env q -> do@@ -705,7 +703,7 @@                    fb axiomErr       Primitive{ primName = s } -> (mempty,) . fb <$> (liftTCM . primBody) s -      PrimitiveSort{ primName = s } -> retDecls []+      PrimitiveSort{} -> retDecls []        Function{} -> function pragma $ functionViaTreeless q @@ -759,12 +757,7 @@   function mhe fun = do     (imp, ccls) <- fun     case mhe of-      Just (HsExport r name) -> setCurrentRange r $ do-        env <- askGHCEnv-        if Just q == ghcEnvFlat env-        then genericError-              "\"COMPILE GHC as\" pragmas are not allowed for the FLAT builtin."-        else do+      Just (HsExport r name) -> do           t <- setCurrentRange r $ haskellType q           let tsig :: HS.Decl               tsig = HS.TypeSig [HS.Ident name] t@@ -787,7 +780,7 @@       def <- getConstInfo q       (argTypes0, resType) <- hsTelApproximation $ defType def       let pars = case theDef def of-                   Function{ funProjection = Just Projection{ projIndex = i } } | i > 0 -> i - 1+                   Function{ funProjection = Right Projection{ projIndex = i } } | i > 0 -> i - 1                    _ -> 0           argTypes  = drop pars argTypes0           argTypesS = filterUsed used argTypes@@ -833,7 +826,9 @@  constructorCoverageCode :: QName -> Int -> [QName] -> HaskellType -> [HaskellCode] -> HsCompileM [HS.Decl] constructorCoverageCode q np cs hsTy hsCons = do-  liftTCM $ checkConstructorCount q cs hsCons+  -- Check that number of constructors matches up.+  unless (length cs == length hsCons) $+    ghcBackendError $ ConstructorCountMismatch q cs hsCons   ifM (liftTCM $ noCheckCover q) (return []) $ do     ccs <- List.concat <$> zipWithM checkConstructorType cs hsCons     cov <- liftTCM $ checkCover q hsTy np cs hsCons@@ -849,10 +844,10 @@ type NameSupply = [HS.Name] type CCContext  = [HS.Name] -ccNameSupply :: Lens' NameSupply CCEnv+ccNameSupply :: Lens' CCEnv NameSupply ccNameSupply f e =  (\ ns' -> e { _ccNameSupply = ns' }) <$> f (_ccNameSupply e) -ccContext :: Lens' CCContext CCEnv+ccContext :: Lens' CCEnv CCContext ccContext f e = (\ cxt -> e { _ccContext = cxt }) <$> f (_ccContext e)  -- | Initial environment for expression generation.@@ -995,7 +990,7 @@   T.TLet t1 t2 -> do     t1' <- term t1     intros 1 $ \[x] -> do-      hsLet x t1' <$> term t2+      hsLet x t1' . hsCoerce <$> term t2    T.TCase sc ct def alts -> do     sc'   <- term $ T.TVar sc@@ -1040,6 +1035,7 @@                       (HS.GuardedRhss [HS.GuardedRhs [HS.Qualifier g] b])                       emptyBinds     T.TALit { T.aLit = LitQName q } -> mkAlt (litqnamepat q)+    T.TALit { T.aLit = LitMeta _ m } -> mkAlt (litmetapat m)     T.TALit { T.aLit = l@LitFloat{}, T.aBody = b } -> do       tell YesFloat       l <- literal l@@ -1062,7 +1058,10 @@     mkAlt :: HS.Pat -> CC HS.Alt     mkAlt pat = do         body' <- term $ T.aBody a-        return $ HS.Alt pat (HS.UnGuardedRhs body') emptyBinds+        let body'' = case body' of+                       HS.Lambda{} -> hsCoerce body'+                       _           -> body'+        return $ HS.Alt pat (HS.UnGuardedRhs body'') emptyBinds  literal :: forall m. Monad m => Literal -> CCT m HS.Exp literal l = case l of@@ -1071,6 +1070,10 @@   LitFloat  x   -> floatExp x "Double"   LitQName  x   -> return $ litqname x   LitString s   -> return $ litString s+  LitMeta _ m   ->+    return $ HS.FakeExp "(,)" `HS.App`+             hsTypedInt (metaId m) `HS.App`+             (hsTypedInt (moduleNameHash $ metaModule m))   _             -> return $ l'   where     l'    = HS.Lit $ hslit l@@ -1135,13 +1138,19 @@   where     NameId n (ModuleNameHash m) = nameId $ qnameName x +litmetapat :: MetaId -> HS.Pat+litmetapat (MetaId m h) =+  HS.PApp (hsName "(,)")+          [ HS.PLit (HS.Int $ fromIntegral m)+          , HS.PLit (HS.Int $ fromIntegral $ moduleNameHash h) ]+ condecl :: QName -> Induction -> HsCompileM HS.ConDecl condecl q _ind = do   opts <- askGhcOpts   def <- getConstInfo q-  let Constructor{ conPars = np, conErased = erased } = theDef def+  let Constructor{ conPars = np, conSrcCon, conErased = erased } = theDef def   (argTypes0, _) <- hsTelApproximation (defType def)-  let strict     = if conInd (theDef def) == Inductive &&+  let strict     = if conInductive conSrcCon == Inductive &&                       optGhcStrictData opts                    then HS.Strict                    else HS.Lazy@@ -1270,10 +1279,11 @@  callGHC :: ReaderT GHCModule TCM () callGHC = do-  opts    <- askGhcOpts-  hsmod   <- prettyPrint <$> curHsMod-  agdaMod <- curAgdaMod-  let outputName = lastWithDefault __IMPOSSIBLE__ $ mnameToList agdaMod+  opts     <- askGhcOpts+  agdaOpts <- lift commandLineOptions+  hsmod    <- prettyPrint <$> curHsMod+  agdaMod  <- curAgdaMod+  let outputName = Text.unpack $ List1.last $ moduleNameParts agdaMod   (mdir, fp) <- curOutFileAndDir   let ghcopts = optGhcFlags opts @@ -1282,13 +1292,11 @@   let isMain = modIsMain && modHasMainFunc  -- both need to be IsMain    -- Warn if no main function and not --no-main-  when (modIsMain /= isMain) $-    genericWarning =<< fsep (pwords "No main function defined in" ++ [prettyTCM agdaMod <> "."] ++-                             pwords "Use --no-main to suppress this warning.")+  when (modIsMain /= isMain) $ warning $ NoMain agdaMod    let overridableArgs =         [ "-O"] ++-        (if isMain then ["-o", mdir </> prettyShow (nameConcrete outputName)] else []) +++        (if isMain then ["-o", mdir </> outputName] else []) ++         [ "-Werror"]       otherArgs       =         [ "-i" ++ mdir] ++@@ -1307,4 +1315,8 @@   -- those versions of GHC we don't print any progress information   -- unless an error is encountered.   let doCall = optGhcCallGhc opts-  liftTCM $ callCompiler doCall ghcBin args (Just utf8)+      cwd    = if optGHCiInteraction agdaOpts ||+                  optJSONInteraction agdaOpts+               then Just mdir+               else Nothing+  liftTCM $ callCompiler doCall ghcBin args cwd (Just utf8)
src/full/Agda/Compiler/MAlonzo/Encode.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ ------------------------------------------------------------------------ -- Module name encoding ------------------------------------------------------------------------
src/full/Agda/Compiler/MAlonzo/HaskellTypes.hs view
@@ -4,14 +4,13 @@  module Agda.Compiler.MAlonzo.HaskellTypes   ( haskellType-  , checkConstructorCount   , hsTelApproximation, hsTelApproximation'   ) where -import Control.Monad (zipWithM)-import Control.Monad.Except--- Control.Monad.Fail import is redundant since GHC 8.8.1-import Control.Monad.Fail (MonadFail)+import Control.Monad         ( zipWithM )+import Control.Monad.Except  ( ExceptT(ExceptT), runExceptT, mapExceptT, catchError, throwError )+import Control.Monad.Trans   ( lift )+ import Data.Maybe (fromMaybe) import Data.List (intercalate) @@ -33,7 +32,7 @@ import Agda.Utils.List import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Pretty (prettyShow)+import Agda.Syntax.Common.Pretty (prettyShow)  import Agda.Utils.Impossible @@ -60,53 +59,10 @@ hsFun a (HS.TyForall vs b) = HS.TyForall vs $ hsFun a b hsFun a b = HS.TyFun a b -data WhyNot = NoPragmaFor QName-            | WrongPragmaFor Range QName-            | BadLambda Term-            | BadMeta Term-            | BadDontCare Term-            | NotCompiled QName--type ToHs = ExceptT WhyNot HsCompileM--notAHaskellType :: Term -> WhyNot -> TCM a-notAHaskellType top offender = typeError . GenericDocError =<< do-  fsep (pwords "The type" ++ [prettyTCM top] ++-        pwords "cannot be translated to a corresponding Haskell type, because it contains" ++-        reason offender) $$ possibleFix offender-  where-    reason (BadLambda        v) = pwords "the lambda term" ++ [prettyTCM v <> "."]-    reason (BadMeta          v) = pwords "a meta variable" ++ [prettyTCM v <> "."]-    reason (BadDontCare      v) = pwords "an erased term" ++ [prettyTCM v <> "."]-    reason (NotCompiled      x) = pwords "a name that is not compiled"-                                  ++ [parens (prettyTCM x) <> "."]-    reason (NoPragmaFor      x) = prettyTCM x : pwords "which does not have a COMPILE pragma."-    reason (WrongPragmaFor _ x) = prettyTCM x : pwords "which has the wrong kind of COMPILE pragma."--    possibleFix BadLambda{}     = empty-    possibleFix BadMeta{}       = empty-    possibleFix BadDontCare{}   = empty-    possibleFix NotCompiled{}   = empty-    possibleFix (NoPragmaFor d) = suggestPragma d $ "add a pragma"-    possibleFix (WrongPragmaFor r d) = suggestPragma d $-      sep [ "replace the value-level pragma at", nest 2 $ pretty r, "by" ]--    suggestPragma d action = do-      def    <- theDef <$> getConstInfo d-      let dataPragma n = ("data type HsD", "data HsD (" ++ intercalate " | " [ "C" ++ show i | i <- [1..n] ] ++ ")")-          typePragma   = ("type HsT", "type HsT")-          (hsThing, pragma) =-            case def of-              Datatype{ dataCons = cs } -> dataPragma (length cs)-              Record{}                  -> dataPragma 1-              _                         -> typePragma-      vcat [ sep ["Possible fix:", action]-           , nest 2 $ hsep [ "{-# COMPILE GHC", prettyTCM d, "=", text pragma, "#-}" ]-           , text ("for a suitable Haskell " ++ hsThing ++ ".")-           ]+type ToHs = ExceptT WhyNotAHaskellType HsCompileM  runToHs :: Term -> ToHs a -> HsCompileM a-runToHs top m = either (liftTCM . notAHaskellType top) return =<< runExceptT m+runToHs top m = either (ghcBackendError . NotAHaskellType top) return =<< runExceptT m  liftE1' :: (forall b. (a -> m b) -> m b) -> (a -> ExceptT e m b) -> ExceptT e m b liftE1' f k = ExceptT (f (runExceptT . k))@@ -160,7 +116,7 @@     Record{}   -> True     _          -> False -getHsVar :: (MonadFail tcm, MonadTCM tcm) => Nat -> tcm HS.Name+getHsVar :: (MonadDebug tcm, MonadTCM tcm) => Nat -> tcm HS.Name getHsVar i =   HS.Ident . encodeString (VarK X) . prettyShow <$> nameOfBV i @@ -171,7 +127,8 @@     fromType = fromTerm . unEl     fromTerm v = do       v   <- liftTCM $ unSpine <$> reduce v-      reportSLn "compile.haskell.type" 50 $ "toHaskellType " ++ show v+      reportSDoc "compile.haskell.type" 25 $ "toHaskellType " <+> prettyTCM v+      reportSDoc "compile.haskell.type" 50 $ "toHaskellType " <+> pretty v       kit <- liftTCM coinductionKit       case v of         Var x es -> do@@ -221,24 +178,6 @@   reportSDoc "tc.pragma.compile" 10 $ (("Haskell type for" <+> prettyTCM q) <> ":") <?> pretty ty   return ty -checkConstructorCount :: QName -> [QName] -> [HaskellCode] -> TCM ()-checkConstructorCount d cs hsCons-  | n == hn   = return ()-  | otherwise = do-    let n_forms_are = case hn of-          1 -> "1 Haskell constructor is"-          n -> show n ++ " Haskell constructors are"-        only | hn == 0   = ""-             | hn < n    = "only "-             | otherwise = ""--    genericDocError =<<-      fsep (prettyTCM d : pwords ("has " ++ show n ++-            " constructors, but " ++ only ++ n_forms_are ++ " given [" ++ unwords hsCons ++ "]"))-  where-    n  = length cs-    hn = length hsCons- -- Type approximations ----------------------------------------------------  data PolyApprox = PolyApprox | NoPolyApprox@@ -252,6 +191,8 @@       rteCon = HS.TyCon . HS.Qual mazRTE . HS.Ident       tyVar n i = HS.TyVar $ HS.Ident $ "a" ++ show (n - i)   let go n t = do+        reportSDoc "compile.haskell.type" 25 $ "hsTypeApproximation " <+> prettyTCM t+        reportSDoc "compile.haskell.type" 50 $ "hsTypeApproximation " <+> pretty t         t <- unSpine <$> reduce t         case t of           Var i _ | poly == PolyApprox -> return $ tyVar n i@@ -259,10 +200,12 @@             where k = case b of Abs{} -> 1; NoAbs{} -> 0           Def q els             | q `is` ghcEnvList-            , Apply t <- last1 (Proj ProjSystem __IMPOSSIBLE__) els ->+            , Just k <- ghcEnvListArity env+            , [Apply t] <- drop (k-1) els ->               HS.TyApp (tyCon "[]") <$> go n (unArg t)             | q `is` ghcEnvMaybe-            , Apply t <- last1 (Proj ProjSystem __IMPOSSIBLE__) els ->+            , Just k <- ghcEnvMaybeArity env+            , [Apply t] <- drop (k-1) els ->               HS.TyApp (tyCon "Maybe") <$> go n (unArg t)             | q `is` ghcEnvBool    -> return $ tyCon "Bool"             | q `is` ghcEnvInteger -> return $ tyCon "Integer"
src/full/Agda/Compiler/MAlonzo/Misc.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Compiler.MAlonzo.Misc where @@ -17,21 +17,19 @@ import Data.Text (Text) import qualified Data.Text as T -#if !(MIN_VERSION_base(4,11,0))-import Data.Semigroup-#endif- import qualified Agda.Utils.Haskell.Syntax as HS -import Agda.Compiler.Common+import Agda.Compiler.Common as CC  import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.TopLevelModuleName  import Agda.TypeChecking.Monad -import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty +import Agda.Utils.CallStack ( HasCallStack ) import Agda.Utils.Impossible  --------------------------------------------------@@ -39,7 +37,7 @@ --------------------------------------------------  data HsModuleEnv = HsModuleEnv-  { mazModuleName :: ModuleName+  { mazModuleName :: TopLevelModuleName     -- ^ The name of the Agda module   , mazIsMainModule :: Bool   -- ^ Whether this is the compilation root and therefore should have the `main` function.@@ -93,12 +91,11 @@   , ghcEnvPathP   , ghcEnvSub   , ghcEnvSubIn-  , ghcEnvId-  , ghcEnvConId     :: Maybe QName     -- Various (possibly) builtin names.   , ghcEnvIsTCBuiltin :: QName -> Bool-    -- ^ Is the given name a @TC@ builtin (except for @TC@ itself)?+  , ghcEnvListArity   :: Maybe Int+  , ghcEnvMaybeArity  :: Maybe Int   }  -- | Module compilation environment, bundling the overall@@ -133,7 +130,7 @@ instance ReadGHCModuleEnv m => ReadGHCModuleEnv (StateT s m)  newtype HsCompileState = HsCompileState-  { mazAccumlatedImports :: Set ModuleName+  { mazAccumlatedImports :: Set TopLevelModuleName   } deriving (Eq, Semigroup, Monoid)  -- | Transformer adding read-only module info and a writable set of imported modules@@ -148,6 +145,9 @@ runHsCompileT :: HsCompileT m a -> GHCModuleEnv -> m (a, HsCompileState) runHsCompileT t e = runHsCompileT' t e mempty +ghcBackendError :: (HasCallStack, MonadTCError m) => GHCBackendError -> m a+ghcBackendError = locatedTypeError GHCBackendError+ -------------------------------------------------- -- utilities for haskell names --------------------------------------------------@@ -161,7 +161,7 @@ -- | This is the same value as @curMName@, but does not rely on the TCM's state. --   (@curMName@ and co. should be removed, but the current @Backend@ interface --   is not sufficient yet to allow that)-curAgdaMod :: ReadGHCModuleEnv m => m ModuleName+curAgdaMod :: ReadGHCModuleEnv m => m TopLevelModuleName curAgdaMod = mazModuleName <$> askHsModuleEnv  -- | Get the Haskell module name of the currently-focused Agda module@@ -237,14 +237,14 @@  -- the toplevel module containing the given one tlmodOf :: ReadTCState m => ModuleName -> m HS.ModuleName-tlmodOf = fmap mazMod . topLevelModuleName+tlmodOf = fmap mazMod . CC.topLevelModuleName   -- qualify HS.Name n by the module of QName q, if necessary; -- accumulates the used module in stImportedModules at the same time. xqual :: QName -> HS.Name -> HsCompileM HS.QName xqual q n = do-  m1 <- topLevelModuleName (qnameModule q)+  m1 <- CC.topLevelModuleName (qnameModule q)   m2 <- curAgdaMod   if m1 == m2     then return (HS.UnQual n)@@ -263,7 +263,7 @@ conhqn q = xhqn ConK =<< canonicalName q  -- qualify name s by the module of builtin b-bltQual :: String -> String -> HsCompileM HS.QName+bltQual :: BuiltinId -> String -> HsCompileM HS.QName bltQual b s = do   Def q _ <- getBuiltin b   xqual q (HS.Ident s)@@ -331,7 +331,7 @@ mazMod' :: String -> HS.ModuleName mazMod' s = HS.ModuleName $ mazstr ++ "." ++ s -mazMod :: ModuleName -> HS.ModuleName+mazMod :: TopLevelModuleName -> HS.ModuleName mazMod = mazMod' . prettyShow  mazCoerceName :: String
src/full/Agda/Compiler/MAlonzo/Pragmas.hs view
@@ -1,6 +1,9 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Compiler.MAlonzo.Pragmas where -import Control.Monad+import Control.Monad.Trans.Maybe+ import Data.Maybe import Data.Char import qualified Data.List as List@@ -10,15 +13,19 @@ import Agda.Syntax.Position import Agda.Syntax.Abstract.Name import Agda.TypeChecking.Monad+import Agda.TypeChecking.Warnings import Agda.TypeChecking.Primitive -import Agda.Utils.Pretty hiding (char)+import Agda.Compiler.MAlonzo.Misc+import Agda.Compiler.Treeless.Erase (isErasable)++import Agda.Syntax.Common.Pretty hiding (char)+import Agda.Utils.Functor+import Agda.Utils.Maybe+import Agda.Utils.Monad import Agda.Utils.String ( ltrim ) import Agda.Utils.Three -import Agda.Compiler.Common-import Agda.Compiler.MAlonzo.Misc- import Agda.Utils.Impossible  type HaskellCode = String@@ -52,17 +59,28 @@       ]     HsExport _r hsCode        -> "as" <+> text hsCode +-- | Retrieve and parse a @COMPILE GHC@ pragma stored for a name.+--+getHaskellPragma :: QName -> TCM (Maybe HaskellPragma)+getHaskellPragma q = runMaybeT do+  p <- MaybeT $ getUniqueCompilerPragma ghcBackendName q+  setCurrentRange p do+    pragma <- MaybeT $ parseHaskellPragma p+    MaybeT $ sanityCheckPragma q pragma+ -- Syntax for Haskell pragmas: --  HsDefn CODE       "= CODE" --  HsType TYPE       "= type TYPE" --  HsData NAME CONS  "= data NAME (CON₁ | .. | CONₙ)" --  HsExport NAME     "as NAME"-parsePragma :: CompilerPragma -> Either String HaskellPragma+parsePragma :: CompilerPragma -> Maybe HaskellPragma parsePragma (CompilerPragma r s) =   case [ p | (p, "") <- readP_to_S pragmaP s ] of-    []  -> Left $ "Failed to parse GHC pragma '" ++ s ++ "'"-    [p] -> Right p-    ps  -> Left $ "Ambiguous parse of pragma '" ++ s ++ "':\n" ++ unlines (map show ps)  -- shouldn't happen+    []  -> Nothing+    [p] -> Just p+    ps  -> -- shouldn't happen+           -- trace ("Ambiguous parse of pragma '" ++ s ++ "':\n" ++ unlines (map show ps)) $+           __IMPOSSIBLE__   where     pragmaP :: ReadP HaskellPragma     pragmaP = choice [ exportP, typeP, dataP, defnP ]@@ -86,9 +104,13 @@      paren = between (skipSpaces *> char '(') (skipSpaces *> char ')') +    isPrefixSpaceOf pre s = case List.stripPrefix pre s of+      Just (x:_) -> isSpace x+      _ -> False+     notTypeOrData = do       s <- look-      guard $ not $ any (`List.isPrefixOf` s) ["type", "data"]+      guard $ not $ any (`isPrefixSpaceOf` s) ["type", "data"]      exportP = HsExport r <$ wordsP ["as"]        <* whitespace <*> hsIdent <* skipSpaces     typeP   = HsType   r <$ wordsP ["=", "type"] <* whitespace <*> hsCode@@ -96,57 +118,71 @@                                                     paren (sepBy (skipSpaces *> hsIdent) barP) <* skipSpaces     defnP   = HsDefn   r <$ wordsP ["="]         <* whitespace <*  notTypeOrData <*> hsCode -parseHaskellPragma :: (MonadTCError m, MonadTrace m) => CompilerPragma -> m HaskellPragma-parseHaskellPragma p = setCurrentRange p $-  case parsePragma p of-    Left err -> genericError err-    Right p  -> return p+parseHaskellPragma :: CompilerPragma -> TCM (Maybe HaskellPragma)+parseHaskellPragma p@(CompilerPragma _ s) = do+  let p' = parsePragma p+  () <- whenNothing p' $ warning $ PragmaCompileUnparsable s+  return p' -getHaskellPragma :: QName -> TCM (Maybe HaskellPragma)-getHaskellPragma q = do-  pragma <- traverse parseHaskellPragma =<< getUniqueCompilerPragma ghcBackendName q-  def <- getConstInfo q-  setCurrentRange pragma $ pragma <$ sanityCheckPragma def pragma+-- | Check whether the parsed @COMPILE GHC@ pragma matches the kind of identifier it attaches to.+--+sanityCheckPragma :: QName -> HaskellPragma -> TCM (Maybe HaskellPragma)+sanityCheckPragma x pragma = do+  reportSLn "compile.haskell.pragma" 40 $ unwords ["sanityCheckPragma" , prettyShow x]+  def <- getConstInfo x+  case pragma of -sanityCheckPragma :: (HasBuiltins m, MonadTCError m, MonadReduce m) => Definition -> Maybe HaskellPragma -> m ()-sanityCheckPragma _ Nothing = return ()-sanityCheckPragma def (Just HsDefn{}) =-  case theDef def of-    Axiom{}        -> return ()-    Function{}     -> return ()-    AbstractDefn{} -> __IMPOSSIBLE__-    Datatype{}     -> recOrDataErr "data"-    Record{}       -> recOrDataErr "record"-    _              -> typeError $ GenericError "Haskell definitions can only be given for postulates and functions."-    where-      recOrDataErr which =-        typeError $ GenericDocError $-          sep [ text $ "Bad COMPILE GHC pragma for " ++ which ++ " type. Use"-              , "{-# COMPILE GHC <Name> = data <HsData> (<HsCon1> | .. | <HsConN>) #-}" ]-sanityCheckPragma def (Just HsData{}) =-  case theDef def of-    Datatype{} -> return ()-    Record{}   -> return ()-    _          -> typeError $ GenericError "Haskell data types can only be given for data or record types."-sanityCheckPragma def (Just HsType{}) =-  case theDef def of-    Axiom{} -> return ()-    Datatype{} -> do-      -- We use HsType pragmas for Nat, Int and Bool-      nat  <- getBuiltinName builtinNat-      int  <- getBuiltinName builtinInteger-      bool <- getBuiltinName builtinBool-      unless (Just (defName def) `elem` [nat, int, bool]) err-    _ -> err-  where-    err = typeError $ GenericError "Haskell types can only be given for postulates."-sanityCheckPragma def (Just HsExport{}) =-  case theDef def of-    Function{} -> return ()-    _ -> typeError $ GenericError "Only functions can be exported to Haskell using {-# COMPILE GHC <Name> as <HsName> #-}"+    HsDefn{} -> case theDef def of+      Axiom{}        -> ok+      Function{}     -> functionCheck+      AbstractDefn{} -> __IMPOSSIBLE__+      Datatype{}     -> recOrDataErr "data"+      Record{}       -> recOrDataErr "record"+      _ -> bad "Haskell definitions can only be given for postulates and functions." +    HsData{} -> case theDef def of+      Datatype{} -> ok+      Record{}   -> ok+      _ -> bad "Haskell data types can only be given for data or record types." +    HsType{} -> case theDef def of+      Axiom{}    -> ok+      Datatype{} -> do+        -- We use HsType pragmas for Nat, Int and Bool+        ifM (anyM ((Just (defName def) ==) <.> getBuiltinName) [builtinNat, builtinInteger, builtinBool])+          {-then-} ok+          {-else-} notPostulate+      _ -> notPostulate +    HsExport{} -> case theDef def of+      Function{} -> functionCheck+      _ -> bad "Only functions can be exported to Haskell using {-# COMPILE GHC <Name> as <HsName> #-}"++  where+    ok  = return $ Just pragma+    bad = (Nothing <$) . warning . PragmaCompileWrong x+    recOrDataErr which = bad $ unwords+      [ "Bad COMPILE GHC pragma for", which, "type. Use"+      , "{-# COMPILE GHC <Name> = data <HsData> (<HsCon1> | .. | <HsConN>) #-}"+      ]+    notPostulate = bad "Haskell types can only be given for postulates."+    notBuiltinFlat = do+      mflat <- getBuiltinName builtinFlat+      reportSLn "compile.haskell.pragma" 40 $ render $ vcat+        [ "Checking pragma for FLAT"+        , hsep [ "x     =", pretty x ]+        , hsep [ "mflat =", pretty mflat ]+        ]+      if Just x == mflat+        then bad "COMPILE GHC pragmas are not allowed for the FLAT builtin."+        else ok+    notErasable = isErasable x >>= \case+      True -> Nothing <$ do warning $ PragmaCompileErased ghcBackendName x+      False -> ok+    functionCheck = runMaybeT do+      _ <- MaybeT notErasable+      MaybeT notBuiltinFlat+ -- TODO: cache this to avoid parsing the pragma for every constructor --       occurrence! getHaskellConstructor :: QName -> HsCompileM (Maybe HaskellCode)@@ -178,7 +214,7 @@ --   file header pragmas, import statements, rest. foreignHaskell :: Interface -> ([String], [String], [String]) foreignHaskell = partitionByKindOfForeignCode classifyForeign-    . map getCode . fromMaybe [] . Map.lookup ghcBackendName . iForeignCode+    . map getCode . maybe [] (reverse . getForeignCodeStack) . Map.lookup ghcBackendName . iForeignCode   where getCode (ForeignCode _ code) = code  -- | Classify @FOREIGN@ Haskell code.
src/full/Agda/Compiler/MAlonzo/Pretty.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  ------------------------------------------------------------------------ -- Pretty-printing of Haskell modules@@ -6,12 +7,14 @@ module Agda.Compiler.MAlonzo.Pretty where  import qualified Agda.Utils.Haskell.Syntax as HS-import Text.PrettyPrint (empty)  import Agda.Compiler.MAlonzo.Encode-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty +import Agda.Utils.Null (empty)+import Agda.Utils.Function (applyWhen) + prettyPrint :: Pretty a => a -> String prettyPrint = show . pretty @@ -163,8 +166,7 @@     HS.String s -> text (show s)     where     parensIfNeg :: (Ord n, Num n) => n -> Doc -> Doc-    parensIfNeg x =-      if x < 0 then mparens (pr > 10) else id+    parensIfNeg x = applyWhen (x < 0) $ mparens (pr > 10)  instance Pretty HS.Exp where   prettyPrec pr e =
src/full/Agda/Compiler/MAlonzo/Primitives.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Compiler.MAlonzo.Primitives where @@ -7,26 +8,22 @@ import qualified Data.List as List import           Data.Map (Map) import qualified Data.Map as Map-import qualified Data.Set as Set import qualified Data.HashMap.Strict as HMap import Data.Maybe-import qualified Data.Text as T  import Agda.Compiler.Common-import Agda.Compiler.ToTreeless import Agda.Compiler.MAlonzo.Misc-import Agda.Compiler.MAlonzo.Pretty import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Syntax.Internal import Agda.Syntax.Treeless import Agda.TypeChecking.Monad import Agda.TypeChecking.Primitive import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Pretty  import Agda.Utils.Either import Agda.Utils.Lens-import Agda.Utils.Pretty (prettyShow)+import Agda.Utils.List   (hasElem) import qualified Agda.Utils.Haskell.Syntax as HS  import Agda.Utils.Impossible@@ -42,17 +39,17 @@ -- TODO: Also only consider top-level definition (not buried inside a module). asMainFunctionDef :: Definition -> Maybe MainFunctionDef asMainFunctionDef d = case (theDef d) of-    Axiom{}                             -> perhaps-    Function{ funProjection = Nothing } -> perhaps-    Function{ funProjection = Just{}  } -> no-    AbstractDefn{}                      -> no-    GeneralizableVar{}                  -> no-    DataOrRecSig{}                      -> no-    Datatype{}                          -> no-    Record{}                            -> no-    Constructor{}                       -> no-    Primitive{}                         -> no-    PrimitiveSort{}                     -> no+    Axiom{}                              -> perhaps+    Function{ funProjection = Left _ }   -> perhaps+    Function{ funProjection = Right{}  } -> no+    AbstractDefn{}                       -> no+    GeneralizableVar{}                   -> no+    DataOrRecSig{}                       -> no+    Datatype{}                           -> no+    Record{}                             -> no+    Constructor{}                        -> no+    Primitive{}                          -> no+    PrimitiveSort{}                      -> no   where   isNamedMain = "main" == prettyShow (nameConcrete . qnameName . defName $ d)  -- ignores the qualification!?   perhaps | isNamedMain = Just $ MainFunctionDef d@@ -78,11 +75,7 @@     ty <- reduce $ defType def     case unEl ty of       Def d _ | d == io -> return mainAlias-      _                 -> do-        err <- fsep $-          pwords "The type of main should be" ++-          [prettyTCM io] ++ pwords " A, for some A. The given type is" ++ [prettyTCM ty]-        typeError $ GenericError $ show err+      _ -> ghcBackendError $ WrongTypeOfMain io ty   where     mainAlias = HS.FunBind [HS.Match mainLHS [] mainRHS emptyBinds ]     mainLHS   = HS.Ident "main"@@ -118,204 +111,190 @@     PIf     -> __IMPOSSIBLE__  -- | Haskell modules to be imported for BUILT-INs-importsForPrim :: BuiltinThings PrimFun -> [Definition] -> [HS.ModuleName]+importsForPrim :: BuiltinThings -> [Definition] -> [HS.ModuleName] importsForPrim builtinThings defs = xForPrim table builtinThings defs ++ [HS.ModuleName "Data.Text"]   where-  table = Map.fromDistinctAscList $ map (second HS.ModuleName)-    -- KEEP THIS LIST IN ALPHABETICAL ORDER!-    -- Otherwise, Map.fromDistinctAscList will produce garbage.-    [ "CHAR"                       |-> "Data.Char"-    , "primFloatCeiling"           |-> "MAlonzo.RTE.Float"-    , "primFloatDecode"            |-> "MAlonzo.RTE.Float"-    , "primFloatEncode"            |-> "MAlonzo.RTE.Float"-    , "primFloatEquality"          |-> "MAlonzo.RTE.Float"-    , "primFloatFloor"             |-> "MAlonzo.RTE.Float"-    , "primFloatInequality"        |-> "MAlonzo.RTE.Float"-    , "primFloatIsSafeInteger"     |-> "MAlonzo.RTE.Float"-    , "primFloatLess"              |-> "MAlonzo.RTE.Float"-    , "primFloatRound"             |-> "MAlonzo.RTE.Float"-    , "primFloatToRatio"           |-> "MAlonzo.RTE.Float"-    , "primFloatToWord64"          |-> "MAlonzo.RTE.Float"-    , "primIsAlpha"                |-> "Data.Char"-    , "primIsAscii"                |-> "Data.Char"-    , "primIsDigit"                |-> "Data.Char"-    , "primIsHexDigit"             |-> "Data.Char"-    , "primIsLatin1"               |-> "Data.Char"-    , "primIsLower"                |-> "Data.Char"-    , "primIsPrint"                |-> "Data.Char"-    , "primIsSpace"                |-> "Data.Char"-    , "primRatioToFloat"           |-> "MAlonzo.RTE.Float"-    , "primToLower"                |-> "Data.Char"-    , "primToUpper"                |-> "Data.Char"+  table = Map.fromList $ map (second HS.ModuleName)+    [ someBuiltin BuiltinChar                |-> "Data.Char"+    , someBuiltin PrimFloatCeiling           |-> "MAlonzo.RTE.Float"+    , someBuiltin PrimFloatDecode            |-> "MAlonzo.RTE.Float"+    , someBuiltin PrimFloatEncode            |-> "MAlonzo.RTE.Float"+    , someBuiltin PrimFloatEquality          |-> "MAlonzo.RTE.Float"+    , someBuiltin PrimFloatFloor             |-> "MAlonzo.RTE.Float"+    , someBuiltin PrimFloatInequality        |-> "MAlonzo.RTE.Float"+    , someBuiltin PrimFloatIsSafeInteger     |-> "MAlonzo.RTE.Float"+    , someBuiltin PrimFloatLess              |-> "MAlonzo.RTE.Float"+    , someBuiltin PrimFloatRound             |-> "MAlonzo.RTE.Float"+    , someBuiltin PrimFloatToRatio           |-> "MAlonzo.RTE.Float"+    , someBuiltin PrimFloatToWord64          |-> "MAlonzo.RTE.Float"+    , someBuiltin PrimIsAlpha                |-> "Data.Char"+    , someBuiltin PrimIsAscii                |-> "Data.Char"+    , someBuiltin PrimIsDigit                |-> "Data.Char"+    , someBuiltin PrimIsHexDigit             |-> "Data.Char"+    , someBuiltin PrimIsLatin1               |-> "Data.Char"+    , someBuiltin PrimIsLower                |-> "Data.Char"+    , someBuiltin PrimIsPrint                |-> "Data.Char"+    , someBuiltin PrimIsSpace                |-> "Data.Char"+    , someBuiltin PrimRatioToFloat           |-> "MAlonzo.RTE.Float"+    , someBuiltin PrimToLower                |-> "Data.Char"+    , someBuiltin PrimToUpper                |-> "Data.Char"     ]   (|->) = (,)  -------------- -xForPrim :: Map String a -> BuiltinThings PrimFun -> [Definition] -> [a]+xForPrim :: Map SomeBuiltin a -> BuiltinThings -> [Definition] -> [a] xForPrim table builtinThings defs = catMaybes     [ Map.lookup s table     | (s, def) <- Map.toList builtinThings-    , getName def `Set.member` qs+    , maybe False elemDefs $ getName def     ]   where-  qs = Set.fromList $ map defName defs-  getName (Builtin t)            = getPrimName t-  getName (Prim (PrimFun q _ _)) = q+  elemDefs = hasElem $ map defName defs+  getName = \case+    Builtin t                 -> Just $ getPrimName t+    Prim (PrimFun q _ _ _)    -> Just q+    BuiltinRewriteRelations _ -> Nothing   -- | Definition bodies for primitive functions-primBody :: MonadTCError m => String -> m HS.Exp-primBody s = maybe unimplemented (fromRight (hsVarUQ . HS.Ident) <$>) $-             List.lookup s $+primBody :: MonadTCError m => PrimitiveId -> m HS.Exp+primBody s = maybe unimplemented (fromRight (hsVarUQ . HS.Ident) <$>) $ List.lookup s $   [   -- Integer functions-    "primIntegerPlus"    |-> binAsis "(+)" "Integer"-  , "primIntegerMinus"   |-> binAsis "(-)" "Integer"-  , "primIntegerTimes"   |-> binAsis "(*)" "Integer"-  , "primIntegerDiv"     |-> binAsis "div" "Integer"-  , "primIntegerMod"     |-> binAsis "mod" "Integer"-  , "primIntegerEquality"|-> rel "(==)" "Integer"-  , "primIntegerLess"    |-> rel "(<)"  "Integer"-  , "primIntegerAbs"     |-> return "(abs :: Integer -> Integer)"-  , "primNatToInteger"   |-> return "(id :: Integer -> Integer)"-  , "primShowInteger"    |-> return "(Data.Text.pack . show :: Integer -> Data.Text.Text)"+    PrimShowInteger      |-> return "(Data.Text.pack . show :: Integer -> Data.Text.Text)"    -- Levels-  , "primLevelZero"   |-> return "()"-  , "primLevelSuc"    |-> return "(\\ _ -> ())"-  , "primLevelMax"    |-> return "(\\ _ _ -> ())"--  -- Sorts-  , "primSetOmega"    |-> return "()"-  , "primStrictSet"   |-> return "\\ _ -> ()"+  , PrimLevelZero        |-> return "()"+  , PrimLevelSuc         |-> return "(\\ _ -> ())"+  , PrimLevelMax         |-> return "(\\ _ _ -> ())"    -- Natural number functions-  , "primNatPlus"      |-> binNat "(+)"-  , "primNatMinus"     |-> binNat "(\\ x y -> max 0 (x - y))"-  , "primNatTimes"     |-> binNat "(*)"-  , "primNatDivSucAux" |-> binNat4 "(\\ k m n j -> k + div (max 0 $ n + m - j) (m + 1))"-  , "primNatModSucAux" |-> binNat4 "(\\ k m n j -> if n > j then mod (n - j - 1) (m + 1) else (k + n))"-  , "primNatEquality"  |-> relNat "(==)"-  , "primNatLess"      |-> relNat "(<)"-  , "primShowNat"      |-> return "(Data.Text.pack . show :: Integer -> Data.Text.Text)"+  , PrimNatPlus         |-> binNat "(+)"+  , PrimNatMinus        |-> binNat "(\\ x y -> max 0 (x - y))"+  , PrimNatTimes        |-> binNat "(*)"+  , PrimNatDivSucAux    |-> binNat4 "(\\ k m n j -> k + div (max 0 $ n + m - j) (m + 1))"+  , PrimNatModSucAux    |-> binNat4 "(\\ k m n j -> if n > j then mod (n - j - 1) (m + 1) else (k + n))"+  , PrimNatEquality     |-> relNat "(==)"+  , PrimNatLess         |-> relNat "(<)"+  , PrimShowNat         |-> return "(Data.Text.pack . show :: Integer -> Data.Text.Text)"    -- Machine word functions-  , "primWord64ToNat"   |-> return "MAlonzo.RTE.word64ToNat"-  , "primWord64FromNat" |-> return "MAlonzo.RTE.word64FromNat"-  , "primWord64ToNatInjective" |-> return mazErasedName+  , PrimWord64ToNat     |-> return "MAlonzo.RTE.word64ToNat"+  , PrimWord64FromNat   |-> return "MAlonzo.RTE.word64FromNat"+  , PrimWord64ToNatInjective   |-> return mazErasedName    -- Floating point functions-  , "primFloatEquality"          |-> return "MAlonzo.RTE.Float.doubleEq"-  , "primFloatInequality"        |-> return "MAlonzo.RTE.Float.doubleLe"-  , "primFloatLess"              |-> return "MAlonzo.RTE.Float.doubleLt"-  , "primFloatIsInfinite"        |-> return "(isInfinite :: Double -> Bool)"-  , "primFloatIsNaN"             |-> return "(isNaN :: Double -> Bool)"-  , "primFloatIsNegativeZero"    |-> return "(isNegativeZero :: Double -> Bool)"-  , "primFloatIsSafeInteger"     |-> return "MAlonzo.RTE.Float.isSafeInteger"-  , "primFloatToWord64"          |-> return "MAlonzo.RTE.Float.doubleToWord64"-  , "primFloatToWord64Injective" |-> return mazErasedName-  , "primNatToFloat"             |-> return "(MAlonzo.RTE.Float.intToDouble :: Integer -> Double)"-  , "primIntToFloat"             |-> return "(MAlonzo.RTE.Float.intToDouble :: Integer -> Double)"-  , "primFloatRound"             |-> return "MAlonzo.RTE.Float.doubleRound"-  , "primFloatFloor"             |-> return "MAlonzo.RTE.Float.doubleFloor"-  , "primFloatCeiling"           |-> return "MAlonzo.RTE.Float.doubleCeiling"-  , "primFloatToRatio"           |-> return "MAlonzo.RTE.Float.doubleToRatio"-  , "primRatioToFloat"           |-> return "MAlonzo.RTE.Float.ratioToDouble"-  , "primFloatDecode"            |-> return "MAlonzo.RTE.Float.doubleDecode"-  , "primFloatEncode"            |-> return "MAlonzo.RTE.Float.doubleEncode"-  , "primShowFloat"              |-> return "(Data.Text.pack . show :: Double -> Data.Text.Text)"-  , "primFloatPlus"              |-> return "MAlonzo.RTE.Float.doublePlus"-  , "primFloatMinus"             |-> return "MAlonzo.RTE.Float.doubleMinus"-  , "primFloatTimes"             |-> return "MAlonzo.RTE.Float.doubleTimes"-  , "primFloatNegate"            |-> return "MAlonzo.RTE.Float.doubleNegate"-  , "primFloatDiv"               |-> return "MAlonzo.RTE.Float.doubleDiv"-  , "primFloatPow"               |-> return "MAlonzo.RTE.Float.doublePow"-  , "primFloatSqrt"              |-> return "MAlonzo.RTE.Float.doubleSqrt"-  , "primFloatExp"               |-> return "MAlonzo.RTE.Float.doubleExp"-  , "primFloatLog"               |-> return "MAlonzo.RTE.Float.doubleLog"-  , "primFloatSin"               |-> return "MAlonzo.RTE.Float.doubleSin"-  , "primFloatCos"               |-> return "MAlonzo.RTE.Float.doubleCos"-  , "primFloatTan"               |-> return "MAlonzo.RTE.Float.doubleTan"-  , "primFloatASin"              |-> return "MAlonzo.RTE.Float.doubleASin"-  , "primFloatACos"              |-> return "MAlonzo.RTE.Float.doubleACos"-  , "primFloatATan"              |-> return "MAlonzo.RTE.Float.doubleATan"-  , "primFloatATan2"             |-> return "MAlonzo.RTE.Float.doubleATan2"-  , "primFloatSinh"              |-> return "MAlonzo.RTE.Float.doubleSinh"-  , "primFloatCosh"              |-> return "MAlonzo.RTE.Float.doubleCosh"-  , "primFloatTanh"              |-> return "MAlonzo.RTE.Float.doubleTanh"-  , "primFloatASinh"             |-> return "MAlonzo.RTE.Float.doubleASinh"-  , "primFloatACosh"             |-> return "MAlonzo.RTE.Float.doubleACosh"-  , "primFloatATanh"             |-> return "MAlonzo.RTE.Float.doubleATanh"+  , PrimFloatEquality            |-> return "MAlonzo.RTE.Float.doubleEq"+  , PrimFloatInequality          |-> return "MAlonzo.RTE.Float.doubleLe"+  , PrimFloatLess                |-> return "MAlonzo.RTE.Float.doubleLt"+  , PrimFloatIsInfinite          |-> return "(isInfinite :: Double -> Bool)"+  , PrimFloatIsNaN               |-> return "(isNaN :: Double -> Bool)"+  , PrimFloatIsNegativeZero      |-> return "(isNegativeZero :: Double -> Bool)"+  , PrimFloatIsSafeInteger       |-> return "MAlonzo.RTE.Float.isSafeInteger"+  , PrimFloatToWord64            |-> return "MAlonzo.RTE.Float.doubleToWord64"+  , PrimFloatToWord64Injective   |-> return mazErasedName+  , PrimNatToFloat               |-> return "(MAlonzo.RTE.Float.intToDouble :: Integer -> Double)"+  , PrimIntToFloat               |-> return "(MAlonzo.RTE.Float.intToDouble :: Integer -> Double)"+  , PrimFloatRound               |-> return "MAlonzo.RTE.Float.doubleRound"+  , PrimFloatFloor               |-> return "MAlonzo.RTE.Float.doubleFloor"+  , PrimFloatCeiling             |-> return "MAlonzo.RTE.Float.doubleCeiling"+  , PrimFloatToRatio             |-> return "MAlonzo.RTE.Float.doubleToRatio"+  , PrimRatioToFloat             |-> return "MAlonzo.RTE.Float.ratioToDouble"+  , PrimFloatDecode              |-> return "MAlonzo.RTE.Float.doubleDecode"+  , PrimFloatEncode              |-> return "MAlonzo.RTE.Float.doubleEncode"+  , PrimShowFloat                |-> return "(Data.Text.pack . show :: Double -> Data.Text.Text)"+  , PrimFloatPlus                |-> return "MAlonzo.RTE.Float.doublePlus"+  , PrimFloatMinus               |-> return "MAlonzo.RTE.Float.doubleMinus"+  , PrimFloatTimes               |-> return "MAlonzo.RTE.Float.doubleTimes"+  , PrimFloatNegate              |-> return "MAlonzo.RTE.Float.doubleNegate"+  , PrimFloatDiv                 |-> return "MAlonzo.RTE.Float.doubleDiv"+  , PrimFloatPow                 |-> return "MAlonzo.RTE.Float.doublePow"+  , PrimFloatSqrt                |-> return "MAlonzo.RTE.Float.doubleSqrt"+  , PrimFloatExp                 |-> return "MAlonzo.RTE.Float.doubleExp"+  , PrimFloatLog                 |-> return "MAlonzo.RTE.Float.doubleLog"+  , PrimFloatSin                 |-> return "MAlonzo.RTE.Float.doubleSin"+  , PrimFloatCos                 |-> return "MAlonzo.RTE.Float.doubleCos"+  , PrimFloatTan                 |-> return "MAlonzo.RTE.Float.doubleTan"+  , PrimFloatASin                |-> return "MAlonzo.RTE.Float.doubleASin"+  , PrimFloatACos                |-> return "MAlonzo.RTE.Float.doubleACos"+  , PrimFloatATan                |-> return "MAlonzo.RTE.Float.doubleATan"+  , PrimFloatATan2               |-> return "MAlonzo.RTE.Float.doubleATan2"+  , PrimFloatSinh                |-> return "MAlonzo.RTE.Float.doubleSinh"+  , PrimFloatCosh                |-> return "MAlonzo.RTE.Float.doubleCosh"+  , PrimFloatTanh                |-> return "MAlonzo.RTE.Float.doubleTanh"+  , PrimFloatASinh               |-> return "MAlonzo.RTE.Float.doubleASinh"+  , PrimFloatACosh               |-> return "MAlonzo.RTE.Float.doubleACosh"+  , PrimFloatATanh               |-> return "MAlonzo.RTE.Float.doubleATanh"    -- Character functions-  , "primCharEquality"   |-> rel "(==)" "Char"-  , "primIsLower"        |-> return "Data.Char.isLower"-  , "primIsDigit"        |-> return "Data.Char.isDigit"-  , "primIsAlpha"        |-> return "Data.Char.isAlpha"-  , "primIsSpace"        |-> return "Data.Char.isSpace"-  , "primIsAscii"        |-> return "Data.Char.isAscii"-  , "primIsLatin1"       |-> return "Data.Char.isLatin1"-  , "primIsPrint"        |-> return "Data.Char.isPrint"-  , "primIsHexDigit"     |-> return "Data.Char.isHexDigit"-  , "primToUpper"        |-> return "Data.Char.toUpper"-  , "primToLower"        |-> return "Data.Char.toLower"-  , "primCharToNat" |-> return "(fromIntegral . fromEnum :: Char -> Integer)"-  , "primNatToChar" |-> return "MAlonzo.RTE.natToChar"-  , "primShowChar"  |-> return "(Data.Text.pack . show :: Char -> Data.Text.Text)"-  , "primCharToNatInjective" |-> return mazErasedName+  , PrimCharEquality     |-> rel "(==)" "Char"+  , PrimIsLower          |-> return "Data.Char.isLower"+  , PrimIsDigit          |-> return "Data.Char.isDigit"+  , PrimIsAlpha          |-> return "Data.Char.isAlpha"+  , PrimIsSpace          |-> return "Data.Char.isSpace"+  , PrimIsAscii          |-> return "Data.Char.isAscii"+  , PrimIsLatin1         |-> return "Data.Char.isLatin1"+  , PrimIsPrint          |-> return "Data.Char.isPrint"+  , PrimIsHexDigit       |-> return "Data.Char.isHexDigit"+  , PrimToUpper          |-> return "Data.Char.toUpper"+  , PrimToLower          |-> return "Data.Char.toLower"+  , PrimCharToNat   |-> return "(fromIntegral . fromEnum :: Char -> Integer)"+  , PrimNatToChar   |-> return "MAlonzo.RTE.natToChar"+  , PrimShowChar    |-> return "(Data.Text.pack . show :: Char -> Data.Text.Text)"+  , PrimCharToNatInjective   |-> return mazErasedName    -- String functions-  , "primStringUncons"   |-> return "Data.Text.uncons"-  , "primStringToList"   |-> return "Data.Text.unpack"-  , "primStringFromList" |-> return "Data.Text.pack"-  , "primStringAppend"   |-> binAsis "Data.Text.append" "Data.Text.Text"-  , "primStringEquality" |-> rel "(==)" "Data.Text.Text"-  , "primShowString"     |-> return "(Data.Text.pack . show :: Data.Text.Text -> Data.Text.Text)"-  , "primStringToListInjective" |-> return mazErasedName-  , "primStringFromListInjective" |-> return mazErasedName+  , PrimStringUncons     |-> return "Data.Text.uncons"+  , PrimStringToList     |-> return "Data.Text.unpack"+  , PrimStringFromList   |-> return "Data.Text.pack"+  , PrimStringAppend     |-> binAsis "Data.Text.append" "Data.Text.Text"+  , PrimStringEquality   |-> rel "(==)" "Data.Text.Text"+  , PrimShowString       |-> return "(Data.Text.pack . show :: Data.Text.Text -> Data.Text.Text)"+  , PrimStringToListInjective   |-> return mazErasedName+  , PrimStringFromListInjective   |-> return mazErasedName    -- Reflection-  , "primQNameEquality"   |-> rel "(==)" "MAlonzo.RTE.QName"-  , "primQNameLess"       |-> rel "(<)" "MAlonzo.RTE.QName"-  , "primShowQName"       |-> return "Data.Text.pack . MAlonzo.RTE.qnameString"-  , "primQNameFixity"     |-> return "MAlonzo.RTE.qnameFixity"-  , "primQNameToWord64s"  |-> return "\\ qn -> (MAlonzo.RTE.nameId qn, MAlonzo.RTE.moduleId qn)"-  , "primQNameToWord64sInjective" |-> return mazErasedName-  , "primMetaEquality"    |-> rel "(==)" "Integer"-  , "primMetaLess"        |-> rel "(<)" "Integer"-  , "primShowMeta"        |-> return "\\ x -> Data.Text.pack (\"_\" ++ show (x :: Integer))"-  , "primMetaToNat"       |-> return "(id :: Integer -> Integer)"-  , "primMetaToNatInjective" |-> return mazErasedName+  , PrimQNameEquality     |-> rel "(==)" "MAlonzo.RTE.QName"+  , PrimQNameLess         |-> rel "(<)" "MAlonzo.RTE.QName"+  , PrimShowQName         |-> return "Data.Text.pack . MAlonzo.RTE.qnameString"+  , PrimQNameFixity       |-> return "MAlonzo.RTE.qnameFixity"+  , PrimQNameToWord64s    |-> return "\\ qn -> (MAlonzo.RTE.nameId qn, MAlonzo.RTE.moduleId qn)"+  , PrimQNameToWord64sInjective   |-> return mazErasedName+  , PrimMetaEquality      |-> rel "(==)" "(Integer, Integer)"+  , PrimMetaLess          |-> rel "(<)" "(Integer, Integer)"+  -- Should be kept in sync with version in `primitiveFunctions` in+  -- Agda.TypeChecking.Primitive+  , PrimShowMeta          |-> return "\\ (m, h) -> Data.Text.pack (\"_\" ++ show (m :: Integer) ++ \"@\" ++ show (h :: Integer))"+  -- Should be kept in sync with `metaToNat` in Agda.TypeChecking.Primitive+  , PrimMetaToNat         |-> return "\\ (m, h) -> (h :: Integer) * 2^64 + (m :: Integer)"+  , PrimMetaToNatInjective   |-> return mazErasedName    -- Seq-  , "primForce"      |-> return "\\ _ _ _ _ x f -> f $! x"-  , "primForceLemma" |-> return mazErasedName+  , PrimForce        |-> return "\\ _ _ _ _ x f -> f $! x"+  , PrimForceLemma   |-> return mazErasedName +  -- Lock universe+  , PrimLockUniv |-> return "()"+   -- Erase-  , "primEraseEquality" |-> return mazErasedName+  , PrimEraseEquality |-> return mazErasedName    -- Cubical-  , builtinIMin       |-> return "(&&)"-  , builtinIMax       |-> return "(||)"-  , builtinINeg       |-> return "not"-  , "primPartial"     |-> return "\\_ _ x -> x"-  , "primPartialP"    |-> return "\\_ _ x -> x"-  , builtinPOr        |-> return "\\_ i _ _ x y -> if i then x else y"-  , builtinComp       |-> return "\\_ _ _ _ x -> x"-  , builtinTrans      |-> return "\\_ _ _ x -> x"-  , builtinHComp      |-> return "\\_ _ _ _ x -> x"-  , builtinSubOut     |-> return "\\_ _ _ _ x -> x"-  , builtin_glueU     |-> return "\\_ _ _ _ _ x -> x"-  , builtin_unglueU   |-> return "\\_ _ _ _ x -> x"-  , builtinFaceForall |-> return+  , PrimIMin          |-> return "(&&)"+  , PrimIMax          |-> return "(||)"+  , PrimINeg          |-> return "not"+  , PrimPartial       |-> return "\\_ _ x -> x"+  , PrimPartialP      |-> return "\\_ _ x -> x"+  , PrimPOr           |-> return "\\_ i _ _ x y -> if i then x else y"+  , PrimComp          |-> return "\\_ _ _ _ x -> x"+  , PrimTrans         |-> return "\\_ _ _ x -> x"+  , PrimHComp         |-> return "\\_ _ _ _ x -> x"+  , PrimSubOut        |-> return "\\_ _ _ _ x -> x"+  , Prim_glueU        |-> return "\\_ _ _ _ _ x -> x"+  , Prim_unglueU      |-> return "\\_ _ _ _ x -> x"+  , PrimFaceForall    |-> return                             "\\f -> f True == True && f False == True"-  , "primDepIMin"     |-> return "\\i f -> if i then f () else False"-  , "primIdFace"      |-> return "\\_ _ _ _ -> fst"-  , "primIdPath"      |-> return "\\_ _ _ _ -> snd"-  , "primIdJ"         |-> return "\\_ _ _ _ _ x _ _ -> x"-  , builtinIdElim     |-> return-                            "\\_ _ _ _ _ f x y -> f (fst y) x (snd y)"   ]   where   x |-> s = (x, Left <$> s)@@ -330,15 +309,10 @@       "(<<0>> :: Integer -> Integer -> Bool)"   rel op ty  = rel' "" op ty   opty t = t ++ "->" ++ t ++ "->" ++ t-  unimplemented = typeError $ NotImplemented s+  unimplemented = typeError $ NotImplemented (getBuiltinId s)    hLam x t = Lam (setHiding Hidden defaultArgInfo) (Abs x t)   nLam x t = Lam (setHiding NotHidden defaultArgInfo) (Abs x t)  noCheckCover :: (HasBuiltins m, MonadReduce m) => QName -> m Bool noCheckCover q = (||) <$> isBuiltin q builtinNat <*> isBuiltin q builtinInteger--------------------------bltQual' :: String -> String -> HsCompileM String-bltQual' b s = prettyPrint <$> bltQual b s
src/full/Agda/Compiler/MAlonzo/Strict.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ ------------------------------------------------------------------------ -- | Strictification of Haskell code ------------------------------------------------------------------------
src/full/Agda/Compiler/ToTreeless.hs view
@@ -1,13 +1,20 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Compiler.ToTreeless   ( toTreeless+  , toTreelessWith   , closedTermToTreeless+  , Pipeline(..)+  , CompilerPass(..)+  , compilerPass+  , compilerPipeline+  , CCConfig+  , CCSubst(..)   ) where -import Control.Arrow        ( first )-import Control.Monad        ( filterM, foldM, forM, zipWithM )+import Prelude hiding ((!!))+ import Control.Monad.Reader ( MonadReader(..), asks, ReaderT, runReaderT )-import Control.Monad.Trans  ( lift )  import Data.Maybe import Data.Map (Map)@@ -22,6 +29,7 @@  import Agda.TypeChecking.CompiledClause as CC import qualified Agda.TypeChecking.CompiledClause.Compile as CC+import Agda.TypeChecking.Datatypes import Agda.TypeChecking.EtaContract (binAppView, BinAppView(..)) import Agda.TypeChecking.Monad as TCM import Agda.TypeChecking.Pretty@@ -43,8 +51,8 @@ import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad-import Agda.Utils.Pretty (prettyShow)-import qualified Agda.Utils.Pretty as P+import Agda.Syntax.Common.Pretty (prettyShow)+import qualified Agda.Syntax.Common.Pretty as P import qualified Agda.Utils.SmallSet as SmallSet  import Agda.Utils.Impossible@@ -57,7 +65,7 @@ getCompiledClauses q = do   def <- getConstInfo q   let cs = defClauses def-      isProj | Function{ funProjection = proj } <- theDef def = isJust (projProper =<< proj)+      isProj | Function{ funProjection = Right x } <- theDef def = isJust (projProper x)              | otherwise = False       translate | isProj    = CC.DontRunRecordPatternTranslation                 | otherwise = CC.RunRecordPatternTranslation@@ -66,45 +74,87 @@   reportSDoc "treeless.convert" 70 $     caseMaybe mst "-- not using split tree" $ \st ->       "-- using split tree" $$ pretty st-  CC.compileClauses' translate cs mst+  CC.compileClauses' q translate cs mst +-- ** Types of pipelines; different backends might use their own custom pipeline.+type BuildPipeline = Int -> QName -> Pipeline++data Pipeline = FixedPoint Int Pipeline+              | Sequential [Pipeline]+              | SinglePass CompilerPass++data CompilerPass = CompilerPass+  { passTag       :: String+  , passVerbosity :: Int+  , passName      :: String+  , passCode      :: EvaluationStrategy -> TTerm -> TCM TTerm+  }++type CC        = ReaderT CCEnv TCM+type CCContext = [Int]+data CCSubst   = EraseUnused | IgnoreUnused deriving Eq++-- | Environment for treeless conversion.+data CCEnv = CCEnv+  { ccCxt         :: CCContext+    -- ^ Maps case tree de-bruijn indices to TTerm de-bruijn indices.+  , ccCatchall    :: Maybe Int+    -- ^ TTerm de-bruijn index of the current catch all.+    -- If an inner case has no catch-all clause, we use the one from its parent.+  , ccEvaluation  :: EvaluationStrategy+    -- ^ Which evaluation strategy does the backend assumes.+  , ccSubstUnused :: CCSubst+    -- ^ Whether to erase unused arguments.+  }++type CCConfig  = (EvaluationStrategy, CCSubst)++-- | Initial environment for expression generation.+initCCEnv :: CCConfig -> CCEnv+initCCEnv (eval, su) = CCEnv+  { ccCxt         = []+  , ccCatchall    = Nothing+  , ccEvaluation  = eval+  , ccSubstUnused = su+  }+ -- | Converts compiled clauses to treeless syntax. -- -- Note: Do not use any of the concrete names in the returned -- term for identification purposes! If you wish to do so, -- first apply the Agda.Compiler.Treeless.NormalizeNames -- transformation.+toTreelessWith :: BuildPipeline -> CCConfig -> QName -> TCM (Maybe C.TTerm)+toTreelessWith pl cfg q+  = ifM (alwaysInline q) (pure Nothing)+  $ Just <$> toTreelessWith' pl cfg q+ toTreeless :: EvaluationStrategy -> QName -> TCM (Maybe C.TTerm)-toTreeless eval q = ifM (alwaysInline q) (pure Nothing) $ Just <$> toTreeless' eval q+toTreeless eval = toTreelessWith compilerPipeline (eval, EraseUnused) -toTreeless' :: EvaluationStrategy -> QName -> TCM C.TTerm-toTreeless' eval q =+toTreelessWith' :: BuildPipeline -> CCConfig -> QName -> TCM C.TTerm+toTreelessWith' pl cfg q =   flip fromMaybeM (getTreeless q) $ verboseBracket "treeless.convert" 20 ("compiling " ++ prettyShow q) $ do     cc <- getCompiledClauses q     unlessM (alwaysInline q) $ setTreeless q (C.TDef q)       -- so recursive inlining doesn't loop, but not for always inlined       -- functions, since that would risk inlining to fail.-    ccToTreeless eval q cc+    ccToTreelessWith pl cfg q cc --- | Does not require the name to refer to a function.-cacheTreeless :: EvaluationStrategy -> QName -> TCM ()-cacheTreeless eval q = do-  def <- theDef <$> getConstInfo q-  case def of-    Function{} -> () <$ toTreeless' eval q-    _          -> return ()+toTreeless' :: EvaluationStrategy -> QName -> TCM C.TTerm+toTreeless' eval = toTreelessWith' compilerPipeline (eval, EraseUnused) -ccToTreeless :: EvaluationStrategy -> QName -> CC.CompiledClauses -> TCM C.TTerm-ccToTreeless eval q cc = do+ccToTreelessWith :: BuildPipeline -> CCConfig -> QName -> CC.CompiledClauses -> TCM C.TTerm+ccToTreelessWith pl cfg@(eval, su) q cc = do   let pbody b = pbody' "" b       pbody' suf b = sep [ text (prettyShow q ++ suf) <+> "=", nest 2 $ prettyPure b ]   v <- ifM (alwaysInline q) (return 20) (return 0)   reportSDoc "treeless.convert" (30 + v) $ "-- compiled clauses of" <+> prettyTCM q $$ nest 2 (prettyPure cc)-  body <- casetreeTop eval cc+  body <- casetreeTop cfg cc   reportSDoc "treeless.opt.converted" (30 + v) $ "-- converted" $$ pbody body-  body <- runPipeline eval q (compilerPipeline v q) body+  body <- runPipeline eval q (pl v q) body   used <- usedArguments q body-  when (ArgUnused `elem` used) $+  when (su == EraseUnused && ArgUnused `elem` used) $     reportSDoc "treeless.opt.unused" (30 + v) $       "-- used args:" <+> hsep [ if u == ArgUsed then text [x] else "_" | (x, u) <- zip ['a'..] used ] $$       pbody' "[stripped]" (stripUnusedArguments used body)@@ -113,21 +163,13 @@   setCompiledArgUse q used   return body -data Pipeline = FixedPoint Int Pipeline-              | Sequential [Pipeline]-              | SinglePass CompilerPass--data CompilerPass = CompilerPass-  { passTag       :: String-  , passVerbosity :: Int-  , passName      :: String-  , passCode      :: EvaluationStrategy -> TTerm -> TCM TTerm-  }+ccToTreeless :: EvaluationStrategy -> QName -> CC.CompiledClauses -> TCM C.TTerm+ccToTreeless eval = ccToTreelessWith compilerPipeline (eval, EraseUnused)  compilerPass :: String -> Int -> String -> (EvaluationStrategy -> TTerm -> TCM TTerm) -> Pipeline compilerPass tag v name code = SinglePass (CompilerPass tag v name code) -compilerPipeline :: Int -> QName -> Pipeline+compilerPipeline :: BuildPipeline compilerPipeline v q =   Sequential     -- Issue #4967: No simplification step before builtin translation! Simplification relies@@ -174,9 +216,9 @@             return t'          | otherwise -> go (i + 1) t' -closedTermToTreeless :: EvaluationStrategy -> I.Term -> TCM C.TTerm-closedTermToTreeless eval t = do-  substTerm t `runReaderT` initCCEnv eval+closedTermToTreeless :: CCConfig -> I.Term -> TCM C.TTerm+closedTermToTreeless cfg t = do+  substTerm t `runReaderT` initCCEnv cfg  alwaysInline :: QName -> TCM Bool alwaysInline q = do@@ -187,27 +229,8 @@               recursive = any (fromMaybe True . clauseRecursive) cs     _ -> False --- | Initial environment for expression generation.-initCCEnv :: EvaluationStrategy -> CCEnv-initCCEnv eval = CCEnv-  { ccCxt        = []-  , ccCatchAll   = Nothing-  , ccEvaluation = eval-  }---- | Environment for naming of local variables.-data CCEnv = CCEnv-  { ccCxt        :: CCContext  -- ^ Maps case tree de-bruijn indices to TTerm de-bruijn indices-  , ccCatchAll   :: Maybe Int  -- ^ TTerm de-bruijn index of the current catch all-  -- If an inner case has no catch-all clause, we use the one from its parent.-  , ccEvaluation :: EvaluationStrategy-  }--type CCContext = [Int]-type CC = ReaderT CCEnv TCM- shift :: Int -> CCContext -> CCContext-shift n = map (+n)+shift n = map (+ n)  -- | Term variables are de Bruijn indices. lookupIndex :: Int -- ^ Case tree de bruijn index.@@ -222,8 +245,8 @@ lookupLevel l xs = fromMaybe __IMPOSSIBLE__ $ xs !!! (length xs - 1 - l)  -- | Compile a case tree into nested case and record expressions.-casetreeTop :: EvaluationStrategy -> CC.CompiledClauses -> TCM C.TTerm-casetreeTop eval cc = flip runReaderT (initCCEnv eval) $ do+casetreeTop :: CCConfig -> CC.CompiledClauses -> TCM C.TTerm+casetreeTop cfg cc = flip runReaderT (initCCEnv cfg) $ do   let a = commonArity cc   lift $ reportSLn "treeless.convert.arity" 40 $ "-- common arity: " ++ show a   lambdasUpTo a $ casetree cc@@ -246,18 +269,16 @@         ]       return v'     CC.Case _ (CC.Branches True _ _ _ Just{} _ _) -> __IMPOSSIBLE__-      -- Andreas, 2016-06-03, issue #1986: Ulf: "no catch-all for copatterns!"-      -- lift $ do-      --   typeError . GenericDocError =<< do-      --     "Not yet implemented: compilation of copattern matching with catch-all clause"     CC.Case (Arg _ n) (CC.Branches True conBrs _ _ Nothing _ _) -> lambdasUpTo n $ do       mkRecord =<< traverse casetree (CC.content <$> conBrs)-    CC.Case (Arg i n) (CC.Branches False conBrs etaBr litBrs catchAll _ lazy) -> lambdasUpTo (n + 1) $ do+    CC.Case (Arg i n) (CC.Branches False conBrs etaBr litBrs catchall _ lazy) -> lambdasUpTo (n + 1) $ do+      -- re #3733 TODO: revise when compiling --cubical+      conBrs <- fmap Map.fromList $ filterM (isConstructor . fst) (Map.toList conBrs)                     -- We can treat eta-matches as regular matches here.       let conBrs' = caseMaybe etaBr conBrs $ \ (c, br) -> Map.insertWith (\ new old -> old) (conName c) br conBrs       if Map.null conBrs' && Map.null litBrs then do         -- there are no branches, just return default-        updateCatchAll catchAll fromCatchAll+        updateCatchall catchall fromCatchall       else do         -- Get the type of the scrutinee.         caseTy <-@@ -266,7 +287,7 @@               where               go (c:cs) = canonicalName c >>= getConstInfo <&> theDef >>= \case                 Constructor{conData} ->-                  return $ C.CTData (getQuantity i) conData+                  return $ C.CTData conData                 _ -> go cs               go [] = __IMPOSSIBLE__             ([], LitChar   _ : _) -> return C.CTChar@@ -275,10 +296,15 @@             ([], LitQName  _ : _) -> return C.CTQName             _ -> __IMPOSSIBLE__ -        updateCatchAll catchAll $ do+        updateCatchall catchall $ do           x <- asks (lookupLevel n . ccCxt)-          def <- fromCatchAll-          let caseInfo = C.CaseInfo { caseType = caseTy, caseLazy = lazy }+          def <- fromCatchall+          let caseInfo = C.CaseInfo+                { caseType   = caseTy+                , caseLazy   = lazy+                , caseErased = fromMaybe __IMPOSSIBLE__ $+                               erasedFromQuantity (getQuantity i)+                }           C.TCase x caseInfo def <$> do             br1 <- conAlts n conBrs'             br2 <- litAlts n litBrs@@ -286,8 +312,8 @@   where     -- normally, Agda should make sure that a pattern match is total,     -- so we set the default to unreachable if no default has been provided.-    fromCatchAll :: CC C.TTerm-    fromCatchAll = asks (maybe C.tUnreachable C.TVar . ccCatchAll)+    fromCatchall :: CC C.TTerm+    fromCatchall = asks (maybe C.tUnreachable C.TVar . ccCatchall)  commonArity :: CC.CompiledClauses -> Int commonArity cc =@@ -308,21 +334,21 @@      wArities cxt (WithArity k c) = map (\ x -> x - k + 1) $ arities (cxt - 1 + k) c -updateCatchAll :: Maybe CC.CompiledClauses -> (CC C.TTerm -> CC C.TTerm)-updateCatchAll Nothing cont = cont-updateCatchAll (Just cc) cont = do+updateCatchall :: Maybe CC.CompiledClauses -> (CC C.TTerm -> CC C.TTerm)+updateCatchall Nothing cont = cont+updateCatchall (Just cc) cont = do   def <- casetree cc   cxt <- asks ccCxt   reportS "treeless.convert.lambdas" 40 $-    [ "-- updateCatchAll:"+    [ "-- updateCatchall:"     , "--   cxt =" <+> prettyPure cxt     , "--   def =" <+> prettyPure def     ]-  local (\ e -> e { ccCatchAll = Just 0, ccCxt = shift 1 cxt }) $ do+  local (\ e -> e { ccCatchall = Just 0, ccCxt = shift 1 cxt }) $ do     C.mkLet def <$> cont  -- | Shrinks or grows the context to the given size.--- Does not update the catchAll expression, the catchAll expression+-- Does not update the catchall expression, the catchall expression -- MUST NOT be used inside `cont`. withContextSize :: Int -> CC C.TTerm -> CC C.TTerm withContextSize n cont = do@@ -389,8 +415,8 @@       cont <&> (`C.mkTApp` map C.TVar (downFrom diff'))  -- | Prepend the given positive number of lambdas.--- Does not update the catchAll expression,--- the catchAll expression must be updated separately (or not be used).+-- Does not update the catchall expression,+-- the catchall expression must be updated separately (or not be used). createLambdas :: Int -> CC C.TTerm -> CC C.TTerm createLambdas diff cont = do   unless (diff >= 1) __IMPOSSIBLE__@@ -405,7 +431,7 @@     cont <&> \ t -> List.iterate C.TLam t !! diff  -- | Adds lambdas until the context has at least the given size.--- Updates the catchAll expression to take the additional lambdas into account.+-- Updates the catchall expression to take the additional lambdas into account. lambdasUpTo :: Int -> CC C.TTerm -> CC C.TTerm lambdasUpTo n cont = do   diff <- asks (((n -) . length) . ccCxt)@@ -413,22 +439,22 @@   if diff <= 0 then cont -- no new lambdas needed   else do     createLambdas diff $ do-      asks ccCatchAll >>= \case-        Just catchAll -> do+      asks ccCatchall >>= \case+        Just catchall -> do           cxt <- asks ccCxt           reportS "treeless.convert.lambdas" 40 $             [ "lambdasUpTo: n =" <+> (text . show) n             , "  diff         =" <+> (text . show) n-            , "  catchAll     =" <+> prettyPure catchAll+            , "  catchall     =" <+> prettyPure catchall             , "  ccCxt        =" <+> prettyPure cxt             ]           -- the catch all doesn't know about the additional lambdas, so just directly           -- apply it again to the newly introduced lambda arguments.           -- we also bind the catch all to a let, to avoid code duplication-          local (\e -> e { ccCatchAll = Just 0+          local (\e -> e { ccCatchall = Just 0                          , ccCxt = shift 1 cxt }) $ do-            let catchAllArgs = map C.TVar $ downFrom diff-            C.mkLet (C.mkTApp (C.TVar $ catchAll + diff) catchAllArgs)+            let catchallArgs = map C.TVar $ downFrom diff+            C.mkLet (C.mkTApp (C.TVar $ catchall + diff) catchallArgs)               <$> cont         Nothing -> cont @@ -458,7 +484,7 @@          (ys, _:zs) = splitAt i cxt          -- compute the de-bruijn indexes of the newly inserted variables          ixs = [0..(n - 1)]-  local (\e -> e { ccCxt = upd (ccCxt e) , ccCatchAll = (+n) <$> ccCatchAll e }) $+  local (\e -> e { ccCxt = upd (ccCxt e) , ccCatchall = (+ n) <$> ccCatchall e }) $     cont  @@ -572,6 +598,14 @@   if static then normalise v else pure v normaliseStatic v = pure v +-- | Does not require the name to refer to a function.+cacheTreeless :: EvaluationStrategy -> QName -> TCM ()+cacheTreeless eval q = do+  def <- theDef <$> getConstInfo q+  case def of+    Function{} -> () <$ toTreeless' eval q+    _          -> return ()+ maybeInlineDef :: I.QName -> I.Args -> CC C.TTerm maybeInlineDef q vs = do   eval <- asks ccEvaluation@@ -584,8 +618,12 @@         | otherwise -> do         -- If ArgUsage hasn't been computed yet, we assume all arguments are used.         used <- lift $ fromMaybe [] <$> getCompiledArgUse q-        let substUsed _   ArgUnused = pure C.TErased-            substUsed arg ArgUsed   = substArg arg+        su <- asks ccSubstUnused+        let substUsed arg used+              | used == ArgUnused && su == EraseUnused+              = pure C.TErased+              | otherwise+              = substArg arg         C.mkTApp (C.TDef q) <$> zipWithM substUsed vs (used ++ repeat ArgUsed)       _ -> C.mkTApp (C.TDef q) <$> substArgs vs   where
src/full/Agda/Compiler/Treeless/AsPatterns.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Compiler.Treeless.AsPatterns (recoverAsPatterns) where  import Control.Monad.Reader
src/full/Agda/Compiler/Treeless/Builtin.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Translates the Agda builtin nat datatype to arbitrary-precision integers. -- -- Philipp, 20150921:@@ -17,7 +19,6 @@ module Agda.Compiler.Treeless.Builtin (translateBuiltins) where  import qualified Agda.Syntax.Internal as I-import Agda.Syntax.Position import Agda.Syntax.Treeless import Agda.Syntax.Literal @@ -52,9 +53,9 @@              <*> isB def builtinNatTimes              <*> isB def builtinNatLess              <*> isB def builtinNatEquals-             <*> isP pf  "primForce"-             <*> isP pf  "primWord64FromNat"-             <*> isP pf  "primWord64ToNat"+             <*> isP pf  PrimForce+             <*> isP pf  PrimWord64FromNat+             <*> isP pf  PrimWord64ToNat   where     con (I.Con c _ _) = pure $ I.conName c     con _           = Nothing@@ -92,8 +93,14 @@         --       builtin minus is monus. The simplifier will do it if it can see         --       that it won't underflow. +      -- Replace calls to primForce with the primitive seq, by binding the+      -- forced expression to a fresh variable and weaken appropriately.+      --+      -- primForce e f es+      -- >>>+      -- let e (seq x⁰ ((raise 1 f) x⁰) (raise 1 es))       TApp (TDef q) (_ : _ : _ : _ : e : f : es)-        | isForce q -> tr $ TLet e $ mkTApp (tOp PSeq (TVar 0) $ mkTApp (raise 1 f) [TVar 0]) es+        | isForce q -> tr $ TLet e $ mkTApp (tOp PSeq (TVar 0) $ mkTApp (raise 1 f) [TVar 0]) $ raise 1 es        TApp (TCon s) [e] | isSuc s ->         case tr e of
src/full/Agda/Compiler/Treeless/Compare.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Compiler.Treeless.Compare (equalTerms) where  import Agda.Syntax.Treeless
src/full/Agda/Compiler/Treeless/EliminateDefaults.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Eliminates case defaults by adding an alternative for all possible -- constructors. Literal cases are preserved as-is. module Agda.Compiler.Treeless.EliminateDefaults where@@ -17,7 +19,7 @@   where     tr :: TTerm -> TCM TTerm     tr = \case-      TCase sc ct@CaseInfo{caseType = CTData _ qn} def alts+      TCase sc ct@CaseInfo{caseType = CTData qn} def alts         | not (isUnreachable def) -> do         dtCons <- defConstructors . theDef <$> getConstInfo qn         let missingCons = dtCons List.\\ map aCon alts
src/full/Agda/Compiler/Treeless/EliminateLiteralPatterns.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Converts case matches on literals to if cascades with equality comparisons. module Agda.Compiler.Treeless.EliminateLiteralPatterns where @@ -37,7 +39,7 @@               (tr body)               cont           litAlt _ _ = __IMPOSSIBLE__-      TCase sc t@CaseInfo{caseType = CTData _ dt} def alts ->+      TCase sc t@CaseInfo{caseType = CTData dt} def alts ->         TCase sc t (tr def) (map trAlt alts)         where           trAlt = \case@@ -62,7 +64,7 @@       TLet e b                -> TLet (tr e) (tr b)      -- TODO:: Defined but not used-    isCaseOn (CTData _ dt) xs = dt `elem` mapMaybe ($ kit) xs+    isCaseOn (CTData dt) xs = dt `elem` mapMaybe ($ kit) xs     isCaseOn _ _ = False      eqFromLit :: Literal -> TPrim
src/full/Agda/Compiler/Treeless/Erase.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE PatternSynonyms #-}  module Agda.Compiler.Treeless.Erase@@ -6,16 +8,14 @@        , isErasable        ) where -import Control.Arrow (first, second)-import Control.Monad-import Control.Monad.State+import Control.Arrow       ( first, second )+import Control.Monad.State ( StateT, evalStateT )+ import Data.Map (Map) import qualified Data.Map as Map-import qualified Data.List as List  import Agda.Syntax.Common import Agda.Syntax.Internal as I-import Agda.Syntax.Position import Agda.Syntax.Treeless import Agda.Syntax.Literal @@ -26,7 +26,6 @@ import Agda.TypeChecking.Pretty import Agda.TypeChecking.Primitive -import {-# SOURCE #-} Agda.Compiler.Backend import Agda.Compiler.Treeless.Subst import Agda.Compiler.Treeless.Unused @@ -35,7 +34,7 @@ import Agda.Utils.Maybe import Agda.Utils.Memo import Agda.Utils.Monad-import Agda.Utils.Pretty (prettyShow)+import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Utils.IntSet.Infinite (IntSet) import qualified Agda.Utils.IntSet.Infinite as IntSet @@ -49,10 +48,10 @@       -- ^ Memoize computed `TypeInfo` for data/record types `QName`.   } -funMap :: Lens' (Map QName FunInfo) ESt+funMap :: Lens' ESt (Map QName FunInfo) funMap f r = f (_funMap r) <&> \ a -> r { _funMap = a } -typeMap :: Lens' (Map QName TypeInfo) ESt+typeMap :: Lens' ESt (Map QName TypeInfo) typeMap f r = f (_typeMap r) <&> \ a -> r { _typeMap = a }  -- | Eraser monad.@@ -110,7 +109,7 @@                    _             -> erase $ subst 0 TErased b             else tLet e <$> erase b         TCase x t d bs -> do-          (d, bs) <- pruneUnreachable x (caseType t) d bs+          (d, bs) <- pruneUnreachable x (caseErased t) (caseType t) d bs           d       <- erase d           bs      <- mapM eraseAlt bs           tCase x t d bs@@ -137,17 +136,41 @@     tCase x t d bs       | isErased d && all (isErased . aBody) bs = pure TErased       | otherwise = case bs of-        [TACon c a b] -> do+        [b@(TACon c _ _)] -> do           h <- snd <$> getFunInfo c           case h of-            NotErasable -> noerase+            NotErasable -> fallback             Empty       -> pure TErased-            Erasable    -> (if a == 0 then pure else erase) $ applySubst (replicate a TErased ++# idS) b-                              -- might enable more erasure-        _ -> noerase+            Erasable    -> erasedBody b+        _ -> fallback       where         noerase = pure $ TCase x t d bs +        erasedBody = \case+          TACon _ arity body ->+            (if arity == 0 then pure else erase) $+               -- might enable more erasure+            applySubst (replicate arity TErased ++# idS) body+          TALit _ body   -> pure body+          TAGuard _ body -> pure body++        fallback = case (caseErased t, bs) of+          (Erased{}, [b]) ->+            -- The case variable is erased, and there is exactly one+            -- case: use the case's body.+            erasedBody b+          (Erased{}, [])  ->+            -- The case variable is erased, and there is no case: use+            -- the default.+            pure $ if isErased d then TErased else d+          (Erased{}, _ : _ : _) ->+            -- The case variable is erased, and there are at least two+            -- cases: crash.+            __IMPOSSIBLE__+          _ ->+            -- The case variable is not erased: do not erase anything.+            noerase+     isErased t = t == TErased || isUnreachable t      eraseRel r t | erasable r = pure TErased@@ -161,29 +184,49 @@         TACon c a <$> erase (applySubst sub b)       TAGuard g b -> TAGuard   <$> erase g <*> erase b +pruneUnreachable ::+  Int -> Erased -> CaseType -> TTerm -> [TAlt] -> E (TTerm, [TAlt])+pruneUnreachable x erased t d bs = case erased of+  NotErased{} -> pruneUnreachable' x erased t d bs+  Erased{}    ->+    -- If the match is on an erased argument, then the first branch+    -- should match.+    case bs of+      []    -> pruneUnreachable' x erased t d            []+      b : _ -> pruneUnreachable' x erased t tUnreachable [b]+ -- | Doesn't have any type information (other than the name of the data type), --   so we can't do better than checking if all constructors are present.-pruneUnreachable :: Int -> CaseType -> TTerm -> [TAlt] -> E (TTerm, [TAlt])-pruneUnreachable _ (CTData quantity q) d bs' = do-  -- In an erased setting erased constructors are not treated-  -- specially.+pruneUnreachable' ::+  Int -> Erased -> CaseType -> TTerm -> [TAlt] -> E (TTerm, [TAlt])+pruneUnreachable' _ erased (CTData q) d bs' = do+  -- Erased constructors are pruned iff the match is made on a+  -- non-erased argument.   cs <- lift $-        if hasQuantity0 quantity+        if isErased erased         then getConstructors q         else getNotErasedConstructors q-  let bs | hasQuantity0 quantity = bs'-         | otherwise             =+  let bs | isErased erased = bs'+         | otherwise       =            flip filter bs' $ \case              a@TACon{} -> (aCon a) `elem` cs              TAGuard{} -> True              TALit{}   -> True-  let complete =length cs == length [ b | b@TACon{} <- bs ]-  let d' | complete  = tUnreachable+  let -- In the case of a match on an erased argument the value d is+      -- equal to tUnreachable, except perhaps if bs is empty. In the+      -- latter case complete is True exactly when the type has zero+      -- constructors (erased or not), in which case it makes sense to+      -- replace d with tUnreachable.+      complete = length cs == length [ b | b@TACon{} <- bs ]+      d' | complete  = tUnreachable          | otherwise = d   return (d', bs)-pruneUnreachable x CTNat d bs = return $ pruneIntCase x d bs (IntSet.below 0)-pruneUnreachable x CTInt d bs = return $ pruneIntCase x d bs IntSet.empty-pruneUnreachable _ _ d bs = pure (d, bs)+pruneUnreachable' x _ CTNat d bs =+  return $ pruneIntCase x d bs (IntSet.below 0)+pruneUnreachable' x _ CTInt d bs =+  return $ pruneIntCase x d bs IntSet.empty+pruneUnreachable' _ _ _ d bs =+  pure (d, bs)  -- These are the guards we generate for Int/Nat pattern matching pattern Below :: Int -> Integer -> TTerm@@ -261,11 +304,6 @@  isErasable :: QName -> TCM Bool isErasable qn =-  -- The active backend should be set-  caseMaybeM (viewTC eActiveBackendName) __IMPOSSIBLE__ $ \ bname ->-  -- However it may not be part of the set of available backends-  -- in which case we default to not erasable to avoid false negatives.-  caseMaybeM (lookupBackend bname)       (pure False)   $ \ _ ->   erasable . snd <$> runE (getFunInfo qn)  telListView :: Type -> TCM (ListTel, Type)@@ -277,7 +315,7 @@ typeWithoutParams q = do   def <- getConstInfo q   let d = case I.theDef def of-        Function{ funProjection = Just Projection{ projIndex = i } } -> i - 1+        Function{ funProjection = Right Projection{ projIndex = i } } -> i - 1         Constructor{ conPars = n } -> n         _                          -> 0   first (drop d) <$> telListView (defType def)
src/full/Agda/Compiler/Treeless/Erase.hs-boot view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Compiler.Treeless.Erase where  import Agda.TypeChecking.Monad.Base (TCM)
src/full/Agda/Compiler/Treeless/GuardsToPrims.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Translates guard alternatives to if-then-else cascades. -- -- The builtin translation must be run before this transformation.
src/full/Agda/Compiler/Treeless/Identity.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Compiler.Treeless.Identity   ( detectIdentityFunctions ) where@@ -6,13 +7,13 @@  import Control.Applicative ( Alternative((<|>), empty) ) import Data.Semigroup-import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List as List  import Agda.Syntax.Treeless import Agda.TypeChecking.Monad  import Agda.Utils.List+import Agda.Utils.List1 (pattern (:|))  import Agda.Utils.Impossible
src/full/Agda/Compiler/Treeless/NormalizeNames.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Ensures that all occurences of an abstract name share -- the same concrete name. --
src/full/Agda/Compiler/Treeless/Pretty.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# OPTIONS_GHC -fno-warn-orphans #-}  module Agda.Compiler.Treeless.Pretty () where@@ -7,15 +9,24 @@ import Control.Arrow (first) import Control.Monad.Reader import Data.Maybe-import qualified Data.Map as Map+import qualified Data.IntMap as IntMap  import Agda.Syntax.Treeless+import Agda.Syntax.Common.Pretty+ import Agda.Compiler.Treeless.Subst-import Agda.Utils.Pretty-import Agda.Utils.List  import Agda.Utils.Impossible+import Agda.Utils.Function+import Agda.Utils.List +instance Pretty Compiled where+  pretty Compiled {cTreeless, cArgUsage} =+    "Compiled {" <?> vcat+      [ "cTreeless   =" <?> pretty cTreeless+      , "funCompiled =" <?> pshow cArgUsage+      ] <?> "}"+ data PEnv = PEnv { pPrec :: Int                  , pFresh :: [String]                  , pBound :: [String] }@@ -36,12 +47,12 @@ withNames' n tm k = withNames n' $ k . insBlanks   where     fv = freeVars tm-    n'  = length $ filter (< n) $ Map.keys fv+    n'  = length $ filter (< n) $ IntMap.keys fv     insBlanks = go n       where         go 0 _ = []         go i xs0@(~(x : xs))-          | Map.member (i - 1) fv = x   : go (i - 1) xs+          | IntMap.member (i - 1) fv = x   : go (i - 1) xs           | otherwise             = "_" : go (i - 1) xs0  bindName :: String -> P a -> P a@@ -53,7 +64,7 @@ paren :: Int -> P Doc -> P Doc paren p doc = do   n <- asks pPrec-  (if p < n then parens else id) <$> doc+  applyWhen (p < n) parens <$> doc  prec :: Int -> P a -> P a prec p = local $ \ e -> e { pPrec = p }
+ src/full/Agda/Compiler/Treeless/Pretty.hs-boot view
@@ -0,0 +1,7 @@++module Agda.Compiler.Treeless.Pretty () where++import Agda.Syntax.Treeless+import Agda.Syntax.Common.Pretty++instance Pretty Compiled
src/full/Agda/Compiler/Treeless/Simplify.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Compiler.Treeless.Simplify (simplifyTTerm) where  import Control.Arrow        ( (***), second )@@ -161,7 +163,7 @@           k = length lets       return $ case u of         TCase y _ d' bs' | x + k == y ->-          mkLets lets $ TCase y t d' $ raise k bs ++ bs'+          mkLets lets $ TCase y t d' $ raise k bs ++ filter (`noOverlap` bs) bs'         _ -> e     unchainCase e = return e @@ -216,7 +218,7 @@         k == j = tOp PLt v u       | Just (PAdd, k, v) <- constArithView v,         TApp (TPrim P64ToI) [u] <- u,-        k >= 2^64, Just trueCon <- true = TCon trueCon+        k >= 2 ^ 64, Just trueCon <- true = TCon trueCon       | Just k <- intView u       , Just j <- intView v       , Just trueCon <- true@@ -356,7 +358,7 @@         d' <- lookupIfVar d         case d' of           TCase y _ d bs'' | x == y ->-            tCase x t d (bs' ++ filter noOverlap bs'')+            tCase x t d (bs' ++ filter (`noOverlap` bs') bs'')           _ -> tCase' x t d bs'       where         bs' = filter (not . isUnreachable) bs@@ -364,11 +366,12 @@         lookupIfVar (TVar i) = lookupVar i         lookupIfVar t = pure t -        noOverlap b = not $ any (overlapped b) bs'-        overlapped (TACon c _ _)  (TACon c' _ _) = c == c'-        overlapped (TALit l _)    (TALit l' _)   = l == l'-        overlapped _              _              = False+    noOverlap b bs = not $ any (overlapped b) bs +    overlapped (TACon c _ _)  (TACon c' _ _) = c == c'+    overlapped (TALit l _)    (TALit l' _)   = l == l'+    overlapped _              _              = False+     -- Drop unreachable cases for Nat and Int cases.     pruneLitCases :: Int -> CaseInfo -> TTerm -> [TAlt] -> S TTerm     pruneLitCases x t d bs | CTNat == caseType t =@@ -456,7 +459,7 @@           literal _ _ = False            -- k + fromWord x ≤ y  if  k + 2^64 - 1 ≤ y-          wordUpperBound (k, [Pos (TApp (TPrim P64ToI) _)]) y = go (k + 2^64 - 1, []) y+          wordUpperBound (k, [Pos (TApp (TPrim P64ToI) _)]) y = go (k + 2 ^ 64 - 1, []) y           wordUpperBound _ _ = False            -- x ≤ k + fromWord y  if  x ≤ k
src/full/Agda/Compiler/Treeless/Subst.hs view
@@ -2,8 +2,8 @@  module Agda.Compiler.Treeless.Subst where -import qualified Data.Map as Map-import Data.Map (Map)+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap) import Data.Maybe import Data.Semigroup ( Semigroup, (<>), All(..), Any(..) ) @@ -81,28 +81,31 @@ -- https://github.com/agda/agda/commit/03eb3945114a4ccdb449f22d69db8d6eaa4699b8#commitcomment-34249120  class HasFree a where-  freeVars :: a -> Map Int Occurs+  freeVars :: a -> IntMap Occurs  freeIn :: HasFree a => Int -> a -> Bool-freeIn i x = Map.member i (freeVars x)+freeIn i x = IntMap.member i (freeVars x)  occursIn :: HasFree a => Int -> a -> Occurs-occursIn i x = fromMaybe mempty $ Map.lookup i (freeVars x)+occursIn i x = fromMaybe mempty $ IntMap.lookup i (freeVars x)  instance HasFree Int where-  freeVars x = Map.singleton x once+  freeVars x = IntMap.singleton x once  instance HasFree a => HasFree [a] where-  freeVars xs = Map.unionsWith mappend $ map freeVars xs+  freeVars xs = IntMap.unionsWith mappend $ map freeVars xs  instance (HasFree a, HasFree b) => HasFree (a, b) where-  freeVars (x, y) = Map.unionWith mappend (freeVars x) (freeVars y)+  freeVars (x, y) = IntMap.unionWith mappend (freeVars x) (freeVars y)  data Binder a = Binder Int a  instance HasFree a => HasFree (Binder a) where   freeVars (Binder 0 x) = freeVars x-  freeVars (Binder k x) = Map.filterWithKey (\ k _ -> k >= 0) $ Map.mapKeysMonotonic (subtract k) $ freeVars x+  freeVars (Binder k x) = dropNeg $ IntMap.mapKeysMonotonic (subtract k) $ freeVars x+    where+      -- keep only elements > -1+      dropNeg = snd . IntMap.split (-1)  newtype InSeq a = InSeq a @@ -111,14 +114,14 @@  instance HasFree TTerm where   freeVars = \case-    TDef{}    -> Map.empty-    TLit{}    -> Map.empty-    TCon{}    -> Map.empty-    TPrim{}   -> Map.empty-    TUnit{}   -> Map.empty-    TSort{}   -> Map.empty-    TErased{} -> Map.empty-    TError{}  -> Map.empty+    TDef{}    -> IntMap.empty+    TLit{}    -> IntMap.empty+    TCon{}    -> IntMap.empty+    TPrim{}   -> IntMap.empty+    TUnit{}   -> IntMap.empty+    TSort{}   -> IntMap.empty+    TErased{} -> IntMap.empty+    TError{}  -> IntMap.empty     TVar i         -> freeVars i     TApp (TPrim PSeq) [TVar x, b] -> freeVars (InSeq x, b)     TApp f ts      -> freeVars (f, ts)@@ -136,6 +139,6 @@ -- | Strenghtening. tryStrengthen :: (HasFree a, Subst a) => Int -> a -> Maybe a tryStrengthen n t =-  case Map.minViewWithKey (freeVars t) of+  case IntMap.minViewWithKey (freeVars t) of     Just ((i, _), _) | i < n -> Nothing     _ -> Just $ applySubst (strengthenS impossible n) t
src/full/Agda/Compiler/Treeless/Uncase.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Compiler.Treeless.Uncase (caseToSeq) where  import Agda.Syntax.Treeless
src/full/Agda/Compiler/Treeless/Unused.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Compiler.Treeless.Unused   ( usedArguments@@ -6,15 +7,8 @@  import Data.Maybe -import qualified Data.Set as Set-  -- Andreas, 2021-02-10-  -- TODO: Replace Set by IntSet.-  -- However, this has to wait until we can comfortably bump to-  -- containers-0.6.3.1, which is the first to contain IntSet.mapMonotonic.-  -- Currently, such a constraints gets us into cabal hell.-  -- GHC 8.10 is still shipped with 0.6.2.1, so we either have to wait-  -- until we drop GHC 8 or until we adopt v2-cabal.-+import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty   ( prettyShow ) import Agda.Syntax.Treeless import Agda.TypeChecking.Monad import Agda.TypeChecking.Substitute@@ -23,7 +17,7 @@  import Agda.Utils.Function ( iterateUntilM ) import Agda.Utils.List     ( downFrom )-import Agda.Utils.Pretty   ( prettyShow )+import qualified Agda.Utils.VarSet as VarSet  usedArguments :: QName -> TTerm -> TCM [ArgUsage] usedArguments q t = computeUnused q b (replicate n ArgUnused)@@ -45,41 +39,50 @@   -- The new usage information is the free variables of @t@,   -- computed under the current usage assumptions of the functions it calls.   fv <- go t-  return $ [ if Set.member i fv then ArgUsed else ArgUnused+  return $ [ if VarSet.member i fv then ArgUsed else ArgUnused            | i <- downFrom (length used)            ]   where     go = \case-      TVar x    -> pure $ Set.singleton x-      TPrim{}   -> pure Set.empty-      TDef{}    -> pure Set.empty-      TLit{}    -> pure Set.empty-      TCon{}    -> pure Set.empty+      TVar x    -> pure $ VarSet.singleton x+      TPrim{}   -> pure VarSet.empty+      TDef{}    -> pure VarSet.empty+      TLit{}    -> pure VarSet.empty+      TCon{}    -> pure VarSet.empty        TApp (TDef f) ts -> do         used <- fromMaybe [] <$> getCompiledArgUse f-        Set.unions <$> sequence [ go t | (t, ArgUsed) <- zip ts $ used ++ repeat ArgUsed ]+        VarSet.unions <$> sequence [ go t | (t, ArgUsed) <- zip ts $ used ++ repeat ArgUsed ] -      TApp f ts -> Set.unions <$> mapM go (f : ts)+      TApp f ts -> VarSet.unions <$> mapM go (f : ts)       TLam b    -> underBinder <$> go b       TLet e b  -> do         uses <- go b-        if | Set.member 0 uses -> Set.union (underBinder uses) <$> go e-           | otherwise         -> pure (underBinder uses)-      TCase x _ d bs -> Set.insert x . Set.unions <$> ((:) <$> go d <*> mapM goAlt bs)-      TUnit{}   -> pure Set.empty-      TSort{}   -> pure Set.empty-      TErased{} -> pure Set.empty-      TError{}  -> pure Set.empty+        if | VarSet.member 0 uses -> VarSet.union (underBinder uses) <$> go e+           | otherwise            -> pure (underBinder uses)+      TCase x i d bs ->+        let e    = caseErased i+            cont = VarSet.unions <$> ((:) <$> go d <*> mapM (goAlt e) bs) in+        case e of+          Erased{}    -> cont+          NotErased{} -> VarSet.insert x <$> cont+      TUnit{}   -> pure VarSet.empty+      TSort{}   -> pure VarSet.empty+      TErased{} -> pure VarSet.empty+      TError{}  -> pure VarSet.empty       TCoerce t -> go t -    goAlt (TALit _   b) = go b-    goAlt (TAGuard g b) = Set.union <$> go g <*> go b-    goAlt (TACon _ a b) = underBinders a <$> go b+    goAlt _ (TALit _   b) = go b+    goAlt e (TAGuard g b) = case e of+      NotErased{} -> VarSet.union <$> go g <*> go b+      Erased{}    -> -- The guard will not be executed if the match+                     -- is on an erased argument.+                     go b+    goAlt _ (TACon _ a b) = underBinders a <$> go b      underBinder = underBinders 1     underBinders 0 = id-    underBinders n = Set.filter (>= 0) . Set.mapMonotonic (subtract n)+    underBinders n = VarSet.filterGE 0 . VarSet.subtract n  stripUnusedArguments :: [ArgUsage] -> TTerm -> TTerm stripUnusedArguments used t = mkTLam m $ applySubst rho b
src/full/Agda/Interaction/AgdaTop.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Interaction.AgdaTop     ( repl     ) where@@ -8,13 +10,16 @@ import Control.Monad.Trans          ( lift )  import Data.Char-import Data.Maybe+ import System.IO  import Agda.Interaction.Base+import Agda.Interaction.ExitCode import Agda.Interaction.Response as R import Agda.Interaction.InteractionTop import Agda.Interaction.Options+import Agda.Interaction.Command ( CommandM )+ import Agda.TypeChecking.Monad import qualified Agda.TypeChecking.Monad.Benchmark as Bench @@ -52,8 +57,14 @@       r <- maybeAbort runInteraction       case r of         Done      -> return True -- Done.-        Error s   -> liftIO (putStrLn s) >> return False         Command _ -> return False+        Error s   -> do+          exit <- optExitOnError <$> commandLineOptions+          if exit+            then liftIO (exitAgdaWith CommandError)+            else do+              liftIO (putStrLn s)+              return False      lift Bench.print     unless done interact'@@ -71,7 +82,6 @@       case dropWhile isSpace r of         ""          -> readCommand         ('-':'-':_) -> readCommand-        _           -> case listToMaybe $ reads r of-          Just (x, "")  -> return $ Command x-          Just (_, rem) -> return $ Error $ "not consumed: " ++ rem-          _             -> return $ Error $ "cannot read: " ++ r+        _           -> case parseIOTCM r of+          Right cmd -> return $ Command cmd+          Left err  -> return $ Error err
src/full/Agda/Interaction/Base.hs view
@@ -3,9 +3,9 @@  module Agda.Interaction.Base where +import           Control.Applicative          ( liftA3 ) import           Control.Concurrent.STM.TChan import           Control.Concurrent.STM.TVar- import           Control.Monad                ( mplus, liftM2, liftM4 ) import           Control.Monad.Except import           Control.Monad.Identity@@ -15,21 +15,23 @@ import           Data.Map                     (Map) import qualified Data.Map                     as Map import           Data.Maybe                   (listToMaybe)+import qualified Data.Text                    as T -import {-# SOURCE #-} Agda.TypeChecking.Monad.Base-  (HighlightingLevel, HighlightingMethod, TCM, Comparison, Polarity, TCErr)+import Agda.TypeChecking.Monad.Base.Types+  (HighlightingLevel, HighlightingMethod, Comparison, Polarity)  import           Agda.Syntax.Abstract         (QName)-import           Agda.Syntax.Common           (InteractionId (..), Modality)+import           Agda.Syntax.Common           (BackendName, InteractionId (..), Modality) import           Agda.Syntax.Internal         (ProblemId, Blocker) import           Agda.Syntax.Position import           Agda.Syntax.Scope.Base       (ScopeInfo)+import           Agda.Syntax.TopLevelModuleName  import           Agda.Interaction.Options     (CommandLineOptions,                                                defaultOptions)  import           Agda.Utils.FileName          (AbsolutePath, mkAbsolute)-import           Agda.Utils.Pretty            (Pretty(..), prettyShow, text)+import           Agda.Syntax.Common.Pretty            (Pretty(..), prettyShow, text) import           Agda.Utils.Time              (ClockTime)  ------------------------------------------------------------------------@@ -75,22 +77,20 @@     , commandQueue         = commandQueue     } --- | Monad for computing answers to interactive commands.------   'CommandM' is 'TCM' extended with state 'CommandState'.--type CommandM = StateT CommandState TCM- -- | Information about the current main module. data CurrentFile = CurrentFile   { currentFilePath  :: AbsolutePath       -- ^ The file currently loaded into interaction.+  , currentFileModule :: TopLevelModuleName+      -- ^ The top-level module name of the currently loaded file.   , currentFileArgs  :: [String]       -- ^ The arguments to Agda used for loading the file.   , currentFileStamp :: ClockTime       -- ^ The modification time stamp of the file when it was loaded.   } deriving (Show) +type CommandM' = StateT CommandState+ ------------------------------------------------------------------------ -- Command queues @@ -109,6 +109,15 @@  type Command = Command' IOTCM +-- | IOTCM commands.+--+-- The commands are obtained by applying the functions to the current+-- top-level module name, if any. Note that the top-level module name+-- is not used by independent commands. For other commands the+-- top-level module name should be known.++type IOTCM = Maybe TopLevelModuleName -> IOTCM' Range+ -- | Command queues.  data CommandQueue = CommandQueue@@ -131,11 +140,7 @@ data Interaction' range     -- | @cmd_load m argv@ loads the module in file @m@, using     -- @argv@ as the command-line options.-  = Cmd_load            FilePath [String]--    -- | @cmd_compile b m argv@ compiles the module in file @m@ using-    -- the backend @b@, using @argv@ as the command-line options.-  | Cmd_compile         CompilerBackend FilePath [String]+  = Cmd_load FilePath [String]    | Cmd_constraints @@ -143,11 +148,15 @@     -- show those instead.   | Cmd_metas Rewrite +    -- | Load a file and fail if there are any unsolved+    -- meta-variables. By default no output is generated if the+    -- command is successful.+    -- (This command was previously used in Agda's installation script (Setup.hs)).+  | Cmd_load_no_metas FilePath+     -- | Shows all the top-level names in the given module, along with     -- their types. Uses the top-level scope.-  | Cmd_show_module_contents_toplevel-                        Rewrite-                        String+  | Cmd_show_module_contents_toplevel Rewrite String      -- | Shows all the top-level names in scope which mention all the given     -- identifiers in their type.@@ -158,22 +167,40 @@   | Cmd_solveAll Rewrite   | Cmd_solveOne Rewrite InteractionId range String -    -- | Solve (all goals / the goal at point) by using Auto.-  | Cmd_autoOne            InteractionId range String-  | Cmd_autoAll+    -- | Solve (all goals / the goal at point) by using Mimer proof search.+  | Cmd_autoOne  Rewrite   InteractionId range String+  | Cmd_autoAll  Rewrite      -- | Parse the given expression (as if it were defined at the     -- top-level of the current module) and infer its type.-  | Cmd_infer_toplevel  Rewrite  -- Normalise the type?-                        String-+  | Cmd_infer_toplevel Rewrite -- Normalise the type?+                       String      -- | Parse and type check the given expression (as if it were defined     -- at the top-level of the current module) and normalise it.-  | Cmd_compute_toplevel ComputeMode-                         String+  | Cmd_compute_toplevel ComputeMode String      ------------------------------------------------------------------------+    -- Backend commands++    -- | @cmd_compile b m argv@ compiles the module in file @m@ using+    -- the backend @b@, using @argv@ as the command-line options.+  | Cmd_compile CompilerBackend FilePath [String]++    -- | Custom top-level command for backends.+  | Cmd_backend_top+      CompilerBackend -- ^ which backend+      String          -- ^ arbitrary user payload++    -- | Custom hole-level command for backends.+  | Cmd_backend_hole+      InteractionId   -- ^ the hole's ID+      range           -- ^ range of the hole+      String          -- ^ text inside the hole+      CompilerBackend -- ^ which backend+      String          -- ^ arbitrary payload++    ------------------------------------------------------------------------     -- Syntax highlighting      -- | @cmd_load_highlighting_info source@ loads syntax highlighting@@ -215,7 +242,7 @@     -- Implicit arguments      -- | Tells Agda whether or not to show implicit arguments.-  | ShowImplicitArgs    Bool -- Show them?+  | ShowImplicitArgs Bool-- Show them?       -- | Toggle display of implicit arguments.@@ -225,8 +252,7 @@     -- Irrelevant arguments      -- | Tells Agda whether or not to show irrelevant arguments.-  | ShowIrrelevantArgs    Bool -- Show them?-+  | ShowIrrelevantArgs Bool -- Show them?      -- | Toggle display of irrelevant arguments.   | ToggleIrrelevantArgs@@ -293,7 +319,6 @@     -- ^ Exit the program.         deriving (Show, Read, Functor, Foldable, Traversable) -type IOTCM = IOTCM' Range data IOTCM' range     = IOTCM         FilePath@@ -319,7 +344,19 @@ --------------------------------------------------------- -- Read instances +-- | An 'IOTCM' parser.+--+-- If the parse fails, then an error message is returned. +parseIOTCM ::+  String -> Either String IOTCM+parseIOTCM s = case listToMaybe $ reads s of+  Just (x, "")  -> Right $ \top -> case x of+    IOTCM f l m i -> IOTCM f l m $+      (fmap . fmap . fmap) (\rf -> mkRangeFile (rangeFilePath rf) top) i+  Just (_, rem) -> Left $ "not consumed: " ++ rem+  _             -> Left $ "cannot read: " ++ s+ -- | The 'Parse' monad. --   'StateT' state holds the remaining input. @@ -346,7 +383,7 @@ -- | Demand an exact string.  exact :: String -> Parse ()-exact s = readsToParse (show s) $ fmap ((),) . List.stripPrefix s . dropWhile (==' ')+exact s = readsToParse (show s) $ fmap ((),) . List.stripPrefix s . dropWhile (== ' ')  readParse :: Read a => Parse a readParse = readsToParse "read failed" $ listToMaybe . reads@@ -377,13 +414,21 @@ instance Read a => Read (Interval' a) where     readsPrec = parseToReadsPrec $ do         exact "Interval"-        liftM2 Interval readParse readParse+        liftA3 Interval readParse readParse readParse  instance Read AbsolutePath where     readsPrec = parseToReadsPrec $ do         exact "mkAbsolute"         fmap mkAbsolute readParse +-- | This instance fills in the 'TopLevelModuleName's using 'Nothing'.+-- Note that these occurrences of 'Nothing' are \"overwritten\" by+-- 'parseIOTCM'.++instance Read RangeFile where+    readsPrec = parseToReadsPrec $+      fmap (flip mkRangeFile Nothing) readParse+ instance Read a => Read (Position' a) where     readsPrec = parseToReadsPrec $ do         exact "Pn"@@ -392,7 +437,7 @@ --------------------------------------------------------- -- | Available backends. -data CompilerBackend = LaTeX | QuickLaTeX | OtherBackend String+data CompilerBackend = LaTeX | QuickLaTeX | OtherBackend BackendName     deriving (Eq)  -- TODO 2021-08-25 get rid of custom Show instance@@ -403,7 +448,7 @@   pretty = \case     LaTeX          -> "LaTeX"     QuickLaTeX     -> "QuickLaTeX"-    OtherBackend s -> text s+    OtherBackend s -> pretty s  instance Read CompilerBackend where   readsPrec _ s = do@@ -411,7 +456,7 @@     let b = case t of               "LaTeX"      -> LaTeX               "QuickLaTeX" -> QuickLaTeX-              _            -> OtherBackend t+              _            -> OtherBackend $ T.pack t     return (b, s)  -- | Ordered ascendingly by degree of normalization.@@ -426,10 +471,10 @@   | WithoutForce  -- ^ Don't ignore any checks.   deriving (Eq, Read, Show) -data OutputForm a b = OutputForm Range [ProblemId] Blocker (OutputConstraint a b)+data OutputForm_boot tcErr a b = OutputForm Range [ProblemId] Blocker (OutputConstraint_boot tcErr a b)   deriving (Functor) -data OutputConstraint a b+data OutputConstraint_boot tcErr a b       = OfType b a | CmpInType Comparison a b b                    | CmpElim [Polarity] a [b] [b]       | JustType b | CmpTypes Comparison b b@@ -440,9 +485,11 @@       | IsEmptyType a       | SizeLtSat a       | FindInstanceOF b a [(a,a,a)]+      | ResolveInstanceOF QName       | PTSInstance b b-      | PostponedCheckFunDef QName a TCErr+      | PostponedCheckFunDef QName a tcErr       | CheckLock b b+      | DataSort QName b       | UsableAtMod Modality b   deriving (Functor)
src/full/Agda/Interaction/BasicOps.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE NondecreasingIndentation #-}- {-# OPTIONS_GHC -fno-warn-orphans #-}  module Agda.Interaction.BasicOps where@@ -7,14 +6,14 @@ import Prelude hiding (null)  import Control.Arrow          ( first )-import Control.Monad          ( (>=>), forM, guard )-import Control.Monad.Except-import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Identity+import Control.Monad.Except   ( MonadError(..) )+import Control.Monad.State    ( MonadState(..), evalState )+import Control.Monad.Identity ( runIdentity )+import Control.Monad.Trans.Maybe -import qualified Data.IntMap as IntMap import qualified Data.Map as Map+import qualified Data.IntMap as IntMap+import qualified Data.Map.Strict as MapS import qualified Data.Set as Set import qualified Data.List as List import Data.Maybe@@ -24,6 +23,7 @@ import qualified Data.Text as T  import Agda.Interaction.Base+import Agda.Interaction.Output import Agda.Interaction.Options import Agda.Interaction.Response (Goals, ResponseContextEntry(..)) @@ -48,32 +48,35 @@ import Agda.TheTypeChecker import Agda.TypeChecking.Constraints import Agda.TypeChecking.Conversion-import Agda.TypeChecking.Errors ( getAllWarnings, stringTCErr )+import Agda.TypeChecking.Errors ( getAllWarnings, Verbalize(..) ) import Agda.TypeChecking.Monad as M hiding (MetaInfo) import Agda.TypeChecking.MetaVars import Agda.TypeChecking.MetaVars.Mention import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope.Path import Agda.TypeChecking.Telescope import Agda.TypeChecking.With import Agda.TypeChecking.Coverage import Agda.TypeChecking.Coverage.Match ( SplitPattern ) import Agda.TypeChecking.Records-import Agda.TypeChecking.Irrelevance (wakeIrrelevantVars) import Agda.TypeChecking.Pretty ( PrettyTCM, prettyTCM )+import Agda.TypeChecking.Pretty.Constraint (prettyRangeConstraint) import Agda.TypeChecking.IApplyConfluence import Agda.TypeChecking.Primitive+import Agda.TypeChecking.ProjectionLike (reduceProjectionLike) import Agda.TypeChecking.Names import Agda.TypeChecking.Free import Agda.TypeChecking.CheckInternal import Agda.TypeChecking.SizedTypes.Solve import qualified Agda.TypeChecking.Pretty as TP import Agda.TypeChecking.Warnings-  ( runPM, warning, WhichWarnings(..), classifyWarnings, isMetaTCWarning-  , WarningsAndNonFatalErrors, emptyWarningsAndNonFatalErrors )+  ( warning, WhichWarnings(..), classifyWarnings, isMetaTCWarning+  , WarningsAndNonFatalErrors )  import Agda.Termination.TermCheck (termMutual) +import Agda.Utils.Function (applyWhen) import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List@@ -82,10 +85,11 @@ import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Pretty as P+import Agda.Syntax.Common.Pretty as P import Agda.Utils.Permutation import Agda.Utils.Size import Agda.Utils.String+import Agda.Utils.WithDefault ( WithDefault'(Value) )  import Agda.Utils.Impossible @@ -93,9 +97,10 @@  parseExpr :: Range -> String -> TCM C.Expr parseExpr rng s = do-  C.ExprWhere e wh <- runPM $ parsePosString exprWhereParser pos s-  unless (null wh) $ typeError $ GenericError $-    "where clauses are not supported in holes"+  (C.ExprWhere e wh, attrs) <-+    runPM $ parsePosString exprWhereParser pos s+  checkAttributes attrs+  unless (null wh) $ interactionError UnexpectedWhere   return e   where pos = fromMaybe (startPos Nothing) $ rStart rng @@ -103,7 +108,7 @@ parseExprIn ii rng s = do     mId <- lookupInteractionId ii     updateMetaVarRange mId rng-    mi  <- getMetaInfo <$> lookupMeta mId+    mi  <- getMetaInfo <$> lookupLocalMeta mId     e   <- parseExpr rng s     -- Andreas, 2019-08-19, issue #4007     -- We need to be in the TCEnv of the meta variable@@ -117,7 +122,7 @@ -- Precondition: we are in the context where the given meta was created. giveExpr :: UseForce -> Maybe InteractionId -> MetaId -> Expr -> TCM Term giveExpr force mii mi e = do-    mv <- lookupMeta mi+    mv <- lookupLocalMeta mi     let t = case mvJudgement mv of               IsSort{}    -> __IMPOSSIBLE__               HasType _ _ t -> t@@ -140,9 +145,10 @@       -- when not in a mutual block.       v <- locallyTC eMutualBlock (const Nothing) $         checkExpr e t'+      reportSDoc "interaction.give" 40 $ "give: checked expression:" TP.<+> pure (pretty v)       case mvInstantiation mv of -        InstV{} -> unlessM ((Irrelevant ==) <$> asksTC getRelevance) $ do+        InstV{} -> unlessM (isIrrelevant <$> viewTC eRelevance) $ do           v' <- instantiate $ MetaV mi $ map Apply ctx           reportSDoc "interaction.give" 20 $ TP.sep             [ "meta was already set to value v' = " TP.<+> prettyTCM v'@@ -160,7 +166,7 @@       unless (force == WithForce) $ redoChecks mii       wakeupConstraints mi       solveSizeConstraints DontDefaultToInfty-      cubical <- isJust . optCubical <$> pragmaOptions+      cubical <- isJust <$> cubicalOption       -- don't double check with cubical, because it gets in the way too often.       unless (cubical || force == WithForce) $ do         -- Double check.@@ -179,36 +185,46 @@   case ipClause ip of     IPNoClause -> return ()     IPClause{ipcQName = f} -> do-      mb <- mutualBlockOf f+      mb <- defMutual <$> getConstInfo f       terErrs <- localTC (\ e -> e { envMutualBlock = Just mb }) $ termMutual []-      unless (null terErrs) $ warning $ TerminationIssue terErrs+      List1.unlessNull terErrs $ warning . TerminationIssue   -- TODO redo positivity check! --- | Try to fill hole by expression.------   Returns the given expression unchanged---   (for convenient generalization to @'refine'@).-give-  :: UseForce       -- ^ Skip safety checks?+-- | Auxiliary definition for 'give' and 'elaborate_give'.+give_ ::+     Bool           -- ^ Elaborating?+  -> UseForce       -- ^ Skip safety checks?   -> InteractionId  -- ^ Hole.   -> Maybe Range   -> Expr           -- ^ The expression to give.-  -> TCM Expr       -- ^ If successful, the very expression is returned unchanged.-give force ii mr e = liftTCM $ do+  -> TCM Term       -- ^ Value of the expression+give_ elaborating force ii mr e = do   -- if Range is given, update the range of the interaction meta   mi  <- lookupInteractionId ii   whenJust mr $ updateMetaVarRange mi   reportSDoc "interaction.give" 10 $ "giving expression" TP.<+> prettyTCM e   reportSDoc "interaction.give" 50 $ TP.text $ show $ deepUnscope e   -- Try to give mi := e-  _ <- withInteractionId ii $ do-     setMetaOccursCheck mi DontRunMetaOccursCheck -- #589, #2710: Allow giving recursive solutions.-     giveExpr force (Just ii) mi e-    `catchError` \ case-      -- Turn PatternErr into proper error:-      PatternErr{} -> typeError . GenericDocError =<< do-        withInteractionId ii $ "Failed to give" TP.<+> prettyTCM e-      err -> throwError err+  withInteractionId ii do+    setMetaOccursCheck mi DontRunMetaOccursCheck -- #589, #2710: Allow giving recursive solutions.+    applyWhen elaborating (locallyTC eCurrentlyElaborating $ const True) do+      -- Andreas, 2025-05-02, issue #7842 reproduces this error+      let err _blocker = typeError $ InteractionError $ CannotGive e+      catchPatternErr err do+        giveExpr force (Just ii) mi e++-- | Try to fill hole by expression.+--+--   Returns the given expression unchanged+--   (for convenient generalization to @'refine'@).+give ::+     UseForce       -- ^ Skip safety checks?+  -> InteractionId  -- ^ Hole.+  -> Maybe Range+  -> Expr           -- ^ The expression to give.+  -> TCM Expr       -- ^ If successful, the very expression is returned unchanged.+give force ii mr e = do+  _ <- give_ False force ii mr e   removeInteractionPoint ii   return e @@ -221,22 +237,11 @@   -> Expr           -- ^ The expression to give.   -> TCM Expr       -- ^ If successful, return the elaborated expression. elaborate_give norm force ii mr e = withInteractionId ii $ do-  -- if Range is given, update the range of the interaction meta-  mi  <- lookupInteractionId ii-  whenJust mr $ updateMetaVarRange mi-  reportSDoc "interaction.give" 10 $ "giving expression" TP.<+> prettyTCM e-  reportSDoc "interaction.give" 50 $ TP.text $ show $ deepUnscope e-  -- Try to give mi := e-  v <- withInteractionId ii $ do-     setMetaOccursCheck mi DontRunMetaOccursCheck -- #589, #2710: Allow giving recursive solutions.-     locallyTC eCurrentlyElaborating (const True) $-       giveExpr force (Just ii) mi e-    `catchError` \ case-      -- Turn PatternErr into proper error:-      PatternErr{} -> typeError . GenericDocError =<< do-        withInteractionId ii $ "Failed to give" TP.<+> prettyTCM e-      err -> throwError err-  nv <- normalForm norm v+  v <- give_ True force ii mr e+  reportSDoc "interaction.give" 40 $ "v = " TP.<+> pure (pretty v)+  -- Reduce projection-likes before quoting, otherwise instance+  -- selection may fail on reload (see #6203).+  nv <- reduceProjectionLike =<< normalForm norm v   locallyTC ePrintMetasBare (const True) $ reify nv  -- | Try to refine hole by expression @e@.@@ -251,7 +256,7 @@   -> TCM Expr       -- ^ The successfully given expression. refine force ii mr e = do   mi <- lookupInteractionId ii-  mv <- lookupMeta mi+  mv <- lookupLocalMeta mi   let range = fromMaybe (getRange mv) mr       scope = M.getMetaScope mv   reportSDoc "interaction.refine" 10 $@@ -265,11 +270,10 @@     tryRefine nrOfMetas r scope = try nrOfMetas Nothing       where         try :: Int -> Maybe TCErr -> Expr -> TCM Expr-        try 0 err e = throwError . stringTCErr $ case err of+        try 0 err e = interactionError $ CannotRefine $ case err of            Just (TypeError _ _ cl) | UnequalTerms _ I.Pi{} _ _ <- clValue cl ->-             "Cannot refine functions with 10 or more arguments"-           _ ->-             "Cannot refine"+             "functions with 10 or more arguments"+           _ -> ""         try n _ e = give force ii (Just r) e `catchError` \err -> try (n - 1) (Just err) =<< appMeta e          -- Apply A.Expr to a new meta@@ -286,6 +290,7 @@                     -- should be something else.                 , metaNumber = Nothing -- in order to print just as ?, not ?n                 , metaNameSuggestion = ""+                , metaKind           = Info.UnificationMeta                 }               metaVar = QuestionMark info ii @@ -308,33 +313,20 @@                   _ -> App i e arg           return $ smartApp (defaultAppInfo r) e $ defaultNamedArg metaVar --- Andreas, 2017-12-16:--- Ulf, your attempt to fix #737 introduced regression #2873.--- Going through concrete syntax does some arbitrary disambiguation--- of constructors, which subsequently makes refine fail.--- I am not convinced of the printing-parsing shortcut to address problems.--- (Unless you prove the roundtrip property.)------           rescopeExpr scope $ smartApp (defaultAppInfo r) e $ defaultNamedArg metaVar--- -- | Turn an abstract expression into concrete syntax and then back into--- --   abstract. This ensures that context precedences are set correctly for--- --   abstract expressions built by hand. Used by refine above.--- rescopeExpr :: ScopeInfo -> Expr -> TCM Expr--- rescopeExpr scope = withScope_ scope . (concreteToAbstract_ <=< runAbsToCon . preserveInteractionIds . toConcrete)- {-| Evaluate the given expression in the current environment -} evalInCurrent :: ComputeMode -> Expr -> TCM Expr evalInCurrent cmode e = do   (v, _t) <- inferExpr e-  reify =<< compute v-  where compute | cmode == HeadCompute = reduce-                | otherwise            = normalise+  vb <- reduceB v+  reportSDoc "interaction.eval" 30 $ "evaluated to" TP.<+> TP.pretty vb+  v  <- pure $ ignoreBlocking vb+  reify =<< if cmode == HeadCompute then pure v else normalise v   evalInMeta :: InteractionId -> ComputeMode -> Expr -> TCM Expr evalInMeta ii cmode e =    do   m <- lookupInteractionId ii-        mi <- getMetaInfo <$> lookupMeta m+        mi <- getMetaInfo <$> lookupLocalMeta m         withMetaInfo mi $             evalInCurrent cmode e @@ -356,9 +348,11 @@ computeIgnoreAbstract DefaultCompute  = False computeIgnoreAbstract HeadCompute     = False computeIgnoreAbstract IgnoreAbstract  = True-computeIgnoreAbstract UseShowInstance = True-  -- UseShowInstance requires the result to be a string literal so respecting-  -- abstract can only ever break things.+computeIgnoreAbstract UseShowInstance = False+  -- WRONG: UseShowInstance requires the result to be a string literal so respecting abstract can+  -- only ever break things.+  -- See #7191. Abstract definitions can come with rewrite rules to give nice show behaviour that+  -- breaks if we don't respect abstract.  computeWrapInput :: ComputeMode -> String -> String computeWrapInput UseShowInstance s = "show (" ++ s ++ ")"@@ -368,7 +362,7 @@ showComputed UseShowInstance e =   case e of     A.Lit _ (LitString s) -> pure (text $ T.unpack s)-    _                     -> ("Not a string:" $$) <$> prettyATop e+    _                     -> ("Expected applying `show` to the given value to produce a string literal, but got:" $$) <$> prettyATop e showComputed _ e = prettyATop e  -- | Modifier for interactive commands,@@ -393,8 +387,10 @@       IsEmptyType _              -> __IMPOSSIBLE__   -- Should never be used on IsEmpty constraints       SizeLtSat{}                -> __IMPOSSIBLE__       FindInstanceOF _ _ _        -> __IMPOSSIBLE__+      ResolveInstanceOF _        -> __IMPOSSIBLE__       PTSInstance i _            -> i       PostponedCheckFunDef{}     -> __IMPOSSIBLE__+      DataSort _ i               -> i       CheckLock i _              -> i       UsableAtMod _ i            -> i @@ -413,76 +409,86 @@     appl s v = A.App defaultAppInfo_ (A.Lit empty (LitString s)) $ fmap unnamed v  instance Reify Constraint where-    type ReifiesTo Constraint = OutputConstraint Expr Expr+  type ReifiesTo Constraint = OutputConstraint Expr Expr -    reify (ValueCmp cmp (AsTermsOf t) u v) = CmpInType cmp <$> reify t <*> reify u <*> reify v-    reify (ValueCmp cmp AsSizes u v) = CmpInType cmp <$> (reify =<< sizeType) <*> reify u <*> reify v-    reify (ValueCmp cmp AsTypes u v) = CmpTypes cmp <$> reify u <*> reify v-    reify (ValueCmpOnFace cmp p t u v) = CmpInType cmp <$> (reify =<< ty) <*> reify (lam_o u) <*> reify (lam_o v)-      where-        lam_o = I.Lam (setRelevance Irrelevant defaultArgInfo) . NoAbs "_"-        ty = runNamesT [] $ do-          p <- open p-          t <- open t-          pPi' "o" p (\ o -> t)-    reify (ElimCmp cmp _ t v es1 es2) =-      CmpElim cmp <$> reify t <*> mapM reifyElimToExpr es1-                              <*> mapM reifyElimToExpr es2-    reify (LevelCmp cmp t t')    = CmpLevels cmp <$> reify t <*> reify t'-    reify (SortCmp cmp s s')     = CmpSorts cmp <$> reify s <*> reify s'-    reify (UnquoteTactic tac _ goal) = do-        tac <- A.App defaultAppInfo_ (A.Unquote exprNoRange) . defaultNamedArg <$> reify tac-        OfType tac <$> reify goal-    reify (UnBlock m) = do-        mi <- mvInstantiation <$> lookupMeta m-        m' <- reify (MetaV m [])-        case mi of-          BlockedConst t -> do-            e  <- reify t-            return $ Assign m' e-          PostponedTypeCheckingProblem cl -> enterClosure cl $ \case-            CheckExpr cmp e a -> do-                a  <- reify a-                return $ TypedAssign m' e a-            CheckLambda cmp (Arg ai (xs, mt)) body target -> do-              domType <- maybe (return underscore) reify mt-              target  <- reify target-              let mkN (WithHiding h x) = setHiding h $ defaultNamedArg $ A.mkBinder_ x-                  bs = mkTBind noRange (fmap mkN xs) domType-                  e  = A.Lam Info.exprNoRange (DomainFull bs) body-              return $ TypedAssign m' e target-            CheckArgs _ _ _ args t0 t1 _ -> do-              t0 <- reify t0-              t1 <- reify t1-              return $ PostponedCheckArgs m' (map (namedThing . unArg) args) t0 t1-            CheckProjAppToKnownPrincipalArg cmp e _ _ _ t _ _ _ _ -> TypedAssign m' e <$> reify t-            DoQuoteTerm cmp v t -> do-              tm <- A.App defaultAppInfo_ (A.QuoteTerm exprNoRange) . defaultNamedArg <$> reify v-              OfType tm <$> reify t-          Open{}  -> __IMPOSSIBLE__-          OpenInstance{}  -> __IMPOSSIBLE__-          InstV{} -> __IMPOSSIBLE__-    reify (FindInstance m mcands) = FindInstanceOF-      <$> reify (MetaV m [])-      <*> (reify =<< getMetaType m)-      <*> forM (fromMaybe [] mcands) (\ (Candidate q tm ty _) -> do-            (,,) <$> reify tm <*> reify tm <*> reify ty)-    reify (IsEmpty r a) = IsEmptyType <$> reify a-    reify (CheckSizeLtSat a) = SizeLtSat  <$> reify a-    reify (CheckFunDef d i q cs err) = do-      a <- reify =<< defType <$> getConstInfo q-      return $ PostponedCheckFunDef q a err-    reify (HasBiggerSort a) = OfType <$> reify a <*> reify (UnivSort a)-    reify (HasPTSRule a b) = do-      (a,(x,b)) <- reify (unDom a,b)-      return $ PTSInstance a b-    reify (CheckLockedVars t _ lk _) = CheckLock <$> reify t <*> reify (unArg lk)-    reify (CheckMetaInst m) = do-      t <- jMetaType . mvJudgement <$> lookupMeta m-      OfType <$> reify (MetaV m []) <*> reify t-    reify (CheckType t) = JustType <$> reify t-    reify (UsableAtModality mod t) = UsableAtMod mod <$> reify t+  reify (ValueCmp cmp (AsTermsOf t) u v) = CmpInType cmp <$> reify t <*> reify u <*> reify v+  reify (ValueCmp cmp AsSizes u v) = CmpInType cmp <$> (reify =<< sizeType) <*> reify u <*> reify v+  reify (ValueCmp cmp AsTypes u v) = CmpTypes cmp <$> reify u <*> reify v+  reify (ValueCmpOnFace cmp p t u v) = CmpInType cmp <$> (reify =<< ty) <*> reify (lam_o u) <*> reify (lam_o v)+    where+      lam_o = I.Lam defaultIrrelevantArgInfo . NoAbs "_"+      ty = runNamesT [] $ do+        p <- open p+        t <- open t+        pPi' "o" p (\ o -> t)+  reify (ElimCmp cmp _ t v es1 es2) =+    CmpElim cmp <$> reify t <*> mapM reifyElimToExpr es1+                            <*> mapM reifyElimToExpr es2+  reify (LevelCmp cmp t t')    = CmpLevels cmp <$> reify t <*> reify t'+  reify (SortCmp cmp s s')     = CmpSorts cmp <$> reify s <*> reify s'+  reify (UnquoteTactic tac _ goal) = do+      tac <- A.App defaultAppInfo_ (A.Unquote exprNoRange) . defaultNamedArg <$> reify tac+      OfType tac <$> reify goal+  reify (UnBlock m) = do+      mi <- lookupMetaInstantiation m+      m' <- reify (MetaV m [])+      case mi of+        BlockedConst t -> do+          e  <- reify t+          return $ Assign m' e+        PostponedTypeCheckingProblem cl -> enterClosure cl $ \case+          CheckExpr cmp e a -> do+              a  <- reify a+              return $ TypedAssign m' e a+          CheckLambda cmp (Arg ai (xs, mt)) body target -> do+            domType <- maybe (return underscore) reify mt+            target  <- reify target+            let mkN (WithHiding h x) = setHiding h $ defaultNamedArg $ A.mkBinder_ x+                bs = mkTBind noRange (fmap mkN xs) domType+                e  = A.Lam Info.exprNoRange (DomainFull bs) body+            return $ TypedAssign m' e target+          CheckArgs _ _ _ args t0 t1 _ -> do+            t0 <- reify t0+            t1 <- reify t1+            return $ PostponedCheckArgs m' (map (namedThing . unArg) args) t0 t1+          CheckProjAppToKnownPrincipalArg cmp e _ _ _ _ t _ _ _ _ -> TypedAssign m' e <$> reify t+          DoQuoteTerm cmp v t -> do+            tm <- A.App defaultAppInfo_ (A.QuoteTerm exprNoRange) . defaultNamedArg <$> reify v+            OfType tm <$> reify t+          DisambiguateConstructor (ConstructorDisambiguationData c0 _cands args t) _cont -> do+            t <- reify t+            return $ TypedAssign m' (foldl (A.App empty)  (A.Con $ unambiguous c0) args) t+        OpenMeta{}  -> __IMPOSSIBLE__+        InstV{} -> __IMPOSSIBLE__+  reify (FindInstance _ m mcands) = FindInstanceOF+    <$> reify (MetaV m [])+    <*> (reify =<< getMetaType m)+    <*> forM (fromMaybe [] mcands) (\ (Candidate q tm ty _) -> do+          (,,) <$> reify tm <*> reify tm <*> reify ty)+  reify (ResolveInstanceHead q) = return $ ResolveInstanceOF q+  reify (IsEmpty r a) = IsEmptyType <$> reify a+  reify (CheckSizeLtSat a) = SizeLtSat  <$> reify a+  reify (CheckFunDef i q cs err) = do+    a <- reify =<< defType <$> getConstInfo q+    return $ PostponedCheckFunDef q a err+  reify (HasBiggerSort a) = OfType <$> reify a <*> reify (UnivSort a)+  reify (HasPTSRule a b) = do+    (a,(x,b)) <- reify (unDom a,b)+    return $ PTSInstance a b+  reify (CheckDataSort q s) = DataSort q <$> reify s+  reify (CheckLockedVars t _ lk _) = CheckLock <$> reify t <*> reify (unArg lk)+  reify (CheckMetaInst m) = do+    t <- jMetaType . mvJudgement <$> lookupLocalMeta m+    OfType <$> reify (MetaV m []) <*> reify t+  reify (CheckType t) = JustType <$> reify t+  reify (UsableAtModality _ _ mod t) = UsableAtMod mod <$> reify t+  {-# SPECIALIZE reify :: Constraint -> TCM (ReifiesTo Constraint) #-} +instance (Pretty a, Pretty b) => PrettyTCM (OutputForm a b) where+  prettyTCM (OutputForm r pids unblock c) =+    prettyRangeConstraint r pids unblock (pretty c)+  {-# SPECIALIZE prettyTCM :: (Pretty a, Pretty b) => (OutputForm a b) -> TCM Doc #-}+ instance (Pretty a, Pretty b) => Pretty (OutputForm a b) where   pretty (OutputForm r pids unblock c) =     pretty c <?>@@ -526,12 +532,15 @@         [ "Resolve instance argument" <?> (pretty s .: t)         , nest 2 $ "Candidate:"         , nest 4 $ vcat [ bin (pretty q) "=" (pretty v) .: t | (q, v, t) <- cs ] ]+      ResolveInstanceOF q ->+        "Resolve output type of instance" <?> pretty q       PTSInstance a b      -> "PTS instance for" <+> pretty (a, b)       PostponedCheckFunDef q a _err ->         vcat [ "Check definition of" <+> pretty q <+> ":" <+> pretty a ]              -- , nest 2 "stuck because" <?> pretty err ] -- We don't have Pretty for TCErr+      DataSort q s         -> "Sort" <+> pretty s <+> "allows data/record definitions"       CheckLock t lk       -> "Check lock" <+> pretty lk <+> "allows" <+> pretty t-      UsableAtMod mod t    -> "Is usable at" <+> pretty mod <+> pretty t+      UsableAtMod mod t    -> "Is usable at" <+> text (verbalize mod) <+> "modality:" <+> pretty t     where       bin a op b = sep [a, nest 2 $ op <+> b]       pcmp cmp a b = bin (pretty a) (pretty cmp) (pretty b)@@ -570,7 +579,9 @@     toConcrete (FindInstanceOF s t cs) =       FindInstanceOF <$> toConcrete s <*> toConcrete t                      <*> mapM (\(q,tm,ty) -> (,,) <$> toConcrete q <*> toConcrete tm <*> toConcrete ty) cs+    toConcrete (ResolveInstanceOF q) = return $ ResolveInstanceOF q     toConcrete (PTSInstance a b) = PTSInstance <$> toConcrete a <*> toConcrete b+    toConcrete (DataSort a b)  = DataSort a <$> toConcrete b     toConcrete (CheckLock a b) = CheckLock <$> toConcrete a <*> toConcrete b     toConcrete (PostponedCheckFunDef q a err) = PostponedCheckFunDef q <$> toConcrete a <*> pure err     toConcrete (UsableAtMod a b) = UsableAtMod a <$> toConcrete b@@ -591,14 +602,14 @@    toConcrete = traverse (toConcreteCtx TopCtx) -instance Pretty c => Pretty (IPBoundary' c) where-  pretty (IPBoundary eqs val meta over) = do+instance Pretty c => Pretty (IPFace' c) where+  pretty (IPFace' eqs val) = do     let       xs = map (\ (l,r) -> pretty l <+> "=" <+> pretty r) eqs-      rhs = case over of-              Overapplied    -> "=" <+> pretty meta-              NotOverapplied -> mempty-    prettyList_ xs <+> "⊢" <+> pretty val <+> rhs+      -- rhs = case over of+      --         Overapplied    -> "=" <+> pretty meta+      --         NotOverapplied -> mempty+    prettyList_ xs <+> "⊢" <+> pretty val -- <+> rhs  prettyConstraints :: [Closure Constraint] -> TCM [OutputForm C.Expr C.Expr] prettyConstraints cs = do@@ -624,6 +635,9 @@       = locallyTCState stInstantiateBlocking (const True) $           instantiateFull p +    nay :: MaybeT TCM Elims+    nay = MaybeT $ pure Nothing+     -- Trying to find the actual meta application, as long as it's not     -- buried too deep.     -- We could look further but probably not under binders as that would mess with@@ -638,27 +652,47 @@         SortCmp cmp a b            -> Nothing         UnBlock{}                  -> Nothing         FindInstance{}             -> Nothing+        ResolveInstanceHead{}      -> Nothing         IsEmpty r t                -> isMeta (unEl t)         CheckSizeLtSat t           -> isMeta t         CheckFunDef{}              -> Nothing         HasBiggerSort a            -> Nothing         HasPTSRule a b             -> Nothing         UnquoteTactic{}            -> Nothing+        CheckDataSort _ s          -> isMetaS s         CheckMetaInst{}            -> Nothing         CheckType t                -> isMeta (unEl t)         CheckLockedVars t _ _ _    -> isMeta t-        UsableAtModality _ t       -> isMeta t+        UsableAtModality _ ms _ t  -> caseMaybe ms (isMeta t) $ \ s -> isMetaS s `mplus` isMeta t -    isMeta (MetaV m' es_m)-      | m == m' = Just es_m+    isMeta :: Term -> Maybe Elims+    isMeta (MetaV m' es_m) | m == m' = pure es_m     isMeta _  = Nothing +    isMetaS :: I.Sort -> Maybe Elims+    isMetaS (MetaS m' es_m)+      | m == m' = pure es_m+    isMetaS _  = Nothing+     getConstrs g f = liftTCM $ do       cs <- stripConstraintPids . filter f <$> (mapM g =<< M.getAllConstraints)-      reportSDoc "constr.ment" 20 $ "getConstraintsMentioning"+      cs <- caseMaybeM (traverse lookupInteractionPoint =<< isInteractionMeta m) (pure cs) $ \ip -> do+        let+          boundary = MapS.keysSet (getBoundary (ipBoundary ip))+          isRedundant c = case allApplyElims =<< hasHeadMeta c of+            Just apps -> caseMaybeM (isFaceConstraint m apps) (pure False) $ \(_, endps, _, _) ->+              pure $ Set.member endps boundary+            Nothing -> pure False+        filterM (flip enterClosure (fmap not . isRedundant) . theConstraint) cs++      reportSDoc "tc.constr.mentioning" 20 $ "getConstraintsMentioning"       forM cs $ \(PConstr s ub c) -> do+        reportSDoc "tc.constr.mentioning" 20 $ "constraint:  " TP.<+> prettyTCM c         c <- normalForm norm c-        case allApplyElims =<< hasHeadMeta (clValue c) of+        let hm = hasHeadMeta (clValue c)+        reportSDoc "tc.constr.mentioning" 20 $ "constraint:  " TP.<+> prettyTCM c+        reportSDoc "tc.constr.mentioning" 20 $ "hasHeadMeta: " TP.<+> prettyTCM hm+        case allApplyElims =<< hm of           Just as_m -> do             -- unifyElimsMeta tries to move the constraint into             -- (an extension of) the context where @m@ comes from.@@ -676,6 +710,16 @@     interestingPids = Set.unions $ map (allBlockingProblems . constraintUnblocker) cs     stripPids (PConstr pids unblock c) = PConstr (Set.intersection pids interestingPids) unblock c +{-# SPECIALIZE interactionIdToMetaId :: InteractionId -> TCM MetaId #-}+-- | Converts an 'InteractionId' to a 'MetaId'.+interactionIdToMetaId :: ReadTCState m => InteractionId -> m MetaId+interactionIdToMetaId i = do+  h <- currentModuleNameHash+  return MetaId+    { metaId     = fromIntegral i+    , metaModule = h+    }+ getConstraints' :: (ProblemConstraint -> TCM ProblemConstraint) -> (ProblemConstraint -> Bool) -> TCM [OutputForm C.Expr C.Expr] getConstraints' g f = liftTCM $ do     cs <- stripConstraintPids . filter f <$> (mapM g =<< M.getAllConstraints)@@ -686,21 +730,86 @@     return $ ss ++ cs   where     toOutputForm (ii, mi, e) = do-      mv <- getMetaInfo <$> lookupMeta mi+      mv <- getMetaInfo <$> lookupLocalMeta mi       withMetaInfo mv $ do-        let m = QuestionMark emptyMetaInfo{ metaNumber = Just $ fromIntegral ii } ii-        abstractToConcrete_ $ OutputForm noRange [] alwaysUnblock $ Assign m e+        mi <- interactionIdToMetaId ii+        let m = QuestionMark emptyMetaInfo{ metaNumber = Just mi } ii+        let oform = OutputForm noRange [] alwaysUnblock $ Assign m e :: OutputForm Expr Expr+        abstractToConcrete_ oform +-- | Reify the boundary of an interaction point as something that can be+-- shown to the user.+getIPBoundary :: Rewrite -> InteractionId -> TCM [IPFace' C.Expr]+getIPBoundary norm ii = withInteractionId ii $ do+  ip <- lookupInteractionPoint ii -getIPBoundary :: Rewrite -> InteractionId -> TCM [IPBoundary' C.Expr]-getIPBoundary norm ii = do-      ip <- lookupInteractionPoint ii-      case ipClause ip of-        IPClause { ipcBoundary = cs } -> do-          forM cs $ \ cl -> enterClosure cl $ \ b ->-            abstractToConcrete_ =<< reifyUnblocked =<< normalForm norm b-        IPNoClause -> return []+  io <- primIOne+  iz <- primIZero +  lookupInteractionMeta ii >>= \case+    Just mi -> do+      mv <- lookupLocalMeta mi++      let t = jMetaType $ mvJudgement mv+      telv@(TelV tel a) <- telView t++      reportSDoc "tc.ip.boundary" 30 $ TP.vcat+        [ "reifying interaction point boundary"+        , "tel:       " TP.<+> prettyTCM tel+        , "meta:      " TP.<+> prettyTCM mi+        ]+      reportSDoc "tc.ip.boundary" 30 $ "boundary:  " TP.<+> pure (pretty (getBoundary (ipBoundary ip)))++      withInteractionId ii $ do+      -- The boundary is a map associating terms (lambda abstractions)+      -- to IntMap Bools. The meta solver will wrap each LHS in lambdas+      -- corresponding to the interaction point's context. Each key of+      -- the boundary has a subset of (the interval variables in) the+      -- interaction point's context as a keysSet.+      as <- getContextArgs+      let+        c = abstractToConcrete_ <=< reifyUnblocked <=< normalForm norm+        go (im, rhs) = do+          reportSDoc "tc.ip.boundary" 30 $ TP.vcat+            [ "reifying constraint for face" TP.<+> TP.pretty im+            ]+          reportSDoc "tc.ip.boundary" 30 $ "term " TP.<+> TP.prettyTCM rhs+          -- Since the RHS is a lambda we have to apply it to the+          -- context:+          rhs <- c (rhs `apply` as)++          -- Reify the IntMap Bool as a list of (i = i0) (j = i1) terms:+          eqns <- forM (IntMap.toList im) $ \(a, b) -> do+            a <- c (I.Var a [])+            (,) a <$> c (if b then io else iz)+          pure $ IPFace' eqns rhs+      traverse go $ MapS.toList (getBoundary (ipBoundary ip))+    Nothing -> pure []++typeAndFacesInMeta :: InteractionId -> Rewrite -> Expr -> TCM (Expr, [IPFace' C.Expr])+typeAndFacesInMeta ii norm expr = withInteractionId ii $ do+  (ex, ty) <- inferExpr expr+  ty <- normalForm norm ty+  ip <- lookupInteractionPoint ii++  io <- primIOne+  iz <- primIZero+  let+    go im = do+      let+        c = abstractToConcrete_ <=< reifyUnblocked <=< normalForm norm+        fa = IntMap.toList im+        face (i, m) = inplaceS i $ if m then io else iz+        sub = foldr (\f s -> composeS (face f) s) idS fa+      eqns <- forM fa $ \(a, b) -> do+        a <- c (I.Var a [])+        (,) a <$> c (if b then io else iz)+      fmap (IPFace' eqns) . c =<< simplify (applySubst sub ex)++  faces <- traverse go $ MapS.keys (getBoundary (ipBoundary ip))+  ty <- reifyUnblocked ty+  pure (ty, faces)+ -- | Goals and Warnings  getGoals :: TCM Goals@@ -736,10 +845,10 @@ getWarningsAndNonFatalErrors :: TCM WarningsAndNonFatalErrors getWarningsAndNonFatalErrors = do   mws <- getAllWarnings AllWarnings-  let notMetaWarnings = filter (not . isMetaTCWarning) mws+  let notMetaWarnings = filter (not . isMetaTCWarning) $ Set.toList mws   return $ case notMetaWarnings of     ws@(_:_) -> classifyWarnings ws-    _ -> emptyWarningsAndNonFatalErrors+    _ -> empty  -- | Collecting the context of the given meta-variable. getResponseContext@@ -759,7 +868,7 @@   mapM solution =<< getInteractionIdsAndMetas   where     solution (i, m) = do-      mv <- lookupMeta m+      mv <- lookupLocalMeta m       withMetaInfo (getMetaInfo mv) $ do         args  <- getContextArgs         scope <- getScope@@ -773,14 +882,13 @@             unsol = return []         case mvInstantiation mv of           InstV{}                        -> sol (MetaV m $ map Apply args)-          Open{}                         -> unsol-          OpenInstance{}                 -> unsol+          OpenMeta{}                     -> unsol           BlockedConst{}                 -> unsol           PostponedTypeCheckingProblem{} -> unsol  typeOfMetaMI :: Rewrite -> MetaId -> TCM (OutputConstraint Expr NamedMeta) typeOfMetaMI norm mi =-     do mv <- lookupMeta mi+     do mv <- lookupLocalMeta mi         withMetaInfo (getMetaInfo mv) $           rewriteJudg mv (mvJudgement mv)    where@@ -825,15 +933,14 @@ typesOfHiddenMetas :: Rewrite -> TCM [OutputConstraint Expr NamedMeta] typesOfHiddenMetas norm = liftTCM $ do   is    <- getInteractionMetas-  store <- IntMap.filterWithKey (openAndImplicit is . MetaId) <$> getMetaStore-  mapM (typeOfMetaMI norm . MetaId) $ IntMap.keys store+  store <- MapS.filterWithKey (implicit is) <$> useR stOpenMetaStore+  mapM (typeOfMetaMI norm) $ MapS.keys store   where-  openAndImplicit is x m | isJust (mvTwin m) = False-  openAndImplicit is x m =+  implicit is x m | isJust (mvTwin m) = False+  implicit is x m =     case mvInstantiation m of-      M.InstV{} -> False-      M.Open    -> x `notElem` is-      M.OpenInstance -> x `notElem` is  -- OR: True !?+      M.InstV{} -> __IMPOSSIBLE__+      M.OpenMeta _ -> x `notElem` is  -- OR: True in case of InstanceMeta !?       M.BlockedConst{} -> False       M.PostponedTypeCheckingProblem{} -> False @@ -846,7 +953,20 @@     A.Application h args <- A.appView . getBody . deepUnscope <$> parseExprIn ii rng ("let " ++ f ++ " = _ in " ++ s)     inCxt   <- hasElem <$> getContextNames     cxtArgs <- getContextArgs+    enclosingFunctionName <- ipcQName . envClause <$> getEnv     a0      <- (`piApply` cxtArgs) <$> (getMetaType =<< lookupInteractionId ii)++    -- Konstantin, 2022-10-23: We don't want to print section parameters in helper type.+    freeVars <- getCurrentModuleFreeVars+    ctx <- getContext+    let contextForAbstracting = take (size ctx - freeVars) ctx++    -- Andreas, 2019-10-11: I actually prefer pi-types over ->.+    let runInPrintingEnvironment = localTC (\e -> e { envPrintDomainFreePi = True, envPrintMetasBare = True })+                                 . escapeContext impossible (length contextForAbstracting)+                                 . withoutPrintingGeneralization+                                 . dontFoldLetBindings+     case mapM (isVar . namedArg) args >>= \ xs -> xs <$ guard (all inCxt xs) of       -- Andreas, 2019-10-11@@ -854,44 +974,44 @@      -- We simply make exactly the given arguments visible and all other hidden.      Just xs -> do       let inXs = hasElem xs-      let hideButXs dom = setHiding (if inXs $ fst $ unDom dom then NotHidden else Hidden) dom-      tel  <- telFromList . map (fmap (first nameToArgName) . hideButXs) . reverse <$> getContext+      let hideButXs ce = setHiding (if inXs (ctxEntryName ce) then NotHidden else Hidden) ce+      let tel = contextToTel . map hideButXs $ contextForAbstracting       OfType' h <$> do-        -- Andreas, 2019-10-11: I actually prefer pi-types over ->.-        localTC (\e -> e { envPrintDomainFreePi = True }) $ reify $ telePiVisible tel a0+        runInPrintingEnvironment $ reify $ telePiVisible tel a0 -     -- If some arguments are not variables.+     -- If some arguments are not variables (in this case, @args@ is not empty).      Nothing -> do-      cxtArgs  <- getContextArgs       -- cleanupType relies on with arguments being named 'w',       -- so we'd better rename any actual 'w's to avoid confusion.-      tel  <- runIdentity . onNamesTel unW <$> getContextTelescope+      let tel = runIdentity . onNamesTel unW . contextToTel $ contextForAbstracting       let a = runIdentity . onNames unW $ a0-      vtys <- mapM (\ a -> fmap (Arg (getArgInfo a) . fmap OtherType) $ inferExpr $ namedArg a) args+      vtys <- mapM (\ a -> fmap (Arg (getArgInfo a) . fmap OtherType) $ inferExpr $ namedArg a) $+        List1.fromListSafe __IMPOSSIBLE__ args       -- Remember the arity of a       TelV atel _ <- telView a       let arity = size atel           (delta1, delta2, _, a', vtys') = splitTelForWith tel a vtys-      a <- localTC (\e -> e { envPrintDomainFreePi = True }) $ do-        reify =<< cleanupType arity args =<< normalForm norm =<< fst <$> withFunctionType delta1 vtys' delta2 a' []-      reportSDoc "interaction.helper" 10 $ TP.vcat $-        let extractOtherType = \case { OtherType a -> a; _ -> __IMPOSSIBLE__ } in-        let (vs, as)   = unzipWith (fmap extractOtherType . unArg) vtys in-        let (vs', as') = unzipWith (fmap extractOtherType . unArg) vtys' in-        [ "generating helper function"-        , TP.nest 2 $ "tel    = " TP.<+> inTopContext (prettyTCM tel)-        , TP.nest 2 $ "a      = " TP.<+> prettyTCM a-        , TP.nest 2 $ "vs     = " TP.<+> prettyTCM vs-        , TP.nest 2 $ "as     = " TP.<+> prettyTCM as-        , TP.nest 2 $ "delta1 = " TP.<+> inTopContext (prettyTCM delta1)-        , TP.nest 2 $ "delta2 = " TP.<+> inTopContext (addContext delta1 $ prettyTCM delta2)-        , TP.nest 2 $ "a'     = " TP.<+> inTopContext (addContext delta1 $ addContext delta2 $ prettyTCM a')-        , TP.nest 2 $ "as'    = " TP.<+> inTopContext (addContext delta1 $ prettyTCM as')-        , TP.nest 2 $ "vs'    = " TP.<+> inTopContext (addContext delta1 $ prettyTCM vs')-        ]+      a <- runInPrintingEnvironment $ do+        reify =<< cleanupType arity args =<< normalForm norm =<< fst <$> withFunctionType delta1 vtys' delta2 a' empty+      reportSDoc "interaction.helper" 10 do+        let extractOtherType = \case { OtherType a -> a; _ -> __IMPOSSIBLE__ }+        let (vs, as)   = List1.unzipWith (fmap extractOtherType . unArg) vtys+        let (vs', as') = List1.unzipWith (fmap extractOtherType . unArg) vtys'+        TP.vcat+          [ "generating helper function"+          , TP.nest 2 $ "tel    = " TP.<+> inTopContext (prettyTCM tel)+          , TP.nest 2 $ "a      = " TP.<+> prettyTCM a+          , TP.nest 2 $ "vs     = " TP.<+> prettyTCM vs+          , TP.nest 2 $ "as     = " TP.<+> prettyTCM as+          , TP.nest 2 $ "delta1 = " TP.<+> inTopContext (prettyTCM delta1)+          , TP.nest 2 $ "delta2 = " TP.<+> inTopContext (addContext delta1 $ prettyTCM delta2)+          , TP.nest 2 $ "a'     = " TP.<+> inTopContext (addContext delta1 $ addContext delta2 $ prettyTCM a')+          , TP.nest 2 $ "as'    = " TP.<+> inTopContext (addContext delta1 $ prettyTCM as')+          , TP.nest 2 $ "vs'    = " TP.<+> inTopContext (addContext delta1 $ prettyTCM vs')+          ]       return $ OfType' h a   where-    failure = typeError $ GenericError $ "Expected an argument of the form f e1 e2 .. en"+    failure = interactionError ExpectedApplication     ensureName f = do       ce <- parseExpr rng f       flip (caseMaybe $ isName ce) (\ _ -> return ()) $ do@@ -928,8 +1048,8 @@     -- renameVars = onNames (stringToArgName <.> renameVar . argNameToString)     renameVars = onNames renameVar -    -- onNames :: Applicative m => (ArgName -> m ArgName) -> Type -> m Type-    onNames :: Applicative m => (String -> m String) -> Type -> m Type+    -- onNames :: Applicative m => (ArgName -> m ArgName) -> I.Type -> m I.Type+    onNames :: Applicative m => (String -> m String) -> I.Type -> m I.Type     onNames f (El s v) = El s <$> onNamesTm f v      -- onNamesTel :: Applicative f => (ArgName -> f ArgName) -> I.Telescope -> f I.Telescope@@ -978,7 +1098,7 @@  contextOfMeta :: InteractionId -> Rewrite -> TCM [ResponseContextEntry] contextOfMeta ii norm = withInteractionId ii $ do-  info <- getMetaInfo <$> (lookupMeta =<< lookupInteractionId ii)+  info <- getMetaInfo <$> (lookupLocalMeta =<< lookupInteractionId ii)   withMetaInfo info $ do     -- List of local variables.     cxt <- getContext@@ -990,8 +1110,8 @@          <*> forMaybeM letVars mkLet    where-    mkVar :: Dom (Name, Type) -> TCM (Maybe ResponseContextEntry)-    mkVar Dom{ domInfo = ai, unDom = (name, t) } = do+    mkVar :: ContextEntry -> TCM (Maybe ResponseContextEntry)+    mkVar (CtxVar name Dom{ domInfo = ai, unDom = t }) = do       if shouldHide ai name then return Nothing else Just <$> do         let n = nameConcrete name         x  <- abstractToConcrete_ name@@ -999,15 +1119,17 @@         ty <- reifyUnblocked =<< normalForm norm t         return $ ResponseContextEntry n x (Arg ai ty) Nothing s -    mkLet :: (Name, Open (Term, Dom Type)) -> TCM (Maybe ResponseContextEntry)+    mkLet :: (Name, Open M.LetBinding) -> TCM (Maybe ResponseContextEntry)     mkLet (name, lb) = do-      (tm, !dom) <- getOpen lb+      LetBinding _ tm !dom <- getOpen lb       if shouldHide (domInfo dom) name then return Nothing else Just <$> do         let n = nameConcrete name         x  <- abstractToConcrete_ name         let s = C.isInScope x         ty <- reifyUnblocked =<< normalForm norm dom-        v  <- reifyUnblocked =<< normalForm norm tm+              -- Remove let bindings from x and later, to avoid folding to x = x, or using bindings+              -- not introduced when x was defined.+        v  <- removeLetBindingsFrom name $ reifyUnblocked =<< normalForm norm tm         return $ ResponseContextEntry n x ty (Just v) s      shouldHide :: ArgInfo -> A.Name -> Bool@@ -1027,7 +1149,7 @@ typeInMeta :: InteractionId -> Rewrite -> Expr -> TCM Expr typeInMeta ii norm e =    do   m <- lookupInteractionId ii-        mi <- getMetaInfo <$> lookupMeta m+        mi <- getMetaInfo <$> lookupLocalMeta m         withMetaInfo mi $             typeInCurrent norm e @@ -1040,7 +1162,7 @@ introTactic :: Bool -> InteractionId -> TCM [String] introTactic pmLambda ii = do   mi <- lookupInteractionId ii-  mv <- lookupMeta mi+  mv <- lookupLocalMeta mi   withMetaInfo (getMetaInfo mv) $ case mvJudgement mv of     HasType _ _ t -> do         t <- reduce =<< piApplyM t =<< getContextArgs@@ -1049,7 +1171,7 @@         TelV tel' t <- telViewUpTo' (-1) notVisible t         -- if we cannot introduce a constructor, we try a lambda         let fallback = do-              cubical <- isJust . optCubical <$> pragmaOptions+              cubical <- isJust <$> cubicalOption               TelV tel _ <- (if cubical then telViewPath else telView) t               reportSDoc "interaction.intro" 20 $ TP.sep                 [ "introTactic/fallback"@@ -1064,9 +1186,9 @@           I.Def d _ -> do             def <- getConstInfo d             case theDef def of-              Datatype{}    -> addContext tel' $ introData t+              Datatype{}    -> addContext tel' $ introData AmbiguousNothing t               Record{ recNamedCon = name }-                | name      -> addContext tel' $ introData t+                | name      -> addContext tel' $ introData AmbiguousConProjs t                 | otherwise -> addContext tel' $ introRec d               _ -> fallback           _ -> fallback@@ -1077,11 +1199,12 @@     conName [p] = [ c | I.ConP c _ _ <- [namedArg p] ]     conName _   = __IMPOSSIBLE__ -    showUnambiguousConName v =-       render . pretty <$> runAbsToCon (lookupQName AmbiguousNothing $ I.conName v)+    showUnambiguousConName :: AllowAmbiguousNames -> ConHead -> TCM String+    showUnambiguousConName amb c = render . pretty <$> do+      abstractToConcreteQName amb $ I.conName c      showTCM :: PrettyTCM a => a -> TCM String-    showTCM v = render <$> prettyTCM v+    showTCM = render <.> prettyTCM      introFun :: ListTel -> TCM [String]     introFun tel = addContext tel' $ do@@ -1093,7 +1216,7 @@             allHidden   = not (any okHiding0 hs)             okHiding    = if allHidden then const True else okHiding0         vars <- -- setShowImplicitArguments (imp || allHidden) $-                (if allHidden then withShowAllArguments else id) $+                applyWhen allHidden withShowAllArguments $                   mapM showTCM [ setHiding h $ defaultArg $ var i :: Arg Term                                | (h, i) <- zip hs $ downFrom n                                , okHiding h@@ -1108,15 +1231,46 @@         makeName ("_", t) = ("x", t)         makeName (x, t)   = (x, t) -    introData :: I.Type -> TCM [String]-    introData t = do+    contextDimensions :: TCM Int+    contextDimensions = do+      let+        go n EmptyTel = pure n+        go n (ExtendTel dom abs) = do+          n' <- isInterval (unDom dom) <&> \case+            True  -> n + 1+            False -> n+          underAbstraction dom abs $ go n'+      go 0 =<< getContextTelescope++    introData :: AllowAmbiguousNames -> I.Type -> TCM [String]+    introData amb t = do       let tel  = telFromList [defaultDom ("_", t)]-          pat  = [defaultArg $ unnamed $ debruijnNamedVar "c" 0]-      r <- splitLast CoInductive tel pat+          pat  = [defaultArg $ unnamed $ deBruijnNamedVar "c" 0]+      -- Gallais, 2023-08-24: #6787 we need to locally ignore the+      -- --without-K or --cubical-compatible options to figure out+      -- that refl is a valid constructor for refl ≡ refl.++      cubical <- isJust <$> cubicalOption+      r <- (if cubical then id else+            locallyTCState (stPragmaOptions . lensOptWithoutK) (const (Value False)))+           $ splitLast CoInductive tel pat++      -- If --cubical then we often get ambiguity because the coverage+      -- checker says most path constructors could also fit the hole. In+      -- that case we compute the number of interval variables in the+      -- context and drop any clauses that have more IApply patterns (=+      -- constructors that have a higher dimensionality) than the+      -- context.+      dim <- traverse (const contextDimensions) =<< cubicalOption+      let+        dimension cl = case dim of+          Just n  -> length (iApplyVars (scPats cl)) <= n+          Nothing -> True+       case r of         Left err -> return []         Right cov ->-           mapM showUnambiguousConName $ concatMap (conName . scPats) $ splitClauses cov+           mapM (showUnambiguousConName amb) $ concatMap (conName . scPats) $ filter dimension $ splitClauses cov      introRec :: QName -> TCM [String]     introRec d = do@@ -1124,7 +1278,7 @@       fs <- ifM showImplicitArguments             (return $ map unDom hfs)             (return [ unDom a | a <- hfs, visible a ])-      let e = C.Rec noRange $ for fs $ \ f ->+      let e = C.Rec empty noRange $ for fs $ \ f ->             Left $ C.FieldAssignment f $ C.QuestionMark noRange Nothing       return [ prettyShow e ]       -- Andreas, 2019-02-25, remark:@@ -1138,9 +1292,11 @@ --   Sets up current module, scope, and context. atTopLevel :: TCM a -> TCM a atTopLevel m = inConcreteMode $ do-  let err = typeError $ GenericError "The file has not been loaded yet."-  caseMaybeM (useTC stCurrentModule) err $ \ current -> do-    caseMaybeM (getVisitedModule $ toTopLevelModuleName current) __IMPOSSIBLE__ $ \ mi -> do+  let err = __IMPOSSIBLE__+    -- Andreas, 2024-08-03: cannot trigger this error:+    -- let err = genericError "The file has not been loaded yet."+  caseMaybeM (useTC stCurrentModule) err $ \(current, topCurrent) -> do+    caseMaybeM (getVisitedModule topCurrent) __IMPOSSIBLE__ $ \ mi -> do       let scope = iInsideScope $ miInterface mi       tel <- lookupSection current       -- Get the names of the local variables from @scope@@@ -1189,8 +1345,7 @@ parseName :: Range -> String -> TCM C.QName parseName r s = do   e <- parseExpr r s-  let failure = typeError $ GenericError $ "Not an identifier: " ++ show e ++ "."-  maybe failure return $ isQName e+  maybe (interactionError $ ExpectedIdentifier e) return $ isQName e  -- | Check whether an expression is a (qualified) identifier. isQName :: C.Expr -> Maybe C.QName@@ -1212,7 +1367,7 @@      -- ^ The range of the next argument.   -> String      -- ^ The module name.-  -> TCM ([C.Name], I.Telescope, [(C.Name, Type)])+  -> TCM ([C.Name], I.Telescope, [(C.Name, I.Type)])      -- ^ Module names,      --   context extension needed to print types,      --   names paired up with corresponding types.@@ -1235,17 +1390,15 @@ getRecordContents   :: Rewrite  -- ^ Amount of normalization in types.   -> C.Expr   -- ^ Expression presumably of record type.-  -> TCM ([C.Name], I.Telescope, [(C.Name, Type)])+  -> TCM ([C.Name], I.Telescope, [(C.Name, I.Type)])               -- ^ Module names,               --   context extension,               --   names paired up with corresponding types. getRecordContents norm ce = do-  e <- toAbstract ce-  (_, t) <- inferExpr e-  let notRecordType = typeError $ ShouldBeRecordType t-  (q, vs, defn) <- fromMaybeM notRecordType $ isRecordType t-  case defn of-    Record{ recFields = fs, recTel = rtel } -> do+  (_, t) <- inferExpr =<< toAbstract ce+  isRecordType t >>= \case+    Nothing -> typeError $ ShouldBeRecordType t+    Just (q, vs, RecordData{ _recFields = fs, _recTel = rtel }) -> do       let xs   = map (nameConcrete . qnameName . unDom) fs           tel  = apply rtel vs           doms = flattenTel tel@@ -1260,7 +1413,6 @@         ]       ts <- mapM (normalForm norm . unDom) doms       return ([], tel, zip xs ts)-    _ -> __IMPOSSIBLE__  -- | Returns the contents of the given module. @@ -1269,7 +1421,7 @@        -- ^ Amount of normalization in types.   -> Maybe C.QName        -- ^ Module name, @Nothing@ if top-level module.-  -> TCM ([C.Name], I.Telescope, [(C.Name, Type)])+  -> TCM ([C.Name], I.Telescope, [(C.Name, I.Type)])        -- ^ Module names,        --   context extension,        --   names paired up with corresponding types.@@ -1281,18 +1433,23 @@       modules = exportedNamesInScope modScope       names :: ThingsInScope AbstractName       names = exportedNamesInScope modScope-      xns = [ (x,n) | (x, ns) <- Map.toList names, n <- ns ]-  types <- forM xns $ \(x, n) -> do-    d <- getConstInfo $ anameName n-    t <- normalForm norm =<< (defType <$> instantiateDef d)-    return (x, t)+      xns = [ (x,n) | (x, ns) <- Map.toList names, n <- List1.toList ns ]+  types <- forMaybeM xns $ \(x, n) -> do+    getConstInfo' (anameName n) >>= \case+      Right d -> do+        t <- normalForm norm =<< (defType <$> instantiateDef d)+        return $ Just (x, t)+      Left{} -> return Nothing   return (Map.keys modules, EmptyTel, types)  -whyInScope :: String -> TCM (Maybe LocalVar, [AbstractName], [AbstractModule])-whyInScope s = do+whyInScope :: FilePath -> String -> TCM WhyInScopeData+whyInScope cwd s = do   x     <- parseName noRange s   scope <- getScope-  return ( lookup x $ map (first C.QName) $ scope ^. scopeLocals-         , scopeLookup x scope-         , scopeLookup x scope )+  return $ WhyInScopeData+    x+    cwd+    (lookup x $ map (first C.QName) $ scope ^. scopeLocals)+    (scopeLookup x scope)+    (scopeLookup x scope)
+ src/full/Agda/Interaction/BuildLibrary.hs view
@@ -0,0 +1,104 @@+-- | Type-check all files of a library (option @--build-library@).++module Agda.Interaction.BuildLibrary (buildLibrary) where++import           Control.Monad.Except             (throwError)+import           Control.Monad.IO.Class           (liftIO)++import           Data.Functor                     (void)+import           Data.List                        (sort)+import qualified Data.Set as Set++import           System.Directory                 (getCurrentDirectory)+import           System.FilePath                  ( (</>) )+import qualified System.FilePath.Find             as Find++import           Agda.Interaction.FindFile        (hasAgdaExtension, checkModuleName)+import           Agda.Interaction.Imports         (Source)+import qualified Agda.Interaction.Imports         as Imp+import           Agda.Interaction.Library         (pattern AgdaLibFile, _libIncludes, _libPragmas, getAgdaLibFile)+import           Agda.Interaction.Options         (optOnlyScopeChecking)++import           Agda.Syntax.Abstract.Name        (noModuleName)+import           Agda.Syntax.Position             (beginningOfFile)++import           Agda.TypeChecking.Monad+import           Agda.TypeChecking.Pretty         (prettyTCM, text, vsep)+import           Agda.TypeChecking.Pretty.Warning (getAllWarnings, tcWarningsToError)+import           Agda.TypeChecking.Warnings       (pattern AllWarnings, classifyWarnings)++import           Agda.Utils.FileName              (absolute)+import           Agda.Utils.Functor               ()+import           Agda.Utils.IO.Directory          (findWithInfo)+import           Agda.Utils.Monad                 (forM, forM_, unless, bracket_)+import           Agda.Utils.Null                  (unlessNullM)+import           Agda.Utils.String                (delimiter)++import           Agda.Utils.Impossible            (__IMPOSSIBLE__)++-- | Find @.agda-lib@ file from current directory+--   and build all modules located in the @include@ paths+--   and their subdirectories of the library.+--+buildLibrary :: TCM ()+buildLibrary = do+  cwd <- liftIO getCurrentDirectory++  -- Read the library file.+  ls <- libToTCM $ getAgdaLibFile cwd+  libFile@AgdaLibFile{ _libIncludes = paths+                     , _libPragmas  = libOpts } <- case ls of+    [l] -> pure l+    []  -> throwError $ GenericException "No library found to build"+    _   -> __IMPOSSIBLE__++  checkAndSetOptionsFromPragma libOpts++  -- Import the primitive modules+  Imp.importPrimitiveModules++  -- Find all modules in the include paths of the library.+  files <- sort . map Find.infoPath . concat <$> forM paths \ path -> do+    liftIO $ findWithInfo (pure True) (hasAgdaExtension <$> Find.filePath) path++  -- Call the type-checker on all these modules.+  -- (Code copied from Agda.Main.)++  opts <- commandLineOptions+  let mode = if optOnlyScopeChecking opts+             then Imp.ScopeCheck+             else Imp.TypeCheck++  forM_ files \ inputFile -> do+    path :: AbsolutePath+      <- liftIO (absolute inputFile)+    sf :: SourceFile+      <- srcFromPath path+    src :: Source+      <- Imp.parseSource sf+    let+      m :: TopLevelModuleName+      m = Imp.srcModuleName src+    setCurrentRange (beginningOfFile path) do+      checkModuleName m (Imp.srcOrigin src) Nothing+      _ <- withCurrentModule noModuleName+           $ withTopLevelModule m+           $ checkModule m src+      return ()++  -- Print accumulated warnings+  unlessNullM (tcWarnings . classifyWarnings . Set.toAscList <$> getAllWarnings AllWarnings) $ \ ws -> do+    let banner = text $ "\n" ++ delimiter "All done; warnings encountered"+    alwaysReportSDoc "warning" 1 $+      vsep $ (banner :) $ map prettyTCM $ Set.toAscList ws++checkModule :: TopLevelModuleName -> Imp.Source -> TCM ()+checkModule m src = do+  mi <- Imp.getNonMainModuleInfo m (Just src)+  -- Here we ignore InfectiveImport warnings since we don't have an actual parent module that can+  -- be infected.+  let isInfectiveWarning InfectiveImport{} = True+      isInfectiveWarning _                 = False+      warns = filter (not . isInfectiveWarning . tcWarning) $ Set.toAscList $ miWarnings mi+  tcWarningsToError warns+  return ()
+ src/full/Agda/Interaction/Command.hs view
@@ -0,0 +1,55 @@+module Agda.Interaction.Command+  ( CommandM, localStateCommandM, liftLocalState, revLift, revLiftTC+  ) where++import Control.Monad.State ( MonadState(..), execStateT, lift )++import Agda.TypeChecking.Monad.Base ( TCM,MonadTCState, TCState, getTC, putTC )+import Agda.TypeChecking.Monad.State ( localTCState )++import Agda.Interaction.Base ( CommandM' )++------------------------------------------------------------------------+-- The CommandM monad++type CommandM  = CommandM' TCM++-- | Restore both 'TCState' and 'CommandState'.++localStateCommandM :: CommandM a -> CommandM a+localStateCommandM m = do+  cSt <- get+  tcSt <- getTC+  x <- m+  putTC tcSt+  put cSt+  return x++-- | Restore 'TCState', do not touch 'CommandState'.++liftLocalState :: TCM a -> CommandM a+liftLocalState = lift . localTCState++-- | Build an opposite action to 'lift' for state monads.++revLift+    :: MonadState st m+    => (forall c . m c -> st -> k (c, st))      -- ^ run+    -> (forall b . k b -> m b)                  -- ^ lift+    -> (forall x . (m a -> k x) -> k x) -> m a  -- ^ reverse lift in double negative position+revLift run lift' f = do+    st <- get+    (a, st') <- lift' $ f (`run` st)+    put st'+    return a++revLiftTC+    :: MonadTCState m+    => (forall c . m c -> TCState -> k (c, TCState))  -- ^ run+    -> (forall b . k b -> m b)                        -- ^ lift+    -> (forall x . (m a -> k x) -> k x) -> m a        -- ^ reverse lift in double negative position+revLiftTC run lift' f = do+    st <- getTC+    (a, st') <- lift' $ f (`run` st)+    putTC st'+    return a
src/full/Agda/Interaction/CommandLine.hs view
@@ -21,6 +21,7 @@  import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty import Agda.Syntax.Internal (telToList, alwaysUnblock) import qualified Agda.Syntax.Internal as I import Agda.Syntax.Parser@@ -35,11 +36,9 @@ import Agda.TypeChecking.Errors import Agda.TypeChecking.Pretty ( PrettyTCM(prettyTCM) ) import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Warnings (runPM)  import Agda.Utils.FileName (absolute, AbsolutePath) import Agda.Utils.Maybe (caseMaybeM)-import Agda.Utils.Pretty  import Agda.Utils.Impossible @@ -58,6 +57,7 @@     , HasOptions, MonadTCEnv, ReadTCState, MonadTCState, MonadTCM     , MonadError TCErr     , MonadReader ReplEnv, MonadState ReplState+    , MonadFileId     )  runReplM :: Maybe AbsolutePath -> TCM () -> (AbsolutePath -> TCM CheckResult) -> ReplM () -> TCM ()@@ -107,7 +107,7 @@                     Just _ ->                         do  go =<< liftTCM (eval $ fromJust ms)             `catchError` \e ->-                do  s <- prettyError e+                do  s <- renderError e                     liftIO $ putStrLn s                     loop @@ -135,14 +135,14 @@     where         reload :: ReplM () = do             checked <- checkCurrentFile-            liftTCM $ setScope $ maybe emptyScopeInfo iInsideScope (crInterface <$> checked)+            liftTCM $ setScope $ maybe emptyScopeInfo (iInsideScope . crInterface) checked             -- Andreas, 2021-01-27, issue #5132, make Set and Prop available from Agda.Primitive             -- if no module is loaded.             when (isNothing checked) $ do               -- @open import Agda.Primitive using (Set; Prop)@               void $ liftTCM importPrimitives           `catchError` \e -> do-            s <- prettyError e+            s <- renderError e             liftIO $ putStrLn s             liftIO $ putStrLn "Failed." @@ -174,7 +174,8 @@ withCurrentFile :: ReplM a -> ReplM a withCurrentFile cont = do   mpath <- gets currentFile-  localTC (\ e -> e { envCurrentPath = mpath }) cont+  i <- traverse idFromFile mpath+  localTC (\ e -> e { envCurrentPath = i }) cont  loadFile :: ReplM () -> [String] -> ReplM () loadFile reload [file] = do@@ -233,11 +234,12 @@ metaParseExpr ::  InteractionId -> String -> TCM A.Expr metaParseExpr ii s =     do  m <- lookupInteractionId ii-        scope <- getMetaScope <$> lookupMeta m-        r <- getRange <$> lookupMeta m+        scope <- getMetaScope <$> lookupLocalMeta m+        r <- getRange <$> lookupLocalMeta m         -- liftIO $ putStrLn $ prettyShow scope         let pos = fromMaybe __IMPOSSIBLE__ (rStart r)-        e <- runPM $ parsePosString exprParser pos s+        (e, attrs) <- runPM $ parsePosString exprParser pos s+        checkAttributes attrs         concreteToAbstract scope e  actOnMeta :: [String] -> (InteractionId -> A.Expr -> TCM a) -> TCM a@@ -277,7 +279,8 @@  parseExpr :: String -> TCM A.Expr parseExpr s = do-    e <- runPM $ parse exprParser s+    (e, attrs) <- runPM $ parse exprParser s+    checkAttributes attrs     localToAbstract e return  evalTerm :: String -> TCM (ExitCode a)@@ -293,20 +296,20 @@     do  e  <- parseExpr (unwords s)         e0 <- typeInCurrent Normalised e         e1 <- typeInCurrent AsIs e-        liftIO . putStrLn =<< showA e1+        liftIO . print =<< prettyA e1  typeIn :: [String] -> TCM () typeIn s@(_:_:_) =     actOnMeta s $ \i e ->     do  e1 <- typeInMeta i Normalised e         e2 <- typeInMeta i AsIs e-        liftIO . putStrLn =<< showA e1+        liftIO . print =<< prettyA e1 typeIn _ = liftIO $ putStrLn ":typeIn meta expr"  showContext :: [String] -> TCM () showContext (meta:args) = do     i <- InteractionId <$> readM meta-    mi <- lookupMeta =<< lookupInteractionId i+    mi <- lookupLocalMeta =<< lookupInteractionId i     withMetaInfo (getMetaInfo mi) $ do       ctx <- List.map I.unDom . telToList <$> getContextTelescope       zipWithM_ display ctx $ reverse $ zipWith const [1..] ctx@@ -349,5 +352,4 @@ readM :: Read a => String -> TCM a readM s = maybe err return $ readMaybe s   where-  err    = throwError $ strMsg $ "Cannot parse: " ++ s-  strMsg = Exception noRange . text+  err = throwError $ GenericException $ "Cannot parse: " ++ s
src/full/Agda/Interaction/EmacsCommand.hs view
@@ -13,9 +13,9 @@   , displayRunningInfo   ) where -import qualified Data.List as List+-- import qualified Data.List as List -import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.String  -- | Simple Emacs Lisp expressions.
src/full/Agda/Interaction/EmacsTop.hs view
@@ -1,9 +1,12 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Interaction.EmacsTop     ( mimicGHCi     , namedMetaOf     , showGoals     , showInfoError     , explainWhyInScope+    , prettyResponseContext     , prettyTypeOfMeta     ) where @@ -15,18 +18,15 @@ import qualified Data.List as List  import Agda.Syntax.Common-import Agda.Syntax.Position-import Agda.Syntax.Scope.Base+import Agda.Syntax.Common.Pretty import Agda.Syntax.Abstract.Pretty (prettyATop)-import Agda.Syntax.Abstract as A import Agda.Syntax.Concrete as C -import Agda.TypeChecking.Errors (prettyError, getAllWarningsOfTCErr)+import Agda.TypeChecking.Errors ( explainWhyInScope, getAllWarningsOfTCErr, renderError, verbalize ) import qualified Agda.TypeChecking.Pretty as TCP import Agda.TypeChecking.Pretty (prettyTCM)-import Agda.TypeChecking.Pretty.Warning (prettyTCWarnings, prettyTCWarnings')+import Agda.TypeChecking.Pretty.Warning (prettyTCWarnings) import Agda.TypeChecking.Monad-import Agda.TypeChecking.Warnings (WarningsAndNonFatalErrors(..)) import Agda.Interaction.AgdaTop import Agda.Interaction.Base import Agda.Interaction.BasicOps as B@@ -34,11 +34,10 @@ import Agda.Interaction.EmacsCommand hiding (putResponse) import Agda.Interaction.Highlighting.Emacs import Agda.Interaction.Highlighting.Precise (TokenBased(..))-import Agda.Interaction.InteractionTop (localStateCommandM)+import Agda.Interaction.Command (localStateCommandM) import Agda.Utils.Function (applyWhen) import Agda.Utils.Null (empty) import Agda.Utils.Maybe-import Agda.Utils.Pretty import Agda.Utils.String import Agda.Utils.Time (CPUTime) import Agda.VersionCommit@@ -109,6 +108,16 @@   ]   where     prn (ii,e)= [showNumIId ii, A $ quote $ prettyShow e]+-- TODO: For now, I piggy-back on the Resp_SolveAll implementation+lispifyResponse (Resp_Mimer ii msol) = return $ case msol of+  Nothing ->+    [ lastTag 1 $ -- TODO: What is this lastTag used for?+        L [ A "agda2-info-action", A $ quote "*Mimer*", A $ quote "No solution found" ]+    ]+  Just str ->+    [ lastTag 1 $ -- TODO: What is this lastTag used for?+        L [ A "agda2-solve-action", showNumIId ii, A $ quote str ]+    ]  lispifyDisplayInfo :: DisplayInfo -> TCM [Lisp String] lispifyDisplayInfo info = case info of@@ -124,7 +133,9 @@       -- abusing the goals field since we ignore the title         (body, _) = formatWarningsAndErrors msg warnings errors       format body "*Compilation result*"-    Info_Constraints s -> format (show $ vcat $ map pretty s) "*Constraints*"+    Info_Constraints s -> do+      doc <- TCP.vcat $ map prettyTCM s+      format (render doc) "*Constraints*"     Info_AllGoalsWarnings ms ws -> do       goals <- showGoals ms       warnings <- prettyTCWarnings (tcWarnings ws)@@ -179,8 +190,8 @@       let doc = "Definitions about" <+>                 text (List.intercalate ", " $ words names) $$ nest 2 (align 10 hitDocs)       format (render doc) "*Search About*"-    Info_WhyInScope s cwd v xs ms -> do-      doc <- explainWhyInScope s cwd v xs ms+    Info_WhyInScope why -> do+      doc <- explainWhyInScope why       format (render doc) "*Scope Info*"     Info_Context ii ctx -> do       doc <- localTCState (prettyResponseContext ii False ctx)@@ -214,31 +225,32 @@     Goal_GoalType norm aux ctx bndry constraints -> do       ctxDoc <- prettyResponseContext ii True ctx       goalDoc <- prettyTypeOfMeta norm ii+      let boundaryDoc hd bndry+            | null bndry = []+            | otherwise  = [ text $ delimiter hd+                           , vcat $ map pretty bndry+                           ]       auxDoc <- case aux of             GoalOnly -> return empty-            GoalAndHave expr -> do+            GoalAndHave expr bndry -> do               doc <- prettyATop expr-              return $ "Have:" <+> doc-            GoalAndElaboration term -> do-              doc <- TCP.prettyTCM term+              return $ ("Have:" <+> doc) $$ vcat (boundaryDoc ("Boundary (actual)") bndry)+            GoalAndElaboration expr -> do+              doc <- prettyATop expr               return $ "Elaborates to:" <+> doc-      let boundaryDoc-            | null bndry = []-            | otherwise  = [ text $ delimiter "Boundary"-                           , vcat $ map pretty bndry-                           ]-      let constraintsDoc = if (null constraints)-            then  []-            else  [ text $ delimiter "Constraints"-                  , vcat $ map pretty constraints-                  ]-      let doc = vcat $-            [ "Goal:" <+> goalDoc-            , auxDoc-            , vcat boundaryDoc-            , text (replicate 60 '\x2014')-            , ctxDoc-            ] ++ constraintsDoc+      let constraintsDoc+            | null constraints = []+            | otherwise        =+              [ TCP.text $ delimiter "Constraints"+              , TCP.vcat $ map prettyTCM constraints+              ]+      doc <- TCP.vcat $+        [ "Goal:" TCP.<+> return goalDoc+        , return (vcat (boundaryDoc "Boundary (wanted)" bndry))+        , return auxDoc+        , TCP.text (replicate 60 '\x2014')+        , return ctxDoc+        ] ++ constraintsDoc       format (render doc) "*Goal type etc.*"     Goal_CurrentGoal norm -> do       doc <- prettyTypeOfMeta norm ii@@ -281,7 +293,7 @@      body = List.intercalate "\n" $ catMaybes              [ g                    <$ guard isG-             , delimiter "Errors"   <$ guard (isE && (isG || isW))+             , delimiter "Error"    <$ guard (isE && (isG || isW))              , e                    <$ guard isE              , delimiter "Warnings" <$ guard (isW && (isG || isE))              , w                    <$ guard isW@@ -291,111 +303,22 @@ -- | Serializing Info_Error showInfoError :: Info_Error -> TCM String showInfoError (Info_GenericError err) = do-  e <- prettyError err-  w <- prettyTCWarnings' =<< getAllWarningsOfTCErr err--  let errorMsg  = if null w-                      then e-                      else delimiter "Error" ++ "\n" ++ e-  let warningMsg = List.intercalate "\n" $ delimiter "Warning(s)"-                                      : filter (not . null) w-  return $ if null w-            then errorMsg-            else errorMsg ++ "\n\n" ++ warningMsg+  e <- renderError err+  w <- prettyTCWarnings =<< getAllWarningsOfTCErr err+  let (body, _) = formatWarningsAndErrors "" w e+  return body showInfoError (Info_CompilationError warnings) = do   s <- prettyTCWarnings warnings   return $ unlines-            [ "You need to fix the following errors before you can compile"-            , "the module:"-            , ""-            , s-            ]+    [ "You need to fix the following errors before you can compile the module:"+    , ""+    , s+    ] showInfoError (Info_HighlightingParseError ii) =   return $ "Highlighting failed to parse expression in " ++ show ii showInfoError (Info_HighlightingScopeCheckError ii) =   return $ "Highlighting failed to scope check expression in " ++ show ii -explainWhyInScope :: FilePath-                  -> String-                  -> (Maybe LocalVar)-                  -> [AbstractName]-                  -> [AbstractModule]-                  -> TCM Doc-explainWhyInScope s _ Nothing [] [] = TCP.text (s ++ " is not in scope.")-explainWhyInScope s _ v xs ms = TCP.vcat-  [ TCP.text (s ++ " is in scope as")-  , TCP.nest 2 $ TCP.vcat [variable v xs, modules ms]-  ]-  where-    -- variable :: Maybe _ -> [_] -> TCM Doc-    variable Nothing vs = names vs-    variable (Just x) vs-      | null vs   = asVar-      | otherwise = TCP.vcat-         [ TCP.sep [ asVar, TCP.nest 2 $ shadowing x]-         , TCP.nest 2 $ names vs-         ]-      where-        asVar :: TCM Doc-        asVar = do-          "* a variable bound at" TCP.<+> TCP.prettyTCM (nameBindingSite $ localVar x)-        shadowing :: LocalVar -> TCM Doc-        shadowing (LocalVar _ _ [])    = "shadowing"-        shadowing _ = "in conflict with"-    names   = TCP.vcat . map pName-    modules = TCP.vcat . map pMod--    pKind = \case-      ConName                  -> "constructor"-      CoConName                -> "coinductive constructor"-      FldName                  -> "record field"-      PatternSynName           -> "pattern synonym"-      GeneralizeName           -> "generalizable variable"-      DisallowedGeneralizeName -> "generalizable variable from let open"-      MacroName                -> "macro name"-      QuotableName             -> "quotable name"-      -- previously DefName:-      DataName                 -> "data type"-      RecName                  -> "record type"-      AxiomName                -> "postulate"-      PrimName                 -> "primitive function"-      FunName                  -> "defined name"-      OtherDefName             -> "defined name"--    pName :: AbstractName -> TCM Doc-    pName a = TCP.sep-      [ "* a"-        TCP.<+> pKind (anameKind a)-        TCP.<+> TCP.text (prettyShow $ anameName a)-      , TCP.nest 2 $ "brought into scope by"-      ] TCP.$$-      TCP.nest 2 (pWhy (nameBindingSite $ qnameName $ anameName a) (anameLineage a))-    pMod :: AbstractModule -> TCM Doc-    pMod  a = TCP.sep-      [ "* a module" TCP.<+> TCP.text (prettyShow $ amodName a)-      , TCP.nest 2 $ "brought into scope by"-      ] TCP.$$-      TCP.nest 2 (pWhy (nameBindingSite $ qnameName $ mnameToQName $ amodName a) (amodLineage a))--    pWhy :: Range -> WhyInScope -> TCM Doc-    pWhy r Defined = "- its definition at" TCP.<+> TCP.prettyTCM r-    pWhy r (Opened (C.QName x) w) | isNoName x = pWhy r w-    pWhy r (Opened m w) =-      "- the opening of"-      TCP.<+> TCP.prettyTCM m-      TCP.<+> "at"-      TCP.<+> TCP.prettyTCM (getRange m)-      TCP.$$-      pWhy r w-    pWhy r (Applied m w) =-      "- the application of"-      TCP.<+> TCP.prettyTCM m-      TCP.<+> "at"-      TCP.<+> TCP.prettyTCM (getRange m)-      TCP.$$-      pWhy r w-- -- | Pretty-prints the context of the given meta-variable.  prettyResponseContext@@ -404,7 +327,7 @@   -> [ResponseContextEntry]   -> TCM Doc prettyResponseContext ii rev ctx = withInteractionId ii $ do-  mod   <- asksTC getModality+  mod <- currentModality   align 10 . concat . applyWhen rev reverse <$> do     forM ctx $ \ (ResponseContextEntry n x (Arg ai expr) letv nis) -> do       let@@ -420,14 +343,20 @@         attribute = c ++ if null c then "" else " "           where c = prettyShow (getCohesion ai) +        pol :: ModalPolarity+        pol = modPolarityAnn $ getModalPolarity ai+         extras :: [Doc]         extras = concat $           [ [ "not in scope" | isInScope nis == C.NotInScope ]-            -- Print erased if hypothesis is erased by goal is non-erased.+            -- Print "erased" if hypothesis is erased but goal is non-erased.           , [ "erased"       | not $ getQuantity  ai `moreQuantity` getQuantity  mod ]-            -- Print irrelevant if hypothesis is strictly less relevant than goal.-          , [ "irrelevant"   | not $ getRelevance ai `moreRelevant` getRelevance mod ]-            -- Print instance if variable is considered by instance search+            -- Print relevance of hypothesis relative to relevance of the goal. (Issue #6706.)+          , [ text $ verbalize r+                             | let r = getRelevance mod `inverseComposeRelevance` getRelevance ai+                             , not $ isRelevant r ]+          , [ text $ verbalize pol | not $ pol == MixedPolarity ]+            -- Print "instance" if variable is considered by instance search.           , [ "instance"     | isInstance ai ]           ]       ty <- prettyATop expr
src/full/Agda/Interaction/ExitCode.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Interaction.ExitCode (   AgdaError(..),@@ -12,6 +13,7 @@ data AgdaError = UnknownError      -- ^ 1                | TCMError          -- ^ 42                | OptionError       -- ^ 71+               | CommandError      -- ^ 113                | ImpossibleError   -- ^ 154                deriving (Show, Eq, Enum, Bounded) @@ -19,6 +21,7 @@ agdaErrorToInt UnknownError    = 1 agdaErrorToInt TCMError        = 42 agdaErrorToInt OptionError     = 71+agdaErrorToInt CommandError    = 113 agdaErrorToInt ImpossibleError = 154  -- ^ Return the error corresponding to an exit code from the@@ -30,5 +33,5 @@                                | error  <- [minBound..maxBound]                                ] -exitAgdaWith :: AgdaError -> IO ()+exitAgdaWith :: AgdaError -> IO a exitAgdaWith = exitWith . ExitFailure . agdaErrorToInt
src/full/Agda/Interaction/FindFile.hs view
@@ -10,21 +10,23 @@   ( SourceFile(..), InterfaceFile(intFilePath)   , toIFile, mkInterfaceFile   , FindError(..), findErrorToTypeError-  , findFile, findFile', findFile''+  , findFile, findFile', findFile'_, findFile''   , findInterfaceFile', findInterfaceFile   , checkModuleName-  , moduleName   , rootNameModule   , replaceModuleExtension+  , dropAgdaExtension, hasAgdaExtension, stripAgdaExtension   ) where  import Prelude hiding (null)  import Control.Monad import Control.Monad.Except+import Control.Monad.State import Control.Monad.Trans-import Data.Maybe (catMaybes)+import Data.Maybe (catMaybes, fromMaybe, isJust) import qualified Data.Map as Map+import qualified Data.Text as T import System.FilePath  import Agda.Interaction.Library ( findProjectRoot )@@ -33,40 +35,43 @@ import Agda.Syntax.Parser import Agda.Syntax.Parser.Literate (literateExtsShortList) import Agda.Syntax.Position--import Agda.Interaction.Options ( optLocalInterfaces )+import Agda.Syntax.TopLevelModuleName  import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Benchmark (billTo) import qualified Agda.TypeChecking.Monad.Benchmark as Bench import {-# SOURCE #-} Agda.TypeChecking.Monad.Options   (getIncludeDirs, libToTCM)-import Agda.TypeChecking.Warnings (runPM)+import Agda.TypeChecking.Monad.State ( registerFileIdWithBuiltin, topLevelModuleName )+import Agda.TypeChecking.Monad.Trace (runPM, setCurrentRange)  import Agda.Version ( version )  import Agda.Utils.Applicative ( (?$>) )+import Agda.Utils.CallStack   ( HasCallStack )+import Agda.Utils.FileId import Agda.Utils.FileName import Agda.Utils.List  ( stripSuffix, nubOn ) import Agda.Utils.List1 ( List1, pattern (:|) )+import Agda.Utils.List2 ( List2, pattern List2 ) import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.List2 as List2 import Agda.Utils.Monad ( ifM, unlessM )-import Agda.Utils.Pretty ( Pretty(..), prettyShow )+import Agda.Syntax.Common.Pretty ( Pretty(..), prettyShow )+import qualified Agda.Syntax.Common.Pretty as P import Agda.Utils.Singleton  import Agda.Utils.Impossible --- | Type aliases for source files and interface files.---   We may only produce one of these if we know for sure that the file---   does exist. We can always output an @AbsolutePath@ if we are not sure.+-- This instance isn't producing something pretty.+-- instance Pretty SourceFile where+--   pretty = pretty . srcFileId --- TODO: do not export @SourceFile@ and force users to check the--- @AbsolutePath@ does exist.-newtype SourceFile    = SourceFile    { srcFilePath :: AbsolutePath } deriving (Eq, Ord)+-- | File must exist. newtype InterfaceFile = InterfaceFile { intFilePath :: AbsolutePath } -instance Pretty SourceFile    where pretty = pretty . srcFilePath-instance Pretty InterfaceFile where pretty = pretty . intFilePath+instance Pretty InterfaceFile where+  pretty = pretty . intFilePath  -- | Makes an interface file from an AbsolutePath candidate. --   If the file does not exist, then fail by returning @Nothing@.@@ -81,18 +86,19 @@ -- | Converts an Agda file name to the corresponding interface file --   name. Note that we do not guarantee that the file exists. -toIFile :: SourceFile -> TCM AbsolutePath-toIFile (SourceFile src) = do+toIFile :: HasCallStack => SourceFile -> TCM AbsolutePath+toIFile (SourceFile fi) = do+  src <- fileFromId fi -- partial function, thus HasCallStack   let fp = filePath src-  mroot <- ifM (optLocalInterfaces <$> commandLineOptions)-               {- then -} (pure Nothing)-               {- else -} (libToTCM $ findProjectRoot (takeDirectory fp))-  pure $ replaceModuleExtension ".agdai" $ case mroot of-    Nothing   -> src-    Just root ->+  let localIFile = replaceModuleExtension ".agdai" src+  mroot <- libToTCM $ findProjectRoot (takeDirectory fp)+  case mroot of+    Nothing   -> pure localIFile+    Just root -> do       let buildDir = root </> "_build" </> version </> "agda"-          fileName = makeRelative root fp-      in mkAbsolute $ buildDir </> fileName+      fileName <- liftIO $ makeRelativeCanonical root (filePath localIFile)+      let separatedIFile = mkAbsolute $ buildDir </> fileName+      pure separatedIFile  replaceModuleExtension :: String -> AbsolutePath -> AbsolutePath replaceModuleExtension ext@('.':_) = mkAbsolute . (++ ext) .  dropAgdaExtension . filePath@@ -103,23 +109,26 @@ -- Invariant: All paths are absolute.  data FindError-  = NotFound [SourceFile]-    -- ^ The file was not found. It should have had one of the given-    -- file names.-  | Ambiguous [SourceFile]-    -- ^ Several matching files were found.-    ---    -- Invariant: The list of matching files has at least two-    -- elements.+  = NotFound [AbsolutePath]+      -- ^ The file was not found.+      --   It should have had one of the given file names.+  | Ambiguous (List2 AbsolutePath)+      -- ^ Several matching files were found.+  deriving Show  -- | Given the module name which the error applies to this function -- converts a 'FindError' to a 'TypeError'.  findErrorToTypeError :: TopLevelModuleName -> FindError -> TypeError-findErrorToTypeError m (NotFound  files) = FileNotFound m (map srcFilePath files)-findErrorToTypeError m (Ambiguous files) =-  AmbiguousTopLevelModuleName m (map srcFilePath files)+findErrorToTypeError m = \case+  NotFound  files -> FileNotFound m files+  Ambiguous files -> AmbiguousTopLevelModuleName m files +-- findErrorToTypeError :: MonadFileId m => TopLevelModuleName -> FindError -> m TypeError+-- findErrorToTypeError m = \case+--   NotFound  files -> FileNotFound m <$> mapM srcFilePath files+--   Ambiguous files -> AmbiguousTopLevelModuleName m <$> mapM srcFilePath files+ -- | Finds the source file corresponding to a given top-level module -- name. The returned paths are absolute. --@@ -138,50 +147,70 @@ --   SIDE EFFECT:  Updates 'stModuleToSource'. findFile' :: TopLevelModuleName -> TCM (Either FindError SourceFile) findFile' m = do-    dirs         <- getIncludeDirs-    modFile      <- useTC stModuleToSource-    (r, modFile) <- liftIO $ findFile'' dirs m modFile-    stModuleToSource `setTCLens` modFile+    dirs     <- getIncludeDirs+    modToSrc <- useTC stModuleToSource+    (r, modToSrc) <- liftIO $ runStateT (findFile'' dirs m) modToSrc+    stModuleToSource `setTCLens` modToSrc     return r +-- | A variant of 'findFile'' which manipulates an extra 'ModuleToSourceId'++findFile'_ ::+     List1 AbsolutePath+       -- ^ Include paths.+  -> TopLevelModuleName+  -> StateT ModuleToSourceId TCM (Either FindError SourceFile)+findFile'_ incs m = do+  dict <- useTC stFileDict+  m2s  <- get+  (r, ModuleToSource dict' m2s') <- liftIO $+    runStateT (findFile'' incs m) $ ModuleToSource dict m2s+  setTCLens stFileDict dict'+  put m2s'+  return r+ -- | A variant of 'findFile'' which does not require 'TCM'. -findFile''-  :: [AbsolutePath]-  -- ^ Include paths.+findFile'' ::+     List1 AbsolutePath+       -- ^ Include paths.   -> TopLevelModuleName-  -> ModuleToSource-  -- ^ Cached invocations of 'findFile'''. An updated copy is returned.-  -> IO (Either FindError SourceFile, ModuleToSource)-findFile'' dirs m modFile =-  case Map.lookup m modFile of-    Just f  -> return (Right (SourceFile f), modFile)+  -> StateT ModuleToSource IO (Either FindError SourceFile)+findFile'' dirs m = do+  ModuleToSource dict modToSrc <- get+  case Map.lookup m modToSrc of+    Just sf -> return $ Right sf     Nothing -> do-      files          <- fileList acceptableFileExts-      filesShortList <- fileList parseFileExtsShortList-      existingFiles  <--        liftIO $ filterM (doesFileExistCaseSensitive . filePath . srcFilePath) files-      return $ case nubOn id existingFiles of-        []     -> (Left (NotFound filesShortList), modFile)-        [file] -> (Right file, Map.insert m (srcFilePath file) modFile)-        files  -> (Left (Ambiguous existingFiles), modFile)+      files          <- liftIO $ fileList agdaFileExtensions+      existingFiles  <- liftIO $ filterM (doesFileExistCaseSensitive . filePath) files+      case nubOn id existingFiles of+        [file]   -> do+          let (i, dict') = registerFileIdWithBuiltin file dict+          let src = SourceFile i+          put $ ModuleToSource dict' $ Map.insert m src modToSrc+          return (Right src)+        []       -> do+          filesShortList <- liftIO $ fileList $ List2.toList parseFileExtsShortList+          return (Left (NotFound filesShortList))+        f0:f1:fs -> return (Left (Ambiguous $ List2 f0 f1 fs))   where-    fileList exts = mapM (fmap SourceFile . absolute)+    fileList exts = mapM absolute                     [ filePath dir </> file-                    | dir  <- dirs+                    | dir  <- List1.toList dirs                     , file <- map (moduleNameToFileName m) exts                     ]  -- | Finds the interface file corresponding to a given top-level -- module file. The returned paths are absolute. ----- Raises 'Nothing' if the the interface file cannot be found.+-- Raises 'Nothing' if the interface file cannot be found. -findInterfaceFile'-  :: SourceFile                 -- ^ Path to the source file+findInterfaceFile' :: HasCallStack  -- We are calling partial function toIFile, thus want a call stack.+  => SourceFile                 -- ^ Path to the source file   -> TCM (Maybe InterfaceFile)  -- ^ Maybe path to the interface file findInterfaceFile' fp = liftIO . mkInterfaceFile =<< toIFile fp + -- | Finds the interface file corresponding to a given top-level -- module file. The returned paths are absolute. --@@ -189,35 +218,37 @@ -- 'Nothing' if the source file can be found but not the interface -- file. -findInterfaceFile :: TopLevelModuleName -> TCM (Maybe InterfaceFile)+findInterfaceFile :: HasCallStack  -- because of calling a partial function+  => TopLevelModuleName -> TCM (Maybe InterfaceFile) findInterfaceFile m = findInterfaceFile' =<< findFile m  -- | Ensures that the module name matches the file name. The file -- corresponding to the module name (according to the include path) -- has to be the same as the given file name. -checkModuleName-  :: TopLevelModuleName-     -- ^ The name of the module.+checkModuleName ::+     TopLevelModuleName+       -- ^ The name of the module.   -> SourceFile-     -- ^ The file from which it was loaded.+       -- ^ The file from which it was loaded.   -> Maybe TopLevelModuleName-     -- ^ The expected name, coming from an import statement.+       -- ^ The expected name, coming from an import statement.   -> TCM ()-checkModuleName name (SourceFile file) mexpected = do+checkModuleName name src0 mexpected = do+  file <- srcFilePath src0   findFile' name >>= \case      Left (NotFound files)  -> typeError $       case mexpected of-        Nothing -> ModuleNameDoesntMatchFileName name (map srcFilePath files)+        Nothing -> ModuleNameDoesntMatchFileName name files         Just expected -> ModuleNameUnexpected name expected      Left (Ambiguous files) -> typeError $-      AmbiguousTopLevelModuleName name (map srcFilePath files)+      AmbiguousTopLevelModuleName name files      Right src -> do-      let file' = srcFilePath src-      file <- liftIO $ absolute (filePath file)+      file' <- srcFilePath src+      file  <- liftIO $ absolute $ filePath file       unlessM (liftIO $ sameFile file file') $         typeError $ ModuleDefinedInOtherFile name file file' @@ -225,7 +256,7 @@   -- that we do not end up with a mismatch between expected   -- and actual module name. -  forM_ mexpected $ \ expected ->+  forM_ mexpected \ expected ->     unless (name == expected) $       typeError $ OverlappingProjects file name expected       -- OverlappingProjects is the correct error for@@ -233,49 +264,21 @@       -- -- typeError $ ModuleNameUnexpected name expected  --- | Computes the module name of the top-level module in the given--- file.------ If no top-level module name is given, then an attempt is made to--- use the file name as a module name.+parseFileExtsShortList :: List2 String+parseFileExtsShortList = List2.cons ".agda" literateExtsShortList --- TODO: Perhaps it makes sense to move this procedure to some other--- module.+-- | Remove an Agda file extension from a filepath, if possible.+stripAgdaExtension :: FilePath -> Maybe FilePath+stripAgdaExtension = stripAnyOfExtensions agdaFileExtensions -moduleName-  :: AbsolutePath-     -- ^ The path to the file.-  -> Module-     -- ^ The parsed module.-  -> TCM TopLevelModuleName-moduleName file parsedModule = billTo [Bench.ModuleName] $-  case moduleNameParts name of-    "_" :| [] -> do-      m <- runPM (parse moduleNameParser defaultName)-             `catchError` \_ ->-           typeError $ GenericError $-             "The file name " ++ prettyShow file ++-             " is invalid because it does not correspond to a valid module name."-      case m of-        Qual {} ->-          typeError $ GenericError $-            "The file name " ++ prettyShow file ++ " is invalid because " ++-            defaultName ++ " is not an unqualified module name."-        QName {} ->-          return $ TopLevelModuleName (getRange m) $ singleton defaultName-    _ -> return name-  where-  name        = topLevelModuleName parsedModule-  defaultName = rootNameModule file+-- | Check if a file path has an Agda extension.+hasAgdaExtension :: FilePath -> Bool+hasAgdaExtension = isJust . stripAgdaExtension -parseFileExtsShortList :: [String]-parseFileExtsShortList = ".agda" : literateExtsShortList+-- | Remove an existing Agda file extension from a file path.+dropAgdaExtension :: FilePath -> FilePath+dropAgdaExtension = fromMaybe __IMPOSSIBLE__ . stripAgdaExtension -dropAgdaExtension :: String -> String-dropAgdaExtension s = case catMaybes [ stripSuffix ext s-                                     | ext <- acceptableFileExts ] of-    [name] -> name-    _      -> __IMPOSSIBLE__  rootNameModule :: AbsolutePath -> String rootNameModule = dropAgdaExtension . snd . splitFileName . filePath
src/full/Agda/Interaction/Highlighting/Common.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Common syntax highlighting functions for Emacs and JSON  module Agda.Interaction.Highlighting.Common
src/full/Agda/Interaction/Highlighting/Dot.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Interaction.Highlighting.Dot   ( dotBackend   ) where
src/full/Agda/Interaction/Highlighting/Dot/Backend.hs view
@@ -1,14 +1,13 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Interaction.Highlighting.Dot.Backend   ( dotBackend   ) where -import Agda.Interaction.Highlighting.Dot.Base-  ( dottify-  , renderDotToFile-  , Env(Env, deConnections, deLabel)-  )+import Prelude hiding (null) +import Agda.Interaction.Highlighting.Dot.Base (renderDotToFile)+ import Control.Monad.Except   ( ExceptT   , runExceptT@@ -19,8 +18,10 @@   ) import Control.DeepSeq -import Data.Map ( Map )-import Data.Set ( Set )+import Data.HashSet (HashSet)+import Data.Map (Map)+import Data.Set (Set)+import qualified Data.HashSet as HashSet import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe@@ -28,30 +29,43 @@  import GHC.Generics (Generic) -import Agda.Compiler.Backend (Backend(..), Backend'(..), Definition, Recompile(..))+import Agda.Compiler.Backend (Backend,Backend_boot(..), Backend',Backend'_boot(..), Definition, Recompile(..)) import Agda.Compiler.Common (curIF, IsMain) +import Agda.Interaction.FindFile (findFile)+import Agda.Interaction.Library import Agda.Interaction.Options   ( ArgDescr(ReqArg)   , Flag   , OptDescr(..)   ) -import Agda.Syntax.Abstract ( ModuleName )+import Agda.Syntax.Common.Pretty ( prettyShow )+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName)  import Agda.TypeChecking.Monad-  ( Interface(iImportedModules, iModuleName)+  ( Interface(iImportedModules)   , MonadTCError   , ReadTCState-  , genericError+  , MonadTCM(..)+  , internalError+  , reportSDoc+  , getAgdaLibFiles+  , srcFilePath   )+import Agda.TypeChecking.Pretty -import Agda.Utils.Pretty ( prettyShow )+import Agda.Utils.Graph.AdjacencyMap.Unidirectional+  (Graph, WithUniqueInt)+import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph+import Agda.Utils.Null  -- ------------------------------------------------------------------------  data DotFlags = DotFlags   { dotFlagDestination :: Maybe FilePath+  , dotFlagLibraries   :: HashSet LibName+    -- ^ Only include modules from the given libraries.   } deriving (Eq, Generic)  instance NFData DotFlags@@ -59,27 +73,41 @@ defaultDotFlags :: DotFlags defaultDotFlags = DotFlags   { dotFlagDestination = Nothing+  , dotFlagLibraries   = empty   }  dotFlagsDescriptions :: [OptDescr (Flag DotFlags)] dotFlagsDescriptions =   [ Option [] ["dependency-graph"] (ReqArg dependencyGraphFlag "FILE")               "generate a Dot file with a module dependency graph"+  , Option [] ["dependency-graph-include"]+      (ReqArg includeFlag "LIBRARY")+      "include modules from the given library (default: all modules)"   ]  dependencyGraphFlag :: FilePath -> Flag DotFlags dependencyGraphFlag f o = return $ o { dotFlagDestination = Just f } +includeFlag :: String -> Flag DotFlags+includeFlag s o = return $+  o { dotFlagLibraries = HashSet.insert (parseLibName s) $ dotFlagLibraries o+    }+ data DotCompileEnv = DotCompileEnv-  { _dotCompileEnvDestination :: FilePath+  { dotCompileEnvDestination :: FilePath+  , dotCompileEnvLibraries   :: HashSet LibName+      -- ^ Only include modules from the given libraries.+      --   If the set is empty, include all libraries.   }  -- Currently unused data DotModuleEnv = DotModuleEnv  data DotModule = DotModule-  { _dotModuleName :: ModuleName-  , dotModuleImportedNames :: Set ModuleName+  { dotModuleName          :: TopLevelModuleName+  , dotModuleImportedNames :: Set TopLevelModuleName+  , dotModuleInclude       :: Bool+    -- ^ Include the module in the graph?   }  -- | Currently unused@@ -95,31 +123,39 @@   , options               = defaultDotFlags   , commandLineFlags      = dotFlagsDescriptions   , isEnabled             = isJust . dotFlagDestination-  , preCompile            = asTCErrors . preCompileDot+  , preCompile            = asInternalErrors . preCompileDot   , preModule             = preModuleDot   , compileDef            = compileDefDot   , postModule            = postModuleDot   , postCompile           = postCompileDot   , scopeCheckingSuffices = True   , mayEraseType          = const $ return True+  , backendInteractTop    = Nothing+  , backendInteractHole   = Nothing   }  -- | Convert a general "MonadError String m" into "MonadTCError m".-asTCErrors :: MonadTCError m => ExceptT String m b -> m b-asTCErrors t = either genericError return =<< runExceptT t+asInternalErrors :: (MonadTCError m) => ExceptT String m b -> m b+asInternalErrors t = either internalError return =<< runExceptT t  preCompileDot   :: MonadError String m   => DotFlags   -> m DotCompileEnv-preCompileDot (DotFlags (Just dest)) = return $ DotCompileEnv dest-preCompileDot (DotFlags Nothing)     = throwError "The Dot backend was invoked without being enabled!"+preCompileDot d = case dotFlagDestination d of+  Just dest -> return $ DotCompileEnv+    { dotCompileEnvDestination = dest+    , dotCompileEnvLibraries   = dotFlagLibraries d+    }+  Nothing ->+    throwError "The Dot backend was invoked without being enabled!"+      -- Andreas, 2024-08-03: I suppose this counts as internal error.  preModuleDot   :: Applicative m   => DotCompileEnv   -> IsMain-  -> ModuleName+  -> TopLevelModuleName   -> Maybe FilePath   -> m (Recompile DotModuleEnv DotModule) preModuleDot _cenv _main _moduleName _ifacePath = pure $ Recompile DotModuleEnv@@ -134,28 +170,85 @@ compileDefDot _cenv _menv _main _def = pure DotDef  postModuleDot-  :: (MonadIO m, ReadTCState m)+  :: (MonadTCM m, ReadTCState m)   => DotCompileEnv   -> DotModuleEnv   -> IsMain-  -> ModuleName+  -> TopLevelModuleName   -> [DotDef]   -> m DotModule-postModuleDot _cenv DotModuleEnv _main moduleName _defs = do+postModuleDot cenv DotModuleEnv _main m _defs = do   i <- curIF   let importedModuleNames = Set.fromList $ fst <$> (iImportedModules i)-  return $ DotModule moduleName importedModuleNames+  let ls = dotCompileEnvLibraries cenv+  include <- case null ls of+    True  -> return True+    False -> liftTCM do+      sf   <- findFile m+      f    <- srcFilePath sf+      libs <- getAgdaLibFiles f m +      let incLibs = filter (\l -> _libName l `HashSet.member` ls) libs+          inLib   = not (null incLibs)++      reportSDoc "dot.include" 10 $ do+        let name = pretty m+            list = nest 2 . vcat . map (pretty . _libName)+        if inLib then+          fsep+            ([ "Including"+             , name+             ] +++             pwords "because it is in the following libraries:") $$+          list incLibs+        else+          fsep+            (pwords "Not including" +++             [name <> ","] +++             pwords "which is in the following libraries:") $$+          list libs++      return inLib++  return $ DotModule+    { dotModuleName          = m+    , dotModuleImportedNames = importedModuleNames+    , dotModuleInclude       = include+    }+ postCompileDot   :: (MonadIO m, ReadTCState m)   => DotCompileEnv   -> IsMain-  -> Map ModuleName DotModule+  -> Map TopLevelModuleName DotModule   -> m ()-postCompileDot (DotCompileEnv fp) _main modulesByName = do-  let env = Env-        { deConnections = (maybe [] (Set.toList . dotModuleImportedNames) . (flip Map.lookup modulesByName))-        , deLabel       = L.pack . prettyShow-        }-  dot <- dottify env . iModuleName <$> curIF-  renderDotToFile dot fp+postCompileDot cenv _main modulesByName =+  renderDotToFile moduleGraph (dotCompileEnvDestination cenv)+  where+  -- Only the keys of this map are used.+  modulesToInclude =+    Map.filter dotModuleInclude modulesByName++  moduleGraph :: Graph (WithUniqueInt L.Text) ()+  moduleGraph =+    Graph.renameNodesMonotonic (fmap (L.pack . prettyShow)) $+    Graph.transitiveReduction $+    Graph.filterNodesKeepingEdges+      (\n -> Graph.otherValue n `Map.member` modulesToInclude) $+    -- The following use of transitive reduction should not affect the+    -- semantics. It tends to make the graph smaller, so it might+    -- improve the overall performance of the code, but I did not+    -- verify this.+    Graph.transitiveReduction $+    Graph.addUniqueInts $+    Graph.fromEdges $+    concatMap+       (\ (name, m) ->+          [ Graph.Edge+              { source = name+              , target = target+              , label  = ()+              }+          | target <- Set.toList $ dotModuleImportedNames m+          ]) $+    Map.toList modulesByName
src/full/Agda/Interaction/Highlighting/Dot/Base.hs view
@@ -1,130 +1,44 @@-{-# LANGUAGE GADTs #-} -- | Generate an import dependency graph for a given module.  module Agda.Interaction.Highlighting.Dot.Base-  ( dottify-  , renderDotToFile+  ( renderDotToFile   , renderDot-  , DotGraph (..)-  , Env(..)+  , DotGraph   ) where -import Control.Monad          (liftM2, when)-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Reader   (ReaderT, runReaderT, ask)-import Control.Monad.State    (State, execState, get, modify, put)--import qualified Data.Map as M-import Data.Map(Map)+import Control.Monad.IO.Class  import qualified Data.Set as S-import Data.Set (Set)  import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Encoding as E import qualified Data.ByteString.Lazy as BS --- | Internal module identifiers for construction of dependency graph.-type NodeId = L.Text+import Agda.Utils.Graph.AdjacencyMap.Unidirectional+  (Graph, WithUniqueInt)+import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph  -- | Graph structure-data DotGraph = DotGraph-  { dgNodeLabels :: Map NodeId L.Text-  , dgEdges      :: Set (NodeId, NodeId)-  }---- * Graph construction monad---- Read-only environment when constructing the graph.-data Env n where-  Env :: Ord n =>-    { deConnections :: n -> [n]-    -- ^ Names connected to an entity-    , deLabel       :: n -> L.Text-    -- ^ Rendering that entity's name to a label-    } -> Env n--data DotState n = DotState-  { dsNodeIds      :: Map n NodeId-    -- ^ Records already processed entities-    --   and maps them to an internal identifier.-  , dsNodeIdSupply :: [NodeId]-    -- ^ Supply of internal identifiers.-  , dsGraph        :: DotGraph-  }--initialDotState :: DotState n-initialDotState = DotState-  { dsNodeIds      = M.empty-  , dsNodeIdSupply = map (L.pack . ('m':) . show) [0..]-  , dsGraph        = DotGraph mempty mempty-  }--type DotM n a = ReaderT (Env n) (State (DotState n)) a--runDotM :: Env n -> DotM n x -> DotGraph-runDotM env@Env{} = dsGraph . flip execState initialDotState . flip runReaderT env--getLabel :: n -> DotM n L.Text-getLabel = liftM2 deLabel ask . pure--getConnections :: n -> DotM n [n]-getConnections = liftM2 deConnections ask . pure---- | Translate an entity name into an internal 'NodeId'.---   Returns @True@ if the 'ModuleName' is new, i.e., has not been---   encountered before and is thus added to the map of processed modules.-addEntity :: Ord n => n -> DotM n (NodeId, Bool)-addEntity name = do-    s@(DotState nodeIds nodeIdSupply graph) <- get-    case M.lookup name nodeIds of-        Just nodeId  -> return (nodeId, False)-        Nothing -> do-            let newNodeId:remainingNodeIdSupply = nodeIdSupply-            label <- getLabel name-            put s-              { dsNodeIds      = M.insert name newNodeId nodeIds-              , dsNodeIdSupply = remainingNodeIdSupply-              , dsGraph        = graph-                { dgNodeLabels = M.insert newNodeId label . dgNodeLabels $ graph-                }-              }-            return (newNodeId, True)---- | Add an arc from importer to imported.-addConnection :: NodeId -> NodeId -> DotM n ()-addConnection m1 m2 = modify $ \s -> s-  { dsGraph = (dsGraph s)-    { dgEdges = S.insert (m1, m2) . dgEdges . dsGraph $ s-    }-  }--dottify :: Ord n => Env n -> n -> DotGraph-dottify env root = runDotM env (dottify' root)--dottify' :: Ord n => n -> DotM n NodeId-dottify' entity = do-  (nodeId, continue) <- addEntity entity-  -- If we have not visited this interface yet,-  -- process its imports recursively and-  -- add them as connections to the graph.-  when continue $ do-    connectedEntities <- getConnections entity-    connectedNodeIds <- mapM dottify' connectedEntities-    mapM_ (addConnection nodeId) connectedNodeIds-  return nodeId+type DotGraph = Graph (WithUniqueInt L.Text) ()  -- * Graph rendering  renderDot :: DotGraph -> L.Text renderDot g = L.unlines $ concat   [ [ "digraph dependencies {" ]-  , [ L.concat ["   ", nodeId, "[label=\"", label, "\"];"]-    | (nodeId, label) <- M.toList (dgNodeLabels g) ]-  , [ L.concat ["   ", r1, " -> ", r2, ";"]-    | (r1 , r2) <- S.toList (dgEdges g) ]+  , [ L.concat ["   ", show' nodeId, "[label=\"", label, "\"];"]+    | Graph.WithUniqueInt nodeId label <- S.toList $ Graph.nodes g+    ]+  , [ L.concat ["   ", show' r1, " -> ", show' r2, ";"]+    | Graph.Edge+        { source = Graph.WithUniqueInt r1 _+        , target = Graph.WithUniqueInt r2 _+        } <- Graph.edges g+    ]   , ["}"]   ]+  where+  show' = L.pack . ("m" ++) . show  renderDotToFile :: MonadIO m => DotGraph -> FilePath -> m () renderDotToFile dot fp = liftIO $ BS.writeFile fp $ E.encodeUtf8 $ renderDot dot
src/full/Agda/Interaction/Highlighting/Emacs.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Functions which give precise syntax highlighting info to Emacs. @@ -8,24 +9,26 @@  import Prelude hiding (null) +import qualified Data.List as List+import Data.Maybe++import Agda.Syntax.Common.Pretty (prettyShow)+ import Agda.Interaction.Highlighting.Common import Agda.Interaction.Highlighting.Precise import Agda.Interaction.Highlighting.Range (Range(..)) import Agda.Interaction.EmacsCommand import Agda.Interaction.Response-import Agda.TypeChecking.Monad (HighlightingMethod(..), ModuleToSource)-import Agda.Utils.FileName (filePath)-import Agda.Utils.IO.TempFile (writeToTempFile)-import Agda.Utils.Pretty (prettyShow)-import Agda.Utils.String (quote) -import qualified Data.List as List-import qualified Data.Map as Map-import Data.Maybe+import Agda.TypeChecking.Monad (HighlightingMethod(..), ModuleToSource, topLevelModuleFilePath) +import Agda.Utils.CallStack    (HasCallStack)+import Agda.Utils.FileName     (AbsolutePath, filePath)+import Agda.Utils.IO.TempFile  (writeToTempFile) import Agda.Utils.Null-import Agda.Utils.Impossible+import Agda.Utils.String       (quote) + ------------------------------------------------------------------------ -- Read/show functions @@ -50,7 +53,9 @@   where   defSite (DefinitionSite m p _ _) =     Cons (A $ quote $ filePath f) (A $ show p)-    where f = Map.findWithDefault __IMPOSSIBLE__ m modFile+    where+      f :: HasCallStack => AbsolutePath+      f = topLevelModuleFilePath modFile m  -- partial function, so use CallStack!    dropNils = List.dropWhileEnd (== A "nil")
src/full/Agda/Interaction/Highlighting/FromAbstract.hs view
@@ -13,7 +13,6 @@ import Prelude hiding (null)  import Control.Applicative-import Control.Monad         ( (<=<) ) import Control.Monad.Reader  ( MonadReader(..), asks, Reader, runReader )  import qualified Data.Map      as Map@@ -28,18 +27,18 @@ import           Agda.Syntax.Abstract                ( IsProjP(..) ) import qualified Agda.Syntax.Abstract      as A import           Agda.Syntax.Common        as Common-import           Agda.Syntax.Concrete                ( FieldAssignment'(..) )+import           Agda.Syntax.Concrete                ( FieldAssignment'(..), TacticAttribute' ) import qualified Agda.Syntax.Concrete.Name as C import           Agda.Syntax.Info                    ( ModuleInfo(..) ) import           Agda.Syntax.Literal import qualified Agda.Syntax.Position      as P import           Agda.Syntax.Position                ( Range, HasRange, getRange, noRange ) import           Agda.Syntax.Scope.Base              ( AbstractName(..), ResolvedName(..), exactConName )+import           Agda.Syntax.TopLevelModuleName  import Agda.TypeChecking.Monad   hiding (ModuleInfo, MetaInfo, Primitive, Constructor, Record, Function, Datatype) -import           Agda.Utils.FileName import           Agda.Utils.Function import           Agda.Utils.Functor import           Agda.Utils.List                     ( initLast1 )@@ -47,31 +46,31 @@ import qualified Agda.Utils.List1          as List1 import           Agda.Utils.Maybe import qualified Agda.Utils.Maybe.Strict   as Strict-import           Agda.Utils.Pretty+import           Agda.Syntax.Common.Pretty import           Agda.Utils.Singleton+import           Agda.Utils.Size  -- Entry point: -- | Create highlighting info for some piece of syntax.-runHighlighter ::-  Hilite a =>-  SourceToModule -> AbsolutePath -> NameKinds -> a ->-  HighlightingInfoBuilder-runHighlighter modMap fileName kinds x =+runHighlighter+  :: Hilite a+  => TopLevelModuleName+     -- ^ The current top-level module's name.+  -> NameKinds -> a -> HighlightingInfoBuilder+runHighlighter top kinds x =   runReader (hilite x) $   HiliteEnv-    { hleNameKinds = kinds-    , hleModMap    = modMap-    , hleFileName  = fileName+    { hleNameKinds         = kinds+    , hleCurrentModuleName = top     }  -- | Environment of the highlighter. data HiliteEnv = HiliteEnv   { hleNameKinds :: NameKinds       -- ^ Function mapping qualified names to their kind.-  , hleModMap    :: SourceToModule-      -- ^ Maps source file paths to module names.-  , hleFileName  :: AbsolutePath-      -- ^ The file name of the current module. Used for consistency checking.+  , hleCurrentModuleName :: TopLevelModuleName+      -- ^ The current top-level module's name. Used for consistency+      -- checking.   }  -- | A function mapping names to the kind of name they stand for.@@ -102,6 +101,8 @@ instance Hilite a => Hilite [a] instance Hilite a => Hilite (List1 a) instance Hilite a => Hilite (Maybe a)+instance Hilite a => Hilite (Ranged a)+instance Hilite a => Hilite (TacticAttribute' a) instance Hilite a => Hilite (WithHiding a)  instance Hilite Void where@@ -159,7 +160,6 @@ -- | A.LetBinding -- --------------------------------------------------------------------- -- | getLet                | A.LetBind                   | bound--- | getLet                | A.LetDeclaredVariable       | bound -- --------------------------------------------------------------------- -- | A.LamBinding -- ---------------------------------------------------------------------@@ -195,6 +195,11 @@ instance Hilite A.RecordDirectives where   hilite (RecordDirectives _ _ _ c) = hilite c +instance Hilite A.RecordConName where+  hilite = \case+    A.NamedRecCon x -> hilite x+    A.FreshRecCon{} -> mempty+ instance Hilite A.Declaration where   hilite = \case       A.Axiom _ax _di ai _occ x e            -> hl ai <> hl x <> hl e@@ -202,36 +207,42 @@       A.Field _di x e                        -> hlField x <> hl e       A.Primitive _di x e                    -> hl x <> hl e       A.Mutual _mi ds                        -> hl ds-      A.Section _r x tel ds                  -> hl x <> hl tel <> hl ds-      A.Apply mi x a _ci dir                 -> hl mi <> hl x <> hl a <> hl dir+      A.Section _r er x tel ds               -> hl er <> hl x <> hl tel <> hl ds+      A.Apply mi er x a _ci dir              -> hl mi <> hl er <> hl x <>+                                                hl a <> hl dir       A.Import mi x dir                      -> hl mi <> hl x <> hl dir       A.Open mi x dir                        -> hl mi <> hl x <> hl dir-      A.FunDef _di x _delayed cs             -> hl x <> hl cs-      A.DataSig _di x tel e                  -> hl x <> hl tel <> hl e+      A.FunDef _di x cs                      -> hl x <> hl cs+      A.DataSig _di er x tel e               -> hl er <> hl x <> hl tel <> hl e       A.DataDef _di x _uc pars cs            -> hl x <> hl pars <> hl cs-      A.RecSig _di x tel e                   -> hl x <> hl tel <> hl e+      A.RecSig _di er x tel e                -> hl er <> hl x <> hl tel <> hl e       A.RecDef _di x _uc dir bs e ds         -> hl x <> hl dir <> hl bs <> hl e <> hl ds       A.PatternSynDef x xs p                 -> hl x <> hl xs <> hl p       A.UnquoteDecl _mi _di xs e             -> hl xs <> hl e       A.UnquoteDef _di xs e                  -> hl xs <> hl e+      A.UnquoteData _i xs _uc _j cs e        -> hl xs <> hl cs <> hl e       A.ScopedDecl s ds                      -> hl ds       A.Pragma _r pragma                     -> hl pragma+      A.UnfoldingDecl _r names               -> hl names     where     hl      a = hilite a     hlField x = hiliteField (concreteQualifier x) (concreteBase x) (Just $ bindingSite x)  instance Hilite A.Pragma where   hilite = \case-    A.OptionsPragma _strings     -> mempty-    A.BuiltinPragma b x          -> singleAspect Keyword b <> hilite x-    A.BuiltinNoDefPragma b k x   -> singleAspect Keyword b <> hiliteQName (Just $ kindOfNameToNameKind k) x-    A.CompilePragma b x _foreign -> singleAspect Keyword b <> hilite x-    A.RewritePragma r xs         -> singleAspect Keyword r <> hilite xs-    A.StaticPragma x             -> hilite x-    A.EtaPragma x                -> hilite x-    A.InjectivePragma x          -> hilite x-    A.InlinePragma _inline x     -> hilite x-    A.DisplayPragma x ps e       -> hilite x <> hilite ps <> hilite e+    A.OptionsPragma _strings        -> mempty+    A.BuiltinPragma b x             -> singleAspect Keyword b <> hilite x+    A.BuiltinNoDefPragma b k x      -> singleAspect Keyword b <> hiliteQName (Just $ kindOfNameToNameKind k) x+    A.CompilePragma b x _foreign    -> singleAspect Keyword b <> hilite x+    A.RewritePragma r xs            -> singleAspect Keyword r <> hilite xs+    A.StaticPragma x                -> hilite x+    A.EtaPragma x                   -> hilite x+    A.InjectivePragma x             -> hilite x+    A.InjectiveForInferencePragma x -> hilite x+    A.NotProjectionLikePragma x     -> hilite x+    A.OverlapPragma x _             -> hilite x+    A.InlinePragma _inline x        -> hilite x+    A.DisplayPragma x ps e          -> hilite x <> hilite ps <> hilite e  instance Hilite A.Expr where   hilite = \case@@ -250,14 +261,13 @@       A.WithApp _r e es             -> hl e <> hl es       A.Lam _r bs e                 -> hl bs <> hl e       A.AbsurdLam _r _h             -> mempty-      A.ExtendedLam _r _di _e _q cs -> hl cs -- No hilighting of generated extended lambda name!+      A.ExtendedLam _r _di er _q cs -> hl er <> hl cs -- No hilighting of generated extended lambda name!       A.Pi _r tel b                 -> hl tel <> hl b       A.Generalized _qs e           -> hl e       A.Fun _r a b                  -> hl a <> hl b       A.Let _r bs e                 -> hl bs <> hl e-      A.ETel _tel                   -> mempty  -- Printing only construct-      A.Rec _r ass                  -> hl ass-      A.RecUpdate _r e ass          -> hl e <> hl ass+      A.Rec _kwr _r ass             -> hl ass+      A.RecUpdate _kwr _r e ass     -> hl e <> hl ass       A.ScopedExpr _ e              -> hl e       A.Quote _r                    -> mempty       A.QuoteTerm _r                -> mempty@@ -281,10 +291,9 @@       A.AbsurdP _r           -> mempty       A.LitP _r l            -> hl l       A.PatternSynP _r qs es -> hilitePatternSynonym qs <> hl es-      A.RecP _r ps           -> hl ps+      A.RecP _kwr _r ps      -> hl ps       A.EqualP _r ps         -> hl ps       A.WithP _ p            -> hl p-      A.AnnP _r a p          -> hl p      where     hl a = hilite a@@ -324,6 +333,7 @@   hilite = \case     Rewrite es    -> hilite $ fmap snd es     Invert _x pes -> hilite pes+    LeftLet pes   -> hilite pes  instance Hilite a => Hilite (A.Clause' a) where   hilite (A.Clause lhs strippedPats rhs wh _catchall) =@@ -333,7 +343,7 @@   hilite (A.ProblemEq p _t _dom) = hilite p  instance Hilite A.WhereDeclarations where-  hilite (A.WhereDecls m ds) = hilite m <> hilite ds+  hilite (A.WhereDecls m _ ds) = hilite m <> hilite ds  instance Hilite A.GeneralizeTelescope where   hilite (A.GeneralizeTel _gen tel) = hilite tel@@ -349,13 +359,17 @@ instance Hilite A.LetBinding where   hilite = \case       A.LetBind    _r ai x t e     -> hl ai <> hl x <> hl t <> hl e+      A.LetAxiom   _r ai x t       -> hl ai <> hl x <> hl t       A.LetPatBind _r p e          -> hl p  <> hl e-      A.LetApply   mi x es _ci dir -> hl mi <> hl x <> hl es <> hl dir-      A.LetOpen    mi x dir        -> hl mi <> hl x <> hl dir-      A.LetDeclaredVariable x      -> hl x+      A.LetApply mi er x es _c dir -> hl mi <> hl er <> hl x <>+                                      hl es <> hl dir+      A.LetOpen mi x dir           -> hl mi <> hl x <> hl dir     where     hl x = hilite x +instance Hilite A.TypedBindingInfo where+  hilite (A.TypedBindingInfo x _) = hilite x+ instance Hilite A.TypedBinding where   hilite = \case     A.TBind _r tac binds e -> hilite tac <> hilite binds <> hilite e@@ -367,7 +381,7 @@     A.DomainFull bind      -> hilite bind  instance Hilite a => Hilite (A.Binder' a) where-  hilite (A.Binder p x) = hilite p <> hilite x+  hilite (A.Binder p _ x) = hilite p <> hilite x  instance Hilite A.BindName where   hilite (A.BindName x) = hiliteBound x@@ -387,13 +401,17 @@   hilite (ArgInfo _hiding modality _origin _fv _a) = hilite modality  instance Hilite Modality where-  hilite (Modality _relevance quantity _cohesion) = hilite quantity+  hilite (Modality _relevance quantity _cohesion _polarity) = hilite quantity  -- | If the 'Quantity' attribute comes with a 'Range', highlight the -- corresponding attribute as 'Symbol'. instance Hilite Quantity where   hilite = singleAspect Symbol +-- | Erasure attributes are highlighted as symbols.+instance Hilite Erased where+  hilite = singleAspect Symbol+ instance Hilite ModuleInfo where   hilite (ModuleInfo _r rAsTo asName _open _impDir)     =  singleAspect Symbol rAsTo            -- TODO: 'to' already covered by A.ImportDirective@@ -450,17 +468,14 @@   hilite = hiliteAmbiguousQName Nothing  instance Hilite A.ModuleName where-  hilite m@(A.MName xs) = do-    modMap <- asks hleModMap-    hiliteModule (isTopLevelModule modMap, m)+  hilite m@(A.MName xs) = hiliteModule (isTopLevelModule, m)     where-    isTopLevelModule modMap =-      case mapMaybe-          ((Strict.toLazy . P.srcFile) <=< (P.rStart . A.nameBindingSite)) xs of-        f : _ ->-          Map.lookup f modMap-            == Just (C.toTopLevelModuleName $ A.mnameToConcrete m)-        [] -> False+    isTopLevelModule =+      case mapMaybe (P.rangeModule . A.nameBindingSite) xs of+        []      -> False+        top : _ ->+          rawTopLevelModuleName top ==+          rawTopLevelModuleNameForModuleName m    -- Andreas, 2020-09-29, issue #4952. -- The target of a @renaming@ clause needs to be highlighted in a special way.@@ -563,36 +578,34 @@      --   The argument is 'True' iff the name is an operator.   -> Hiliter hiliteCName xs x fr mR asp = do-  HiliteEnv _ modMap fileName <- ask+  env <- ask   -- We don't care if we get any funny ranges.-  if all (== Strict.Just fileName) fileNames then pure $-    frFile modMap <>-    H.singleton (rToR rs)-                (aspects { definitionSite = mFilePos modMap })-   else-    mempty+  if all (== Just (hleCurrentModuleName env)) moduleNames+  then pure $+    frFile <>+    H.singleton (rToR rs) (aspects { definitionSite = mFilePos })+  else mempty   where-  aspects       = asp $ C.isOperator x-  fileNames     = mapMaybe (fmap P.srcFile . P.rStart . getRange) (x : xs)-  frFile modMap = H.singleton (rToR fr) (aspects { definitionSite = notHere <$> mFilePos modMap })-  rs            = getRange (x : xs)+  aspects     = asp $ C.isOperator x+  moduleNames = mapMaybe (P.rangeModule' . getRange) (x : xs)+  frFile      = H.singleton (rToR fr) $+                aspects { definitionSite = notHere <$> mFilePos }+  rs          = getRange (x : xs)    -- The fixity declaration should not get a symbolic anchor.   notHere d = d { defSiteHere = False } -  mFilePos-    :: SourceToModule  -- Maps source file paths to module names.-    -> Maybe DefinitionSite-  mFilePos modMap = do+  mFilePos :: Maybe DefinitionSite+  mFilePos = do     r <- mR     P.Pn { P.srcFile = Strict.Just f, P.posPos = p } <- P.rStart r-    mod <- Map.lookup f modMap+    mod <- P.rangeFileName f     -- Andreas, 2017-06-16, Issue #2604: Symbolic anchors.     -- We drop the file name part from the qualifiers, since     -- this is contained in the html file name already.     -- We want to get anchors of the form:     -- @<a name="TopLevelModule.html#LocalModule.NestedModule.identifier">@-    let qualifiers = drop (length $ C.moduleNameParts mod) xs+    let qualifiers = drop (size mod) xs     -- For bound variables, we do not create symbolic anchors.         local = maybe True isLocalAspect $ aspect aspects     return $ DefinitionSite@@ -640,13 +653,13 @@      -- ^ The argument is 'True' iff the name is an operator.   -> Hiliter hiliteAName x include asp = do-  fileName <- asks hleFileName+  currentModule <- asks hleCurrentModuleName   hiliteCName (concreteQualifier x)               (concreteBase x)-              (rangeOfFixityDeclaration fileName)+              (rangeOfFixityDeclaration currentModule)               (if include then Just $ bindingSite x else Nothing)               asp-    <> (notationFile fileName)+    <> notationFile currentModule   where   -- TODO: Currently we highlight fixity and syntax declarations by   -- producing highlighting something like once per occurrence of the@@ -654,14 +667,14 @@   -- avoid doing this for other files). Perhaps it would be better to   -- only produce this highlighting once. -  rangeOfFixityDeclaration fileName =-    if P.rangeFile r == Strict.Just fileName+  rangeOfFixityDeclaration currentModule =+    if P.rangeModule r == Just currentModule     then r else noRange     where     r = theNameRange $ A.nameFixity $ A.qnameName x -  notationFile fileName = pure $-    if P.rangeFile (getRange notation) == Strict.Just fileName+  notationFile currentModule = pure $+    if P.rangeModule (getRange notation) == Just currentModule     then mconcat $ map genPartFile notation     else mempty     where@@ -669,10 +682,10 @@      boundAspect = nameAsp Bound False -    genPartFile (BindHole r i)   = several [rToR r, rToR $ getRange i] boundAspect-    genPartFile (NormalHole r i) = several [rToR r, rToR $ getRange i] boundAspect-    genPartFile WildHole{}       = mempty-    genPartFile (IdPart x)       = H.singleton (rToR $ getRange x) (asp False)+    genPartFile (VarPart r i)  = several [rToR r, rToR $ getRange i] boundAspect+    genPartFile (HolePart r i) = several [rToR r, rToR $ getRange i] boundAspect+    genPartFile WildPart{}     = mempty+    genPartFile (IdPart x)     = H.singleton (rToR $ getRange x) (asp False)  -- * Short auxiliary functions. ---------------------------------------------------------------------------
src/full/Agda/Interaction/Highlighting/Generate.hs view
@@ -23,7 +23,6 @@ import Prelude hiding (null)  import Control.Monad-import Control.Arrow (second)  import qualified Data.Foldable as Fold import qualified Data.Map as Map@@ -50,33 +49,38 @@ import Agda.TypeChecking.Monad   hiding (ModuleInfo, MetaInfo, Primitive, Constructor, Record, Function, Datatype) import qualified Agda.TypeChecking.Monad  as TCM+import qualified Agda.TypeChecking.Monad.Base.Warning as W import qualified Agda.TypeChecking.Pretty as TCM import Agda.TypeChecking.Positivity.Occurrence-import Agda.TypeChecking.Warnings ( raiseWarningsOnUsage, runPM )+import Agda.TypeChecking.Warnings ( raiseWarningsOnUsage )  import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Concrete.Definitions as W ( DeclarationWarning(..), DeclarationWarning'(..) )-import Agda.Syntax.Common (pattern Ranged)-import qualified Agda.Syntax.Common as Common+import Agda.Syntax.Common (Induction(..), pattern Ranged)+import qualified Agda.Syntax.Common.Aspect as Aspect import qualified Agda.Syntax.Concrete.Name as C import qualified Agda.Syntax.Internal as I import qualified Agda.Syntax.Literal as L import qualified Agda.Syntax.Parser as Pa import qualified Agda.Syntax.Parser.Tokens as T import qualified Agda.Syntax.Position as P-import Agda.Syntax.Position (Range, HasRange, getRange, noRange)+import Agda.Syntax.Position+  (RangeFile, Range, HasRange, getRange, noRange)+import Agda.Syntax.TopLevelModuleName  import Agda.Syntax.Scope.Base     ( WithKind(..) ) import Agda.Syntax.Abstract.Views ( KName, declaredNames )  import Agda.Utils.FileName-import Agda.Utils.List            ( caseList, initWithDefault, last1 )+import Agda.Utils.List            ( caseList, last1 )+import Agda.Utils.List1           ( List1 )+import qualified Agda.Utils.List1 as List1 import Agda.Utils.List2           ( List2 ) import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Null-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.Singleton  import Agda.Utils.Impossible@@ -127,19 +131,19 @@   -> TCM () generateAndPrintSyntaxInfo decl _ _ | null $ getRange decl = return () generateAndPrintSyntaxInfo decl hlLevel updateState = do-  file <- getCurrentPath+  top <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule -  reportSLn "import.iface.create" 15 $ concat-    [ "Generating syntax info for "-    , filePath file-    , case hlLevel of-        Full   {} -> " (final)."-        Partial{} -> " (first approximation)."-    ]+  reportSDoc "import.iface.create" 15 $+    TCM.fwords+      ("Generating syntax info for the following declaration " +++       case hlLevel of+         Full   {} -> "(final):"+         Partial{} -> "(first approximation):")+      TCM.$$+    TCM.prettyA decl    ignoreAbstractMode $ do-    modMap <- sourceToModule-    kinds  <- nameKinds hlLevel decl+    kinds <- nameKinds hlLevel decl      -- After the code has been type checked more information may be     -- available for overloaded constructors, and@@ -147,11 +151,11 @@     -- Note, however, that highlighting for overloaded constructors is     -- included also in @nameInfo@.     constructorInfo <- case hlLevel of-      Full{} -> generateConstructorInfo modMap file kinds decl+      Full{} -> generateConstructorInfo top kinds decl       _      -> return mempty      -- Main source of scope-checker generated highlighting:-    let nameInfo = runHighlighter modMap file kinds decl+    let nameInfo = runHighlighter top kinds decl      reportSDoc "highlighting.warning" 60 $ TCM.hcat       [ "current path = "@@ -184,21 +188,31 @@  generateTokenInfo :: AbsolutePath -> TCM HighlightingInfo generateTokenInfo file =-  generateTokenInfoFromSource file . Text.unpack =<<-    runPM (Pa.readFilePM file)+  generateTokenInfoFromSource rf . Text.unpack =<<+    runPM (Pa.readFilePM rf)+  where+  -- Note the use of Nothing here. The file might not even parse, but+  -- it should still be possible to obtain token-based highlighting+  -- information. The top-level module names seem to be *mostly*+  -- unused, but one cannot use __IMPOSSIBLE__ instead of Nothing,+  -- because the top-level module names are used by interleaveRanges,+  -- which is used by parseLiterateWithComments, which is used by+  -- generateTokenInfoFromSource.+  rf = P.mkRangeFile file Nothing  -- | Generate and return the syntax highlighting information for the -- tokens in the given file.  generateTokenInfoFromSource-  :: AbsolutePath+  :: RangeFile      -- ^ The module to highlight.   -> String      -- ^ The file contents. Note that the file is /not/ read from      -- disk.   -> TCM HighlightingInfo generateTokenInfoFromSource file input =-  runPM $ tokenHighlighting . fst <$> Pa.parseFile Pa.tokensParser file input+  runPM $ tokenHighlighting . fst . fst <$>+          Pa.parseFile Pa.tokensParser file input  -- | Generate and return the syntax highlighting information for the -- tokens in the given string, which is assumed to correspond to the@@ -207,7 +221,8 @@ generateTokenInfoFromString :: Range -> String -> TCM HighlightingInfo generateTokenInfoFromString r _ | r == noRange = return mempty generateTokenInfoFromString r s = do-  runPM $ tokenHighlighting <$> Pa.parsePosString Pa.tokensParser p s+  runPM $ tokenHighlighting . fst <$>+          Pa.parsePosString Pa.tokensParser p s   where     Just p = P.rStart r @@ -273,17 +288,19 @@   defnToKind   TCM.Axiom{}                           = Postulate   defnToKind   TCM.DataOrRecSig{}                    = Postulate   defnToKind   TCM.GeneralizableVar{}                = Generalizable-  defnToKind d@TCM.Function{} | isProperProjection d = Field-                            | otherwise            = Function+  defnToKind d@TCM.Function{}+    | isProperProjection d                           = Field+    | isMacro d                                      = Macro          -- AIM XL, issue #7324+    | otherwise                                      = Function   defnToKind   TCM.Datatype{}                        = Datatype   defnToKind   TCM.Record{}                          = Record-  defnToKind   TCM.Constructor{ TCM.conInd = i }       = Constructor i+  defnToKind   TCM.Constructor{ TCM.conSrcCon = c }  = Constructor $ I.conInductive c   defnToKind   TCM.Primitive{}                       = Primitive   defnToKind   TCM.PrimitiveSort{}                   = Primitive   defnToKind   TCM.AbstractDefn{}                    = __IMPOSSIBLE__    con :: NameKind-  con = Constructor Common.Inductive+  con = Constructor Inductive  -- | The 'TCM.Axiom' constructor is used to represent various things -- which are not really axioms, so when maps are merged 'Postulate's@@ -323,12 +340,12 @@ -- the type checker.  generateConstructorInfo-  :: SourceToModule  -- ^ Maps source file paths to module names.-  -> AbsolutePath    -- ^ The module to highlight.+  :: TopLevelModuleName+     -- ^ The module to highlight.   -> NameKinds   -> A.Declaration   -> TCM HighlightingInfoBuilder-generateConstructorInfo modMap file kinds decl = do+generateConstructorInfo top kinds decl = do    -- Get boundaries of current declaration.   -- @noRange@ should be impossible, but in case of @noRange@@@ -345,7 +362,7 @@         constrs = IntMap.elems m2      -- Return suitable syntax highlighting information.-    return $ foldMap (runHighlighter modMap file kinds) constrs+    return $ foldMap (runHighlighter top kinds) constrs  printSyntaxInfo :: Range -> TCM () printSyntaxInfo r = do@@ -364,7 +381,7 @@ -- | Generate highlighting for error.  errorHighlighting :: TCErr -> TCM HighlightingInfoBuilder-errorHighlighting e = errorHighlighting' (getRange e) <$> TCM.prettyError e+errorHighlighting e = errorHighlighting' (getRange e) <$> TCM.renderError e  errorHighlighting'   :: Range     -- ^ Error range.@@ -400,73 +417,123 @@ warningHighlighting' b w = case tcWarning w of   TerminationIssue terrs     -> terminationErrorHighlighting terrs   NotStrictlyPositive d ocs  -> positivityErrorHighlighting d ocs+  ConstructorDoesNotFitInData _dataOrRecord c _s1 _s2 _err -> errorWarningHighlighting $+     getRange c `catchNull` getRange w+  CoinductiveEtaRecord _x    -> deadcodeHighlighting w   -- #3965 highlight each unreachable clause independently: they   -- may be interleaved with actually reachable clauses!   UnreachableClauses _ rs    -> foldMap deadcodeHighlighting rs   CoverageIssue{}            -> coverageErrorHighlighting $ getRange w   CoverageNoExactSplit{}     -> catchallHighlighting $ getRange w-  UnsolvedConstraints cs     -> if b then constraintsHighlighting [] cs else mempty-  UnsolvedMetaVariables rs   -> if b then metasHighlighting rs          else mempty-  AbsurdPatternRequiresNoRHS{} -> deadcodeHighlighting w-  ModuleDoesntExport{}         -> deadcodeHighlighting w+  InlineNoExactSplit{}       -> catchallHighlighting $ getRange w+  UnsolvedConstraints cs     -> if b then constraintsHighlighting [] $ Fold.toList cs else mempty+  UnsolvedMetaVariables rs   -> if b then metasHighlighting          $ Fold.toList rs else mempty+  AbsurdPatternRequiresAbsentRHS{} -> deadcodeHighlighting w+  DuplicateRecordDirective{}   -> deadcodeHighlighting w+  ModuleDoesntExport _ _ _ xs  -> foldMap deadcodeHighlighting xs   DuplicateUsing xs            -> foldMap deadcodeHighlighting xs   FixityInRenamingModule rs    -> foldMap deadcodeHighlighting rs   -- expanded catch-all case to get a warning for new constructors   CantGeneralizeOverSorts{}  -> mempty   UnsolvedInteractionMetas{} -> mempty-  OldBuiltin{}               -> mempty+  InteractionMetaBoundaries{} -> mempty+  OldBuiltin{}                -> deadcodeHighlighting w+  BuiltinDeclaresIdentifier{} -> mempty   EmptyRewritePragma{}       -> deadcodeHighlighting w   EmptyWhere{}               -> deadcodeHighlighting w+  -- TODO: linearity+  -- FixingQuantity _ q _       -> if null r then cosmeticHighlighting w else deadcodeHighlighting r+  --   where r = getRange q+  FixingRelevance _ q _      -> if null r then cosmeticProblemHighlighting w else deadcodeHighlighting r+    where r = getRange q+  FixingCohesion _ q _       -> if null r then cosmeticProblemHighlighting w else deadcodeHighlighting r+    where r = getRange q+  FixingPolarity _ q _       -> if null r then cosmeticProblemHighlighting w else deadcodeHighlighting r+    where r = getRange q   IllformedAsClause{}        -> deadcodeHighlighting w+  UselessPragma r _          -> deadcodeHighlighting r   UselessPublic{}            -> deadcodeHighlighting w   UselessHiding xs           -> foldMap deadcodeHighlighting xs   UselessInline{}            -> mempty   UselessPatternDeclarationForRecord{} -> deadcodeHighlighting w+  UselessTactic{}            -> deadcodeHighlighting w   ClashesViaRenaming _ xs    -> foldMap deadcodeHighlighting xs     -- #4154, TODO: clashing renamings are not dead code, but introduce problems.     -- Should we have a different color?-  WrongInstanceDeclaration{} -> mempty-  InstanceWithExplicitArg{}  -> deadcodeHighlighting w-  InstanceNoOutputTypeName{} -> mempty-  InstanceArgWithExplicitArg{} -> mempty+  WrongInstanceDeclaration{}   -> instanceProblemHighlighting w+  InstanceWithExplicitArg{}    -> instanceProblemHighlighting w+  InstanceNoOutputTypeName{}   -> instanceProblemHighlighting w+  InstanceArgWithExplicitArg{} -> instanceProblemHighlighting w   InversionDepthReached{}    -> mempty-  NoGuardednessFlag{}        -> mempty-  GenericWarning{}           -> mempty-  GenericUseless r _         -> deadcodeHighlighting r   -- Andreas, 2020-03-21, issue #4456:   -- Error warnings that do not have dedicated highlighting   -- are highlighted as errors.-  GenericNonFatalError{}                -> errorWarningHighlighting w+  InvalidCharacterLiteral{}             -> errorWarningHighlighting w   SafeFlagPostulate{}                   -> errorWarningHighlighting w   SafeFlagPragma{}                      -> errorWarningHighlighting w-  SafeFlagNonTerminating                -> errorWarningHighlighting w-  SafeFlagTerminating                   -> errorWarningHighlighting w   SafeFlagWithoutKFlagPrimEraseEquality -> errorWarningHighlighting w-  SafeFlagEta                           -> errorWarningHighlighting w-  SafeFlagInjective                     -> errorWarningHighlighting w-  SafeFlagNoCoverageCheck               -> errorWarningHighlighting w-  SafeFlagNoPositivityCheck             -> errorWarningHighlighting w-  SafeFlagPolarity                      -> errorWarningHighlighting w-  SafeFlagNoUniverseCheck               -> errorWarningHighlighting w   InfectiveImport{}                     -> errorWarningHighlighting w   CoInfectiveImport{}                   -> errorWarningHighlighting w+  InvalidDisplayForm{}                  -> deadcodeHighlighting w+  UnusedVariablesInDisplayForm xs       -> foldMap deadcodeHighlighting xs+  TooManyArgumentsToSort _ args         -> errorWarningHighlighting args+  RewritesNothing                       -> cosmeticProblemHighlighting w+  WithClauseProjectionFixityMismatch p _ _ _ -> cosmeticProblemHighlighting p   WithoutKFlagPrimEraseEquality -> mempty+  ConflictingPragmaOptions{} -> mempty   DeprecationWarning{}       -> mempty   UserWarning{}              -> mempty   LibraryWarning{}           -> mempty+  ConfluenceCheckingIncompleteBecauseOfMeta{} -> confluenceErrorHighlighting w+  ConfluenceForCubicalNotSupported{} -> mempty   RewriteNonConfluent{}      -> confluenceErrorHighlighting w   RewriteMaybeNonConfluent{} -> confluenceErrorHighlighting w   RewriteAmbiguousRules{}    -> confluenceErrorHighlighting w   RewriteMissingRule{}       -> confluenceErrorHighlighting w+  IllegalRewriteRule x _     -> deadcodeHighlighting x+  NotARewriteRule x _        -> deadcodeHighlighting x   PragmaCompileErased{}      -> deadcodeHighlighting w+  PragmaCompileList{}        -> deadcodeHighlighting w+  PragmaCompileMaybe{}       -> deadcodeHighlighting w+  PragmaCompileWrong{}       -> deadcodeHighlighting w+  PragmaCompileWrongName{}   -> deadcodeHighlighting w+  PragmaCompileUnparsable{}  -> deadcodeHighlighting w+  PragmaExpectsDefinedSymbol{}+                             -> deadcodeHighlighting w+  PragmaExpectsUnambiguousConstructorOrFunction{}+                             -> deadcodeHighlighting w+  PragmaExpectsUnambiguousProjectionOrFunction{}+                             -> deadcodeHighlighting w+  NoMain{}                   -> mempty   NotInScopeW{}              -> deadcodeHighlighting w+  UnsupportedIndexedMatch{}  -> mempty   AsPatternShadowsConstructorOrPatternSynonym{}                              -> deadcodeHighlighting w+  PatternShadowsConstructor{}-> errorWarningHighlighting w  -- or mempty ?+  PlentyInHardCompileTimeMode o+                             -> deadcodeHighlighting o   RecordFieldWarning w       -> recordFieldWarningHighlighting w+  OptionWarning w            -> mempty   ParseWarning w             -> case w of+    Pa.MisplacedAttributes{}      -> deadcodeHighlighting w+    Pa.UnknownPolarity{}          -> deadcodeHighlighting w+    Pa.UnknownAttribute{}         -> deadcodeHighlighting w     Pa.UnsupportedAttribute{}     -> deadcodeHighlighting w     Pa.MultipleAttributes{}       -> deadcodeHighlighting w     Pa.OverlappingTokensWarning{} -> mempty+  MissingTypeSignatureForOpaque{} -> errorWarningHighlighting w+  NotAffectedByOpaque{}           -> deadcodeHighlighting w+  UselessOpaque{}                 -> deadcodeHighlighting w+  UnfoldingWrongName x            -> deadcodeHighlighting x+  UnfoldTransparentName r         -> deadcodeHighlighting r+  FaceConstraintCannotBeHidden{}  -> deadcodeHighlighting w+  FaceConstraintCannotBeNamed{}   -> deadcodeHighlighting w++  HiddenNotInArgumentPosition{}   -> errorWarningHighlighting w+  InstanceNotInArgumentPosition{} -> errorWarningHighlighting w+  MacroInLetBindings{}            -> errorWarningHighlighting w+  AbstractInLetBindings{}         -> errorWarningHighlighting w+   NicifierIssue (DeclarationWarning _ w) -> case w of     -- we intentionally override the binding of `w` here so that our pattern of     -- using `getRange w` still yields the most precise range information we@@ -482,25 +549,39 @@     EmptyPrivate{}                   -> deadcodeHighlighting w     EmptyGeneralize{}                -> deadcodeHighlighting w     EmptyField{}                     -> deadcodeHighlighting w+    EmptyPolarityPragma{}            -> deadcodeHighlighting w+    HiddenGeneralize{}               -> mempty+      -- Andreas, 2022-03-25, issue #5850+      -- We would like @deadcodeHighlighting w@ for the braces in+      -- @variable {x} : A@, but these have no range, so we cannot highlight them.+      -- Highlighting the variable instead might be misleading,+      -- suggesting that it is not generalized over.     UselessAbstract{}                -> deadcodeHighlighting w     UselessInstance{}                -> deadcodeHighlighting w+    UselessMacro{}                   -> deadcodeHighlighting w     UselessPrivate{}                 -> deadcodeHighlighting w+    InvalidCatchallPragma{}          -> deadcodeHighlighting w     InvalidNoPositivityCheckPragma{} -> deadcodeHighlighting w     InvalidNoUniverseCheckPragma{}   -> deadcodeHighlighting w     InvalidTerminationCheckPragma{}  -> deadcodeHighlighting w     InvalidCoverageCheckPragma{}     -> deadcodeHighlighting w-    InvalidConstructor{}             -> deadcodeHighlighting w     InvalidConstructorBlock{}        -> deadcodeHighlighting w-    InvalidRecordDirective{}         -> deadcodeHighlighting w-    OpenPublicAbstract{}             -> deadcodeHighlighting w-    OpenPublicPrivate{}              -> deadcodeHighlighting w+    OpenImportAbstract{}             -> cosmeticProblemHighlighting w+    OpenImportPrivate{}              -> cosmeticProblemHighlighting w+    SafeFlagEta                   {} -> errorWarningHighlighting w+    SafeFlagInjective             {} -> errorWarningHighlighting w+    SafeFlagNoCoverageCheck       {} -> errorWarningHighlighting w+    SafeFlagNoPositivityCheck     {} -> errorWarningHighlighting w+    SafeFlagNoUniverseCheck       {} -> errorWarningHighlighting w+    SafeFlagNonTerminating        {} -> errorWarningHighlighting w+    SafeFlagPolarity              {} -> errorWarningHighlighting w+    SafeFlagTerminating           {} -> errorWarningHighlighting w     W.ShadowingInTelescope nrs       -> foldMap                                           (shadowingTelHighlighting . snd)                                           nrs-    MissingDeclarations{}            -> missingDefinitionHighlighting w+    MissingDataDeclaration{}         -> missingDefinitionHighlighting w     MissingDefinitions{}             -> missingDefinitionHighlighting w     -- TODO: explore highlighting opportunities here!-    InvalidCatchallPragma{}           -> mempty     PolarityPragmasButNotPostulates{} -> mempty     PragmaNoTerminationCheck{}        -> mempty     PragmaCompiled{}                  -> errorWarningHighlighting w@@ -508,14 +589,21 @@     UnknownNamesInFixityDecl{}        -> mempty     UnknownNamesInPolarityPragmas{}   -> mempty +  -- Backends+  CustomBackendWarning{} -> mempty++  -- Polarities+  TooManyPolarities _x occs -> deadcodeHighlighting occs+  TopLevelPolarity{} -> errorWarningHighlighting w+ recordFieldWarningHighlighting ::   RecordFieldWarning -> HighlightingInfoBuilder recordFieldWarningHighlighting = \case-  DuplicateFieldsWarning xrs      -> dead xrs-  TooManyFieldsWarning _q _ys xrs -> dead xrs+  W.DuplicateFields xrs      -> dead xrs+  W.TooManyFields _q _ys xrs -> dead xrs   where-  dead :: [(C.Name, Range)] -> HighlightingInfoBuilder-  dead = mconcat . map deadcodeHighlighting+  dead :: List1 (C.Name, Range) -> HighlightingInfoBuilder+  dead = sconcat . fmap deadcodeHighlighting   -- Andreas, 2020-03-27 #3684: This variant seems to only highlight @x@:   -- dead = mconcat . map f   -- f (x, r) = deadcodeHighlighting (getRange x) `mappend` deadcodeHighlighting r@@ -523,14 +611,14 @@ -- | Generate syntax highlighting for termination errors.  terminationErrorHighlighting ::-  [TerminationError] -> HighlightingInfoBuilder+  List1 TerminationError -> HighlightingInfoBuilder terminationErrorHighlighting termErrs = functionDefs `mappend` callSites   where     m            = parserBased { otherAspects = Set.singleton TerminationProblem }     functionDefs = foldMap (\x -> H.singleton (rToR $ bindingSite x) m) $                    concatMap termErrFunctions termErrs     callSites    = foldMap (\r -> H.singleton (rToR r) m) $-                   concatMap (map callInfoRange . termErrCalls) termErrs+                   concatMap (map getRange . termErrCalls) termErrs     bindingSite  = A.nameBindingSite . A.qnameName  -- | Generate syntax highlighting for not-strictly-positive inductive@@ -565,15 +653,27 @@ catchallHighlighting r = H.singleton (rToR $ P.continuousPerLine r) m   where m = parserBased { otherAspects = Set.singleton CatchallClause } +cosmeticProblemHighlighting :: HasRange a => a -> HighlightingInfoBuilder+cosmeticProblemHighlighting a = H.singleton (rToR $ P.continuousPerLine r) m+  where+    r = getRange a+    m = parserBased { otherAspects = Set.singleton CosmeticProblem }+ confluenceErrorHighlighting ::   HasRange a => a -> HighlightingInfoBuilder confluenceErrorHighlighting a = H.singleton (rToR $ P.continuousPerLine $ getRange a) m   where m = parserBased { otherAspects = Set.singleton ConfluenceProblem } +instanceProblemHighlighting :: HasRange a => a -> HighlightingInfoBuilder+instanceProblemHighlighting a = H.singleton (rToR $ P.continuousPerLine r) m+  where+    r = getRange a+    m = parserBased { otherAspects = Set.singleton InstanceProblem }+ missingDefinitionHighlighting ::   HasRange a => a -> HighlightingInfoBuilder missingDefinitionHighlighting a = H.singleton (rToR $ P.continuousPerLine $ getRange a) m-  where m = parserBased { otherAspects = Set.singleton MissingDefinition }+  where m = parserBased { otherAspects = Set.singleton Aspect.MissingDefinition }  -- | Generates and prints syntax highlighting information for unsolved -- meta-variables and certain unsolved constraints.@@ -614,11 +714,11 @@   return $ (rs ++ rs', metasHighlighting' rs)  metasHighlighting :: [Range] -> HighlightingInfoBuilder-metasHighlighting rs = metasHighlighting' (map (rToR . P.continuousPerLine) rs)+metasHighlighting = metasHighlighting' . fmap (rToR . P.continuousPerLine)  metasHighlighting' :: [Ranges] -> HighlightingInfoBuilder-metasHighlighting' rs = several rs-                     $ parserBased { otherAspects = Set.singleton UnsolvedMeta }+metasHighlighting' rs =+  several (List1.toList rs) parserBased{ otherAspects = Set.singleton UnsolvedMeta }  -- | Generates syntax highlighting information for unsolved constraints --   (ideally: that are not connected to a meta variable).@@ -653,7 +753,7 @@ storeDisambiguatedProjection :: A.QName -> TCM () storeDisambiguatedProjection = storeDisambiguatedField -storeDisambiguatedConstructor :: Common.Induction -> A.QName -> TCM ()+storeDisambiguatedConstructor :: Induction -> A.QName -> TCM () storeDisambiguatedConstructor i = storeDisambiguatedName $ Constructor i  -- TODO: move the following function to a new module TypeChecking.Overloading
src/full/Agda/Interaction/Highlighting/Generate.hs-boot view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Interaction.Highlighting.Generate where  import Agda.TypeChecking.Monad.Base (TCM, TCWarning)
src/full/Agda/Interaction/Highlighting/HTML.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Backend for generating highlighted, hyperlinked HTML from Agda sources.
src/full/Agda/Interaction/Highlighting/HTML/Backend.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Backend for generating highlighted, hyperlinked HTML from Agda sources. @@ -22,10 +23,10 @@     , OptDescr(..)     , Flag     )-import Agda.Compiler.Backend (Backend(..), Backend'(..), Recompile(..))+import Agda.Compiler.Backend (Backend,Backend_boot(..), Backend',Backend'_boot(..), Recompile(..)) import Agda.Compiler.Common (IsMain(..), curIF) -import Agda.Syntax.Abstract (ModuleName, toTopLevelModuleName)+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName)  import Agda.TypeChecking.Monad   ( MonadDebug@@ -52,7 +53,7 @@  data HtmlModuleEnv = HtmlModuleEnv   { htmlModEnvCompileEnv :: HtmlCompileEnv-  , htmlModEnvName       :: ModuleName+  , htmlModEnvName       :: TopLevelModuleName   }  data HtmlModule = HtmlModule@@ -77,6 +78,8 @@   -- will not have their definition site populated.   , scopeCheckingSuffices = True   , mayEraseType          = const $ return False+  , backendInteractTop    = Nothing+  , backendInteractHole   = Nothing   }  initialHtmlFlags :: HtmlFlags@@ -164,7 +167,7 @@   :: Applicative m   => HtmlCompileEnv   -> IsMain-  -> ModuleName+  -> TopLevelModuleName   -> Maybe FilePath   -> m (Recompile HtmlModuleEnv HtmlModule) preModuleHtml cenv _isMain modName _ifacePath = pure $ Recompile (HtmlModuleEnv cenv modName)@@ -183,12 +186,12 @@   => HtmlCompileEnv   -> HtmlModuleEnv   -> IsMain-  -> ModuleName+  -> TopLevelModuleName   -> [HtmlDef]   -> m HtmlModule postModuleHtml _env menv _isMain _modName _defs = do   let generatePage = defaultPageGen . htmlCompileEnvOpts . htmlModEnvCompileEnv $ menv-  htmlSrc <- srcFileOfInterface (toTopLevelModuleName . htmlModEnvName $ menv) <$> curIF+  htmlSrc <- srcFileOfInterface (htmlModEnvName menv) <$> curIF   runLogHtmlWithMonadDebug $ generatePage htmlSrc   return HtmlModule @@ -196,6 +199,6 @@   :: Applicative m   => HtmlCompileEnv   -> IsMain-  -> Map ModuleName HtmlModule+  -> Map TopLevelModuleName HtmlModule   -> m () postCompileHtml _cenv _isMain _modulesByName = pure ()
src/full/Agda/Interaction/Highlighting/HTML/Base.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Function for generating highlighted, hyperlinked HTML from Agda -- sources.@@ -20,12 +21,10 @@ import Control.Monad.Trans ( MonadIO(..), lift ) import Control.Monad.Trans.Reader ( ReaderT(runReaderT), ask ) -import Data.Function ( on ) import Data.Foldable (toList, concatMap) import Data.Maybe import qualified Data.IntMap as IntMap-import qualified Data.List   as List-import Data.List.Split (splitWhen, chunksOf)+import Data.List.Split (splitWhen) import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T @@ -50,20 +49,22 @@   -- The imported operator (!) attaches an Attribute to an Html value   -- The defined operator (!!) attaches a list of such Attributes -import Paths_Agda- import Agda.Interaction.Highlighting.Precise hiding (toList) -import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Common+import Agda.Syntax.TopLevelModuleName  import qualified Agda.TypeChecking.Monad as TCM   ( Interface(..)   ) +import Agda.Setup ( getDataFileName )+ import Agda.Utils.Function+import Agda.Utils.List1 (String1, pattern (:|))+import qualified Agda.Utils.List1   as List1 import qualified Agda.Utils.IO.UTF8 as UTF8-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty  import Agda.Utils.Impossible @@ -107,11 +108,13 @@ highlightOnlyCode :: HtmlHighlight -> FileType -> Bool highlightOnlyCode HighlightAll  _ = False highlightOnlyCode HighlightCode _ = True-highlightOnlyCode HighlightAuto AgdaFileType = False-highlightOnlyCode HighlightAuto MdFileType   = True-highlightOnlyCode HighlightAuto RstFileType  = True-highlightOnlyCode HighlightAuto OrgFileType  = True-highlightOnlyCode HighlightAuto TexFileType  = False+highlightOnlyCode HighlightAuto AgdaFileType  = False+highlightOnlyCode HighlightAuto MdFileType    = True+highlightOnlyCode HighlightAuto RstFileType   = True+highlightOnlyCode HighlightAuto OrgFileType   = True+highlightOnlyCode HighlightAuto TypstFileType = True+highlightOnlyCode HighlightAuto TreeFileType  = True+highlightOnlyCode HighlightAuto TexFileType   = False  -- | Determine the generated file extension @@ -119,11 +122,13 @@ highlightedFileExt hh ft   | not $ highlightOnlyCode hh ft = "html"   | otherwise = case ft of-      AgdaFileType -> "html"-      MdFileType   -> "md"-      RstFileType  -> "rst"-      TexFileType  -> "tex"-      OrgFileType  -> "org"+      AgdaFileType  -> "html"+      MdFileType    -> "md"+      RstFileType   -> "rst"+      TexFileType   -> "tex"+      OrgFileType   -> "org"+      TypstFileType -> "typ"+      TreeFileType  -> "tree"  -- | Options for HTML generation @@ -137,7 +142,7 @@ -- | Internal type bundling the information related to a module source file  data HtmlInputSourceFile = HtmlInputSourceFile-  { _srcFileModuleName :: C.TopLevelModuleName+  { _srcFileModuleName :: TopLevelModuleName   , _srcFileType :: FileType   -- ^ Source file type   , _srcFileText :: Text@@ -148,7 +153,8 @@  -- | Bundle up the highlighting info for a source file -srcFileOfInterface :: C.TopLevelModuleName -> TCM.Interface -> HtmlInputSourceFile+srcFileOfInterface ::+  TopLevelModuleName -> TCM.Interface -> HtmlInputSourceFile srcFileOfInterface m i = HtmlInputSourceFile m (TCM.iFileType i) (TCM.iSource i) (TCM.iHighlighting i)  -- | Logging during HTML generation@@ -213,7 +219,7 @@  -- | Converts module names to the corresponding HTML file names. -modToFile :: C.TopLevelModuleName -> String -> FilePath+modToFile :: TopLevelModuleName -> String -> FilePath modToFile m ext = Network.URI.Encode.encode $ render (pretty m) <.> ext  -- | Generates a highlighted, hyperlinked version of the given module.@@ -236,7 +242,7 @@ page :: FilePath              -- ^ URL to the CSS file.      -> Bool                  -- ^ Highlight occurrences      -> Bool                  -- ^ Whether to reserve literate-     -> C.TopLevelModuleName  -- ^ Module to be highlighted.+     -> TopLevelModuleName    -- ^ Module to be highlighted.      -> Html      -> Text page css@@ -269,7 +275,7 @@  type TokenInfo =   ( Int-  , String+  , String1   , Aspects   ) @@ -280,11 +286,9 @@      -> HighlightingInfo -- ^ Highlighting information.      -> [TokenInfo] tokenStream contents info =-  map (\cs -> case cs of-          (mi, (pos, _)) : _ ->-            (pos, map (snd . snd) cs, fromMaybe mempty mi)-          [] -> __IMPOSSIBLE__) $-  List.groupBy ((==) `on` fst) $+  map (\ ((mi, (pos, c)) :| xs) ->+            (pos, c :| map (snd . snd) xs, fromMaybe mempty mi)) $+  List1.groupBy ((==) `on` fst) $   zipWith (\pos c -> (IntMap.lookup pos infoMap, (pos, c))) [1..] (T.unpack contents)   where   infoMap = toMap info@@ -300,12 +304,14 @@          -- Explicitly written all cases, so people          -- get compile error when adding new file types          -- when they forget to modify the code here-         RstFileType  -> map mkRst . splitByMarkup-         MdFileType   -> map mkMd . chunksOf 2 . splitByMarkup-         AgdaFileType -> map mkHtml-         -- Any points for using this option?-         TexFileType  -> map mkMd . chunksOf 2 . splitByMarkup-         OrgFileType  -> map mkOrg . splitByMarkup+         RstFileType   -> map mkRst . splitByMarkup+         MdFileType    -> map mkMd . splitByMarkup+         AgdaFileType  -> map mkHtml+         OrgFileType   -> map mkOrg . splitByMarkup+         TreeFileType  -> map mkMd . splitByMarkup+         -- Two useless cases, probably will never used by anyone+         TexFileType   -> map mkMd . splitByMarkup+         TypstFileType -> map mkMd . splitByMarkup   else map mkHtml   where   trd (_, _, a) = a@@ -317,31 +323,28 @@   mkHtml (pos, s, mi) =     -- Andreas, 2017-06-16, issue #2605:     -- Do not create anchors for whitespace.-    applyUnless (mi == mempty) (annotate pos mi) $ toHtml s+    applyUnless (mi == mempty) (annotate pos mi) $ toHtml $ List1.toList s +  backgroundOrAgdaToHtml :: TokenInfo -> Html+  backgroundOrAgdaToHtml token@(_, s, mi) = case aspect mi of+    Just Background -> preEscapedToHtml $ List1.toList s+    Just Markup     -> __IMPOSSIBLE__+    _               -> mkHtml token+   -- Proposed in #3373, implemented in #3384   mkRst :: [TokenInfo] -> Html-  mkRst = mconcat . (toHtml rstDelimiter :) . map go-    where-      go token@(_, s, mi) = if aspect mi == Just Background-        then preEscapedToHtml s-        else mkHtml token+  mkRst = mconcat . (toHtml rstDelimiter :) . map backgroundOrAgdaToHtml -  -- Proposed in #3137, implemented in #3313-  -- Improvement proposed in #3366, implemented in #3367-  mkMd :: [[TokenInfo]] -> Html-  mkMd = mconcat . go+  -- The assumption here and in mkOrg is that Background tokens and Agda tokens are always+  -- separated by Markup tokens, so these runs only contain one kind.+  mkMd :: [TokenInfo] -> Html+  mkMd tokens = if containsCode then formatCode else formatNonCode     where-      work token@(_, s, mi) = case aspect mi of-        Just Background -> preEscapedToHtml s-        Just Markup     -> __IMPOSSIBLE__-        _               -> mkHtml token-      go [a, b] = [ mconcat $ work <$> a-                  , Html5.pre ! Attr.class_ "Agda" $ mconcat $ work <$> b-                  ]-      go [a]    = work <$> a-      go _      = __IMPOSSIBLE__+      containsCode = any ((/= Just Background) . aspect . trd) tokens +      formatCode = Html5.pre ! Attr.class_ "Agda" $ mconcat $ backgroundOrAgdaToHtml <$> tokens+      formatNonCode = mconcat $ backgroundOrAgdaToHtml <$> tokens+   mkOrg :: [TokenInfo] -> Html   mkOrg tokens = mconcat $ if containsCode then formatCode else formatNonCode     where@@ -350,12 +353,8 @@       startDelimiter = preEscapedToHtml orgDelimiterStart       endDelimiter = preEscapedToHtml orgDelimiterEnd -      formatCode = startDelimiter : foldr (\x -> (go x :)) [endDelimiter] tokens-      formatNonCode = map go tokens--      go token@(_, s, mi) = if aspect mi == Just Background-        then preEscapedToHtml s-        else mkHtml token+      formatCode = startDelimiter : foldr (\x -> (backgroundOrAgdaToHtml x :)) [endDelimiter] tokens+      formatNonCode = map backgroundOrAgdaToHtml tokens    -- Put anchors that enable referencing that token.   -- We put a fail safe numeric anchor (file position) for internal references
src/full/Agda/Interaction/Highlighting/JSON.hs view
@@ -1,21 +1,22 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Functions which give precise syntax highlighting info in JSON format.  module Agda.Interaction.Highlighting.JSON (jsonifyHighlightingInfo) where +import qualified Data.ByteString.Lazy.Char8 as BS+ import Agda.Interaction.Highlighting.Common import Agda.Interaction.Highlighting.Precise hiding (String) import Agda.Interaction.Highlighting.Range (Range(..)) import Agda.Interaction.JSON import Agda.Interaction.Response-import Agda.TypeChecking.Monad (HighlightingMethod(..), ModuleToSource)-import Agda.Utils.FileName (filePath)-import Agda.Utils.IO.TempFile (writeToTempFile) -import qualified Data.ByteString.Lazy.Char8 as BS-import qualified Data.Map as Map+import Agda.TypeChecking.Monad (HighlightingMethod(..), ModuleToSource, topLevelModuleFilePath) -import Agda.Utils.Impossible+import Agda.Utils.FileName     (AbsolutePath, filePath)+import Agda.Utils.IO.TempFile  (writeToTempFile)+import Agda.Utils.CallStack    (HasCallStack)  -- | Encode meta information into a JSON Value showAspects@@ -31,9 +32,12 @@   ]   where     defSite (DefinitionSite mdl position _ _) = object-      [ "filepath" .= filePath (Map.findWithDefault __IMPOSSIBLE__ mdl modFile)+      [ "filepath" .= filePath f       , "position" .= position       ]+      where+        f :: HasCallStack => AbsolutePath+        f = topLevelModuleFilePath modFile mdl  -- partial function, so use CallStack!  instance EncodeTCM TokenBased where instance ToJSON TokenBased where
src/full/Agda/Interaction/Highlighting/LaTeX.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Generating highlighted and aligned LaTeX from literate Agda source.  module Agda.Interaction.Highlighting.LaTeX
src/full/Agda/Interaction/Highlighting/LaTeX/Backend.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Interaction.Highlighting.LaTeX.Backend   ( latexBackend@@ -5,8 +6,7 @@  import Agda.Interaction.Highlighting.LaTeX.Base   ( LaTeXOptions(..)-  , LogLaTeXT-  , runLogLaTeXTWith+  , MonadLogLaTeX(logLaTeX)   , logMsgToText   , generateLaTeXIO   , prepareCommonAssets@@ -15,36 +15,38 @@ import Control.DeepSeq import Control.Monad.Trans (MonadIO) -import qualified Data.Map as Map-import Data.Map (Map)--import qualified Data.Text as T+import           Data.Functor ( (<&>) )+import qualified Data.Map     as Map+import           Data.Map     ( Map )+import qualified Data.Text    as T  import GHC.Generics (Generic)  import System.FilePath ( (</>) ) -import Agda.Compiler.Backend (Backend(..), Backend'(..), Definition, Recompile(..))+import Agda.Compiler.Backend (Backend,Backend_boot(..), Backend',Backend'_boot(..), Definition, Recompile(..)) import Agda.Compiler.Common (curIF, IsMain(IsMain, NotMain))  import Agda.Interaction.Options   ( ArgDescr(NoArg, ReqArg)   , CommandLineOptions ( optGHCiInteraction, optPragmaOptions )-  , PragmaOptions ( optCountClusters )+  , optCountClusters   , Flag   , OptDescr(..)   ) -import Agda.Syntax.Abstract.Name (ModuleName, toTopLevelModuleName)-import Agda.Syntax.Concrete.Name (TopLevelModuleName, projectRoot)+import Agda.Syntax.Position (mkRangeFile, rangeFilePath)+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName, projectRoot)  import Agda.TypeChecking.Monad   ( HasOptions(commandLineOptions)   , MonadDebug-  , stModuleToSource+  , stModuleToSourceId   , useTC   , ReadTCState   , reportS+  , MonadFileId+  , srcFilePath   )  import Agda.Utils.FileName (filePath, mkAbsolute)@@ -111,25 +113,40 @@   , postCompile           = postCompileLaTeX   , scopeCheckingSuffices = True   , mayEraseType          = const $ return False+  , backendInteractTop    = Nothing+  , backendInteractHole   = Nothing   } -runLogLaTeXWithMonadDebug :: MonadDebug m => LogLaTeXT m a -> m a-runLogLaTeXWithMonadDebug = runLogLaTeXTWith $ (reportS "compile.latex" 1) . T.unpack . logMsgToText+-- | A wrapper to implement 'MonadLogLaTeX'.+newtype LogLaTeXDebugT m a = LogLaTeXDebugT { runLogLaTeXDebugT :: m a }+  deriving (Functor, Applicative, Monad, MonadIO) +instance MonadDebug m => MonadLogLaTeX (LogLaTeXDebugT m) where+  logLaTeX = LogLaTeXDebugT . (reportS "compile.latex" 1) . T.unpack . logMsgToText+ -- Resolve the raw flags into usable LaTeX options.-resolveLaTeXOptions :: (HasOptions m, ReadTCState m) => LaTeXFlags -> TopLevelModuleName -> m LaTeXOptions+resolveLaTeXOptions :: (HasOptions m, ReadTCState m, MonadFileId m)+  => LaTeXFlags+  -> TopLevelModuleName+  -> m LaTeXOptions resolveLaTeXOptions flags moduleName = do   options <- commandLineOptions-  modFiles <- useTC stModuleToSource+  modFiles <- useTC stModuleToSourceId+  let msrc = Map.lookup moduleName modFiles+  mf <- traverse srcFilePath msrc   let-    mSrcFileName = (mkAbsolute . filePath) <$> Map.lookup moduleName modFiles+    mSrcFileName = mf <&> \ f ->+      mkRangeFile (mkAbsolute (filePath f)) (Just moduleName)+      -- TODO:    ^^^^^^^^^^^^^^^^^^^^^^^^^ can this just be `f`?     countClusters = optCountClusters . optPragmaOptions $ options     latexDir = latexFlagOutDir flags     -- FIXME: This reliance on emacs-mode to decide whether to interpret the output location as project-relative or     -- cwd-relative is gross. Also it currently behaves differently for JSON mode :-/     -- And it prevents us from doing a real "one-time" setup.     outDir = case (mSrcFileName, optGHCiInteraction options) of-      (Just sourceFile, True) -> filePath (projectRoot sourceFile moduleName) </> latexDir+      (Just sourceFile, True) ->+        filePath (projectRoot (rangeFilePath sourceFile) moduleName) </>+        latexDir       _ -> latexDir   return LaTeXOptions     { latexOptOutDir         = outDir@@ -144,14 +161,14 @@ preCompileLaTeX flags = pure $ LaTeXCompileEnv flags  preModuleLaTeX-  :: (HasOptions m, ReadTCState m)+  :: (HasOptions m, ReadTCState m, MonadFileId m)   => LaTeXCompileEnv   -> IsMain-  -> ModuleName+  -> TopLevelModuleName   -> Maybe FilePath   -> m (Recompile LaTeXModuleEnv LaTeXModule) preModuleLaTeX (LaTeXCompileEnv flags) isMain moduleName _ifacePath = case isMain of-  IsMain  -> Recompile . LaTeXModuleEnv <$> resolveLaTeXOptions flags (toTopLevelModuleName moduleName)+  IsMain  -> Recompile . LaTeXModuleEnv <$> resolveLaTeXOptions flags moduleName   NotMain -> return $ Skip LaTeXModule  compileDefLaTeX@@ -168,12 +185,12 @@   => LaTeXCompileEnv   -> LaTeXModuleEnv   -> IsMain-  -> ModuleName+  -> TopLevelModuleName   -> [LaTeXDef]   -> m LaTeXModule postModuleLaTeX _cenv (LaTeXModuleEnv latexOpts) _main _moduleName _defs = do   i <- curIF-  runLogLaTeXWithMonadDebug $ do+  runLogLaTeXDebugT do     -- FIXME: It would be better to do "prepareCommonAssets" in @preCompileLaTeX@, but because     -- the output directory depends on the module-relative project root (when in emacs-mode),     -- we can't do that until we see the module.@@ -186,6 +203,6 @@   :: Applicative m   => LaTeXCompileEnv   -> IsMain-  -> Map ModuleName LaTeXModule+  -> Map TopLevelModuleName LaTeXModule   -> m () postCompileLaTeX _cenv _main _modulesByName = pure ()
src/full/Agda/Interaction/Highlighting/LaTeX/Base.hs view
@@ -1,18 +1,15 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns #-}  -- | Function for generating highlighted and aligned LaTeX from literate -- Agda source.  module Agda.Interaction.Highlighting.LaTeX.Base-  ( generateLaTeXIO+  ( LaTeXOptions(..)+  , generateLaTeXIO   , prepareCommonAssets-  , runLogLaTeXTWith-  , logMsgToText+  , MonadLogLaTeX(logLaTeX)   , LogMessage(..)-  , MonadLogLaTeX-  , LogLaTeXT-  , LaTeXOptions(..)+  , logMsgToText   ) where  import Prelude hiding (log)@@ -20,13 +17,10 @@ import Data.Bifunctor (second) import Data.Char import Data.Maybe-import Data.Function+import Data.Function (on) import Data.Foldable (toList)-#if !(MIN_VERSION_base(4,11,0))-import Data.Semigroup (Semigroup(..))-#endif -import Control.Monad (forM_, mapM_, unless, when)+import Control.Exception.Base (IOException, try) import Control.Monad.Trans.Reader as R ( ReaderT(runReaderT)) import Control.Monad.RWS.Strict   ( RWST(runRWST)@@ -39,9 +33,8 @@   )  import System.Directory-import System.Exit import System.FilePath-import System.Process+import System.Process ( readProcess )  import Data.Text (Text) import qualified Data.Text               as T@@ -57,24 +50,24 @@ import qualified Data.IntMap  as IntMap import qualified Data.List    as List -import Paths_Agda--import Agda.Syntax.Abstract (toTopLevelModuleName) import Agda.Syntax.Common-import Agda.Syntax.Concrete (TopLevelModuleName, moduleNameParts) import Agda.Syntax.Parser.Literate (literateTeX, LayerRole, atomizeLayers) import qualified Agda.Syntax.Parser.Literate as L-import Agda.Syntax.Position (startPos)+import Agda.Syntax.Position (RangeFile, startPos')+import Agda.Syntax.TopLevelModuleName+  (TopLevelModuleName, moduleNameParts)  import Agda.Interaction.Highlighting.Precise hiding (toList) -import Agda.TypeChecking.Monad (Interface(..))+import Agda.TypeChecking.Monad (Interface(..)) --, reportSLn) -import Agda.Utils.FileName (AbsolutePath)+import Agda.Setup ( getDataFileName )+ import Agda.Utils.Function (applyWhen) import Agda.Utils.Functor  ((<&>)) import Agda.Utils.List     (last1, updateHead, updateLast) import Agda.Utils.Maybe    (whenJust)+import Agda.Utils.Monad import qualified Agda.Utils.List1 as List1  import Agda.Utils.Impossible@@ -82,9 +75,6 @@ ------------------------------------------------------------------------ -- * Logging -class Monad m => MonadLogLaTeX m where-  logLaTeX :: LogMessage -> m ()- -- | Log LaTeX messages using a provided action. -- -- This could be accomplished by putting logs into the RWST output and splitting it@@ -93,37 +83,32 @@ -- -- We want the logging to be reasonably polymorphic, avoid space leaks that can occur -- with WriterT, and also be usable during outer phases such as directory preparation.------ I'm not certain this is the best way to do it, but whatever.-type LogLaTeXT m = ReaderT (LogMessage -> m ()) m -instance Monad m => MonadLogLaTeX (LogLaTeXT m) where-  logLaTeX message = do-    doLog <- ask-    lift $ doLog message--runLogLaTeXTWith :: Monad m => (LogMessage -> m ()) -> LogLaTeXT m a -> m a-runLogLaTeXTWith = flip runReaderT+class Monad m => MonadLogLaTeX m where+  logLaTeX :: LogMessage -> m () --- Not currently used, but for example:--- runLogLaTeXWithIO :: MonadIO m => LogLaTeXT m a -> m a--- runLogLaTeXWithIO = runLogLaTeXTWith $ liftIO . T.putStrLn . logMsgToText+data LogMessage = LogMessage Debug Text [Text] deriving Show  --------------------------------------------------------------------------- * Datatypes.+-- * The monad and its associated data types. --- | The @LaTeX@ monad is a combination of @ExceptT@, @RWST@ and--- a logger @m@. The error part is just used to keep track whether we finished or--- not, the reader part contains static options used, the writer is where the--- output goes and the state is for keeping track of the tokens and some--- other useful info, and the MonadLogLaTeX part is used for printing debugging info.+-- | The @LaTeX@ monad is a combination of @RWST@ and a logger @m@.+--+-- The reader part contains static options used,+-- the writer is where the output goes,+-- the state is for keeping track of the tokens and some other useful info, and+-- the MonadLogLaTeX part is used for printing debugging info. -type LaTeX a = forall m. MonadLogLaTeX m => RWST Env [Output] State m a+type LaTeXT = RWST Env [Output] State+type LaTeX a = forall m. MonadLogLaTeX m => LaTeXT m a+-- Andreas, 2025-03-23 we sometimes expand @a -> LaTeX b@+-- to @forall m. MonadLogLaTeX m => a -> LaTeXT m b@+-- to combat changes in the type checker of GHC 9 over GHC 8.+-- Originally (by asr, 2021-02-07) we used eta-expansions in these places+-- to circumvent the GHC type checker regressions (see Issue #4955).  -- | Output items. -data LogMessage = LogMessage Debug Text [Text] deriving Show- data Output   = Text !Text     -- ^ A piece of text.@@ -207,10 +192,8 @@  -- | Run function for the @LaTeX@ monad. runLaTeX :: MonadLogLaTeX m =>-  LaTeX a -> Env -> State -> m (a, State, [Output])--- ASR (2021-02-07). The eta-expansion is required by GHC >= 9.0.1--- (see Issue #4955).-runLaTeX l = runRWST l+  LaTeXT m a -> Env -> State -> m (a, State, [Output])+runLaTeX = runRWST  emptyState :: State emptyState = State@@ -259,12 +242,9 @@ --   by the length of the token. Otherwise, `moveColumnForToken` is a no-op. moveColumnForToken :: Token -> LaTeX () moveColumnForToken Token{ text = t } = do-  unless (isSpaces t) $ do+  unless (isSpaces t) do     log MoveColumn t-    -- ASR (2021-02-07). The eta-expansion is required by GHC >= 9.0.1-    -- (see Issue #4955).-    n <- size t-    moveColumn n+    moveColumn =<< size t  -- | Merges 'columns' into 'columnsPrev', resets 'column' and -- 'columns'@@ -282,8 +262,8 @@     where     leastNew = columnColumn (last1 n ns) -moveColumn :: Int -> LaTeX ()-moveColumn i = modify $ \s -> s { column = i + column s }+moveColumn :: MonadLogLaTeX m => Int -> LaTeXT m ()+moveColumn i = modify \ s -> s { column = i + column s }  -- | Registers a column of the given kind. The column is returned. @@ -366,7 +346,7 @@   logHelper Code text ["columns=", tshow cols, "col=", tshow col] log debug text = logHelper debug text [] -output :: Output -> LaTeX ()+output :: MonadLogLaTeX m => Output -> LaTeXT m () output item = do   log Output $ tshow item   tell [item]@@ -452,31 +432,26 @@ ------------------------------------------------------------------------ -- * Output generation from a stream of labelled tokens. -processLayers :: [(LayerRole, Tokens)] -> LaTeX ()--- ASR (2021-02-07). The eta-expansion on @lt@ is required by GHC >=--- 9.0.1 (see Issue #4955).-processLayers lt = forM_ lt $ \ (layerRole,toks) -> do+processLayers :: MonadLogLaTeX m => [(LayerRole, Tokens)] -> LaTeXT m ()+processLayers = mapM_ \ (layerRole, toks) -> do   case layerRole of     L.Markup  -> processMarkup  toks     L.Comment -> processComment toks     L.Code    -> processCode    toks  -- | Deals with markup, which is output verbatim.-processMarkup :: Tokens -> LaTeX ()--- ASR (2021-02-07). The eta-expansion on @ts@ is required by GHC >=--- 9.0.1 (see Issue #4955).-processMarkup ts = forM_ ts $ \ t' -> do-  moveColumnForToken t'-  output (Text (text t'))+processMarkup :: MonadLogLaTeX m => Tokens -> LaTeXT m ()+processMarkup = mapM_ \ t -> do+  moveColumnForToken t+  output $ Text $ text t  -- | Deals with literate text, which is output verbatim-processComment :: Tokens -> LaTeX ()--- ASR (2021-02-07). The eta-expansion with @ts@ is required by GHC >=--- 9.0.1 (see Issue #4955).-processComment ts = forM_ ts $ \ t' -> do-  unless ("%" == T.take 1 (T.stripStart (text t'))) $ do-    moveColumnForToken t'-  output (Text (text t'))+processComment :: MonadLogLaTeX m => Tokens -> LaTeXT m ()+processComment = mapM_ \ t -> do+  let t' = text t+  unless ("%" == T.take 1 (T.stripStart t')) $ do+    moveColumnForToken t+  output $ Text t'  -- | Deals with code blocks. Every token, except spaces, is pretty -- printed as a LaTeX command.@@ -516,9 +491,7 @@     ptOpenWhenColumnZero col =         when (col == 0) $ do           registerColumnZero-          -- ASR (2021-02-07). The eta-expansion @\o -> output o@ is-          -- required by GHC >= 9.0.1 (see Issue #4955).-          (\o -> output o). Text . ptOpen =<< columnZero+          output . Text . ptOpen =<< columnZero      -- Translation from OtherAspect to command strings. So far it happens     -- to correspond to @show@ but it does not have to (cf. fromAspect)@@ -600,10 +573,8 @@ -- Newlines. spaces (s@(T.uncons -> Just ('\n', _)) : ss) = do   col <- gets column-  when (col == 0) $-    -- ASR (2021-02-07). The eta-expansion @\o -> output o@ is-    -- required by GHC >= 9.0.1 (see Issue #4955).-    (\o -> output o) . Text . ptOpen =<< columnZero+  when (col == 0) do+    output . Text . ptOpen =<< columnZero   output $ Text $ ptClose <> ptNL <>                   T.replicate (T.length s - 1) ptEmptyLine   resetColumn@@ -695,7 +666,7 @@  data LaTeXOptions = LaTeXOptions   { latexOptOutDir         :: FilePath-  , latexOptSourceFileName :: Maybe AbsolutePath+  , latexOptSourceFileName :: Maybe RangeFile     -- ^ The parser uses a @Position@ which includes a source filename for     -- error reporting and such. We don't actually get the source filename     -- with an @Interface@, and it isn't necessary to look it up.@@ -718,28 +689,45 @@ -- | Create the common base output directory and check for/install the style file. prepareCommonAssets :: (MonadLogLaTeX m, MonadIO m) => FilePath -> m () prepareCommonAssets dir = do-  liftIO $ createDirectoryIfMissing True dir-  (code, _, _) <--    liftIO $-      readProcessWithExitCode+  -- Make sure @dir@ will exist.+  dirExisted <- liftIO $ doesDirectoryExist dir+  unless dirExisted $+    -- Create directory @dir@ and parent directories.+    liftIO $ createDirectoryIfMissing True dir++  -- Check whether TeX will find @agda.sty@.+  texFindsSty <- liftIO $ try $+      readProcess         "kpsewhich"-        ["--path=" ++ dir, defaultStyFile]+        (applyWhen dirExisted (("--path=" ++ dir) :) [defaultStyFile])         ""-  when (code /= ExitSuccess) $ do-    logLaTeX $ LogMessage FileSystem-      (T.pack $ unwords [defaultStyFile, "was not found. Copying a default version of", defaultStyFile, "into", dir])-      []-    liftIO $ do-      styFile <- getDataFileName $-        latexDataDir </> defaultStyFile-      copyFile styFile (dir </> defaultStyFile)+  case texFindsSty of+    Right _ -> return ()+    Left (e :: IOException) -> do+     -- -- we are lacking MonadDebug here, so no debug printing via reportSLn+     -- reportSLn "compile.latex.sty" 70 $ unlines+     --   [ unwords [ "Searching for", defaultStyFile, "in", dir, "returns:" ]+     --   , show e+     --   ]+     let agdaSty = dir </> defaultStyFile+     unlessM (pure dirExisted `and2M` liftIO (doesFileExist agdaSty)) $ do+       -- It is safe now to create the default style file in @dir@ without overwriting+       -- a possibly user-edited copy there.+       logLaTeX $ LogMessage FileSystem+         (T.pack $ unwords [defaultStyFile, "was not found. Copying a default version of", defaultStyFile, "into", dir])+         []+       liftIO $ do+         styFile <- getDataFileName $+           latexDataDir </> defaultStyFile+         copyFile styFile agdaSty  -- | Generates a LaTeX file for the given interface. generateLaTeXIO :: (MonadLogLaTeX m, MonadIO m) => LaTeXOptions -> Interface -> m () generateLaTeXIO opts i = do   let textWidthEstimator = getTextWidthEstimator (latexOptCountClusters opts)   let baseDir = latexOptOutDir opts-  let outPath = baseDir </> (latexOutRelativeFilePath $ toTopLevelModuleName $ iModuleName i)+  let outPath = baseDir </>+                latexOutRelativeFilePath (iTopLevelModuleName i)   latex <- E.encodeUtf8 <$> toLaTeX               (emptyEnv textWidthEstimator)               (latexOptSourceFileName opts)@@ -750,22 +738,16 @@     BS.writeFile outPath latex  latexOutRelativeFilePath :: TopLevelModuleName -> FilePath-latexOutRelativeFilePath m = List.intercalate [pathSeparator] (List1.toList $ moduleNameParts m) <.> "tex"--groupByFst :: forall a b. Eq a => [(a,b)] -> [(a,[b])]-groupByFst =-    map (\xs -> case xs of                     -- Float the grouping to the top level-          []           -> __IMPOSSIBLE__-          (tag, _): _ -> (tag, map snd xs))--  . List.groupBy ((==) `on` fst)  -- Group together characters in the same-                                  -- role.+latexOutRelativeFilePath m =+  List.intercalate [pathSeparator]+    (map T.unpack $ List1.toList $ moduleNameParts m) <.>+  "tex"  -- | Transforms the source code into LaTeX. toLaTeX   :: MonadLogLaTeX m   => Env-  -> Maybe AbsolutePath+  -> Maybe RangeFile   -> L.Text   -> HighlightingInfo   -> m L.Text@@ -806,22 +788,25 @@                 ( -- Split tokens at newlines                   concatMap stringLiteral                 . concatMap multiLineComment-                . map ( \(mi, cs) ->-                              Token {text = T.pack cs, info = fromMaybe mempty mi}+                . List1.toList+                . fmap (\ (mi, cs) -> Token+                        { text = T.pack $ List1.toList cs+                        , info = fromMaybe mempty mi+                        }                       )-                . groupByFst+                . List1.groupByFst1                 )             )       )-    . groupByFst--  -- Look up the meta info at each position in the highlighting info.-  . zipWith (\pos (role, char) -> (role, (IntMap.lookup pos infoMap, char)))-            [1..] . -- Add position in file to each character.-              -- Map each character to its role-              atomizeLayers . literateTeX (startPos path)+    . List1.groupByFst -  $ L.unpack source+    -- Look up the meta info at each position in the highlighting info.+    . zipWith (\pos (role, char) -> (role, (IntMap.lookup pos infoMap, char)))+              [1..]+    -- Map each character to its role+    . atomizeLayers+    . literateTeX (startPos' ())+    $ L.unpack source   where   infoMap = toMap hi
src/full/Agda/Interaction/Highlighting/Precise.hs view
@@ -29,164 +29,35 @@  import Prelude hiding (null) -import Control.Arrow (second) import Control.DeepSeq-import Control.Monad -import Data.Function-import qualified Data.List as List-import Data.Maybe+import Data.Function (on) import Data.Semigroup  import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap--import Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map- import Data.Set (Set) import qualified Data.Set as Set  import GHC.Generics (Generic) -import qualified Agda.Syntax.Position as P import qualified Agda.Syntax.Common   as Common-import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.TopLevelModuleName import Agda.Syntax.Scope.Base                   ( KindOfName(..) )  import Agda.Interaction.Highlighting.Range -import Agda.Utils.List import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Null import Agda.Utils.RangeMap (RangeMap, IsBasicRangeMap(..)) import qualified Agda.Utils.RangeMap as RangeMap++import Agda.Syntax.Common.Aspect import Agda.Utils.String  import Agda.Utils.Impossible ---------------------------------------------------------------------------- Highlighting information---- | Syntactic aspects of the code. (These cannot overlap.)--data Aspect-  = Comment-  | Keyword-  | String-  | Number-  | Hole-  | Symbol                     -- ^ Symbols like forall, =, ->, etc.-  | PrimitiveType              -- ^ Things like Set and Prop.-  | Name (Maybe NameKind) Bool -- ^ Is the name an operator part?-  | Pragma                     -- ^ Text occurring in pragmas that-                               --   does not have a more specific-                               --   aspect.-  | Background                 -- ^ Non-code contents in literate Agda-  | Markup-    -- ^ Delimiters used to separate the Agda code blocks from the-    -- other contents in literate Agda-    deriving (Eq, Show, Generic)---- | @NameKind@s are figured out during scope checking.--data NameKind-  = Bound                         -- ^ Bound variable.-  | Generalizable                 -- ^ Generalizable variable.-                                  --   (This includes generalizable-                                  --   variables that have been-                                  --   generalized).-  | Constructor Common.Induction  -- ^ Inductive or coinductive constructor.-  | Datatype-  | Field                         -- ^ Record field.-  | Function-  | Module                        -- ^ Module name.-  | Postulate-  | Primitive                     -- ^ Primitive.-  | Record                        -- ^ Record type.-  | Argument                      -- ^ Named argument, like x in {x = v}-  | Macro                         -- ^ Macro.-    deriving (Eq, Show, Generic)---- | Other aspects, generated by type checking.---   (These can overlap with each other and with 'Aspect's.)--data OtherAspect-  = Error-  | ErrorWarning-    -- ^ A warning that is considered fatal in the end.-  | DottedPattern-  | UnsolvedMeta-  | UnsolvedConstraint-    -- ^ Unsolved constraint not connected to meta-variable. This-    -- could for instance be an emptyness constraint.-  | TerminationProblem-  | PositivityProblem-  | Deadcode-    -- ^ Used for highlighting unreachable clauses, unreachable RHS-    -- (because of an absurd pattern), etc.-  | ShadowingInTelescope-    -- ^ Used for shadowed repeated variable names in telescopes.-  | CoverageProblem-  | IncompletePattern-    -- ^ When this constructor is used it is probably a good idea to-    -- include a 'note' explaining why the pattern is incomplete.-  | TypeChecks-    -- ^ Code which is being type-checked.-  | MissingDefinition-    -- ^ Function declaration without matching definition-  -- NB: We put CatchallClause last so that it is overwritten by other,-  -- more important, aspects in the emacs mode.-  | CatchallClause-  | ConfluenceProblem-    deriving (Eq, Ord, Show, Enum, Bounded, Generic)---- | Meta information which can be associated with a--- character\/character range.--data Aspects = Aspects-  { aspect       :: Maybe Aspect-  , otherAspects :: Set OtherAspect-  , note         :: String-    -- ^ This note, if not null, can be displayed as a tool-tip or-    -- something like that. It should contain useful information about-    -- the range (like the module containing a certain identifier, or-    -- the fixity of an operator).-  , definitionSite :: Maybe DefinitionSite-    -- ^ The definition site of the annotated thing, if applicable and-    --   known.-  , tokenBased :: !TokenBased-    -- ^ Is this entry token-based?-  }-  deriving (Show, Generic)--data DefinitionSite = DefinitionSite-  { defSiteModule :: C.TopLevelModuleName-      -- ^ The defining module.-  , defSitePos    :: Int-      -- ^ The file position in that module. File positions are-      -- counted from 1.-  , defSiteHere   :: Bool-      -- ^ Has this @DefinitionSite@ been created at the defining site of the name?-  , defSiteAnchor :: Maybe String-      -- ^ A pretty name for the HTML linking.-  }-  deriving (Show, Generic)--instance Eq DefinitionSite where-  DefinitionSite m p _ _ == DefinitionSite m' p' _ _ = m == m' && p == p'---- | Is the highlighting \"token-based\", i.e. based only on--- information from the lexer?--data TokenBased = TokenBased | NotOnlyTokenBased-  deriving (Eq, Show)--instance Eq Aspects where-  Aspects a o _ d t == Aspects a' o' _ d' t' =-    (a, o, d, t) == (a', o', d', t')- -- | A limited kind of syntax highlighting information: a pair -- consisting of 'Ranges' and 'Aspects'. --@@ -399,28 +270,7 @@   mempty  = TokenBased   mappend = (<>) --- | Some 'NameKind's are more informative than others.-instance Semigroup NameKind where-  -- During scope-checking of record, we build a constructor-  -- whose arguments (@Bound@ variables) are the fields.-  -- Later, we process them as @Field@s proper.-  Field    <> Bound    = Field-  Bound    <> Field    = Field-  -- -- Projections are special functions.-  -- -- TODO necessary?-  -- Field    <> Function = Field-  -- Function <> Field    = Field-  -- TODO: more overwrites?-  k1 <> k2 | k1 == k2  = k1-           | otherwise = k1 -- TODO: __IMPOSSIBLE__ --- | @NameKind@ in @Name@ can get more precise.-instance Semigroup Aspect where-  Name mk1 op1 <> Name mk2 op2 = Name (unionMaybeWith (<>) mk1 mk2) op1-    -- (op1 || op2) breaks associativity-  a1 <> a2 | a1 == a2  = a1-           | otherwise = a1 -- TODO: __IMPOSSIBLE__- instance Semigroup DefinitionSite where   d1 <> d2 | d1 == d2  = d1            | otherwise = d1 -- TODO: __IMPOSSIBLE__@@ -466,7 +316,6 @@ -- NFData instances  instance NFData Aspect-instance NFData NameKind instance NFData OtherAspect instance NFData DefinitionSite
src/full/Agda/Interaction/Highlighting/Range.hs view
@@ -55,9 +55,7 @@ -- | The 'Ranges' invariant.  rangesInvariant :: Ranges -> Bool-rangesInvariant (Ranges []) = True-rangesInvariant (Ranges rs) =-  and (zipWith (<) (map to $ init rs) (map from $ tail rs))+rangesInvariant (Ranges rs) = allConsecutive (\ r s -> to r < from s) rs  ------------------------------------------------------------------------ -- Queries@@ -67,7 +65,7 @@ -- The ranges are assumed to be well-formed.  overlapping :: Range -> Range -> Bool-overlapping r1 r2 = (not $ r1 `isLeftOf` r2) && (not $ r2 `isLeftOf` r1)+overlapping r1 r2 = not (r1 `isLeftOf` r2) && not (r2 `isLeftOf` r1)  isLeftOf :: Range -> Range -> Bool isLeftOf r1 r2 = to r1 <= from r2@@ -95,9 +93,7 @@ rToR :: P.Range -> Ranges rToR r = Ranges (map iToR (P.rangeIntervals r))   where-  iToR (P.Interval { P.iStart = P.Pn { P.posPos = pos1 }-                   , P.iEnd   = P.Pn { P.posPos = pos2 }-                   }) =+  iToR (P.Interval () P.Pn{ P.posPos = pos1 } P.Pn{ P.posPos = pos2 }) =     Range { from = fromIntegral pos1, to = fromIntegral pos2 }  -- | Converts a 'P.Range', seen as a continuous range, to a 'Range'.@@ -106,9 +102,10 @@ rangeToRange r =   case P.rangeToInterval r of     Nothing -> Range { from = 0, to = 0 }-    Just i  -> Range { from = fromIntegral $ P.posPos $ P.iStart i-                     , to   = fromIntegral $ P.posPos $ P.iEnd i-                     }+    Just (P.Interval _ s e) -> Range+      { from = fromIntegral $ P.posPos s+      , to   = fromIntegral $ P.posPos e+      }  ------------------------------------------------------------------------ -- Operations
src/full/Agda/Interaction/Highlighting/Vim.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Interaction.Highlighting.Vim where @@ -16,9 +17,11 @@  import Agda.TypeChecking.Monad +import Agda.Utils.List1             ( List1, pattern (:|) )+import qualified Agda.Utils.List1   as List1 import qualified Agda.Utils.IO.UTF8 as UTF8 import Agda.Utils.Tuple-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty  vimFile :: FilePath -> FilePath vimFile file =@@ -40,13 +43,12 @@ keyword _ [] = "" keyword cat ws  = "syn keyword " ++ unwords (cat : ws) -match :: String -> [String] -> String-match _   [] = ""-match cat ws =+match :: String -> List1 String -> String+match cat (w :| ws) =   "syn match "     ++ cat     ++ " \""-    ++ List.intercalate "\\|" (map (wordBounded . escape) ws)+    ++ List.intercalate "\\|" (map (wordBounded . escape) $ w:ws)     ++ "\""  matches :: [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> [String]@@ -60,18 +62,18 @@         defs'  = foo "agdaFunction"         $ classify length defs         idefs' = foo "agdaInfixFunction"    $ classify length idefs -        classify f = List.groupBy ((==) `on` f)+        classify f = List1.groupBy ((==) `on` f)                      . List.sortBy (compare `on` f) -        foo :: String -> [[String]] -> [(Int, String)]-        foo cat = map (length . head /\ match cat)+        foo :: String -> [List1 String] -> [(Int, String)]+        foo cat = map (length . List1.head /\ match cat)  toVim :: NamesInScope -> String toVim ns = unlines $ matches mcons micons mdefs midefs mflds miflds     where-        cons = [ x | (x, con:_) <- Map.toList ns, isJust $ isConName $ anameKind con ]-        defs = [ x | (x, def:_) <- Map.toList ns, isDefName (anameKind def) ]-        flds = [ x | (x, fld:_) <- Map.toList ns, anameKind fld == FldName  ]+        cons = [ x | (x, con :| _) <- Map.toList ns, isJust $ isConName $ anameKind con ]+        defs = [ x | (x, def :| _) <- Map.toList ns, isDefName (anameKind def) ]+        flds = [ x | (x, fld :| _) <- Map.toList ns, anameKind fld == FldName  ]          mcons = map prettyShow cons         mdefs = map prettyShow defs
src/full/Agda/Interaction/Imports.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE NondecreasingIndentation #-}  {-| This module deals with finding imported modules and loading their     interface files.@@ -17,6 +18,11 @@   , scopeCheckImport   , parseSource   , typeCheckMain+  , getNonMainInterface+  , getNonMainModuleInfo+  , getInterface+  , importPrimitiveModules+  , raiseNonFatalErrors    -- Currently only used by test/api/Issue1168.hs:   , readInterface@@ -24,46 +30,52 @@  import Prelude hiding (null) -import Control.Monad               ( forM, forM_, void )-import Control.Monad.Except+import Control.Monad.Except        ( MonadError(..), ExceptT, runExceptT, withExceptT ) import Control.Monad.IO.Class      ( MonadIO(..) )-import Control.Monad.State+import Control.Monad.State         ( MonadState(..), execStateT ) import Control.Monad.Trans.Maybe import qualified Control.Exception as E -#if __GLASGOW_HASKELL__ < 808-import Control.Monad.Fail (MonadFail)-#endif--import Data.Either (lefts)-import qualified Data.Map as Map+import Data.Either+import Data.List (intercalate) import qualified Data.List as List-import Data.Set (Set)-import qualified Data.Set as Set import Data.Maybe import Data.Map (Map)+import qualified Data.Map as Map import qualified Data.HashMap.Strict as HMap+import Data.Set (Set)+import qualified Data.Set as Set import Data.Text (Text)+import qualified Data.Text as T import qualified Data.Text.Lazy as TL  import System.Directory (doesFileExist, removeFile)-import System.FilePath ((</>), takeDirectory)+import System.FilePath  ( (</>) )  import Agda.Benchmarking  import qualified Agda.Syntax.Abstract as A import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Attribute import Agda.Syntax.Abstract.Name import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty hiding (Mode) import Agda.Syntax.Parser import Agda.Syntax.Position import Agda.Syntax.Scope.Base+import Agda.Syntax.TopLevelModuleName import Agda.Syntax.Translation.ConcreteToAbstract+  ( TopLevel( TopLevel )+  , TopLevelInfo( TopLevelInfo, topLevelDecls, topLevelScope)+  , checkAttributes, concreteToAbstract_+  )+import qualified Agda.Syntax.Translation.ConcreteToAbstract as CToA +import Agda.TypeChecking.InstanceArguments import Agda.TypeChecking.Errors import Agda.TypeChecking.Warnings hiding (warnings) import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Rewriting.Confluence ( checkConfluenceOfRules )+import Agda.TypeChecking.Rewriting.Confluence ( checkConfluenceOfRules, sortRulesOfSymbol ) import Agda.TypeChecking.MetaVars ( openMetasToPostulates ) import Agda.TypeChecking.Monad import Agda.TypeChecking.Serialise@@ -77,7 +89,7 @@ import Agda.Interaction.BasicOps ( getGoals, showGoals ) import Agda.Interaction.FindFile import Agda.Interaction.Highlighting.Generate-import Agda.Interaction.Highlighting.Precise  ( convert )+import qualified Agda.Interaction.Highlighting.Precise as Highlighting ( convert ) import Agda.Interaction.Highlighting.Vim import Agda.Interaction.Library import Agda.Interaction.Options@@ -86,15 +98,19 @@ import Agda.Interaction.Response   (RemoveTokenBasedHighlighting(KeepHighlighting)) +import Agda.Utils.CallStack (HasCallStack) import Agda.Utils.FileName+import Agda.Utils.Hash+import Agda.Utils.IO.Binary import Agda.Utils.Lens+import Agda.Utils.List ( nubOn ) import Agda.Utils.Maybe import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.IO.Binary-import Agda.Utils.Pretty hiding (Mode)-import Agda.Utils.Hash+import qualified Agda.Utils.ProfileOptions as Profile+import Agda.Utils.Singleton+import qualified Agda.Utils.Set1 as Set1 import qualified Agda.Utils.Trie as Trie  import Agda.Utils.Impossible@@ -116,19 +132,49 @@   , srcFileType    :: FileType              -- ^ Source file type   , srcOrigin      :: SourceFile            -- ^ Source location at the time of its parsing   , srcModule      :: C.Module              -- ^ The parsed module.-  , srcModuleName  :: C.TopLevelModuleName  -- ^ The top-level module name.+  , srcModuleName  :: TopLevelModuleName    -- ^ The top-level module name.   , srcProjectLibs :: [AgdaLibFile]         -- ^ The .agda-lib file(s) of the project this file belongs to.+  , srcAttributes  :: !Attributes+    -- ^ Every encountered attribute.   }  -- | Parses a source file and prepares the 'Source' record.  parseSource :: SourceFile -> TCM Source-parseSource sourceFile@(SourceFile f) = Bench.billTo [Bench.Parsing] $ do-  source                <- runPM $ readFilePM f-  (parsedMod, fileType) <- runPM $-                           parseFile moduleParser f $ TL.unpack source-  parsedModName         <- moduleName f parsedMod-  libs <- getAgdaLibFiles $ takeDirectory $ filePath f+parseSource sourceFile = Bench.billTo [Bench.Parsing] $ do+  -- Issue #7303:+  -- The parser previously used mdo to avoid the duplicate parsing for the+  -- bootstrapping of the TopLevelModuleName in Range.+  -- But that made ranges blackholes during parsing,+  -- introducing regression #7301, fragility of the API as observed in #7492,+  -- and debugging headaches as ranges could not be showed during parsing.+  -- Now we bite the bullet to parse the source twice,+  -- until a better management of ranges comes about.+  --+  -- (E.g. it is unclear why ranges need the file name/id in place+  -- so early, as all the ranges from one file have the same file id.+  -- It would be sufficient to fill in the file name/id when the mixing+  -- with other files starts, e.g. during scope checking.)++  f <- srcFilePath sourceFile++  -- Read the source text.+  let rf0 = mkRangeFile f Nothing+  setCurrentRange (beginningOfFile rf0) do++  source <- runPM $ readFilePM rf0+  let txt = TL.unpack source++  -- Bootstrapping: parse the module name.+  parsedModName0 <- moduleName f . fst . fst =<< do+    runPMDropWarnings $ parseFile moduleParser rf0 txt++  -- Now parse again, with module name present to be filled into the ranges.+  let rf = mkRangeFile f $ Just parsedModName0+  ((parsedMod, attrs), fileType) <- runPM $ parseFile moduleParser rf txt+  parsedModName                  <- moduleName f parsedMod++  libs <- getAgdaLibFiles f parsedModName   return Source     { srcText        = source     , srcFileType    = fileType@@ -136,8 +182,44 @@     , srcModule      = parsedMod     , srcModuleName  = parsedModName     , srcProjectLibs = libs+    , srcAttributes  = attrs     } ++-- | Computes the module name of the top-level module in the given file.+--+-- If no top-level module name is given, then an attempt is made to+-- use the file name as a module name.++moduleName ::+     AbsolutePath+     -- ^ The path to the file.+  -> C.Module+     -- ^ The parsed module.+  -> TCM TopLevelModuleName+moduleName file parsedModule = Bench.billTo [Bench.ModuleName] $ do+  let defaultName = rootNameModule file+      raw         = rawTopLevelModuleNameForModule parsedModule+  topLevelModuleName =<< if isNoName raw+    then setCurrentRange (rangeFromAbsolutePath file) do+      m <- runPM (fst <$> parse moduleNameParser defaultName)+             `catchError` \_ ->+           typeError $ InvalidFileName file DoesNotCorrespondToValidModuleName+      case m of+        C.Qual{} ->+          typeError $ InvalidFileName file $+            RootNameModuleNotAQualifiedModuleName $ T.pack defaultName+        C.QName{} ->+          return $ RawTopLevelModuleName+            { rawModuleNameRange = getRange m+            , rawModuleNameParts = singleton (T.pack defaultName)+            , rawModuleNameInferred = True+                -- Andreas, 2025-06-21, issue #7953:+                -- Remember we made up this module name to improve errors.+            }+    else return raw++ srcDefaultPragmas :: Source -> [OptionsPragma] srcDefaultPragmas src = map _libPragmas (srcProjectLibs src) @@ -145,17 +227,22 @@ srcFilePragmas src = pragmas   where   cpragmas = C.modPragmas (srcModule src)-  pragmas = [ opts | C.OptionsPragma _ opts <- cpragmas ]--srcPragmas :: Source -> [OptionsPragma]-srcPragmas src = srcDefaultPragmas src ++ srcFilePragmas src+  pragmas = [ OptionsPragma+                { pragmaStrings = opts+                , pragmaRange   = r+                }+            | C.OptionsPragma r opts <- cpragmas+            ]  -- | Set options from a 'Source' pragma, using the source---   ranges of the pragmas for error reporting.-setOptionsFromSourcePragmas :: Source -> TCM ()-setOptionsFromSourcePragmas src =-  setCurrentRange (C.modPragmas . srcModule $ src) $-    mapM_ setOptionsFromPragma (srcPragmas src)+--   ranges of the pragmas for error reporting. Flag to check consistency.+setOptionsFromSourcePragmas :: Bool -> Source -> TCM ()+setOptionsFromSourcePragmas checkOpts src = do+  mapM_ setOpts (srcDefaultPragmas src)+  mapM_ setOpts (srcFilePragmas    src)+  where+    setOpts | checkOpts = checkAndSetOptionsFromPragma+            | otherwise = setOptionsFromPragma  -- | Is the aim to type-check the top-level module, or only to -- scope-check it?@@ -196,84 +283,126 @@ mergeInterface i = do     let sig     = iSignature i         builtin = Map.toAscList $ iBuiltin i-        prim    = [ x | (_,Prim x) <- builtin ]-        bi      = Map.fromDistinctAscList [ (x, Builtin t) | (x, Builtin t) <- builtin ]-                    -- Andreas, 2021-08-19: this seeming identity filters out the @Prim@s-                    -- and converts the type.+        primOrBi = \case+          (_, Prim x)                     -> Left x+          (x, Builtin t)                  -> Right (x, Builtin t)+          (x, BuiltinRewriteRelations xs) -> Right (x, BuiltinRewriteRelations xs)+        (prim, bi') = partitionEithers $ map primOrBi builtin+        bi      = Map.fromDistinctAscList bi'         warns   = iWarnings i     bs <- getsTC stBuiltinThings-    reportSLn "import.iface.merge" 10 "Merging interface"+    reportSLn "import.iface.merge" 10 $ "Merging interface " ++ prettyShow (iTopLevelModuleName i)     reportSLn "import.iface.merge" 20 $       "  Current builtins " ++ show (Map.keys bs) ++ "\n" ++       "  New builtins     " ++ show (Map.keys bi)-    let check b (Builtin x) (Builtin y)+    let check (BuiltinName b) (Builtin x) (Builtin y)               | x == y    = return ()               | otherwise = typeError $ DuplicateBuiltinBinding b x y+        check _ (BuiltinRewriteRelations xs) (BuiltinRewriteRelations ys) = return ()         check _ _ _ = __IMPOSSIBLE__     sequence_ $ Map.intersectionWithKey check bs bi-    addImportedThings sig bi+    addImportedThings+      sig+      (iMetaBindings i)+      bi       (iPatternSyns i)       (iDisplayForms i)       (iUserWarnings i)       (iPartialDefs i)       warns-    reportSLn "import.iface.merge" 20 $+      (iOpaqueBlocks i)+      (iOpaqueNames i)+    reportSLn "import.iface.merge" 50 $       "  Rebinding primitives " ++ show prim     mapM_ rebind prim-    whenJustM (optConfluenceCheck <$> pragmaOptions) $ \confChk -> do-      reportSLn "import.iface.confluence" 20 $ "  Checking confluence of imported rewrite rules"-      checkConfluenceOfRules confChk $ concat $ HMap.elems $ sig ^. sigRewriteRules+    whenJustM (optConfluenceCheck <$> pragmaOptions) \ confChk -> do+      let rews = concat $ HMap.elems $ sig ^. sigRewriteRules+      verboseS "import.iface.confluence" 20 do+        if null rews then reportSLn "" 1 $ "  No rewrite rules imported"+        else do+          reportSDoc "" 1 $ P.vcat $ map (P.nest 2) $+            "Checking confluence of imported rewrite rules" :+            map (("-" P.<+>) . prettyTCM . rewName) rews++      -- Andreas, 2025-06-28, PR #7934 and issue #7969:+      -- Global confluence checker requires rules to be sorted+      -- according to the generality of their lhs+      when (confChk == GlobalConfluenceCheck) $+        forM_ (nubOn id $ map rewHead rews) sortRulesOfSymbol+      checkConfluenceOfRules confChk rews     where         rebind (x, q) = do             PrimImpl _ pf <- lookupPrimitiveFunction x-            stImportedBuiltins `modifyTCLens` Map.insert x (Prim pf{ primFunName = q })+            stImportedBuiltins `modifyTCLens` Map.insert (someBuiltin x) (Prim pf{ primFunName = q })  addImportedThings   :: Signature-  -> BuiltinThings PrimFun+  -> RemoteMetaStore+  -> BuiltinThings   -> A.PatternSynDefns   -> DisplayForms-  -> Map A.QName Text      -- ^ Imported user warnings+  -> UserWarnings      -- ^ Imported user warnings   -> Set QName             -- ^ Name of imported definitions which are partial-  -> [TCWarning]+  -> Set TCWarning+  -> Map OpaqueId OpaqueBlock+  -> Map QName OpaqueId   -> TCM ()-addImportedThings isig ibuiltin patsyns display userwarn partialdefs warnings = do-  stImports              `modifyTCLens` \ imp -> unionSignatures [imp, isig]+addImportedThings isig metas ibuiltin patsyns display userwarn+                  partialdefs warnings oblock oid = do+  stImports              `modifyTCLens` \ imp -> unionSignature imp isig+  stImportedMetaStore    `modifyTCLens` HMap.union metas   stImportedBuiltins     `modifyTCLens` \ imp -> Map.union imp ibuiltin   stImportedUserWarnings `modifyTCLens` \ imp -> Map.union imp userwarn   stImportedPartialDefs  `modifyTCLens` \ imp -> Set.union imp partialdefs   stPatternSynImports    `modifyTCLens` \ imp -> Map.union imp patsyns   stImportedDisplayForms `modifyTCLens` \ imp -> HMap.unionWith (++) imp display-  stTCWarnings           `modifyTCLens` \ imp -> imp `List.union` warnings-  addImportedInstances isig---- | Scope checks the given module. A proper version of the module--- name (with correct definition sites) is returned.+  stTCWarnings           `modifyTCLens` \ imp -> Set.union imp warnings+  stOpaqueBlocks         `modifyTCLens` \ imp -> imp `Map.union` oblock+  stOpaqueIds            `modifyTCLens` \ imp -> imp `Map.union` oid -scopeCheckImport :: ModuleName -> TCM (ModuleName, Map ModuleName Scope)-scopeCheckImport x = do-    reportSLn "import.scope" 5 $ "Scope checking " ++ prettyShow x-    verboseS "import.scope" 10 $ do+-- | Scope checks the given module, generating an interface or retrieving an existing one.+--   Returns the module name and exported scope from the interface.+--+scopeCheckImport ::+     TopLevelModuleName+  -> TCM (ModuleName, Map ModuleName Scope)+scopeCheckImport top = do+    reportSLn "import.scope" 15 $ "Scope checking " ++ prettyShow top+    verboseS "import.scope" 30 $ do       visited <- prettyShow <$> getPrettyVisitedModules-      reportSLn "import.scope" 10 $ "  visited: " ++ visited+      reportSLn "import.scope" 30 $ "  visited: " ++ visited     -- Since scopeCheckImport is called from the scope checker,     -- we need to reimburse her account.-    i <- Bench.billTo [] $ getNonMainInterface (toTopLevelModuleName x) Nothing-    addImport x+    i <- Bench.billTo [] $ getNonMainInterface top Nothing+    addImport top +    -- Print list of imported modules in current state.+    verboseS "import.iface.imports" 10 do+      imports <- Set.toList <$> useTC stImportedModules+      reportSLn "import.iface.imports" 10 $ intercalate "\n" $+        unwords [prettyShow top, "added, all imports:"] :+        map (\ x -> unwords [ " ", "-", prettyShow x ]) imports++    -- Print list of transitively imported modules in current state.+    verboseS "import.iface.imports" 20 do+      imports <- Set.toList <$> useTC stImportedModulesTransitive+      reportSLn "import.iface.imports" 10 $ intercalate "\n" $+        unwords [prettyShow top, "added, all transitive imports:"] :+        map (\ x -> unwords [ " ", "-", prettyShow x ]) imports+     -- If that interface was supposed to raise a warning on import, do so.     whenJust (iImportWarning i) $ warning . UserWarning      -- let s = publicModules $ iInsideScope i     let s = iScope i-    return (iModuleName i `withRangesOfQ` mnameToConcrete x, s)+    return (iModuleName i, s)  -- | If the module has already been visited (without warnings), then -- its interface is returned directly. Otherwise the computation is -- used to find the interface and the computed interface is stored for -- potential later use. -alreadyVisited :: C.TopLevelModuleName ->+alreadyVisited :: TopLevelModuleName ->                   MainInterface ->                   PragmaOptions ->                   TCM ModuleInfo ->@@ -313,7 +442,7 @@     -- Check that imported options are compatible with current ones (issue #2487),     -- but give primitive modules a pass     -- compute updated warnings if needed-    wt <- fromMaybe ws <$> (getOptionsCompatibilityWarnings isMain isPrim currentOptions i)+    wt <- fromMaybe ws <$> getOptionsCompatibilityWarnings isMain isPrim currentOptions i      return mi { miWarnings = wt } @@ -325,13 +454,13 @@      -- Interfaces are not stored if we are only scope-checking, or     -- if any warnings were encountered.-    case (isMain, miWarnings mi) of+    case (isMain, null $ miWarnings mi) of       (MainInterface ScopeCheck, _) -> return ()-      (_, _:_)                      -> return ()+      (_, False)                    -> return ()       _                             -> storeDecodedModule mi      reportS "warning.import" 10-      [ "module: " ++ show (C.moduleNameParts x)+      [ "module: " ++ show (moduleNameParts x)       , "WarningOnImport: " ++ show (iImportWarning (miInterface mi))       ] @@ -350,7 +479,7 @@  -- | Flattened unidirectional pattern for 'CheckResult' for destructuring inside --   the 'ModuleInfo' field.-pattern CheckResult :: Interface -> [TCWarning] -> ModuleCheckMode -> Source -> CheckResult+pattern CheckResult :: Interface -> Set TCWarning -> ModuleCheckMode -> Source -> CheckResult pattern CheckResult { crInterface, crWarnings, crMode, crSource } <- CheckResult'     { crModuleInfo = ModuleInfo         { miInterface = crInterface@@ -383,42 +512,57 @@ typeCheckMain mode src = do   -- liftIO $ putStrLn $ "This is typeCheckMain " ++ prettyShow f   -- liftIO . putStrLn . show =<< getVerbosity++  -- For the main interface, we also remember the pragmas from the file+  setOptionsFromSourcePragmas True src++  -- Import the Agda.Primitive modules+  importPrimitiveModules++  -- Now do the type checking via getInterface.+  checkModuleName' (srcModuleName src) (srcOrigin src)++  mi <- getInterface (srcModuleName src) (MainInterface mode) (Just src)++  stCurrentModule `setTCLens'`+    Just ( iModuleName (miInterface mi)+         , iTopLevelModuleName (miInterface mi)+         )++  return $ CheckResult' mi src++-- Andreas, 2016-07-11, issue 2092+-- The error range should be set to the file with the wrong module name+-- not the importing one (which would be the default).+checkModuleName' :: TopLevelModuleName' Range -> SourceFile -> TCM ()+checkModuleName' m f =+  setCurrentRange m $ checkModuleName m f Nothing++-- | Import the primitive modules (unless --no-load-primitives).+importPrimitiveModules :: TCM ()+importPrimitiveModules = whenM (optLoadPrimitives <$> pragmaOptions) $ do   reportSLn "import.main" 10 "Importing the primitive modules."-  libdirPrim <- liftIO getPrimitiveLibDir+  libdirPrim <- useTC stPrimitiveLibDir   reportSLn "import.main" 20 $ "Library primitive dir = " ++ show libdirPrim   -- Turn off import-chasing messages.   -- We have to modify the persistent verbosity setting, since   -- getInterface resets the current verbosity settings to the persistent ones.+   bracket_ (getsTC Lens.getPersistentVerbosity) Lens.putPersistentVerbosity $ do-    Lens.modifyPersistentVerbosity (Trie.delete [])  -- set root verbosity to 0+    Lens.modifyPersistentVerbosity+      (Strict.Just . Trie.insert [] 0 . Strict.fromMaybe Trie.empty)+      -- set root verbosity to 0      -- We don't want to generate highlighting information for Agda.Primitive.     withHighlightingLevel None $-      forM_ (Set.map (libdirPrim </>) Lens.primitiveModules) $ \f -> do-        primSource <- parseSource (SourceFile $ mkAbsolute f)+      forM_ (map (filePath libdirPrim </>) $ Set.toList primitiveModules) \ f -> do+        sf <- srcFromPath (mkAbsolute f)+        primSource <- parseSource sf         checkModuleName' (srcModuleName primSource) (srcOrigin primSource)         void $ getNonMainInterface (srcModuleName primSource) (Just primSource)    reportSLn "import.main" 10 $ "Done importing the primitive modules." -  -- Now do the type checking via getInterface.-  checkModuleName' (srcModuleName src) (srcOrigin src)--  -- For the main interface, we also remember the pragmas from the file-  setOptionsFromSourcePragmas src--  mi <- getInterface (srcModuleName src) (MainInterface mode) (Just src)--  stCurrentModule `setTCLens` Just (iModuleName (miInterface mi))--  return $ CheckResult' mi src-  where-  checkModuleName' m f =-    -- Andreas, 2016-07-11, issue 2092-    -- The error range should be set to the file with the wrong module name-    -- not the importing one (which would be the default).-    setCurrentRange m $ checkModuleName m f Nothing- -- | Tries to return the interface associated to the given (imported) module. --   The time stamp of the relevant interface file is also returned. --   Calls itself recursively for the imports of the given module.@@ -428,24 +572,32 @@ --   Do not use this for the main file, use 'typeCheckMain' instead.  getNonMainInterface-  :: C.TopLevelModuleName+  :: TopLevelModuleName   -> Maybe Source      -- ^ Optional: the source code and some information about the source code.   -> TCM Interface getNonMainInterface x msrc = do+  mi <- getNonMainModuleInfo x msrc+  tcWarningsToError $ Set.toAscList $ miWarnings mi+  return (miInterface mi)++getNonMainModuleInfo+  :: TopLevelModuleName+  -> Maybe Source+     -- ^ Optional: the source code and some information about the source code.+  -> TCM ModuleInfo+getNonMainModuleInfo x msrc =   -- Preserve/restore the current pragma options, which will be mutated when loading   -- and checking the interface.-  mi <- bracket_ (useTC stPragmaOptions) (stPragmaOptions `setTCLens`) $-          getInterface x NotMainInterface msrc-  tcWarningsToError $ miWarnings mi-  return (miInterface mi)+  bracket_ (useTC stPragmaOptions) (stPragmaOptions `setTCLens`) $+           getInterface x NotMainInterface msrc  -- | A more precise variant of 'getNonMainInterface'. If warnings are -- encountered then they are returned instead of being turned into -- errors.  getInterface-  :: C.TopLevelModuleName+  :: TopLevelModuleName   -> MainInterface   -> Maybe Source      -- ^ Optional: the source code and some information about the source code.@@ -472,14 +624,16 @@           -- To prevent this, we register the connection in @ModuleToSource@ here,           -- where we have the correct spelling of the file name.           let file = srcOrigin src-          modifyTCLens stModuleToSource $ Map.insert x (srcFilePath file)+          modifyTCLens stModuleToSourceId $ Map.insert x file           pure file-      reportSLn "import.iface" 15 $ List.intercalate "\n" $ map ("  " ++)-        [ "module: " ++ prettyShow x-        , "file:   " ++ prettyShow file-        ]+      reportSDoc "import.iface" 15 do+        path <- srcFilePath file+        P.text $ List.intercalate "\n" $ map ("  " ++)+          [ "module: " ++ prettyShow x+          , "file:   " ++ prettyShow path+          ] -      reportSLn "import.iface" 10 $ "  Check for cycle"+      reportSLn "import.iface" 15 $ "  Check for cycle"       checkForImportCycle        -- -- Andreas, 2014-10-20 AIM XX:@@ -494,58 +648,76 @@       let recheck = \reason -> do             reportSLn "import.iface" 5 $ concat ["  ", prettyShow x, " is not up-to-date because ", reason, "."]             setCommandLineOptions . stPersistentOptions . stPersistentState =<< getTC-            case isMain of+            modl <- case isMain of               MainInterface _ -> createInterface x file isMain msrc               NotMainInterface -> createInterfaceIsolated x file msrc +            -- Ensure that the given module name matches the one in the file.+            let topLevelName = iTopLevelModuleName (miInterface modl)+            unless (topLevelName == x) do+              path <- srcFilePath file+              typeError $ OverlappingProjects path topLevelName x++            return modl+       either recheck pure stored +-- | If checking produced non-benign warnings, error out.+--+raiseNonFatalErrors :: (HasOptions m, MonadTCError m)+  => CheckResult  -- ^ E.g. obtained from 'typeCheckMain'.+  -> m ()+raiseNonFatalErrors result = do+  Set1.unlessNullM (applyFlagsToTCWarnings (crWarnings result)) $ \ ws ->+    typeError $ NonFatalErrors ws+ -- | Check if the options used for checking an imported module are --   compatible with the current options. Raises Non-fatal errors if --   not.-checkOptionsCompatible :: PragmaOptions -> PragmaOptions -> ModuleName -> TCM Bool+checkOptionsCompatible ::+  PragmaOptions -> PragmaOptions -> TopLevelModuleName -> TCM Bool checkOptionsCompatible current imported importedModule = flip execStateT True $ do-  reportSDoc "import.iface.options" 5 $ P.nest 2 $ "current options  =" P.<+> showOptions current-  reportSDoc "import.iface.options" 5 $ P.nest 2 $ "imported options =" P.<+> showOptions imported-  forM_ coinfectiveOptions $ \ (opt, optName) -> do-    unless (opt current `implies` opt imported) $ do-      put False-      warning (CoInfectiveImport optName importedModule)-  forM_ infectiveOptions $ \ (opt, optName) -> do-    unless (opt imported `implies` opt current) $ do+  reportSDoc "import.iface.options" 25 $ P.nest 2 $ "current options  =" P.<+> showOptions current+  reportSDoc "import.iface.options" 25 $ P.nest 2 $ "imported options =" P.<+> showOptions imported+  forM_ infectiveCoinfectiveOptions $ \opt -> do+    unless (icOptionOK opt current imported) $ do       put False-      warning (InfectiveImport optName importedModule)+      warning $+        (case icOptionKind opt of+           Infective   -> InfectiveImport+           Coinfective -> CoInfectiveImport)+        (icOptionWarning opt importedModule)   where-    implies :: Bool -> Bool -> Bool-    p `implies` q = p <= q--    showOptions opts = P.prettyList (map (\ (o, n) -> (P.text n <> ": ") P.<+> P.pretty (o opts))-                                 (coinfectiveOptions ++ infectiveOptions))-+  showOptions opts =+    P.prettyList $+    map (\opt -> (P.text (icOptionDescription opt) <> ": ") P.<+>+                 P.pretty (icOptionActive opt opts))+      infectiveCoinfectiveOptions  -- | Compare options and return collected warnings. -- | Returns `Nothing` if warning collection was skipped. -getOptionsCompatibilityWarnings :: MainInterface -> Bool -> PragmaOptions -> Interface -> TCM (Maybe [TCWarning])+getOptionsCompatibilityWarnings :: MainInterface -> Bool -> PragmaOptions -> Interface -> TCM (Maybe (Set TCWarning)) getOptionsCompatibilityWarnings isMain isPrim currentOptions i = runMaybeT $ exceptToMaybeT $ do   -- We're just dropping these reasons-for-skipping messages for now.   -- They weren't logged before, but they're nice for documenting the early returns.   when isPrim $     throwError "Options consistency checking disabled for always-available primitive module"-  whenM (lift $ checkOptionsCompatible currentOptions (iOptionsUsed i) (iModuleName i)) $+  whenM (lift $ checkOptionsCompatible currentOptions (iOptionsUsed i)+                  (iTopLevelModuleName i)) $     throwError "No warnings to collect because options were compatible"   lift $ getAllWarnings' isMain ErrorWarnings  -- | Try to get the interface from interface file or cache. -getStoredInterface-  :: C.TopLevelModuleName+getStoredInterface :: HasCallStack+  => TopLevelModuleName      -- ^ Module name of file we process.   -> SourceFile      -- ^ File we process.   -> Maybe Source   -> ExceptT String TCM ModuleInfo-getStoredInterface x file msrc = do+getStoredInterface x file@(SourceFile fi) msrc = do   -- Check whether interface file exists and is in cache   --  in the correct version (as testified by the interface file hash).   --@@ -570,7 +742,9 @@   -- is invalid, missing, or skipped for some other reason.   let checkSourceHashET ifaceH = do         sourceH <- case msrc of-                    Nothing -> liftIO $ hashTextFile (srcFilePath file)+                    Nothing -> do+                      path <- srcFilePath file+                      liftIO $ hashTextFile path                     Just src -> return $ hashText (srcText src)          unless (sourceH == ifaceH) $@@ -581,44 +755,15 @@          reportSLn "import.iface" 5 $ concat ["  ", prettyShow x, " is up-to-date."] -  -- Check if we have cached the module.-  cachedE <- runExceptT $ maybeToExceptT "the interface has not been decoded" $ MaybeT $-      lift $ getDecodedModule x--  case cachedE of-    -- If it's cached ignoreInterfaces has no effect;-    -- to avoid typechecking a file more than once.-    Right mi -> do-      (ifile, hashes) <- getIFileHashesET--      let ifp = filePath $ intFilePath ifile-      let i = miInterface mi--      -- Make sure the hashes match.-      let cachedIfaceHash = iFullHash i-      let fileIfaceHash = snd hashes-      unless (cachedIfaceHash == fileIfaceHash) $ do-        lift $ dropDecodedModule x-        reportSLn "import.iface" 50 $ "  cached hash = " ++ show cachedIfaceHash-        reportSLn "import.iface" 50 $ "  stored hash = " ++ show fileIfaceHash-        reportSLn "import.iface" 5 $ "  file is newer, re-reading " ++ ifp-        throwError $ concat-          [ "the cached interface hash (", show cachedIfaceHash, ")"-          , " does not match interface file (", show fileIfaceHash, ")"-          ]--      Bench.billTo [Bench.Deserialization] $ do-        checkSourceHashET (iSourceHash i)--        reportSLn "import.iface" 5 $ "  using stored version of " ++ (filePath $ intFilePath ifile)-        loadDecodedModule file mi--    Left whyNotCached -> withExceptT (\e -> concat [whyNotCached, " and ", e]) $ do+  let+    -- Load or reload the interface file, if possible.+    loadInterfaceFile whyNotCached =+      withExceptT (\e -> concat [whyNotCached, " and ", e]) $ do       whenM ignoreAllInterfaces $         throwError "we're ignoring all interface files"        whenM ignoreInterfaces $-        unlessM (lift $ Lens.isBuiltinModule (filePath $ srcFilePath file)) $+        whenNothingM (isBuiltinModule fi) $             throwError "we're ignoring non-builtin interface files"        (ifile, hashes) <- getIFileHashesET@@ -634,38 +779,86 @@           readInterface ifile          -- Ensure that the given module name matches the one in the file.-        let topLevelName = toTopLevelModuleName $ iModuleName i-        unless (topLevelName == x) $-          -- Andreas, 2014-03-27 This check is now done in the scope checker.-          -- checkModuleName topLevelName file-          lift $ typeError $ OverlappingProjects (srcFilePath file) topLevelName x+        let topLevelName = iTopLevelModuleName i+        unless (topLevelName == x) do+          path <- srcFilePath file+          lift $ typeError $ OverlappingProjects path topLevelName x -        isPrimitiveModule <- lift $ Lens.isPrimitiveModule (filePath $ srcFilePath file)+        isPrimitiveMod <- isPrimitiveModule fi          lift $ chaseMsg "Loading " x $ Just ifp         -- print imported warnings-        let ws = filter ((Strict.Just (srcFilePath file) ==) . tcWarningOrigin) (iWarnings i)-        unless (null ws) $ reportSDoc "warning" 1 $ P.vcat $ P.prettyTCM <$> ws+        reportWarningsForModule x $ iWarnings i          loadDecodedModule file $ ModuleInfo           { miInterface = i-          , miWarnings = []-          , miPrimitive = isPrimitiveModule+          , miWarnings = empty+          , miPrimitive = isPrimitiveMod           , miMode = ModuleTypeChecked           } +  -- Check if we have cached the module.+  cachedE <- runExceptT $ maybeToExceptT "the interface has not been decoded" $ MaybeT $+      lift $ getDecodedModule x +  case cachedE of+    Left whyNotCached -> loadInterfaceFile whyNotCached++    -- If it's cached ignoreInterfaces has no effect;+    -- to avoid typechecking a file more than once.+    Right mi -> do+      (ifile, hashes) <- getIFileHashesET++      let ifp = filePath $ intFilePath ifile+      let i = miInterface mi++      -- Make sure the hashes match.+      let cachedIfaceHash = iFullHash i+      let fileIfaceHash = snd hashes+      if cachedIfaceHash /= fileIfaceHash then do+        lift $ dropDecodedModule x+        reportSLn "import.iface" 50 $ "  cached hash = " ++ show cachedIfaceHash+        reportSLn "import.iface" 50 $ "  stored hash = " ++ show fileIfaceHash+        reportSLn "import.iface" 5 $ "  file is newer, re-reading " ++ ifp+        loadInterfaceFile $ concat+          [ "the cached interface hash (", show cachedIfaceHash, ")"+          , " does not match interface file (", show fileIfaceHash, ")"+          ]+       else Bench.billTo [Bench.Deserialization] $ do+        checkSourceHashET (iSourceHash i)++        reportSLn "import.iface" 5 $ "  using stored version of " ++ filePath (intFilePath ifile)+        loadDecodedModule file mi++-- | Report those given warnings that come from the given module.++reportWarningsForModule :: MonadDebug m => TopLevelModuleName -> Set TCWarning -> m ()+reportWarningsForModule x warns = do+  unlessNull (filter ((Strict.Just (Just x) ==) . fmap rangeFileName . tcWarningOrigin) $ Set.toAscList warns) \ ws ->+    alwaysReportSDoc "warning" 1 $ P.vsep $ map P.prettyTCM ws++-- | Check whether the loaded module is up-to-date+--   and merge into state if this is the case.+-- loadDecodedModule   :: SourceFile      -- ^ File we process.   -> ModuleInfo+     -- ^ The interface we loaded or created.   -> ExceptT String TCM ModuleInfo-loadDecodedModule file mi = do-  let fp = filePath $ srcFilePath file-  let i = miInterface mi+loadDecodedModule sf@(SourceFile fi) mi = do+  file <- srcFilePath sf+  let fp      = filePath file+  let i       = miInterface mi+  let imports = iImportedModules i+  let name    = iTopLevelModuleName i -  -- Check that it's the right version-  reportSLn "import.iface" 5 $ "  imports: " ++ prettyShow (iImportedModules i)+  -- Print imported modules.+  verboseS "import.iface.imports" 5 $ unless (null imports) $+    reportSLn "import.iface.imports" 5 $ intercalate "\n" $+      unwords [ prettyShow name, "imports:" ] :+      map (\ (x, hash) -> unwords [ " ", "-", prettyShow x, concat ["(hash: ", prettyShow hash, ")"] ])+        imports    -- We set the pragma options of the skipped file here, so that   -- we can check that they are compatible with those of the@@ -673,27 +866,18 @@   -- want the pragmas to apply to interactive commands in the UI.   -- Jesper, 2021-04-18: Check for changed options in library files!   -- (see #5250)-  libOptions <- lift $ getLibraryOptions $ takeDirectory fp+  libOptions <- lift $ getLibraryOptions file name   lift $ mapM_ setOptionsFromPragma (libOptions ++ iFilePragmaOptions i)    -- Check that options that matter haven't changed compared to-  -- current options (issue #2487)-  unlessM (lift $ Lens.isBuiltinModule fp) $ do-    currentOptions <- useTC stPragmaOptions-    let disagreements =-          [ optName | (opt, optName) <- restartOptions,-                      opt currentOptions /= opt (iOptionsUsed i) ]-    unless (null disagreements) $ do-      reportSLn "import.iface.options" 4 $ concat-        [ "  Changes in the following options in "-        , prettyShow fp-        , ", re-typechecking: "-        , prettyShow disagreements-        ]+  -- current options (issue #2487).+  whenNothingM (isBuiltinModule fi) do+    current <- useTC stPragmaOptions+    when (recheckBecausePragmaOptionsChanged (iOptionsUsed i) current) $       throwError "options changed" -  -- If any of the imports are newer we need to retype check-  badHashMessages <- fmap lefts $ forM (iImportedModules i) $ \(impName, impHash) -> runExceptT $ do+  -- If any of the imports are newer we need to re-typecheck.+  badHashMessages <- fmap lefts $ forM imports \ (impName, impHash) -> runExceptT do     reportSLn "import.iface" 30 $ concat ["Checking that module hash of import ", prettyShow impName, " matches ", prettyShow impHash ]     latestImpHash <- lift $ lift $ setCurrentRange impName $ moduleHash impName     reportSLn "import.iface" 30 $ concat ["Done checking module hash of import ", prettyShow impName]@@ -705,11 +889,11 @@    unlessNull badHashMessages (throwError . unlines) -  reportSLn "import.iface" 5 "  New module. Let's check it out."+  reportSLn "import.iface" 5 $ prettyShow name ++ ": interface is valid and can be merged into the state."   lift $ mergeInterface i   Bench.billTo [Bench.Highlighting] $     lift $ ifTopLevelAndHighlightingLevelIs NonInteractive $-      highlightFromInterface i file+      highlightFromInterface i sf    return mi @@ -721,7 +905,7 @@ --   in order to forget some state changes after successful type checking.  createInterfaceIsolated-  :: C.TopLevelModuleName+  :: TopLevelModuleName      -- ^ Module name of file we process.   -> SourceFile      -- ^ File we process.@@ -739,10 +923,13 @@       ds          <- getDecodedModules       opts        <- stPersistentOptions . stPersistentState <$> getTC       isig        <- useTC stImports+      metas       <- useTC stImportedMetaStore       ibuiltin    <- useTC stImportedBuiltins       display     <- useTC stImportsDisplayForms       userwarn    <- useTC stImportedUserWarnings       partialdefs <- useTC stImportedPartialDefs+      opaqueblk   <- useTC stOpaqueBlocks+      opaqueid    <- useTC stOpaqueIds       ipatsyns <- getPatternSynImports       ho       <- getInteractionOutputCallback       -- Every interface is treated in isolation. Note: Some changes to@@ -768,7 +955,8 @@                setInteractionOutputCallback ho                stModuleToSource `setTCLens` mf                setVisitedModules vs-               addImportedThings isig ibuiltin ipatsyns display userwarn partialdefs []+               addImportedThings isig metas ibuiltin ipatsyns display+                 userwarn partialdefs empty opaqueblk opaqueid                 r  <- createInterface x file NotMainInterface msrc                mf' <- useTC stModuleToSource@@ -790,7 +978,7 @@       -- NOTE: This attempts to type-check FOREVER if for some       -- reason it continually fails to validate interface.       let recheckOnError = \msg -> do-            reportSLn "import.iface" 1 $ "Failed to validate just-loaded interface: " ++ msg+            alwaysReportSLn "import.iface" 1 $ "Failed to validate just-loaded interface: " ++ msg             createInterfaceIsolated x file msrc        either recheckOnError pure validated@@ -800,15 +988,21 @@  chaseMsg   :: String               -- ^ The prefix, like @Checking@, @Finished@, @Loading @.-  -> C.TopLevelModuleName -- ^ The module name.+  -> TopLevelModuleName   -- ^ The module name.   -> Maybe String         -- ^ Optionally: the file name.   -> TCM () chaseMsg kind x file = do   indentation <- (`replicate` ' ') <$> asksTC (pred . length . envImportPath)+  traceImports <- optTraceImports <$> commandLineOptions   let maybeFile = caseMaybe file "." $ \ f -> " (" ++ f ++ ")."-      vLvl | kind == "Checking" = 1-           | otherwise          = 2-  reportSLn "import.chase" vLvl $ concat+      vLvl | kind == "Checking"+             && traceImports > 0 = 1+           | kind == "Finished"+             && traceImports > 1 = 1+           | List.isPrefixOf "Loading" kind+             && traceImports > 2 = 1+           | otherwise = 2+  alwaysReportSLn "import.chase" vLvl $ concat     [ indentation, kind, " ", prettyShow x, maybeFile ]  -- | Print the highlighting information contained in the given interface.@@ -818,10 +1012,11 @@   -> SourceFile      -- ^ The corresponding file.   -> TCM ()-highlightFromInterface i file = do-  reportSLn "import.iface" 5 $-    "Generating syntax info for " ++ filePath (srcFilePath file) ++-    " (read from interface)."+highlightFromInterface i sf = do+  reportSDoc "import.iface" 5 do+    file <- srcFilePath sf+    P.text $ "Generating syntax info for " ++ filePath file +++      " (read from interface)."   printHighlightingInfo KeepHighlighting (iHighlighting i)  -- | Read interface file corresponding to a module.@@ -848,7 +1043,7 @@   where     handler = \case       IOException _ _ e -> do-        reportSLn "" 0 $ "IO exception: " ++ show e+        alwaysReportSLn "" 0 $ "IO exception: " ++ show e         return Nothing   -- Work-around for file locking bug.                          -- TODO: What does this refer to? Please                          -- document.@@ -872,18 +1067,16 @@     -- [Old: Andreas, 2016-02-02 this causes issue #1804, so don't do it:]     -- Andreas, 2020-05-13, #1804, #4647: removed private declarations     -- only when we actually write the interface.-    let filteredIface = i { iInsideScope  = withoutPrivates $ iInsideScope i }+    let+      filteredIface = i { iInsideScope = withoutPrivates $ iInsideScope i }+    filteredIface <- pruneTemporaryInstances filteredIface     reportSLn "import.iface.write" 50 $       "Writing interface file with hash " ++ show (iFullHash filteredIface) ++ "."     encodedIface <- encodeFile fp filteredIface     reportSLn "import.iface.write" 5 "Wrote interface file."-#if __GLASGOW_HASKELL__ >= 804     fromMaybe __IMPOSSIBLE__ <$> (Bench.billTo [Bench.Deserialization] (decode encodedIface))-#else-    return filteredIface-#endif   `catchError` \e -> do-    reportSLn "" 1 $+    alwaysReportSLn "" 1 $       "Failed to write interface " ++ fp ++ "."     liftIO $       whenM (doesFileExist fp) $ removeFile fp@@ -897,47 +1090,55 @@ -- information.  createInterface-  :: C.TopLevelModuleName  -- ^ The expected module name.+  :: TopLevelModuleName    -- ^ The expected module name.   -> SourceFile            -- ^ The file to type check.   -> MainInterface         -- ^ Are we dealing with the main module?   -> Maybe Source      -- ^ Optional information about the source code.   -> TCM ModuleInfo-createInterface mname file isMain msrc = do-  let x = mname-  let fp = filePath $ srcFilePath file+createInterface mname sf@(SourceFile sfi) isMain msrc = do+  file <- srcFilePath sf+  let fp = filePath file   let checkMsg = case isMain of                    MainInterface ScopeCheck -> "Reading "                    _                        -> "Checking"       withMsgs = bracket_-       (chaseMsg checkMsg x $ Just fp)+       (chaseMsg checkMsg mname $ Just fp)        (const $ do ws <- getAllWarnings AllWarnings-                   let classified = classifyWarnings ws-                   let wa' = filter ((Strict.Just (srcFilePath file) ==) . tcWarningOrigin) (tcWarnings classified)-                   unless (null wa') $-                     reportSDoc "warning" 1 $ P.vcat $ P.prettyTCM <$> wa'-                   when (null (nonFatalErrors classified)) $ chaseMsg "Finished" x Nothing)+                   let classified = classifyWarnings $ Set.toAscList ws+                   reportWarningsForModule mname $ tcWarnings classified+                   when (null (nonFatalErrors classified)) $ chaseMsg "Finished" mname Nothing)    withMsgs $     Bench.billTo [Bench.TopModule mname] $-    localTC (\e -> e { envCurrentPath = Just (srcFilePath file) }) $ do+    localTC (\ e -> e { envCurrentPath = Just sfi }) do      let onlyScope = isMain == MainInterface ScopeCheck      reportSLn "import.iface.create" 5 $-      "Creating interface for " ++ prettyShow mname ++ "."+      "Creating interface for " ++ prettyShow mname ++ "..."     verboseS "import.iface.create" 10 $ do       visited <- prettyShow <$> getPrettyVisitedModules       reportSLn "import.iface.create" 10 $ "  visited: " ++ visited -    src <- maybe (parseSource file) pure msrc+    src <- maybe (parseSource sf) pure msrc -    let srcPath = srcFilePath $ srcOrigin src+    srcPath <- srcFilePath $ srcOrigin src      fileTokenInfo <- Bench.billTo [Bench.Highlighting] $-      generateTokenInfoFromSource srcPath (TL.unpack $ srcText src)+      generateTokenInfoFromSource+        (let !top = srcModuleName src in+         mkRangeFile srcPath (Just top))+        (TL.unpack $ srcText src)     stTokens `modifyTCLens` (fileTokenInfo <>) -    setOptionsFromSourcePragmas src+    -- Only check consistency if not main (we check consistency for the main module in+    -- `typeCheckMain`.+    let checkConsistency | MainInterface{} <- isMain = False+                         | otherwise                 = True+    setOptionsFromSourcePragmas checkConsistency src+    checkAttributes (srcAttributes src)+    syntactic <- optSyntacticEquality <$> pragmaOptions+    localTC (\env -> env { envSyntacticEqualityFuel = syntactic }) $ do      verboseS "import.iface.create" 15 $ do       nestingLevel      <- asksTC (pred . length . envImportPath)@@ -948,24 +1149,24 @@         ]      -- Scope checking.-    reportSLn "import.iface.create" 7 "Starting scope checking."+    reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Starting scope checking."     topLevel <- Bench.billTo [Bench.Scoping] $ do       let topDecls = C.modDecls $ srcModule src-      concreteToAbstract_ (TopLevel srcPath mname topDecls)-    reportSLn "import.iface.create" 7 "Finished scope checking."+      concreteToAbstract_ (TopLevel (srcOrigin src) mname topDecls)+    reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Finished scope checking."      let ds    = topLevelDecls topLevel         scope = topLevelScope topLevel      -- Highlighting from scope checker.-    reportSLn "import.iface.create" 7 "Starting highlighting from scope."+    reportSLn "import.iface.highlight" 15 $ prettyShow mname ++ ": Starting highlighting from scope."     Bench.billTo [Bench.Highlighting] $ do       -- Generate and print approximate syntax highlighting info.       ifTopLevelAndHighlightingLevelIs NonInteractive $         printHighlightingInfo KeepHighlighting fileTokenInfo       ifTopLevelAndHighlightingLevelIsOr NonInteractive onlyScope $         mapM_ (\ d -> generateAndPrintSyntaxInfo d Partial onlyScope) ds-    reportSLn "import.iface.create" 7 "Finished highlighting from scope."+    reportSLn "import.iface.highlight" 15 $ prettyShow mname ++ ": Finished highlighting from scope."       -- Type checking.@@ -988,12 +1189,12 @@      if onlyScope       then do-        reportSLn "import.iface.create" 7 "Skipping type checking."+        reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Skipping type checking."         cacheCurrentLog       else do-        reportSLn "import.iface.create" 7 "Starting type checking."+        reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Starting type checking."         Bench.billTo [Bench.Typing] $ mapM_ checkDeclCached ds `finally_` cacheCurrentLog-        reportSLn "import.iface.create" 7 "Finished type checking."+        reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Finished type checking."      -- Ulf, 2013-11-09: Since we're rethrowing the error, leave it up to the     -- code that handles that error to reset the state.@@ -1006,12 +1207,12 @@     unfreezeMetas      -- Profiling: Count number of metas.-    verboseS "profile.metas" 10 $ do-      MetaId n <- fresh-      tickN "metas" (fromIntegral n)+    whenProfile Profile.Metas $ do+      m <- fresh+      tickN "metas" (fromIntegral (metaId m))      -- Highlighting from type checker.-    reportSLn "import.iface.create" 7 "Starting highlighting from type info."+    reportSLn "import.iface.highlight" 15 $ prettyShow mname ++ ": Starting highlighting from type info."     Bench.billTo [Bench.Highlighting] $ do        -- Move any remaining token highlighting to stSyntaxInfo.@@ -1022,20 +1223,20 @@        -- Grabbing warnings and unsolved metas to highlight them       warnings <- getAllWarnings AllWarnings-      unless (null warnings) $ reportSDoc "import.iface.create" 20 $+      unless (null warnings) $ reportSDoc "import.iface.highlight" 20 $         "collected warnings: " <> prettyTCM warnings       unsolved <- getAllUnsolvedWarnings-      unless (null unsolved) $ reportSDoc "import.iface.create" 20 $+      unless (null unsolved) $ reportSDoc "import.iface.highlight" 20 $         "collected unsolved: " <> prettyTCM unsolved       let warningInfo =-            convert $ foldMap warningHighlighting $ unsolved ++ warnings+            Highlighting.convert $ foldMap warningHighlighting $ Set.fromList unsolved `Set.union` warnings        stSyntaxInfo `modifyTCLens` \inf -> (inf `mappend` toks) `mappend` warningInfo        whenM (optGenerateVimFile <$> commandLineOptions) $         -- Generate Vim file.         withScope_ scope $ generateVimFile $ filePath $ srcPath-    reportSLn "import.iface.create" 7 "Finished highlighting from type info."+    reportSLn "import.iface.create" 15 $ prettyShow mname ++ ": Finished highlighting from type info."      setScope scope     reportSLn "scope.top" 50 $ "SCOPE " ++ show scope@@ -1043,9 +1244,9 @@     -- TODO: It would be nice if unsolved things were highlighted     -- after every mutual block. -    openMetas           <- getOpenMetas+    openMetas <- getOpenMetas     unless (null openMetas) $ do-      reportSLn "import.metas" 10 "We have unsolved metas."+      reportSLn "import.metas" 10 $ prettyShow mname ++ ": We have unsolved metas."       reportSLn "import.metas" 10 =<< showGoals =<< getGoals      ifTopLevelAndHighlightingLevelIs NonInteractive printUnsolvedInfo@@ -1060,7 +1261,7 @@       -- We do not get here when checking the main module       -- (then includeStateChanges is True).       whenM (optAllowUnsolved <$> pragmaOptions) $ do-        reportSLn "import.iface.create" 7 "Turning unsolved metas (if any) into postulates."+        reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Turning unsolved metas (if any) into postulates."         withCurrentModule (scope ^. scopeCurrent) openMetasToPostulates         -- Clear constraints as they might refer to what         -- they think are open metas.@@ -1068,7 +1269,7 @@         stSleepingConstraints `setTCLens` []      -- Serialization.-    reportSLn "import.iface.create" 7 "Starting serialization."+    reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Starting serialization."     i <- Bench.billTo [Bench.Serialization, Bench.BuildInterface] $       buildInterface src topLevel @@ -1082,29 +1283,29 @@       | (q, def) <- HMap.toList $ iSignature i ^. sigDefinitions,         Function{ funCompiled = cc } <- [theDef def]       ]-    reportSLn "import.iface.create" 7 "Finished serialization."+    reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Finished serialization."      mallWarnings <- getAllWarnings' isMain ErrorWarnings -    reportSLn "import.iface.create" 7 "Considering writing to interface file."-    finalIface <- constructIScope <$> case (mallWarnings, isMain) of-      (_:_, _) -> do+    reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Considering writing to interface file."+    finalIface <- constructIScope <$> case (null mallWarnings, isMain) of+      (False, _) -> do         -- Andreas, 2018-11-15, re issue #3393         -- The following is not sufficient to fix #3393         -- since the replacement of metas by postulates did not happen.         -- -- | not (allowUnsolved && all (isUnsolvedWarning . tcWarning) allWarnings) -> do-        reportSLn "import.iface.create" 7 "We have warnings, skipping writing interface file."+        reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": We have warnings, skipping writing interface file."         return i-      ([], MainInterface ScopeCheck) -> do-        reportSLn "import.iface.create" 7 "We are just scope-checking, skipping writing interface file."+      (True, MainInterface ScopeCheck) -> do+        reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": We are just scope-checking, skipping writing interface file."         return i-      ([], _) -> Bench.billTo [Bench.Serialization] $ do-        reportSLn "import.iface.create" 7 "Actually calling writeInterface."+      (True, _) -> Bench.billTo [Bench.Serialization] $ do+        reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Actually calling writeInterface."         -- The file was successfully type-checked (and no warnings were         -- encountered), so the interface should be written out.-        ifile <- toIFile file+        ifile <- toIFile sf         serializedIface <- writeInterface ifile i-        reportSLn "import.iface.create" 7 "Finished writing to interface file."+        reportSLn "import.iface.create" 7 $ prettyShow mname ++ ": Finished writing to interface file."         return serializedIface      -- -- Restore the open metas, as we might continue in interaction mode.@@ -1112,20 +1313,20 @@     -- stMetaStore `setTCLens` savedMetaStore      -- Profiling: Print statistics.-    printStatistics 30 (Just mname) =<< getStatistics+    printStatistics (Just mname) =<< getStatistics      -- Get the statistics of the current module     -- and add it to the accumulated statistics.     localStatistics <- getStatistics     lensAccumStatistics `modifyTCLens` Map.unionWith (+) localStatistics-    verboseS "profile" 1 $ reportSLn "import.iface" 5 "Accumulated statistics."+    reportSLn "import.iface" 25 $ prettyShow mname ++ ": Added statistics to the accumulated statistics." -    isPrimitiveModule <- Lens.isPrimitiveModule (filePath srcPath)+    isPrimitiveMod <- isPrimitiveModule sfi      return ModuleInfo       { miInterface = finalIface       , miWarnings = mallWarnings-      , miPrimitive = isPrimitiveModule+      , miPrimitive = isPrimitiveMod       , miMode = moduleCheckMode isMain       } @@ -1133,7 +1334,7 @@ -- 'MainInterface', the warnings definitely include also unsolved -- warnings. -getAllWarnings' :: (MonadFail m, ReadTCState m, MonadWarning m) => MainInterface -> WhichWarnings -> m [TCWarning]+getAllWarnings' :: (ReadTCState m, MonadWarning m, MonadTCM m) => MainInterface -> WhichWarnings -> m (Set TCWarning) getAllWarnings' (MainInterface _) = getAllWarningsPreserving unsolvedWarnings getAllWarnings' NotMainInterface  = getAllWarningsPreserving Set.empty @@ -1148,8 +1349,7 @@   i{ iScope = publicModules $ iInsideScope i }  -- | Builds an interface for the current module, which should already--- have been successfully type checked.-+--   have been successfully type checked. buildInterface   :: Source      -- ^ 'Source' for the current module.@@ -1158,11 +1358,12 @@   -> TCM Interface buildInterface src topLevel = do     reportSLn "import.iface" 5 "Building interface..."-    let mname = topLevelModuleName topLevel+    let mname = CToA.topLevelModuleName topLevel         source   = srcText src         fileType = srcFileType src         defPragmas = srcDefaultPragmas src         filePragmas  = srcFilePragmas src+     -- Andreas, 2014-05-03: killRange did not result in significant reduction     -- of .agdai file size, and lost a few seconds performance on library-test.     -- Andreas, Makoto, 2014-10-18 AIM XX: repeating the experiment@@ -1173,56 +1374,78 @@     -- that introduced this change seems to have made Agda a bit     -- faster and interface file sizes a bit smaller, at least for the     -- standard library).-    builtin     <- useTC stLocalBuiltins-    ms          <- getImports-    mhs         <- mapM (\ m -> (m,) <$> moduleHash m) $ Set.toList ms-    foreignCode <- useTC stForeignCode-    -- Ulf, 2016-04-12:-    -- Non-closed display forms are not applicable outside the module anyway,-    -- and should be dead-code eliminated (#1928).-    origDisplayForms <- HMap.filter (not . null) . HMap.map (filter isClosed) <$> useTC stImportsDisplayForms-    -- TODO: Kill some ranges?-    (display, sig) <- eliminateDeadCode origDisplayForms =<< getSignature-    userwarns      <- useTC stLocalUserWarnings-    importwarn     <- useTC stWarningOnImport-    syntaxInfo     <- useTC stSyntaxInfo-    optionsUsed    <- useTC stPragmaOptions-    partialDefs    <- useTC stLocalPartialDefs+    !mhs <- mapM (\top -> (top,) <$> moduleHash top) . Set.toAscList =<< useR stImportedModules+    !foreignCode <- useTC stForeignCode +    let !scope = topLevelScope topLevel++    (!solvedMetas, !definitions, !displayForms) <- eliminateDeadCode scope+    !sig <- set sigDefinitions definitions <$> getSignature+     -- Andreas, 2015-02-09 kill ranges in pattern synonyms before     -- serialization to avoid error locations pointing to external files     -- when expanding a pattern synonym.-    patsyns <- killRange <$> getPatternSyns-    let builtin' = Map.mapWithKey (\ x b -> (x,) . primFunName <$> b) builtin-    warnings <- getAllWarnings AllWarnings-    reportSLn "import.iface" 7 "  instantiating all meta variables"-    -- Note that the meta-variables in the definitions in "sig" have-    -- already been instantiated (by eliminateDeadCode).-    i <- instantiateFullExceptForDefinitions Interface-      { iSourceHash      = hashText source-      , iSource          = source-      , iFileType        = fileType-      , iImportedModules = mhs-      , iModuleName      = mname-      , iScope           = empty -- publicModules scope-      , iInsideScope     = topLevelScope topLevel-      , iSignature       = sig-      , iDisplayForms    = display-      , iUserWarnings    = userwarns-      , iImportWarning   = importwarn-      , iBuiltin         = builtin'-      , iForeignCode     = foreignCode-      , iHighlighting    = syntaxInfo-      , iDefaultPragmaOptions = defPragmas-      , iFilePragmaOptions    = filePragmas-      , iOptionsUsed     = optionsUsed-      , iPatternSyns     = patsyns-      , iWarnings        = warnings-      , iPartialDefs     = partialDefs-      }+    !patsyns <- killRange <$> getPatternSyns++    !userwarns   <- useTC stLocalUserWarnings+    !importwarn  <- useTC stWarningOnImport+    !syntaxInfo  <- useTC stSyntaxInfo+    !optionsUsed <- useTC stPragmaOptions+    !partialDefs <- useTC stLocalPartialDefs++    -- Only serialise the opaque blocks actually defined in this+    -- top-level module.+    !opaqueBlocks' <- useTC stOpaqueBlocks+    !opaqueIds' <- useTC stOpaqueIds+    let+      !mh = moduleNameId (srcModuleName src)+      !opaqueBlocks = Map.filterWithKey (\(OpaqueId _ mod) _ -> mod == mh) opaqueBlocks'+      isLocal qnm = case nameId (qnameName qnm) of+        NameId _ mh' -> mh' == mh+      !opaqueIds = Map.filterWithKey (\qnm (OpaqueId _ mod) -> isLocal qnm || mod == mh) opaqueIds'++    !builtin  <- Map.mapWithKey (\ x b -> primName x <$> b) <$> useTC stLocalBuiltins+    !warnings <- Set.filter (isSourceCodeWarning . warningName . tcWarning) <$> getAllWarnings AllWarnings++    let !i = Interface+          { iSourceHash           = hashText source+          , iSource               = source+          , iFileType             = fileType+          , iImportedModules      = mhs+          , iModuleName           = mname+          , iTopLevelModuleName   = srcModuleName src+          , iScope                = empty -- publicModules scope+          , iInsideScope          = scope+          , iSignature            = sig+          , iMetaBindings         = solvedMetas+          , iDisplayForms         = displayForms+          , iUserWarnings         = userwarns+          , iImportWarning        = importwarn+          , iBuiltin              = builtin+          , iForeignCode          = foreignCode+          , iHighlighting         = syntaxInfo+          , iDefaultPragmaOptions = defPragmas+          , iFilePragmaOptions    = filePragmas+          , iOptionsUsed          = optionsUsed+          , iPatternSyns          = patsyns+          , iWarnings             = warnings+          , iPartialDefs          = partialDefs+          , iOpaqueBlocks         = opaqueBlocks+          , iOpaqueNames          = opaqueIds+          }+    !i <-+      ifM (optSaveMetas <$> pragmaOptions)+        (return i)+        (do reportSLn "import.iface" 7+              "  instantiating all metavariables in interface"+            Bench.billTo [Bench.InterfaceInstantiateFull] $ liftReduce $ instantiateFull' i)     reportSLn "import.iface" 7 "  interface complete"     return i +    where+      primName (PrimitiveName x) b = (x, primFunName b)+      primName (BuiltinName x)   b = __IMPOSSIBLE__+ -- | Returns (iSourceHash, iFullHash) --   We do not need to check that the file exist because we only --   accept @InterfaceFile@ as an input and not arbitrary @AbsolutePath@!@@ -1234,5 +1457,5 @@   maybe 0 (uncurry (+)) hs `seq` close   return hs -moduleHash :: ModuleName -> TCM Hash-moduleHash m = iFullHash <$> getNonMainInterface (toTopLevelModuleName m) Nothing+moduleHash :: TopLevelModuleName -> TCM Hash+moduleHash m = iFullHash <$> getNonMainInterface m Nothing
src/full/Agda/Interaction/Imports.hs-boot view
@@ -1,10 +1,12 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Interaction.Imports where -import Data.Map                     ( Map )+import Data.Map                       ( Map ) -import Agda.Syntax.Abstract.Name    ( ModuleName )-import Agda.Syntax.Scope.Base       ( Scope )-import Agda.TypeChecking.Monad.Base ( TCM )+import Agda.Syntax.Abstract.Name      ( ModuleName )+import Agda.Syntax.Scope.Base         ( Scope )+import Agda.Syntax.TopLevelModuleName ( TopLevelModuleName )+import Agda.TypeChecking.Monad.Base   ( TCM ) -scopeCheckImport :: ModuleName -> TCM (ModuleName, Map ModuleName Scope)+scopeCheckImport :: TopLevelModuleName -> TCM (ModuleName, Map ModuleName Scope)
src/full/Agda/Interaction/InteractionTop.hs view
@@ -13,33 +13,30 @@ import Control.Concurrent.Async import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TVar- import qualified Control.Exception  as E -import Control.Monad import Control.Monad.Except         ( MonadError(..), ExceptT(..), runExceptT ) import Control.Monad.IO.Class       ( MonadIO(..) )-import Control.Monad.Fail           ( MonadFail ) import Control.Monad.State          ( MonadState(..), gets, modify, runStateT ) import Control.Monad.STM-import Control.Monad.Trans          ( lift )+import Control.Monad.State          ( StateT )  import qualified Data.Char as Char-import Data.Function+import Data.Function (on) import qualified Data.List as List import qualified Data.Map as Map+import qualified Data.Set as Set import Data.Maybe  import System.Directory import System.FilePath  import Agda.TypeChecking.Monad as TCM-  hiding (initState, setCommandLineOptions)-import qualified Agda.TypeChecking.Monad as TCM import qualified Agda.TypeChecking.Pretty as TCP-import Agda.TypeChecking.Rules.Term (checkExpr, isType_) import Agda.TypeChecking.Errors-import Agda.TypeChecking.Warnings (runPM)+import Agda.TypeChecking.Opacity (saturateOpaqueBlocks)+import Agda.TypeChecking.Rules.Term (checkExpr, isType_)+import Agda.TypeChecking.Warnings (warning)  import Agda.Syntax.Fixity import Agda.Syntax.Position@@ -51,10 +48,13 @@ import Agda.Syntax.Abstract.Pretty import Agda.Syntax.Info (mkDefInfo) import Agda.Syntax.Translation.ConcreteToAbstract-import Agda.Syntax.Translation.AbstractToConcrete hiding (withScope)+import Agda.Syntax.Translation.AbstractToConcrete+import Agda.Syntax.Translation.InternalToAbstract (reify) import Agda.Syntax.Scope.Base+import Agda.Syntax.TopLevelModuleName  import Agda.Interaction.Base+import Agda.Interaction.ExitCode (pattern TCMError, exitAgdaWith) import Agda.Interaction.FindFile import Agda.Interaction.Options import Agda.Interaction.Options.Lenses as Lenses@@ -66,71 +66,34 @@ import Agda.Interaction.Highlighting.Precise hiding (Error, Postulate, singleton) import Agda.Interaction.Imports  ( Mode, pattern ScopeCheck, pattern TypeCheck ) import qualified Agda.Interaction.Imports as Imp+import Agda.Interaction.Command+  (CommandM, liftLocalState, revLift, revLiftTC, localStateCommandM) import Agda.Interaction.Highlighting.Generate  import Agda.Compiler.Backend -import Agda.Auto.Auto as Auto+import Agda.Mimer.Mimer as Mimer+import qualified Control.DeepSeq as DeepSeq  import Agda.Utils.Either import Agda.Utils.FileName import Agda.Utils.Function import Agda.Utils.Hash+import Agda.Utils.IO (showIOException) import Agda.Utils.Lens import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Pretty hiding (Mode)+import Agda.Syntax.Common.Pretty hiding (Mode)+import qualified Agda.Utils.ProfileOptions as Profile import Agda.Utils.Singleton import Agda.Utils.String import Agda.Utils.Time import Agda.Utils.Tuple+import Agda.Utils.WithDefault (lensCollapseDefault, lensKeepDefault)  import Agda.Utils.Impossible ---------------------------------------------------------------------------- The CommandM monad---- | Restore both 'TCState' and 'CommandState'.--localStateCommandM :: CommandM a -> CommandM a-localStateCommandM m = do-  cSt <- get-  tcSt <- getTC-  x <- m-  putTC tcSt-  put cSt-  return x---- | Restore 'TCState', do not touch 'CommandState'.--liftLocalState :: TCM a -> CommandM a-liftLocalState = lift . localTCState---- | Build an opposite action to 'lift' for state monads.--revLift-    :: MonadState st m-    => (forall c . m c -> st -> k (c, st))      -- ^ run-    -> (forall b . k b -> m b)                  -- ^ lift-    -> (forall x . (m a -> k x) -> k x) -> m a  -- ^ reverse lift in double negative position-revLift run lift' f = do-    st <- get-    (a, st') <- lift' $ f (`run` st)-    put st'-    return a--revLiftTC-    :: MonadTCState m-    => (forall c . m c -> TCState -> k (c, TCState))  -- ^ run-    -> (forall b . k b -> m b)                        -- ^ lift-    -> (forall x . (m a -> k x) -> k x) -> m a        -- ^ reverse lift in double negative position-revLiftTC run lift' f = do-    st <- getTC-    (a, st') <- lift' $ f (`run` st)-    putTC st'-    return a- -- | Opposite of 'liftIO' for 'CommandM'. -- -- This function should only be applied to computations that are@@ -183,7 +146,7 @@ getOldInteractionScope ii = do   ms <- gets $ Map.lookup ii . oldInteractionScopes   case ms of-    Nothing    -> fail $ "not an old interaction point: " ++ show ii+    Nothing    -> __IMPOSSIBLE_VERBOSE__ $ "not an old interaction point: " ++ show ii     Just scope -> return scope  -- | Do setup and error handling for a command.@@ -230,16 +193,18 @@     -- AsyncCancelled, which is used to abort Agda.     handleNastyErrors :: CommandM () -> CommandM ()     handleNastyErrors m = commandMToIO $ \ toIO -> do-      let handle e =-            Right <$>-              toIO (handleErr (Just Direct) $-                        Exception noRange $ text $ show e) -          asyncHandler e@AsyncCancelled = return (Left e)+      let asyncHandler e@AsyncCancelled = return (Left e) -          generalHandler (e :: E.SomeException) = handle e+          ioHandler (e :: E.IOException) = Right <$> do+            toIO $ handleErr (Just Direct) $ IOException Nothing noRange e -      r <- ((Right <$> toIO m) `E.catch` asyncHandler)+          generalHandler (e :: E.SomeException) = Right <$> do+            toIO $ handleErr (Just Direct) $ GenericException $ showIOException e++      r <- (Right <$> toIO m)+             `E.catch` asyncHandler+             `E.catch` ioHandler              `E.catch` generalHandler       case r of         Right x -> return x@@ -249,6 +214,11 @@     -- error. Because this function may switch the focus to another file     -- the status information is also updated.     handleErr method e = do++      -- TODO: make a better predicate for this+      noError <- lift $ null <$> renderError e+      unless noError do+         unsolved <- lift $ computeUnsolvedInfo         err     <- lift $ errorHighlighting e         modFile <- lift $ useTC stModuleToSource@@ -258,12 +228,10 @@         let info = convert $ err <> unsolved                      -- Errors take precedence over unsolved things. -        -- TODO: make a better predicate for this-        noError <- lift $ null <$> prettyError e-         showImpl <- lift $ optShowImplicit <$> useTC stPragmaOptions         showIrr <- lift $ optShowIrrelevant <$> useTC stPragmaOptions-        unless noError $ mapM_ putResponse $+        do+          mapM_ putResponse $             [ Resp_DisplayInfo $ Info_Error $ Info_GenericError e ] ++             tellEmacsToJumpToError (getRange e) ++             [ Resp_HighlightingInfo info KeepHighlighting@@ -272,6 +240,8 @@                                    , sShowImplicitArguments = showImpl                                    , sShowIrrelevantArguments = showIrr                                    } ]+          whenM (optExitOnError <$> commandLineOptions) $+            liftIO $ exitAgdaWith TCMError  -- | Run an 'IOTCM' value, catch the exceptions, emit output --@@ -280,15 +250,17 @@ --   loaded interfaces for example).  runInteraction :: IOTCM -> CommandM ()-runInteraction (IOTCM current highlighting highlightingMethod cmd) =+runInteraction iotcm =   handleCommand inEmacs onFail $ do     currentAbs <- liftIO $ absolute current-    -- Raises an error if the given file is not the one currently-    -- loaded.-    cf <- gets theCurrentFile-    when (not (independent cmd) && Just currentAbs /= (currentFilePath <$> cf)) $ do+    cf  <- gets theCurrentFile+    cmd <- if independent cmd then return cmd else do+      when (Just currentAbs /= (currentFilePath <$> cf)) $ do         let mode = TypeCheck         cmd_load' current [] True mode $ \_ -> return ()+      cf <- fromMaybe __IMPOSSIBLE__ <$> gets theCurrentFile+      return $ case iotcm (Just (currentFileModule cf)) of+        IOTCM _ _ _ cmd -> cmd      withCurrentFile $ interpret cmd @@ -299,6 +271,10 @@         putResponse . Resp_InteractionPoints =<< gets theInteractionPoints    where+    -- The ranges in cmd might be incorrect because of the use of+    -- Nothing here. That is taken care of above.+    IOTCM current highlighting highlightingMethod cmd = iotcm Nothing+     inEmacs :: forall a. CommandM a -> CommandM a     inEmacs = liftCommandMT $ withEnv $ initEnv             { envHighlightingLevel  = highlighting@@ -337,28 +313,22 @@       tcState <- getTC       tcEnv   <- askTC       result  <- liftIO $ race-                   (runTCM tcEnv tcState $ runStateT (m c) commandState)+                   (runTCM tcEnv tcState $+                    runStateT (m c) commandState)                    (waitForAbort n q)       case result of         Left ((x, commandState'), tcState') -> do           putTC tcState'           put commandState'-          case c of+          case c Nothing of             IOTCM _ _ _ Cmd_exit -> do               putResponse Resp_DoneExiting               return Done             _ -> return (Command (Just x))         Right a -> do           liftIO $ popAbortedCommands q a-          putTC $ initState-            { stPersistentState = stPersistentState tcState-            , stPreScopeState   =-                (stPreScopeState initState)-                  { stPrePragmaOptions =-                      stPrePragmaOptions-                        (stPreScopeState tcState)-                  }-            }+          putTC $ set lensPragmaOptions (tcState ^. lensPragmaOptions) $+            initStateFromPersistentState $ stPersistentState tcState           put $ (initCommandState (commandQueue commandState))             { optionsOnReload = optionsOnReload commandState             }@@ -420,7 +390,7 @@       readCommands n = do         c <- next         case c of-          Command (IOTCM _ _ _ Cmd_abort) -> do+          Command c | IOTCM _ _ _ Cmd_abort <- c Nothing -> do             atomically $ writeTVar abort (Just n)             readCommands n           _ -> do@@ -441,6 +411,7 @@  independent :: Interaction -> Bool independent (Cmd_load {})                   = True+independent Cmd_load_no_metas{}             = True independent (Cmd_compile {})                = True independent (Cmd_load_highlighting_info {}) = True independent Cmd_tokenHighlighting {}        = True@@ -453,8 +424,11 @@ updateInteractionPointsAfter :: Interaction -> Bool updateInteractionPointsAfter Cmd_load{}                          = True updateInteractionPointsAfter Cmd_compile{}                       = True+updateInteractionPointsAfter Cmd_backend_top{}                   = True+updateInteractionPointsAfter Cmd_backend_hole{}                  = True updateInteractionPointsAfter Cmd_constraints{}                   = False updateInteractionPointsAfter Cmd_metas{}                         = False+updateInteractionPointsAfter Cmd_load_no_metas{}                 = False updateInteractionPointsAfter Cmd_show_module_contents_toplevel{} = False updateInteractionPointsAfter Cmd_search_about_toplevel{}         = False updateInteractionPointsAfter Cmd_solveAll{}                      = True@@ -493,6 +467,13 @@  -- | Interpret an interaction +getBackendName :: CompilerBackend -> BackendName+getBackendName = \case+  LaTeX -> "LaTeX"+  QuickLaTeX -> "LaTeX"+  OtherBackend "GHCNoMain" -> "GHC"+  OtherBackend b -> b+ interpret :: Interaction -> CommandM ()  interpret (Cmd_load m argv) =@@ -502,28 +483,39 @@  interpret (Cmd_compile backend file argv) =   cmd_load' file argv allowUnsolved mode $ \ checkResult -> do-    mw <- lift $ applyFlagsToTCWarnings $ crWarnings checkResult-    case mw of-      [] -> do-        lift $ case backend of-          LaTeX                    -> callBackend "LaTeX" IsMain checkResult-          QuickLaTeX               -> callBackend "LaTeX" IsMain checkResult-          OtherBackend "GHCNoMain" -> callBackend "GHC" NotMain checkResult   -- for backwards compatibility-          OtherBackend b           -> callBackend b IsMain checkResult+    ws <- lift $ applyFlagsToTCWarnings $ crWarnings checkResult+    case null ws of+      True -> do+        lift $ callBackend (getBackendName backend) isMain checkResult         display_info . Info_CompilationOk backend =<< lift B.getWarningsAndNonFatalErrors-      w@(_:_) -> display_info $ Info_Error $ Info_CompilationError w+      False -> display_info $ Info_Error $ Info_CompilationError ws   where   allowUnsolved = backend `elem` [LaTeX, QuickLaTeX]   mode | QuickLaTeX <- backend = ScopeCheck        | otherwise             = TypeCheck+  isMain | OtherBackend "GHCNoMain" <- backend = NotMain+         | otherwise                           = IsMain +interpret (Cmd_backend_top backend cmd) =+  callBackendInteractTop (getBackendName backend) cmd++interpret (Cmd_backend_hole ii rng s backend cmd) =+  callBackendInteractHole (getBackendName backend) cmd ii rng s+ interpret Cmd_constraints =-    display_info . Info_Constraints =<< lift B.getConstraints+  display_info . Info_Constraints =<< lift B.getConstraints  interpret (Cmd_metas norm) = do   ms <- lift $ B.getGoals' norm (max Simplified norm)   display_info . Info_AllGoalsWarnings ms =<< lift B.getWarningsAndNonFatalErrors +interpret (Cmd_load_no_metas file) = do+  -- Fail if there are open metas.+  let allowMetas = False+  cmd_load' file [] allowMetas TypeCheck $ \ result -> do+    Imp.raiseNonFatalErrors result+    unlessM (null <$> getOpenMetas) __IMPOSSIBLE__+ interpret (Cmd_show_module_contents_toplevel norm s) =   atTopLevel $ showModuleContents norm noRange s @@ -565,28 +557,22 @@ interpret (ShowImplicitArgs showImpl) = do   opts <- lift commandLineOptions   setCommandLineOpts $-    opts { optPragmaOptions =-             (optPragmaOptions opts) { optShowImplicit = showImpl } }+    set (lensPragmaOptions . lensOptShowImplicit . lensKeepDefault) showImpl opts  interpret ToggleImplicitArgs = do   opts <- lift commandLineOptions-  let ps = optPragmaOptions opts   setCommandLineOpts $-    opts { optPragmaOptions =-             ps { optShowImplicit = not $ optShowImplicit ps } }+    over (lensPragmaOptions . lensOptShowImplicit . lensCollapseDefault) not opts  interpret (ShowIrrelevantArgs showIrr) = do   opts <- lift commandLineOptions   setCommandLineOpts $-    opts { optPragmaOptions =-             (optPragmaOptions opts) { optShowIrrelevant = showIrr } }+    set (lensPragmaOptions . lensOptShowIrrelevant . lensKeepDefault) showIrr opts  interpret ToggleIrrelevantArgs = do   opts <- lift commandLineOptions-  let ps = optPragmaOptions opts   setCommandLineOpts $-    opts { optPragmaOptions =-             ps { optShowIrrelevant = not $ optShowIrrelevant ps } }+    over (lensPragmaOptions . lensOptShowIrrelevant . lensCollapseDefault) not opts  interpret (Cmd_load_highlighting_info source) = do   l <- asksTC envHighlightingLevel@@ -596,7 +582,7 @@     setCommandLineOpts =<< lift commandLineOptions     resp <- lift $ liftIO . tellToUpdateHighlighting =<< do       ex        <- liftIO $ doesFileExist source-      absSource <- liftIO $ SourceFile <$> absolute source+      absSource <- srcFromPath =<< liftIO (absolute source)       if ex         then            do@@ -677,55 +663,45 @@   let s' = trim s   in (if null s' then Cmd_intro pmLambda else Cmd_refine) ii r s' -interpret (Cmd_autoOne ii rng hint) = do-  -- Andreas, 2014-07-05 Issue 1226:-  -- Save the state to have access to even those interaction ids-  -- that Auto solves (since Auto gives the solution right away).-  st <- getTC-  (time , res) <- maybeTimed $ Auto.auto ii rng hint-  case autoProgress res of-   Solutions sols -> do-    lift $ reportSLn "auto" 10 $ "Auto produced the following solutions " ++ show sols-    forM_ sols $ \(ii', sol) -> do-      -- Andreas, 2014-07-05 Issue 1226:-      -- For highlighting, Resp_GiveAction needs to access-      -- the @oldInteractionScope@s of the interaction points solved by Auto.-      -- We dig them out from the state before Auto was invoked.-      insertOldInteractionScope ii' =<< liftLocalState (putTC st >> getInteractionScope ii')-      -- Andreas, 2014-07-07: NOT TRUE:-      -- -- Andreas, 2014-07-05: The following should be obsolete,-      -- -- as Auto has removed the interaction points already:-      -- modifyTheInteractionPoints $ filter (/= ii)-      putResponse $ Resp_GiveAction ii' $ Give_String sol-    -- Andreas, 2014-07-07: Remove the interaction points in one go.-    modifyTheInteractionPoints (List.\\ (map fst sols))-    case autoMessage res of-     Nothing  -> interpret $ Cmd_metas AsIs-     Just msg -> display_info $ Info_Auto msg-   FunClauses cs -> do-    case autoMessage res of-     Nothing  -> return ()-     Just msg -> display_info $ Info_Auto msg-    putResponse $ Resp_MakeCase ii R.Function cs-   Refinement s -> give_gen WithoutForce ii rng s Refine-  maybe (return ()) (display_info . Info_Time) time+interpret (Cmd_autoOne norm ii rng str) = do+  iscope <- getInteractionScope ii+  (time, result) <- maybeTimed $ Mimer.mimer norm ii rng str+  case result of+    MimerNoResult -> display_info $ Info_Auto "No solution found"+    MimerExpr str -> do+      insertOldInteractionScope ii iscope+      _ <- lift $ B.parseExprIn ii rng str >>= B.give WithForce ii (Just rng)+      putResponse $ Resp_GiveAction ii $ Give_String str+      modifyTheInteractionPoints (List.delete ii)+      maybe (return ()) (display_info . Info_Time) time+    MimerList sols -> do+      display_info $ Info_Auto $ unlines $+        [ "Solutions:" ] +++        [ "  " ++ show i ++ ". " ++ s | (i, s) <- sols ]+    MimerClauses{} -> __IMPOSSIBLE__    -- Mimer can't do case splitting yet -interpret Cmd_autoAll = do+interpret (Cmd_autoAll norm) = do   iis <- getInteractionPoints+  getOldScope <- do+    st <- getTC+    pure $ \ ii -> liftLocalState $ putTC st >> getInteractionScope ii   unless (null iis) $ do     let time = 1000 `div` length iis     st <- getTC-    solved <- forM iis $ \ ii -> do+    solved <- fmap concat $ forM iis $ \ ii -> do       rng <- getInteractionRange ii-      res <- Auto.auto ii rng ("-t " ++ show time ++ "ms")-      case autoProgress res of-        Solutions sols -> forM sols $ \ (jj, s) -> do-            oldInteractionScope <- liftLocalState (putTC st >> getInteractionScope jj)-            insertOldInteractionScope jj oldInteractionScope-            putResponse $ Resp_GiveAction ii $ Give_String s-            return jj-        _ -> return []-    modifyTheInteractionPoints (List.\\ concat solved)+      res <- Mimer.mimer norm ii rng ("-t " ++ show time ++ "ms")+      case res of+        MimerNoResult -> pure []+        MimerExpr str -> do+          iscope <- getOldScope ii+          insertOldInteractionScope ii iscope+          _ <- liftTCM $ B.parseExprIn ii rng str >>= B.give WithoutForce ii (Just rng)+          putResponse $ Resp_GiveAction ii $ Give_String str+          pure [ii]+        MimerList{} -> pure []    -- Don't list solutions in autoAll+        MimerClauses{} -> __IMPOSSIBLE__  -- Mimer can't do case splitting yet+    modifyTheInteractionPoints (List.\\ solved)  interpret (Cmd_context norm ii _ _) =   display_info . Info_Context ii =<< liftLocalState (B.getResponseContext norm ii)@@ -755,21 +731,21 @@   aux <- if all Char.isSpace s             then return GoalOnly             else do-              typ <- liftLocalState-                    $ withInteractionId ii-                    $ B.typeInMeta ii norm =<< B.parseExprIn ii rng s-              return (GoalAndHave typ)+              liftLocalState $ withInteractionId ii $ do+                parsed <- B.parseExprIn ii rng s+                (typ, faces) <- B.typeAndFacesInMeta ii norm parsed+                return (GoalAndHave typ faces)   cmd_goal_type_context_and aux norm ii rng s  interpret (Cmd_goal_type_context_check norm ii rng s) = do-  term <- liftLocalState $ withInteractionId ii $ do+  expr <- liftLocalState $ withInteractionId ii $ do     expr <- B.parseExprIn ii rng s     goal <- B.typeOfMeta AsIs ii     term <- case goal of       OfType _ ty -> checkExpr expr =<< isType_ ty       _           -> __IMPOSSIBLE__-    B.normalForm norm term-  cmd_goal_type_context_and (GoalAndElaboration term) norm ii rng s+    reify =<< B.normalForm norm term+  cmd_goal_type_context_and (GoalAndElaboration expr) norm ii rng s  interpret (Cmd_show_module_contents norm ii rng s) =   liftCommandMT (withInteractionId ii) $ showModuleContents norm rng s@@ -785,7 +761,7 @@   liftCommandMT (withInteractionId ii) $ do     tel <- lift $ lookupSection (qnameModule f) -- don't shadow the names in this telescope     unicode <- getsTC $ optUseUnicode . getPragmaOptions-    pcs      :: [Doc]      <- lift $ inTopContext $ addContext tel $ mapM prettyA cs+    pcs      :: [Doc]      <- lift $ inTopContext $ addContext tel $ mapM prettyAUnqualify cs     let pcs' :: [String]    = List.map (extlam_dropName unicode casectxt . decorate) pcs     lift $ reportSDoc "interaction.case" 60 $ TCP.vcat       [ "InteractionTop.Cmd_make_case"@@ -802,26 +778,8 @@         ]       ]     putResponse $ Resp_MakeCase ii (makeCaseVariant casectxt) pcs'-  where-    decorate = renderStyle (style { mode = OneLineMode }) -    makeCaseVariant :: CaseContext -> MakeCaseVariant-    makeCaseVariant Nothing = R.Function-    makeCaseVariant Just{}  = R.ExtendedLambda -    -- very dirty hack, string manipulation by dropping the function name-    -- and replacing the last " = " with " -> ". It's important not to replace-    -- the equal sign in named implicit with an arrow!-    extlam_dropName :: UnicodeOrAscii -> CaseContext -> String -> String-    extlam_dropName _ Nothing x = x-    extlam_dropName glyphMode Just{}  x-        = unwords $ reverse $ replEquals $ reverse $ drop 1 $ words x-      where-        arrow = render $ _arrow $ specialCharactersForGlyphs glyphMode-        replEquals ("=" : ws) = arrow : ws-        replEquals (w   : ws) = w : replEquals ws-        replEquals []         = []- interpret (Cmd_compute cmode ii rng s) = do   expr <- liftLocalState $ do     e <- B.parseExprIn ii rng $ B.computeWrapInput cmode s@@ -833,6 +791,27 @@ interpret Cmd_abort = return () interpret Cmd_exit  = return () ++decorate :: Doc -> String+decorate = renderStyle (style { mode = OneLineMode })++makeCaseVariant :: CaseContext -> MakeCaseVariant+makeCaseVariant Nothing = R.Function+makeCaseVariant Just{}  = R.ExtendedLambda++-- very dirty hack, string manipulation by dropping the function name+-- and replacing the last " = " with " -> ". It's important not to replace+-- the equal sign in named implicit with an arrow!+extlam_dropName :: UnicodeOrAscii -> CaseContext -> String -> String+extlam_dropName _ Nothing x = x+extlam_dropName glyphMode Just{}  x+    = unwords $ reverse $ replEquals $ reverse $ drop 1 $ words x+  where+    arrow = render $ _arrow $ specialCharactersForGlyphs glyphMode+    replEquals ("=" : ws) = arrow : ws+    replEquals (w   : ws) = w : replEquals ws+    replEquals []         = []+ -- | Solved goals already instantiated internally -- The second argument potentially limits it to one specific goal. solveInstantiatedGoals :: Rewrite -> Maybe InteractionId -> CommandM ()@@ -846,7 +825,7 @@   putResponse $ Resp_SolveAll out   where       prt (i, m, e) = do-        mi <- getMetaInfo <$> lookupMeta m+        mi <- getMetaInfo <$> lookupLocalMeta m         e' <- withMetaInfo mi $ abstractToConcreteCtx TopCtx e         return (i, e') @@ -867,18 +846,12 @@                -- ^ Continuation after successful loading.   -> CommandM a cmd_load' file argv unsolvedOK mode cmd = do-    fp <- liftIO $ absolute file-    ex <- liftIO $ doesFileExist $ filePath fp-    unless ex $ typeError $ GenericError $-      "The file " ++ file ++ " was not found."      -- Forget the previous "current file" and interaction points.     modify $ \ st -> st { theInteractionPoints = []                         , theCurrentFile       = Nothing                         } -    t <- liftIO $ getModificationTime file-     -- Update the status. Because the "current file" is not set the     -- status is not "Checked".     displayStatus@@ -898,7 +871,16 @@     -- Parse the file.     --     -- Note that options are set below.-    src <- lift $ Imp.parseSource (SourceFile fp)+    fp  <- liftIO $ absolute file+    sf  <- liftTCM $ srcFromPath fp+    src <- lift $ Imp.parseSource sf+    -- Andreas, 2024-08-03, see test/interaction/FileNotFound:+    -- Run 'getModificationTime' after 'parseSource',+    -- otherwise the user gets a weird error for non-existing files.+    -- (We assume that parsing is fast in comparison to type-checking,+    -- so it should not matter much whether we get the time stamp+    -- before or after parsing.)+    t   <- liftIO $ getModificationTime file      -- Store the warnings.     warnings <- useTC stTCWarnings@@ -907,17 +889,18 @@     -- choice of whether or not to display implicit arguments.     opts0 <- gets optionsOnReload     backends <- useTC stBackends-    z <- runOptM $ parseBackendOptions backends argv opts0+    let (z, warns) = runOptM $ parseBackendOptions backends argv opts0+    mapM_ (lift . warning . OptionWarning) warns     case z of-      Left err   -> lift $ typeError $ GenericError err+      Left err -> lift $ typeError $ OptionError err       Right (_, opts) -> do         opts <- lift $ addTrustedExecutables opts-        let update o = o { optAllowUnsolved = unsolvedOK && optAllowUnsolved o}-            root     = projectRoot fp $ Imp.srcModuleName src+        let update = over (lensOptAllowUnsolved . lensKeepDefault) (unsolvedOK &&)+            root   = projectRoot fp $ Imp.srcModuleName src         lift $ TCM.setCommandLineOptions' root $ mapPragmaOptions update opts      -- Restore the warnings that were saved above.-    modifyTCLens stTCWarnings (++ warnings)+    modifyTCLens stTCWarnings $ Set.union warnings      ok <- lift $ Imp.typeCheckMain mode src @@ -928,7 +911,12 @@     when (t == t') $ do       is <- lift $ sortInteractionPoints =<< getInteractionPoints       modify $ \st -> st { theInteractionPoints = is-                         , theCurrentFile       = Just $ CurrentFile fp argv t+                         , theCurrentFile       = Just $ CurrentFile+                             { currentFilePath   = fp+                             , currentFileModule = Imp.srcModuleName src+                             , currentFileArgs   = argv+                             , currentFileStamp  = t+                             }                          }      cmd ok@@ -937,7 +925,8 @@ withCurrentFile :: CommandM a -> CommandM a withCurrentFile m = do   mfile <- gets $ fmap currentFilePath . theCurrentFile-  localTC (\ e -> e { envCurrentPath = mfile }) m+  i <- traverse idFromFile mfile+  localTC (\ e -> e { envCurrentPath = i }) m  atTopLevel :: CommandM a -> CommandM a atTopLevel cmd = liftCommandMT B.atTopLevel cmd@@ -1002,6 +991,13 @@       [ "ce = " ++ show ce       , "scopePrecedence = " ++ show (scope ^. scopePrecedence)       ]++    -- Issue 7218: if the give/refine command creates an extended+    -- lambda, it also needs to be added to the relevant unfolding sets.+    -- The easiest way to make sure this is consistent is to just re-run+    -- the saturation procedures.+    saturateOpaqueBlocks+     -- if the command was @Give@, use the literal user input;     -- Andreas, 2014-01-15, see issue 1020:     -- Refine could solve a goal by introducing the sole constructor@@ -1050,7 +1046,7 @@ -- | Sorts interaction points based on their ranges.  sortInteractionPoints-  :: (MonadInteractionPoints m, MonadError TCErr m, MonadFail m)+  :: (MonadInteractionPoints m, MonadError TCErr m, MonadDebug m)   => [InteractionId] -> m [InteractionId] sortInteractionPoints is =   map fst . List.sortBy (compare `on` snd) <$> do@@ -1091,10 +1087,10 @@  whyInScope :: String -> CommandM () whyInScope s = do-  Just (CurrentFile file _ _) <- gets theCurrentFile-  let cwd = takeDirectory (filePath file)-  (v, xs, ms) <- liftLocalState (B.whyInScope s)-  display_info $ Info_WhyInScope s cwd v xs ms+  Just file <- gets theCurrentFile+  let cwd = takeDirectory (filePath $ currentFilePath file)+  why <- liftLocalState $ B.whyInScope cwd s+  display_info $ Info_WhyInScope why  -- | Sets the command line options and updates the status information. @@ -1118,16 +1114,13 @@   -- changed since. Note: This code does not check if any dependencies   -- have changed, and uses a time stamp to check for changes.   checked  <- lift $ case cf of-    Nothing     -> return False-    Just (CurrentFile f _ t) -> do-      t' <- liftIO $ getModificationTime $ filePath f-      if t == t'+    Nothing -> return False+    Just f  -> do+      t <- liftIO $ getModificationTime $ filePath (currentFilePath f)+      if currentFileStamp f == t         then-          do-            mm <- lookupModuleFromSource f-            case mm of-              Nothing -> return False -- work-around for Issue1007-              Just m  -> maybe False (null . miWarnings) <$> getVisitedModule m+          maybe False (null . miWarnings) <$>+          getVisitedModule (currentFileModule f)         else             return False @@ -1164,13 +1157,14 @@   -> CommandM (Maybe CPUTime, a) parseAndDoAtToplevel cmd s = do   localStateCommandM $ do-    e <- lift $ runPM $ parse exprParser s+    (e, attrs) <- lift $ runPM $ parse exprParser s+    lift $ checkAttributes attrs     maybeTimed $ atTopLevel $ lift $       cmd =<< concreteToAbstract_ e  maybeTimed :: CommandM a -> CommandM (Maybe CPUTime, a) maybeTimed work = do-  doTime <- lift $ hasVerbosity "profile.interactive" 10+  doTime <- lift $ hasProfileOption Profile.Interactive   if not doTime     then (Nothing,) <$> work     else do@@ -1194,4 +1188,4 @@     Nothing                                           -> []     Just (Pn { srcFile = Strict.Nothing })            -> []     Just (Pn { srcFile = Strict.Just f, posPos = p }) ->-       [ Resp_JumpToError (filePath f) p ]+       [ Resp_JumpToError (filePath (rangeFilePath f)) p ]
src/full/Agda/Interaction/JSON.hs view
@@ -21,7 +21,7 @@ #endif  import Data.Text (Text)-import GHC.Int (Int32)+import Data.Word (Word32)  -- import qualified Agda.Syntax.Translation.InternalToAbstract as I2A -- import qualified Agda.Syntax.Translation.AbstractToConcrete as A2C@@ -29,7 +29,7 @@ -- import qualified Agda.Syntax.Concrete as C -- import qualified Agda.Syntax.Internal as I import Agda.TypeChecking.Monad-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import qualified Agda.Utils.FileName as File import qualified Agda.Utils.Maybe.Strict as Strict @@ -124,11 +124,11 @@ -- overlaps with the instance declared above instance {-# OVERLAPPING #-} EncodeTCM String -instance EncodeTCM Bool where-instance EncodeTCM Int where-instance EncodeTCM Int32 where-instance EncodeTCM Value where-instance EncodeTCM Doc where+instance EncodeTCM Bool+instance EncodeTCM Int+instance EncodeTCM Word32+instance EncodeTCM Value+instance EncodeTCM Doc  instance ToJSON Doc where   toJSON = toJSON . render
src/full/Agda/Interaction/JSONTop.hs view
@@ -2,8 +2,10 @@     ( jsonREPL     ) where -import Control.Monad          ( (<=<), forM )-import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad+         ( (<=<), forM )+import Control.Monad.IO.Class+         ( MonadIO(..) )  import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Char8 as BS@@ -12,31 +14,50 @@  import Agda.Interaction.AgdaTop import Agda.Interaction.Base-  (CommandState(..), CurrentFile(..), ComputeMode(..), Rewrite(..), OutputForm(..), OutputConstraint(..))+         ( CommandState(..), CurrentFile(..), ComputeMode(..), Rewrite(..)+         , OutputConstraint_boot(..), OutputForm_boot(..))+import Agda.Interaction.Output (OutputConstraint, OutputForm) import qualified Agda.Interaction.BasicOps as B import Agda.Interaction.EmacsTop import Agda.Interaction.JSON import Agda.Interaction.Response as R import Agda.Interaction.Highlighting.JSON-import Agda.Syntax.Abstract.Pretty (prettyATop)++import Agda.Syntax.Abstract.Pretty+         ( prettyATop ) import Agda.Syntax.Common import qualified Agda.Syntax.Concrete as C-import Agda.Syntax.Concrete.Name (NameInScope(..), Name)-import Agda.Syntax.Internal (telToList, Dom'(..), Dom, MetaId(..), ProblemId(..), Blocker(..), alwaysUnblock)-import Agda.Syntax.Position (Range, rangeIntervals, Interval'(..), Position'(..), noRange)-import Agda.VersionCommit+import Agda.Syntax.Concrete.Name+         ( NameInScope(..), Name )+import Agda.Syntax.Internal+         ( telToList, Dom'(..), Dom, MetaId(..), ProblemId(..), Blocker(..), alwaysUnblock )+import Agda.Syntax.Position+         ( Range, rangeIntervals, Interval'(..), Position'(..), noRange )+import Agda.Syntax.Scope.Base+         ( WhyInScopeData(..) ) -import Agda.TypeChecking.Errors (getAllWarningsOfTCErr)-import Agda.TypeChecking.Monad (Comparison(..), inTopContext, TCM, TCErr, TCWarning, NamedMeta(..), withInteractionId)-import Agda.TypeChecking.Monad.MetaVars (getInteractionRange, getMetaRange, withMetaId)-import Agda.TypeChecking.Pretty (PrettyTCM(..), prettyTCM)+import Agda.TypeChecking.Errors+         ( getAllWarningsOfTCErr )+import Agda.TypeChecking.Monad+         ( Comparison(..), inTopContext, TCM, TCErr, TCWarning, NamedMeta(..), withInteractionId )+import Agda.TypeChecking.Monad.MetaVars+         ( getInteractionRange, getMetaRange, withMetaId )+import Agda.TypeChecking.Pretty+         ( PrettyTCM(..), prettyTCM ) -- borrowed from EmacsTop, for temporarily serialising stuff-import Agda.TypeChecking.Pretty.Warning (filterTCWarnings)-import Agda.TypeChecking.Warnings (WarningsAndNonFatalErrors(..))-import Agda.Utils.Pretty (Pretty(..))-import qualified Agda.Utils.Pretty as P-import Agda.Utils.Time (CPUTime(..))+import Agda.TypeChecking.Pretty.Warning+         ( filterTCWarnings )+import Agda.TypeChecking.Warnings+         ( WarningsAndNonFatalErrors(..) ) +import qualified Agda.Syntax.Common.Pretty as P+import Agda.Syntax.Common.Pretty+         ( Pretty(..), prettyShow )+import Agda.Utils.Time+         ( CPUTime(..) )++import Agda.VersionCommit+ --------------------------------------------------------------------------------  -- | 'jsonREPL' is a interpreter like 'mimicGHCi', but outputs JSON-encoded strings.@@ -70,7 +91,7 @@  instance EncodeTCM CurrentFile where instance ToJSON CurrentFile where-  toJSON (CurrentFile path _ time) = toJSON (path, time)  -- backwards compat.+  toJSON (CurrentFile path _ _ time) = toJSON (path, time)  -- backwards compat.  instance EncodeTCM ResponseContextEntry where   encodeTCM entry = obj@@ -91,14 +112,22 @@ instance EncodeTCM Range where instance ToJSON Range where   toJSON = toJSON . map prettyInterval . rangeIntervals-    where prettyInterval i = object [ "start" .= iStart i, "end" .= iEnd i ]+    where prettyInterval (Interval f s e) = object [ "start" .= (f <$ s), "end" .= (f <$ e) ]  instance EncodeTCM ProblemId where instance EncodeTCM MetaId    where  instance ToJSON ProblemId where toJSON (ProblemId i) = toJSON i-instance ToJSON MetaId    where toJSON (MetaId    i) = toJSON i +instance ToJSON ModuleNameHash where+  toJSON (ModuleNameHash h) = toJSON h++instance ToJSON MetaId where+  toJSON m = object+    [ "id"     .= toJSON (metaId m)+    , "module" .= toJSON (metaModule m)+    ]+ instance EncodeTCM InteractionId where   encodeTCM ii@(InteractionId i) = obj     [ "id"    @= toJSON i@@ -215,6 +244,9 @@           [ "value"  #= encPrettyTCM v           , "type"   #= encPrettyTCM t           ]+ ResolveInstanceOF q -> kind "ResolveInstanceOF"+  [ "name"           @= encodePretty q+  ]  PTSInstance a b -> kind "PTSInstance"   [ "constraintObjs" #= traverse f [a, b]   ]@@ -223,6 +255,10 @@   , "type"           #= encPrettyTCM a   , "error"          #= encodeTCM err   ]+ DataSort q s -> kind "DataSort"+  [ "name"           @= encodePretty q+  , "sort"           #= f s+  ]  CheckLock t lk -> kind "CheckLock"   [ "head"           #= f t   , "lock"           #= f lk@@ -249,24 +285,32 @@ instance EncodeTCM Blocker where   encodeTCM (UnblockOnMeta x)    = kind "UnblockOnMeta" [ "meta" @= x ]   encodeTCM (UnblockOnProblem p) = kind "UnblockOnProblem" [ "id" @= p ]+  encodeTCM (UnblockOnDef q)     = kind "UnblockOnDef" [ "name" @= encodePretty q ]   encodeTCM (UnblockOnAll us)    = kind "UnblockOnAll" [ "blockers" @= Set.toList us ]   encodeTCM (UnblockOnAny us)    = kind "UnblockOnAny" [ "blockers" @= Set.toList us ]  instance EncodeTCM DisplayInfo where-  encodeTCM (Info_CompilationOk backend wes) = kind "CompilationOk"-    [ "backend"           @= encodePretty backend-    , "warnings"          #= encodeTCM (filterTCWarnings (tcWarnings wes))-    , "errors"            #= encodeTCM (filterTCWarnings (nonFatalErrors wes))-    ]+  encodeTCM :: DisplayInfo -> TCM Value+  encodeTCM (Info_CompilationOk backend wes) = do+    ws <- filterTCWarnings (tcWarnings wes)+    es <- filterTCWarnings (nonFatalErrors wes)+    kind "CompilationOk"+      [ "backend"           @= encodePretty backend+      , "warnings"          #= encodeTCM ws+      , "errors"            #= encodeTCM es+      ]   encodeTCM (Info_Constraints constraints) = kind "Constraints"     [ "constraints"       #= forM constraints encodeTCM     ]-  encodeTCM (Info_AllGoalsWarnings (vis, invis) wes) = kind "AllGoalsWarnings"-    [ "visibleGoals"      #= forM vis (\i -> withInteractionId (B.outputFormId $ OutputForm noRange [] alwaysUnblock i) $ encodeOC encodeTCM encodePrettyTCM i)-    , "invisibleGoals"    #= forM invis (encodeOC encodeTCM encodePrettyTCM)-    , "warnings"          #= encodeTCM (filterTCWarnings (tcWarnings wes))-    , "errors"            #= encodeTCM (filterTCWarnings (nonFatalErrors wes))-    ]+  encodeTCM (Info_AllGoalsWarnings (vis, invis) wes) = do+    ws <- filterTCWarnings (tcWarnings wes)+    es <- filterTCWarnings (nonFatalErrors wes)+    kind "AllGoalsWarnings"+      [ "visibleGoals"      #= forM vis (\i -> withInteractionId (B.outputFormId $ OutputForm noRange [] alwaysUnblock i) $ encodeOC encodeTCM encodePrettyTCM i)+      , "invisibleGoals"    #= forM invis (encodeOC encodeTCM encodePrettyTCM)+      , "warnings"          #= encodeTCM ws+      , "errors"            #= encodeTCM es+      ]   encodeTCM (Info_Time time) = kind "Time"     [ "time"              @= time     ]@@ -288,7 +332,7 @@       encodeDomType dom = obj         [ "dom"       #= encodePrettyTCM (unDom dom)         , "name"      @= fmap encodePretty (bareNameOf dom)-        , "finite"    @= toJSON (domFinite dom)+        , "finite"    @= toJSON (domIsFinite dom)         , "cohesion"  @= encodeShow (modCohesion . argInfoModality $ domInfo dom)         , "relevance" @= encodeShow (modRelevance . argInfoModality $ domInfo dom)         , "hiding"    @= case argInfoHiding $ domInfo dom of@@ -299,11 +343,11 @@     [ "results"           #= forM results encodeNamedPretty     , "search"            @= toJSON search     ]-  encodeTCM (Info_WhyInScope thing path v xs ms) = kind "WhyInScope"-    [ "thing"             @= thing+  encodeTCM (Info_WhyInScope why@(WhyInScopeData y path _ _ _)) = kind "WhyInScope"+    [ "thing"             @= prettyShow y     , "filepath"          @= toJSON path     -- use Emacs message first-    , "message"           #= explainWhyInScope thing path v xs ms+    , "message"           #= explainWhyInScope why     ]   encodeTCM (Info_NormalForm commandState computeMode time expr) = kind "NormalForm"     [ "commandState"      @= commandState@@ -330,10 +374,10 @@  instance EncodeTCM GoalTypeAux where   encodeTCM GoalOnly = kind "GoalOnly" []-  encodeTCM (GoalAndHave expr) = kind "GoalAndHave"+  encodeTCM (GoalAndHave expr _) = kind "GoalAndHave"     [ "expr" #= encodePrettyTCM expr ]-  encodeTCM (GoalAndElaboration term) = kind "GoalAndElaboration"-    [ "term" #= encodePrettyTCM term ]+  encodeTCM (GoalAndElaboration expr) = kind "GoalAndElaboration"+    [ "term" #= encodePrettyTCM expr ]  encodeGoalSpecific :: InteractionId -> GoalDisplayInfo -> TCM Value encodeGoalSpecific ii = go@@ -362,11 +406,13 @@     ]  instance EncodeTCM Info_Error where-  encodeTCM (Info_GenericError err) = kind "Error"-    [ "warnings"          #= (getAllWarningsOfTCErr err-                            >>= encodeTCM . filterTCWarnings)-    , "error"             #= encodeTCM err-    ]+  encodeTCM :: Info_Error -> TCM Value+  encodeTCM (Info_GenericError err) = do+    ws <- filterTCWarnings =<< getAllWarningsOfTCErr err+    kind "Error"+      [ "warnings"          #= encodeTCM ws+      , "error"             #= encodeTCM err+      ]   encodeTCM err = kind "Error"     [ "warnings"          @= ([] :: [String])     , "error"             #= obj@@ -425,8 +471,11 @@     where       encodeSolution (i, expr) = object         [ "interactionPoint"  .= i-        , "expression"        .= show expr+        , "expression"        .= P.prettyShow expr         ]+  encodeTCM (Resp_Mimer ii str) = kind "Mimer"+    [ "solution" @= str+    ]  -- | Convert Response to an JSON value for interactive editor frontends. jsonifyResponse :: Response -> TCM ByteString
src/full/Agda/Interaction/Library.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Library management. -- --   Sample use:@@ -22,9 +25,15 @@   , getInstalledLibraries   , getTrustedExecutables   , libraryIncludePaths-  , getAgdaLibFiles'+  , getAgdaLibFile   , getPrimitiveLibDir-  , LibName+  , classifyBuiltinModule_+  , builtinModules+  , builtinModulesWithSafePostulates+  , builtinModulesWithUnsafePostulates+  , primitiveModules+  , LibName, parseLibName+  , OptionsPragma(..)   , AgdaLibFile(..)   , ExeName   , LibM@@ -34,67 +43,55 @@   , libraryWarningName   , ProjectConfig(..)   -- * Exported for testing-  , VersionView(..), versionView, unVersionView   , findLib'   ) where -import Control.Arrow          ( first , second )-import Control.Monad          ( filterM, forM )-import Control.Monad.Except-import Control.Monad.State-import Control.Monad.Writer+import qualified Control.Exception as E+import Control.Monad.Except   ( runExceptT, MonadError, throwError )+import Control.Monad.Writer   ( Writer, runWriterT, tell ) import Control.Monad.IO.Class ( MonadIO(..) ) -import Data.Char-import Data.Data ( Data )+import Data.Bifunctor ( second ) import Data.Either-import Data.Function+import Data.Function (on)+import qualified Data.List as List import Data.Map ( Map ) import qualified Data.Map as Map-import Data.Maybe ( catMaybes, fromMaybe )-import qualified Data.List as List+import Data.Set ( Set )+import qualified Data.Set as Set import qualified Data.Text as T  import System.Directory import System.FilePath-import System.Environment+import System.IO.Error ( isPermissionError )  import Agda.Interaction.Library.Base import Agda.Interaction.Library.Parse-import Agda.Interaction.Options.Warnings +import Agda.TypeChecking.Monad.Base.Types ( IsBuiltinModule(..) )+ import Agda.Utils.Environment import Agda.Utils.FileName-import Agda.Utils.Functor ( (<&>) ) import Agda.Utils.IO ( catchIO ) import qualified Agda.Utils.IO.UTF8 as UTF8+import Agda.Utils.Lens import Agda.Utils.List-import Agda.Utils.List1 ( List1 )-import qualified Agda.Utils.List1 as List1+import Agda.Utils.List1             ( List1, pattern (:|) )+import Agda.Utils.List2             ( pattern List2 )+import qualified Agda.Utils.List1   as List1+import qualified Agda.Utils.List2   as List2 import Agda.Utils.Maybe import Agda.Utils.Monad-import Agda.Utils.Pretty-import Agda.Utils.String ( trim )+import Agda.Utils.Singleton+import Agda.Utils.Tuple ( mapSndM ) +import Agda.Setup ( getDataFileName, getAgdaAppDir ) import Agda.Version --- Paths_Agda.hs is in $(BUILD_DIR)/build/autogen/.-import Paths_Agda ( getDataFileName )- ------------------------------------------------------------------------ -- * Types and Monads ------------------------------------------------------------------------ --- | Library names are structured into the base name and a suffix of version---   numbers, e.g. @mylib-1.2.3@.  The version suffix is optional.-data VersionView = VersionView-  { vvBase    :: LibName-      -- ^ Actual library name.-  , vvNumbers :: [Integer]-      -- ^ Major version, minor version, subminor version, etc., all non-negative.-      --   Note: a priori, there is no reason why the version numbers should be @Int@s.-  } deriving (Eq, Show)- -- | Raise collected 'LibErrors' as exception. -- mkLibM :: [AgdaLibFile] -> LibErrorIO a -> LibM a@@ -102,51 +99,32 @@   (x, ews) <- lift $ lift $ runWriterT m   let (errs, warns) = partitionEithers ews   tell warns-  unless (null errs) $ do-    let doc = vcat $ map (formatLibError libs) errs-    throwError doc+  () <- List1.unlessNull errs \ errs -> throwError $ LibErrors libs errs   return x  ------------------------------------------------------------------------ -- * Resources ------------------------------------------------------------------------ --- | Get the path to @~/.agda@ (system-specific).---   Can be overwritten by the @AGDA_DIR@ environment variable.------   (This is not to be confused with the directory for the data files---   that Agda needs (e.g. the primitive modules).)----getAgdaAppDir :: IO FilePath-getAgdaAppDir = do-  -- System-specific command to build the path to ~/.agda (Unix) or %APPDATA%\agda (Win)-  let agdaDir = getAppUserDataDirectory "agda"-  -- The default can be overwritten by setting the AGDA_DIR environment variable-  caseMaybeM (lookupEnv "AGDA_DIR") agdaDir $ \ dir ->-      ifM (doesDirectoryExist dir) (canonicalizePath dir) $ do-        d <- agdaDir-        putStrLn $ "Warning: Environment variable AGDA_DIR points to non-existing directory " ++ show dir ++ ", using " ++ show d ++ " instead."-        return d- -- | Returns the absolute default lib dir. This directory is used to -- store the Primitive.agda file.-getPrimitiveLibDir :: IO FilePath+getPrimitiveLibDir :: IO AbsolutePath getPrimitiveLibDir = do   libdir <- filePath <$> (absolute =<< getDataFileName "lib")   ifM (doesDirectoryExist libdir)-      (return $ libdir </> "prim")+      (return $ AbsolutePath $ T.pack $ libdir </> "prim")       (error $ "The lib directory " ++ libdir ++ " does not exist")  -- | The @~/.agda/libraries@ file lists the libraries Agda should know about. --   The content of @libraries@ is a list of paths to @.agda-lib@ files. -----   Agda honors also version specific @libraries@ files, e.g. @libraries-2.6.0@.+--   Agda honors also version-specific @libraries@ files, e.g. @libraries-2.6.0@. -- --   @defaultLibraryFiles@ gives a list of all @libraries@ files Agda should process---   by default.+--   by default.  The first file in this list that exists is actually used. -- defaultLibraryFiles :: List1 FilePath-defaultLibraryFiles = List1.fromList ["libraries-" ++ version, "libraries"]+defaultLibraryFiles = ("libraries-" ++ version) :| "libraries" : []  -- | The @defaultsFile@ contains a list of library names relevant for each Agda project. --@@ -156,15 +134,100 @@ -- | The @~/.agda/executables@ file lists the executables Agda should know about. --   The content of @executables@ is a list of paths to executables. -----   Agda honors also version specific @executables@ files, e.g. @executables-2.6.0@.+--   Agda honors also version-specific @executables@ files, e.g. @executables-2.6.0@. -- --   @defaultExecutablesFiles@ gives a list of all @executables@ Agda should process---   by default.+--   by default.  The first file in this list that exists is actually used. -- defaultExecutableFiles :: List1 FilePath-defaultExecutableFiles = List1.fromList ["executables-" ++ version, "executables"]+defaultExecutableFiles = ("executables-" ++ version) :| "executables" : []  ------------------------------------------------------------------------+-- * Agda builtin modules+------------------------------------------------------------------------++-- | Prefix path with @Agda.Builtin@.++agdaBuiltin :: FilePath -> FilePath+agdaBuiltin = ("Agda" </>) . ("Builtin" </>)++-- | The very magical, auto-imported modules.++primitiveModules :: Set FilePath+primitiveModules = Set.fromList+  [ "Agda" </> "Primitive.agda"+  , "Agda" </> "Primitive" </> "Cubical.agda"+  ]++-- | These builtins may use postulates, and are still considered @--safe@.++builtinModulesWithSafePostulates :: Set FilePath+builtinModulesWithSafePostulates =+  (primitiveModules `Set.union`) $ Set.fromList $+  map agdaBuiltin $+    [ "Bool.agda"+    , "Char.agda"+    , "Char" </> "Properties.agda"+    , "Coinduction.agda"+    , "Cubical" </> "Equiv.agda"+    , "Cubical" </> "Glue.agda"+    , "Cubical" </> "HCompU.agda"+    , "Cubical" </> "Id.agda"+    , "Cubical" </> "Path.agda"+    , "Cubical" </> "Sub.agda"+    , "Equality" </> "Erase.agda"+    , "Equality.agda"+    , "Float.agda"+    , "Float" </> "Properties.agda"+    , "FromNat.agda"+    , "FromNeg.agda"+    , "FromString.agda"+    , "Int.agda"+    , "IO.agda"+    , "List.agda"+    , "Maybe.agda"+    , "Nat.agda"+    , "Reflection.agda"+    , "Reflection" </> "Properties.agda"+    , "Reflection" </> "External.agda"+    , "Sigma.agda"+    , "Size.agda"+    , "Strict.agda"+    , "String.agda"+    , "String" </> "Properties.agda"+    , "Unit.agda"+    , "Word.agda"+    , "Word" </> "Properties.agda"+    ]++-- | These builtins may not use postulates under @--safe@. They are not+--   automatically unsafe, but will be if they use an unsafe feature.++builtinModulesWithUnsafePostulates :: Set FilePath+builtinModulesWithUnsafePostulates = Set.fromList $+  map agdaBuiltin $+    [ "TrustMe.agda"+    , "Equality" </> "Rewrite.agda"+    ]++-- | All builtin modules.++builtinModules :: Set FilePath+builtinModules = builtinModulesWithSafePostulates `Set.union`+                 builtinModulesWithUnsafePostulates++-- | Determine whether the second absolute path refers to one of Agda's primitive modules.+--   The first argument should be the result of 'getPrimitiveLibDir'.+--+classifyBuiltinModule_ :: AbsolutePath -> AbsolutePath -> Maybe IsBuiltinModule+classifyBuiltinModule_ primLibDir fp = do+  f <- relativizeAbsolutePath fp primLibDir+  guard $ f `Set.member` builtinModules+  if f `Set.member` builtinModulesWithUnsafePostulates then return IsBuiltinModule+  else if f `Set.member` primitiveModules then return IsPrimitiveModule+  else return IsBuiltinModuleWithSafePostulates++------------------------------------------------------------------------ -- * Get the libraries for the current project ------------------------------------------------------------------------ @@ -172,32 +235,41 @@ -- --   If there are none, look in the parent directories until one is found. -findProjectConfig-  :: FilePath                          -- ^ Candidate (init: the directory Agda was called in)-  -> LibM ProjectConfig                -- ^ Actual root and @.agda-lib@ files for this project-findProjectConfig root = mkLibM [] $ findProjectConfig' root--findProjectConfig'-  :: FilePath                          -- ^ Candidate (init: the directory Agda was called in)-  -> LibErrorIO ProjectConfig          -- ^ Actual root and @.agda-lib@ files for this project-findProjectConfig' root = do+findProjectConfig ::+     FilePath+       -- ^ Candidate (initially: the directory Agda was called in).+  -> LibM ProjectConfig+       -- ^ Actual root and @.agda-lib@ file for this project.+findProjectConfig root = do   getCachedProjectConfig root >>= \case     Just conf -> return conf-    Nothing   -> do-      libFiles <- liftIO $ filter ((== ".agda-lib") . takeExtension) <$> getDirectoryContents root+    Nothing   -> handlePermissionException do+      libFiles <- liftIO $ getDirectoryContents root >>=+        filterM (\file -> and2M+          (pure $ takeExtension file == ".agda-lib")+          (doesFileExist (root </> file)))       case libFiles of         []     -> liftIO (upPath root) >>= \case           Just up -> do-            conf <- findProjectConfig' up+            conf <- over lensConfigAbove (+ 1) <$> findProjectConfig up             storeCachedProjectConfig root conf             return conf           Nothing -> return DefaultProjectConfig-        files -> do-          let conf = ProjectConfig root files+        [file] -> do+          let conf = ProjectConfig root file 0           storeCachedProjectConfig root conf           return conf+        f1:f2:files -> throwError $ LibErrors [] $ singleton $ LibError Nothing $+          SeveralAgdaLibFiles root $ List2 f1 f2 files    where+    -- Andreas, 2024-06-26, issue #7331:+    -- In case of missing permission we terminate our search for the project file+    -- with the default value.+    handlePermissionException :: LibM ProjectConfig -> LibM ProjectConfig+    handlePermissionException = flip catchIO \ e ->+      if isPermissionError e then return DefaultProjectConfig else liftIO $ E.throwIO e+     -- Note that "going up" one directory is OS dependent     -- if the directory is a symlink.     --@@ -221,15 +293,17 @@  findProjectRoot :: FilePath -> LibM (Maybe FilePath) findProjectRoot root = findProjectConfig root <&> \case-  ProjectConfig p _    -> Just p+  ProjectConfig p _ _  -> Just p   DefaultProjectConfig -> Nothing  --- | Get the contents of @.agda-lib@ files in the given project root.-getAgdaLibFiles' :: FilePath -> LibErrorIO [AgdaLibFile]-getAgdaLibFiles' path = findProjectConfig' path >>= \case-  DefaultProjectConfig    -> return []-  ProjectConfig root libs -> parseLibFiles Nothing $ map ((0,) . (root </>)) libs+-- | Get the content of the @.agda-lib@ file in the given project root.+getAgdaLibFile :: FilePath -> LibM [AgdaLibFile]+getAgdaLibFile path = findProjectConfig path >>= \case+  DefaultProjectConfig          -> return []+  ProjectConfig root file above -> mkLibM [] $+    map (set libAbove above) <$>+    parseLibFiles Nothing [(0, root </> file)]  -- | Get dependencies and include paths for given project root: --@@ -241,10 +315,10 @@   :: FilePath  -- ^ Project root.   -> Bool      -- ^ Use @defaults@ if no @.agda-lib@ file exists for this project?   -> LibM ([LibName], [FilePath])  -- ^ The returned @LibName@s are all non-empty strings.-getDefaultLibraries root optDefaultLibs = mkLibM [] $ do-  libs <- getAgdaLibFiles' root+getDefaultLibraries root optDefaultLibs = do+  libs <- getAgdaLibFile root   if null libs-    then (,[]) <$> if optDefaultLibs then (libNameForCurrentDir :) <$> readDefaultsFile else return []+    then (,[]) <$> if optDefaultLibs then mkLibM [] $ (libNameForCurrentDir :) <$> readDefaultsFile else return []     else return $ libsAndPaths libs   where     libsAndPaths ls = ( concatMap _libDepends ls@@ -261,9 +335,9 @@     let file = agdaDir </> defaultsFile     ifNotM (liftIO $ doesFileExist file) (return []) $ {-else-} do       ls <- liftIO $ map snd . stripCommentLines <$> UTF8.readFile file-      return $ concatMap splitCommas ls+      return $ map parseLibName $ concatMap splitCommas ls   `catchIO` \ e -> do-    raiseErrors' [ OtherError $ unlines ["Failed to read defaults file.", show e] ]+    raiseErrors' [ ReadError e "Failed to read defaults file." ]     return []  ------------------------------------------------------------------------@@ -274,15 +348,17 @@ -- --   Note: file may not exist. --+--   If the user specified an alternative @libraries@ file which does not exist,+--   an exception is thrown containing the name of this file. getLibrariesFile-  :: (MonadIO m, MonadError String m)+  :: (MonadIO m, MonadError FilePath m)   => Maybe FilePath -- ^ Override the default @libraries@ file?   -> m LibrariesFile getLibrariesFile (Just overrideLibFile) = do   -- A user-specified override file must exist.   ifM (liftIO $ doesFileExist overrideLibFile)     {-then-} (return $ LibrariesFile overrideLibFile True)-    {-else-} (throwError $ "Libraries file not found: " ++ overrideLibFile)+    {-else-} (throwError overrideLibFile) getLibrariesFile Nothing = do   agdaDir <- liftIO $ getAgdaAppDir   let defaults = List1.map (agdaDir </>) defaultLibraryFiles -- NB: very short list@@ -301,14 +377,16 @@ getInstalledLibraries overrideLibFile = mkLibM [] $ do     filem <- liftIO $ runExceptT $ getLibrariesFile overrideLibFile     case filem of-      Left err -> raiseErrors' [OtherError err] >> return []+      Left theOverrideLibFile -> do+        raiseErrors' [ LibrariesFileNotFound theOverrideLibFile ]+        return []       Right file -> do         if not (lfExists file) then return [] else do           ls    <- liftIO $ stripCommentLines <$> UTF8.readFile (lfPath file)           files <- liftIO $ sequence [ (i, ) <$> expandEnvironmentVariables s | (i, s) <- ls ]           parseLibFiles (Just file) $ nubOn snd files   `catchIO` \ e -> do-    raiseErrors' [ OtherError $ unlines ["Failed to read installed libraries.", show e] ]+    raiseErrors' [ ReadError e "Failed to read installed libraries." ]     return []  -- | Parse the given library files.@@ -336,9 +414,9 @@   let (xs, warns) = unzip anns       (errs, als) = partitionEithers xs -  unless (null warns) $ warnings $ concat warns-  unless (null errs)  $-    raiseErrors $ map (\(mc,s) -> LibError mc $ OtherError s) errs+  List1.unlessNull (concat warns) warnings+  List1.unlessNull errs $ \ errs1 ->+    raiseErrors $ fmap (\ (mc, err) -> LibError mc $ LibParseError err) errs1    return $ nubOn _libFile als @@ -374,11 +452,10 @@     file <- liftIO getExecutablesFile     if not (efExists file) then return Map.empty else do       es    <- liftIO $ stripCommentLines <$> UTF8.readFile (efPath file)-      files <- liftIO $ sequence [ (i, ) <$> expandEnvironmentVariables s | (i, s) <- es ]-      tmp   <- parseExecutablesFile file $ nubOn snd files-      return tmp+      lines <- liftIO $ mapM (mapSndM expandEnvironmentVariables) es+      parseExecutablesFile file lines   `catchIO` \ e -> do-    raiseErrors' [ OtherError $ unlines ["Failed to read trusted executables.", show e] ]+    raiseErrors' [ ReadError e "Failed to read trusted executables." ]     return Map.empty  -- | Parse the @executables@ file.@@ -387,16 +464,29 @@   :: ExecutablesFile   -> [(LineNumber, FilePath)]   -> LibErrorIO (Map ExeName FilePath)-parseExecutablesFile ef files =-  fmap (Map.fromList . catMaybes) . forM files $ \(ln, fp) -> do-+parseExecutablesFile ef files = do+  executables <- forM files $ \(ln, fp) -> do     -- Compute canonical executable name and absolute filepath.     let strExeName  = takeFileName fp     let strExeName' = fromMaybe strExeName $ stripExtension exeExtension strExeName     let txtExeName  = T.pack strExeName'     exePath <- liftIO $ makeAbsolute fp-    return $ Just (txtExeName, exePath)+    return (txtExeName, (ln, exePath)) +  -- Create a map from executable names to their location(s).+  let exeMap1 :: Map ExeName (List1 (LineNumber, FilePath))+      exeMap1 = Map.fromListWith (<>) $ map (second singleton) $ reverse executables++  -- Separate non-ambiguous from ambiguous mappings.+  let (exeMap, duplicates) = Map.mapEither List2.fromList1Either exeMap1++  -- Report ambiguous mappings with line numbers.+  List1.unlessNull (Map.toList duplicates) $ \ duplicates1 ->+    raiseErrors' $ fmap (uncurry $ DuplicateExecutable $ efPath ef) duplicates1++  -- Return non-ambiguous mappings without line numbers.+  return $ fmap snd exeMap+ ------------------------------------------------------------------------ -- * Resolving library names to include pathes ------------------------------------------------------------------------@@ -407,13 +497,15 @@   -> [AgdaLibFile]   -- ^ Libraries Agda knows about.   -> [LibName]       -- ^ (Non-empty) library names to be resolved to (lists of) pathes.   -> LibM [FilePath] -- ^ Resolved pathes (no duplicates).  Contains "." if @[LibName]@ does.-libraryIncludePaths overrideLibFile libs xs0 = mkLibM libs $ WriterT $ do+libraryIncludePaths overrideLibFile libs xs0 = mkLibM libs $ do     efile <- liftIO $ runExceptT $ getLibrariesFile overrideLibFile     case efile of-      Left err -> return ([], [Left $ LibError Nothing $ OtherError err])-      Right file -> return $ runWriter $ (dot ++) . incs <$> find file [] xs+      Left theOverrideLibFile -> do+        raiseErrors' [ LibrariesFileNotFound theOverrideLibFile ]+        return []+      Right file -> embedWriter $ (dot ++) . incs <$> find file [] xs   where-    (dots, xs) = List.partition (== libNameForCurrentDir) $ map trim xs0+    (dots, xs) = List.partition (== libNameForCurrentDir) xs0     incs       = nubOn id . concatMap _libIncludes     dot        = [ "." | not $ null dots ] @@ -422,7 +514,7 @@       :: LibrariesFile  -- Only for error reporting.       -> [LibName]      -- Already resolved libraries.       -> [LibName]      -- Work list: libraries left to be resolved.-      -> Writer [Either LibError LibWarning] [AgdaLibFile]+      -> Writer LibErrWarns [AgdaLibFile]     find _ _ [] = pure []     find file visited (x : xs)       | x `elem` visited = find file visited xs@@ -431,7 +523,7 @@           ml <- case findLib x libs of             [l] -> pure (Just l)             []  -> Nothing <$ raiseErrors' [LibNotFound file x]-            ls  -> Nothing <$ raiseErrors' [AmbiguousLib x ls]+            l1 : l2 : ls  -> Nothing <$ raiseErrors' [AmbiguousLib x $ List2 l1 l2 ls]           -- If it is found, add its dependencies to work list           let xs' = foldMap _libDepends ml ++ xs           mcons ml <$> find file (x : visited) xs'@@ -462,46 +554,15 @@ findLib' libName x libs =   case ls of     -- Take the first and all exact matches (modulo leading zeros in version numbers).-    l : ls' -> l : takeWhile (((==) `on` versionMeasure) l) ls'+    l : ls' -> l : takeWhile (((==) `on` libName) l) ls'     []      -> []   where     -- @LibName@s that match @x@, sorted descendingly.     -- The unversioned LibName, if any, will come first.-    ls = List.sortBy (flip compare `on` versionMeasure)-                     [ l | l <- libs, x `hasMatch` libName l ]-+    ls = List.sortBy (flip compare `on` libName) [ l | l <- libs, x `hasMatch` libName l ]     -- foo > foo-2.2 > foo-2.0.1 > foo-2 > foo-1.0-    versionMeasure l = (rx, null vs, vs)-      where-        VersionView rx vs = versionView (libName l) --- | @x `hasMatch` y@ if @x@ and @y@ have the same @vvBase@ and+-- | @x `hasMatch` y@ if @x@ and @y@ have the same base and --   either @x@ has no version qualifier or the versions also match. hasMatch :: LibName -> LibName -> Bool-hasMatch x y = rx == ry && (vx == vy || null vx)-  where-    VersionView rx vx = versionView x-    VersionView ry vy = versionView y---- | Split a library name into basename and a list of version numbers.------   > versionView "foo-1.2.3"    == VersionView "foo" [1, 2, 3]---   > versionView "foo-01.002.3" == VersionView "foo" [1, 2, 3]------   Note that because of leading zeros, @versionView@ is not injective.---   (@unVersionView . versionView@ would produce a normal form.)-versionView :: LibName -> VersionView-versionView s =-  case span (\ c -> isDigit c || c == '.') (reverse s) of-    (v, '-' : x) | valid vs ->-      VersionView (reverse x) $ reverse $ map (read . reverse) vs-      where vs = chopWhen (== '.') v-            valid [] = False-            valid vs = not $ any null vs-    _ -> VersionView s []---- | Print a @VersionView@, inverse of @versionView@ (modulo leading zeros).-unVersionView :: VersionView -> LibName-unVersionView = \case-  VersionView base [] -> base-  VersionView base vs -> base ++ "-" ++ List.intercalate "." (map show vs)+hasMatch (LibName rx vx) (LibName ry vy) = rx == ry && (vx == vy || null vx)
src/full/Agda/Interaction/Library/Base.hs view
@@ -2,46 +2,98 @@  module Agda.Interaction.Library.Base where -import Control.Arrow ( first , second )+import Prelude hiding (null)+ import Control.DeepSeq+import qualified Control.Exception as E+ import Control.Monad.Except import Control.Monad.State-import Control.Monad.Writer-import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.Writer        ( WriterT, runWriterT, MonadWriter, tell )+import Control.Monad.IO.Class      ( MonadIO(..) ) -import Data.Char ( isDigit )-import Data.Data ( Data )-import qualified Data.List as List-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Text ( Text )+import Data.Bifunctor              ( first , second )+import Data.Char                   ( isDigit )+import Data.Function               ( (&), on )+import Data.Hashable               ( Hashable )+import qualified Data.List         as List+import Data.Map                    ( Map )+import qualified Data.Map          as Map+import Data.Semigroup              ( Semigroup(..) )+import Data.Text                   ( Text, unpack )+import qualified Data.Text         as T -import GHC.Generics (Generic)+import GHC.Generics                ( Generic )  import System.Directory-import System.FilePath  import Agda.Interaction.Options.Warnings -import Agda.Utils.FileName+import Agda.Syntax.Common.Pretty+import Agda.Syntax.Position++import Agda.Utils.IO               ( showIOException ) import Agda.Utils.Lens-import Agda.Utils.Pretty+import Agda.Utils.List             ( chopWhen )+import Agda.Utils.List1            ( List1, toList )+import Agda.Utils.List2            ( List2, toList )+import qualified Agda.Utils.List1  as List1+import Agda.Utils.Null  -- | A symbolic library name. ---type LibName = String+--   Library names are structured into the base name and a suffix of version+--   numbers, e.g. @mylib-1.2.3@.  The version suffix is optional.+data LibName = LibName+  { libNameBase    :: Text+      -- ^ Actual library name.+  , libNameVersion :: [Integer]+      -- ^ Major version, minor version, subminor version, etc., all non-negative.+  } deriving (Eq, Show, Generic) +-- | In comparisons, a missing version number is assumed to be infinity.+--   E.g. @foo > foo-2.2 > foo-2.0.1 > foo-2 > foo-1.0@.+instance Ord LibName where+  compare = compare `on` versionMeasure+    where+      versionMeasure :: LibName -> (Text, Bool, [Integer])+      versionMeasure (LibName rx vs) = (rx, null vs, vs)++instance Pretty LibName where+  pretty = \case+    LibName base [] -> pretty base+    LibName base vs -> hcat [ pretty base, "-", text $ List.intercalate "." $ map show vs ]++-- | Split a library name into basename and a list of version numbers.+--+--   > parseLibName "foo-1.2.3"    == LibName "foo" [1, 2, 3]+--   > parseLibName "foo-01.002.3" == LibName "foo" [1, 2, 3]+--+--   Note that because of leading zeros, @parseLibName@ is not injective.+--   (@prettyShow . parseLibName@ would produce a normal form.)+parseLibName :: String -> LibName+parseLibName s =+  case span (\ c -> isDigit c || c == '.') (reverse s) of+    (v, '-' : x) | valid vs ->+      LibName (T.pack $ reverse x) $ reverse $ map (read . reverse) vs+      where+        vs = chopWhen (== '.') v+        valid [] = False+        valid vs = not $ any null vs+    _ -> LibName (T.pack s) []+ data LibrariesFile = LibrariesFile   { lfPath   :: FilePath       -- ^ E.g. @~/.agda/libraries@.   , lfExists :: Bool        -- ^ The libraries file might not exist,        --   but we may print its assumed location in error messages.-  } deriving (Show)+  } deriving (Show, Generic)  -- | A symbolic executable name. -- type ExeName = Text+type ExeMap  = Map ExeName FilePath  data ExecutablesFile = ExecutablesFile   { efPath   :: FilePath@@ -49,60 +101,113 @@   , efExists :: Bool        -- ^ The executables file might not exist,        --   but we may print its assumed location in error messages.-  } deriving (Show, Data, Generic)+  } deriving (Show, Generic)  -- | The special name @\".\"@ is used to indicated that the current directory --   should count as a project root. -- libNameForCurrentDir :: LibName-libNameForCurrentDir = "."+libNameForCurrentDir = LibName "." []  -- | A file can either belong to a project located at a given root---   containing one or more .agda-lib files, or be part of the default---   project.+--   containing an .agda-lib file, or be part of the default project. data ProjectConfig   = ProjectConfig     { configRoot         :: FilePath-    , configAgdaLibFiles :: [FilePath]+        -- ^ Directory which contains the @.agda-lib@ file for the current project.+    , configAgdaLibFile  :: FilePath+        -- ^ @.agda-lib@ file relative to 'configRoot' (filename only, no directory).+    , configAbove        :: !Int+        -- ^ How many directories above the Agda file is the @.agda-lib@ file located?     }   | DefaultProjectConfig   deriving Generic +-- | The options from an @OPTIONS@ pragma (or a @.agda-lib@ file).+--+-- In the future it might be nice to switch to a more structured+-- representation. Note that, currently, there is not a one-to-one+-- correspondence between list elements and options.+data OptionsPragma = OptionsPragma+  { pragmaStrings :: [String]+    -- ^ The options.+  , pragmaRange :: Range+    -- ^ The range of the options in the pragma (not including things+    -- like an @OPTIONS@ keyword).+  }+  deriving Show++instance Semigroup OptionsPragma where+  OptionsPragma { pragmaStrings = ss1, pragmaRange = r1 } <>+    OptionsPragma { pragmaStrings = ss2, pragmaRange = r2 } =+    OptionsPragma+      { pragmaStrings = ss1 ++ ss2+      , pragmaRange   = fuseRanges r1 r2+      }++instance Monoid OptionsPragma where+  mempty  = OptionsPragma { pragmaStrings = [], pragmaRange = noRange }+  mappend = (<>)++-- | Ranges are not forced.++instance NFData OptionsPragma where+  rnf (OptionsPragma a _) = rnf a+ -- | Content of a @.agda-lib@ file. -- data AgdaLibFile = AgdaLibFile   { _libName     :: LibName     -- ^ The symbolic name of the library.   , _libFile     :: FilePath    -- ^ Path to this @.agda-lib@ file (not content of the file).+  , _libAbove    :: !Int        -- ^ How many directories above the+                                --   Agda file is the @.agda-lib@ file+                                --   located?   , _libIncludes :: [FilePath]  -- ^ Roots where to look for the modules of the library.   , _libDepends  :: [LibName]   -- ^ Dependencies.-  , _libPragmas  :: [String]    -- ^ Default pragma options for all files in the library.+  , _libPragmas  :: OptionsPragma+                                -- ^ Default pragma options for all files in the library.   }   deriving (Show, Generic)  emptyLibFile :: AgdaLibFile emptyLibFile = AgdaLibFile-  { _libName     = ""+  { _libName     = empty   , _libFile     = ""+  , _libAbove    = 0   , _libIncludes = []   , _libDepends  = []-  , _libPragmas  = []+  , _libPragmas  = mempty   } --- | Lenses for AgdaLibFile+---------------------------------------------------------------------------+-- * Lenses+--------------------------------------------------------------------------- -libName :: Lens' LibName AgdaLibFile+-- ** Lenses for 'ProjectConfig'++lensConfigAbove :: Lens' ProjectConfig Int+lensConfigAbove f = \case+  DefaultProjectConfig -> DefaultProjectConfig <$ f 0+  c@ProjectConfig{} -> f (configAbove c) <&> \ !i -> c{ configAbove = i }++-- ** Lenses for 'AgdaLibFile'++libName :: Lens' AgdaLibFile LibName libName f a = f (_libName a) <&> \ x -> a { _libName = x } -libFile :: Lens' FilePath AgdaLibFile+libFile :: Lens' AgdaLibFile FilePath libFile f a = f (_libFile a) <&> \ x -> a { _libFile = x } -libIncludes :: Lens' [FilePath] AgdaLibFile+libAbove :: Lens' AgdaLibFile Int+libAbove f a = f (_libAbove a) <&> \ x -> a { _libAbove = x }++libIncludes :: Lens' AgdaLibFile [FilePath] libIncludes f a = f (_libIncludes a) <&> \ x -> a { _libIncludes = x } -libDepends :: Lens' [LibName] AgdaLibFile+libDepends :: Lens' AgdaLibFile [LibName] libDepends f a = f (_libDepends a) <&> \ x -> a { _libDepends = x } -libPragmas :: Lens' [String] AgdaLibFile+libPragmas :: Lens' AgdaLibFile OptionsPragma libPragmas f a = f (_libPragmas a) <&> \ x -> a { _libPragmas = x }  @@ -110,160 +215,358 @@ -- * Library warnings and errors ------------------------------------------------------------------------ +-- ** Position information+ type LineNumber = Int +-- | Information about which @.agda-lib@ file we are reading+--   and from where in the @libraries@ file it came from.+ data LibPositionInfo = LibPositionInfo-  { libFilePos :: Maybe FilePath -- ^ Name of @libraries@ file+  { libFilePos :: Maybe FilePath -- ^ Name of @libraries@ file.   , lineNumPos :: LineNumber     -- ^ Line number in @libraries@ file.-  , filePos    :: FilePath       -- ^ Library file+  , filePos    :: FilePath       -- ^ Library file.   }-  deriving (Show, Data, Generic)+  deriving (Show, Generic) +-- ** Warnings+ data LibWarning = LibWarning (Maybe LibPositionInfo) LibWarning'-  deriving (Show, Data, Generic)+  deriving (Show, Generic)  -- | Library Warnings. data LibWarning'   = UnknownField String-  deriving (Show, Data, Generic)--data LibError = LibError (Maybe LibPositionInfo) LibError'+  deriving (Show, Generic)  libraryWarningName :: LibWarning -> WarningName libraryWarningName (LibWarning c (UnknownField{})) = LibUnknownField_ +-- * Errors++data LibError = LibError (Maybe LibPositionInfo) LibError'+  deriving (Show, Generic)+ -- | Collected errors while processing library files. -- data LibError'-  = LibNotFound LibrariesFile LibName+  = LibrariesFileNotFound FilePath+      -- ^ The user specified replacement for the default @libraries@ file does not exist.+  | LibNotFound LibrariesFile LibName       -- ^ Raised when a library name could not successfully be resolved       --   to an @.agda-lib@ file.       ---  | AmbiguousLib LibName [AgdaLibFile]+  | AmbiguousLib LibName (List2 AgdaLibFile)       -- ^ Raised when a library name is defined in several @.agda-lib files@.-  | OtherError String-      -- ^ Generic error.-  deriving (Show)+  | SeveralAgdaLibFiles FilePath (List2 FilePath)+      -- ^ The given project root contains more than one @.agda-lib@ file.+  | LibParseError LibParseError+      -- ^ The @.agda-lib@ file could not be parsed.+  | ReadError+      -- ^ An I/O Error occurred when reading a file.+      E.IOException+        -- ^ The caught exception+      String+        -- ^ Explanation when this error occurred.+  | DuplicateExecutable+      -- ^ The @executables@ file contains duplicate entries.+      FilePath+        -- ^ Name of the @executables@ file.+      Text+        -- ^ Name of the executable that is defined twice.+      (List2 (LineNumber, FilePath))+        -- ^ The resolutions of the executable.+  deriving (Show, Generic) --- | Cache locations of project configurations and parsed .agda-lib files-type LibState =-  ( Map FilePath ProjectConfig-  , Map FilePath AgdaLibFile-  )+-- | Exceptions thrown by the @.agda-lib@ parser.+--+data LibParseError+  = BadLibraryName String+      -- ^ An invalid library name, e.g., containing spaces.+  | ReadFailure FilePath E.IOException+      -- ^ I/O error while reading file.+  | MissingFields (List1 String)+      -- ^ Missing these mandatory fields.+  | DuplicateFields (List1 String)+      -- ^ These fields occur each more than once.+  | MissingFieldName LineNumber+      -- ^ At the given line number, a field name is missing before the @:@.+  | BadFieldName LineNumber String+      -- ^ At the given line number, an invalid field name is encountered before the @:@.+      --   (E.g., containing spaces.)+  | MissingColonForField LineNumber String+      -- ^ At the given line number, the given field is not followed by @:@.+  | ContentWithoutField LineNumber+      -- ^ At the given line number, indented text (content) is not preceded by a field.+  deriving (Show, Generic) --- | Collects 'LibError's and 'LibWarning's.+-- ** Raising warnings and errors++-- | Collection of 'LibError's and 'LibWarning's. ---type LibErrorIO = WriterT [Either LibError LibWarning] (StateT LibState IO)+type LibErrWarns = [Either LibError LibWarning] --- | Throws 'Doc' exceptions, still collects 'LibWarning's.-type LibM = ExceptT Doc (WriterT [LibWarning] (StateT LibState IO))+warnings :: MonadWriter LibErrWarns m => List1 LibWarning -> m ()+warnings = tell . map Right . toList -warnings :: MonadWriter [Either LibError LibWarning] m => [LibWarning] -> m ()-warnings = tell . map Right+warnings' :: MonadWriter LibErrWarns m => List1 LibWarning' -> m ()+warnings' = tell . map (Right . LibWarning Nothing) . toList -warnings' :: MonadWriter [Either LibError LibWarning] m => [LibWarning'] -> m ()-warnings' = tell . map (Right . LibWarning Nothing)+raiseErrors' :: MonadWriter LibErrWarns m => List1 LibError' -> m ()+raiseErrors' = tell . map (Left . (LibError Nothing)) . toList --- UNUSED Liang-Ting Chen 2019-07-16---warning :: MonadWriter [Either LibError LibWarning] m => LibWarning -> m ()---warning = warnings . pure+raiseErrors :: MonadWriter LibErrWarns m => List1 LibError -> m ()+raiseErrors = tell . map Left . toList -raiseErrors' :: MonadWriter [Either LibError LibWarning] m => [LibError'] -> m ()-raiseErrors' = tell . map (Left . (LibError Nothing)) -raiseErrors :: MonadWriter [Either LibError LibWarning] m => [LibError] -> m ()-raiseErrors = tell . map Left+------------------------------------------------------------------------+-- * Library Monad+------------------------------------------------------------------------ +-- | Collects 'LibError's and 'LibWarning's.+--+type LibErrorIO = WriterT LibErrWarns (StateT LibState IO)++-- | Throws 'LibErrors' exceptions, still collects 'LibWarning's.+type LibM = ExceptT LibErrors (WriterT [LibWarning] (StateT LibState IO))++type LibState = LibCache++-- | Cache locations of project configurations and parsed @.agda-lib@ files.+data LibCache = LibCache+  { projectConfigs :: !(Map FilePath ProjectConfig)+      -- ^ Map from directories to paths of closest enclosing @.agda-lib@+      --   files (or 'DefaultProjectConfig' if there are none).+  , agdaLibFiles   :: !(Map FilePath AgdaLibFile)+      -- ^ Contents of @.agda-lib@ files that have already been parsed.+  }+  deriving (Generic)++-- | Collected errors when processing an @.agda-lib@ file.+--+data LibErrors = LibErrors+  { libErrorsInstalledLibraries :: [AgdaLibFile]+  , libErrors                   :: List1 LibError+  } deriving (Show, Generic)++runLibM :: LibM a -> LibState -> IO ((Either LibErrors a, [LibWarning]), LibState)+runLibM m s = m & runExceptT & runWriterT & (`runStateT` s)+ getCachedProjectConfig   :: (MonadState LibState m, MonadIO m)   => FilePath -> m (Maybe ProjectConfig) getCachedProjectConfig path = do   path <- liftIO $ canonicalizePath path-  cache <- gets fst-  return $ Map.lookup path cache+  Map.lookup path <$> gets projectConfigs  storeCachedProjectConfig   :: (MonadState LibState m, MonadIO m)   => FilePath -> ProjectConfig -> m () storeCachedProjectConfig path conf = do   path <- liftIO $ canonicalizePath path-  modify $ first $ Map.insert path conf+  modify \ s -> s { projectConfigs = Map.insert path conf $ projectConfigs s }  getCachedAgdaLibFile   :: (MonadState LibState m, MonadIO m)   => FilePath -> m (Maybe AgdaLibFile) getCachedAgdaLibFile path = do   path <- liftIO $ canonicalizePath path-  gets $ Map.lookup path . snd+  Map.lookup path <$> gets agdaLibFiles  storeCachedAgdaLibFile   :: (MonadState LibState m, MonadIO m)   => FilePath -> AgdaLibFile -> m () storeCachedAgdaLibFile path lib = do   path <- liftIO $ canonicalizePath path-  modify $ second $ Map.insert path lib+  modify \ s -> s { agdaLibFiles = Map.insert path lib $ agdaLibFiles s }  ------------------------------------------------------------------------ -- * Prettyprinting errors and warnings ------------------------------------------------------------------------ -formatLibPositionInfo :: LibPositionInfo -> String -> Doc-formatLibPositionInfo (LibPositionInfo libFile lineNum file) err = text $-  let loc | Just lf <- libFile = lf ++ ":" ++ show lineNum ++ ": "-          | otherwise = ""-  in if "Failed to read" `List.isPrefixOf` err-     then loc-     else file ++ ":" ++ (if all isDigit (take 1 err) then "" else " ")- -- | Pretty-print 'LibError'. formatLibError :: [AgdaLibFile] -> LibError -> Doc-formatLibError installed (LibError mc e) = prefix <+> body where-  prefix = case mc of-    Nothing                      -> ""-    Just c | OtherError err <- e -> formatLibPositionInfo c err-    _                            -> ""+formatLibError installed (LibError mc e) =+  case (mc, e) of+    (Just c, LibParseError err) -> sep  [ formatLibPositionInfo c err, pretty e ]+    (_     , LibNotFound{}    ) -> vcat [ pretty e, prettyInstalledLibraries installed ]+    _ -> pretty e -  body = case e of++-- | Pretty-print 'LibErrors'.+formatLibErrors :: LibErrors -> Doc+formatLibErrors (LibErrors libs errs) =+  vcat $  map (formatLibError libs) $ List1.toList errs++-- | Does a parse error contain a line number?+hasLineNumber :: LibParseError -> Maybe LineNumber+hasLineNumber = \case+  BadLibraryName       _   -> Nothing+  ReadFailure          _ _ -> Nothing+  MissingFields        _   -> Nothing+  DuplicateFields      _   -> Nothing+  MissingFieldName     l   -> Just l+  BadFieldName         l _ -> Just l+  MissingColonForField l _ -> Just l+  ContentWithoutField  l   -> Just l++-- UNUSED:+-- -- | Does a parse error contain the name of the parsed file?+-- hasFilePath :: LibParseError -> Maybe FilePath+-- hasFilePath = \case+--   BadLibraryName       _   -> Nothing+--   ReadFailure          f _ -> Just f+--   MissingFields        _   -> Nothing+--   DuplicateFields      _   -> Nothing+--   MissingFieldName     _   -> Nothing+--   BadFieldName         _ _ -> Nothing+--   MissingColonForField _ _ -> Nothing+--   ContentWithoutField  _   -> Nothing++-- | Compute a position position prefix.+--+--   Depending on the error to be printed, it will+--+--   - either give the name of the @libraries@ file and a line inside it,+--+--   - or give the name of the @.agda-lib@ file.+--+formatLibPositionInfo :: LibPositionInfo -> LibParseError -> Doc+formatLibPositionInfo (LibPositionInfo libFile lineNum file) = \case++  -- If we couldn't even read the @.agda-lib@ file, report error in the @libraries@ file.+  ReadFailure _ _+    | Just lf <- libFile+      -> hcat [ text lf, ":", pretty lineNum, ":" ]+    | otherwise+      -> empty++  -- If the parse error comes with a line number, print it here.+  e | Just l <- hasLineNumber e+      -> hcat [ text file, ":", pretty l, ":" ]+    | otherwise+      -> hcat [ text file, ":" ]++prettyInstalledLibraries :: [AgdaLibFile] -> Doc+prettyInstalledLibraries installed =+  vcat $ ("Installed libraries:" :) $+    map (nest 2) $+    if null installed then ["(none)"]+    else [ sep [ pretty $ _libName l, nest 2 $ parens $ text $ _libFile l ]+         | l <- installed+         ]++-- | Pretty-print library management error without position info.++instance Pretty LibError' where+  pretty = \case++    LibrariesFileNotFound path -> sep+      [ text "Libraries file not found:"+      , text path+      ]+     LibNotFound file lib -> vcat $-      [ text $ "Library '" ++ lib ++ "' not found."+      [ hcat [ "Library '", pretty lib, "' not found." ]       , sep [ "Add the path to its .agda-lib file to"             , nest 2 $ text $ "'" ++ lfPath file ++ "'"             , "to install."             ]-      , "Installed libraries:"-      ] ++-      map (nest 2)-         (if null installed then ["(none)"]-          else [ sep [ text $ _libName l, nest 2 $ parens $ text $ _libFile l ]-               | l <- installed ])+      ]      AmbiguousLib lib tgts -> vcat $-      sep [ text $ "Ambiguous library '" ++ lib ++ "'."+      sep [ hcat [ "Ambiguous library '", pretty lib, "'." ]             , "Could refer to any one of"           ]-        : [ nest 2 $ text (_libName l) <+> parens (text $ _libFile l) | l <- tgts ]+        : [ nest 2 $ pretty (_libName l) <+> parens (text $ _libFile l) | l <- toList tgts ] +    SeveralAgdaLibFiles root files -> vcat $+      sep [ "The project root", pretty root ]+        : "may contain only one .agda-lib file, but I found several:"+        : map (("-" <+>) . pretty) (List.sort $ toList files) -    OtherError err -> text err+    LibParseError err -> pretty err -instance Pretty LibWarning where-  pretty (LibWarning mc w) = prefix <+> pretty w+    ReadError e msg -> vcat+      [ text $ msg+      , text $ showIOException e+      ]++    DuplicateExecutable exeFile exe paths -> vcat $+      hcat [ "Duplicate entries for executable '", (text . unpack) exe, "' in ", text exeFile, ":" ] :+      map (\ (ln, fp) -> nest 2 $ (pretty ln <> colon) <+> text fp) (toList paths)++-- | Print library file parse error without position info.+--+instance Pretty LibParseError where+  pretty = \case++    BadLibraryName s -> sep+      [ "Bad library name:", quotes (text s) ]+    ReadFailure file e -> vcat+      [ hsep [ "Failed to read library file", text file <> "." ]+      , "Reason:" <+> text (showIOException e)+      ]++    MissingFields   xs -> "Missing"   <+> listFields xs+    DuplicateFields xs -> "Duplicate" <+> listFields xs++    MissingFieldName     l   -> atLine l $ "Missing field name"+    BadFieldName         l s -> atLine l $ "Bad field name" <+> text (show s)+    MissingColonForField l s -> atLine l $ "Missing ':' for field " <+> text (show s)+    ContentWithoutField  l   -> atLine l $ "Missing field"+     where-      prefix = case mc of-        Nothing -> ""-        Just c  -> formatLibPositionInfo c ""+    listFields xs = hsep $ fieldS xs : list xs+    fieldS xs     = singPlural xs "field:" "fields:"+    list          = punctuate comma . map (quotes . text) . toList+    atLine l      = id+    -- The line number will be printed by 'formatLibPositionInfo'!+    -- atLine l doc  = hsep [ text (show l) <> ":", doc ]  +instance Pretty LibWarning where+  pretty (LibWarning mc w) =+    case mc of+      Nothing -> pretty w+      Just (LibPositionInfo _ _ file) -> hcat [ text file, ":"] <+> pretty w+ instance Pretty LibWarning' where   pretty (UnknownField s) = text $ "Unknown field '" ++ s ++ "'"  ------------------------------------------------------------------------+-- Hashable instances+------------------------------------------------------------------------++instance Hashable LibName++------------------------------------------------------------------------+-- Null instances+------------------------------------------------------------------------++instance Null LibName where+  empty = LibName empty empty+  null (LibName a b) = null a && null b++instance Null LibCache where+  empty = LibCache empty empty+  null (LibCache a b) = null a && null b++------------------------------------------------------------------------ -- NFData instances ------------------------------------------------------------------------  instance NFData ExecutablesFile+instance NFData LibrariesFile instance NFData ProjectConfig instance NFData AgdaLibFile+instance NFData LibName+instance NFData LibCache instance NFData LibPositionInfo instance NFData LibWarning instance NFData LibWarning'+instance NFData LibError+instance NFData LibError'+instance NFData LibErrors+instance NFData LibParseError+instance NFData E.IOException where rnf _ = ()
src/full/Agda/Interaction/Library/Parse.hs view
@@ -33,24 +33,32 @@ import Control.Monad.Except import Control.Monad.Writer import Data.Char-import Data.Data import qualified Data.List as List+import Data.Text (Text)+import qualified Data.Text as T import System.FilePath  import Agda.Interaction.Library.Base +import Agda.Syntax.Position+ import Agda.Utils.Applicative-import Agda.Utils.IO ( catchIO )+import Agda.Utils.FileName+import Agda.Utils.IO                ( catchIO ) import qualified Agda.Utils.IO.UTF8 as UTF8 import Agda.Utils.Lens-import Agda.Utils.List   ( duplicates )-import Agda.Utils.String ( ltrim )+import Agda.Utils.List              ( duplicates )+import Agda.Utils.List1             ( List1, toList )+import qualified Agda.Utils.List1   as List1+import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.Singleton+import Agda.Utils.String            ( ltrim ) --- | Parser monad: Can throw @String@ error messages, and collects+-- | Parser monad: Can throw @LibParseError@s, and collects -- @LibWarning'@s library warnings.-type P = ExceptT String (Writer [LibWarning'])+type P = ExceptT LibParseError (Writer [LibWarning']) -runP :: P a -> (Either String a, [LibWarning'])+runP :: P a -> (Either LibParseError a, [LibWarning']) runP = runWriter . runExceptT  warningP :: LibWarning' -> P ()@@ -67,29 +75,35 @@  -- | Library file field format format [sic!]. data Field = forall a. Field-  { fName     :: String            -- ^ Name of the field.-  , fOptional :: Bool              -- ^ Is it optional?-  , fParse    :: [String] -> P a   -- ^ Content parser for this field.-  , fSet      :: LensSet a AgdaLibFile-    -- ^ Sets parsed content in 'AgdaLibFile' structure.+  { fName     :: String+      -- ^ Name of the field.+  , fOptional :: Bool+      -- ^ Is it optional?+  , fParse    :: Range -> [String] -> P a+      -- ^ Content parser for this field.+      --+      -- The range points to the start of the file.+  , fSet      :: LensSet AgdaLibFile a+      -- ^ Sets parsed content in 'AgdaLibFile' structure.   } -optionalField :: String -> ([String] -> P a) -> Lens' a AgdaLibFile -> Field+optionalField ::+  String -> (Range -> [String] -> P a) -> Lens' AgdaLibFile a -> Field optionalField str p l = Field str True p (set l)  -- | @.agda-lib@ file format with parsers and setters. agdaLibFields :: [Field] agdaLibFields =   -- Andreas, 2017-08-23, issue #2708, field "name" is optional.-  [ optionalField "name"    parseName                      libName-  , optionalField "include" (pure . concatMap parsePaths)  libIncludes-  , optionalField "depend"  (pure . concatMap splitCommas) libDepends-  , optionalField "flags"   (pure . concatMap parseFlags)  libPragmas+  [ optionalField "name"    (\_ -> parseName)                     libName+  , optionalField "include" (\_ -> pure . concatMap parsePaths)   libIncludes+  , optionalField "depend"  (\_ -> pure . map parseLibName . concatMap splitCommas)  libDepends+  , optionalField "flags"   (\r -> pure . foldMap (parseFlags r)) libPragmas   ]   where     parseName :: [String] -> P LibName-    parseName [s] | [name] <- words s = pure name-    parseName ls = throwError $ "Bad library name: '" ++ unwords ls ++ "'"+    parseName [s] | [name] <- words s = pure $ parseLibName name+    parseName ls = throwError $ BadLibraryName $ unwords ls      parsePaths :: String -> [FilePath]     parsePaths = go id where@@ -100,8 +114,11 @@       go acc (       ' '  :cs) = fixup acc ++ go id cs       go acc (c           :cs) = go (acc . (c:)) cs -    parseFlags :: String -> [String]-    parseFlags = words+    parseFlags :: Range -> String -> OptionsPragma+    parseFlags r s = OptionsPragma+      { pragmaStrings = words s+      , pragmaRange   = r+      }  -- | Parse @.agda-lib@ file. --@@ -109,23 +126,29 @@ -- pathes (provided the given 'FilePath' is absolute). -- parseLibFile :: FilePath -> IO (P AgdaLibFile)-parseLibFile file =-  (fmap setPath . parseLib <$> UTF8.readFile file) `catchIO` \e ->-    return $ throwError $ unlines-      [ "Failed to read library file " ++ file ++ "."-      , "Reason: " ++ show e-      ]+parseLibFile file = do+  abs <- absolute file+  (fmap setPath . parseLib abs <$> UTF8.readFile file) `catchIO` \e ->+    return $ throwError $ ReadFailure file e   where     setPath      lib = unrelativise (takeDirectory file) (set libFile file lib)     unrelativise dir = over libIncludes (map (dir </>))  -- | Parse file contents.-parseLib :: String -> P AgdaLibFile-parseLib s = fromGeneric =<< parseGeneric s+parseLib+  :: AbsolutePath+     -- ^ The parsed file.+  -> String+  -> P AgdaLibFile+parseLib file s = fromGeneric file =<< parseGeneric s  -- | Parse 'GenericFile' with 'agdaLibFields' descriptors.-fromGeneric :: GenericFile -> P AgdaLibFile-fromGeneric = fromGeneric' agdaLibFields+fromGeneric+  :: AbsolutePath+     -- ^ The parsed file.+  -> GenericFile+  -> P AgdaLibFile+fromGeneric file = fromGeneric' file agdaLibFields  -- | Given a list of 'Field' descriptors (with their custom parsers), --   parse a 'GenericFile' into the 'AgdaLibFile' structure.@@ -133,33 +156,48 @@ --   Checks mandatory fields are present; --   no duplicate fields, no unknown fields. -fromGeneric' :: [Field] -> GenericFile -> P AgdaLibFile-fromGeneric' fields fs = do+fromGeneric'+  :: AbsolutePath+     -- ^ The parsed file.+  -> [Field]+  -> GenericFile+  -> P AgdaLibFile+fromGeneric' file fields fs = do   checkFields fields (map geHeader fs)   foldM upd emptyLibFile fs   where+    -- The range points to the start of the file.+    r = Range+          (Strict.Just $ mkRangeFile file Nothing)+          (singleton (posToInterval () p p))+      where+      p = Pn { srcFile = ()+             , posPos  = 1+             , posLine = 1+             , posCol  = 1+             }+     upd :: AgdaLibFile -> GenericEntry -> P AgdaLibFile     upd l (GenericEntry h cs) = do       mf <- findField h fields       case mf of         Just Field{..} -> do-          x <- fParse cs+          x <- fParse r cs           return $ fSet x l         Nothing -> return l  -- | Ensure that there are no duplicate fields and no mandatory fields are missing. checkFields :: [Field] -> [String] -> P () checkFields fields fs = do-  let mandatory = [ fName f | f <- fields, not $ fOptional f ]-      -- Missing fields.-      missing   = mandatory List.\\ fs-      -- Duplicate fields.-      dup       = duplicates fs-      -- Plural s for error message.-      s xs      = if length xs > 1 then "s" else ""-      list xs   = List.intercalate ", " [ "'" ++ f ++ "'" | f <- xs ]-  unless (null missing) $ throwError $ "Missing field" ++ s missing ++ " " ++ list missing-  unless (null dup)     $ throwError $ "Duplicate field" ++ s dup ++ " " ++ list dup+  -- Report missing mandatory fields.+  () <- List1.unlessNull missing $ throwError . MissingFields+  -- Report duplicate fields.+  List1.unlessNull (duplicates fs) $ throwError . DuplicateFields+  where+  mandatory :: [String]+  mandatory = [ fName f | f <- fields, not $ fOptional f ]+  missing   :: [String]+  missing   = mandatory List.\\ fs  -- | Find 'Field' with given 'fName', throw error if unknown. findField :: String -> [Field] -> P (Maybe Field)@@ -221,23 +259,23 @@   | isSpace c   = pure [Content l $ ltrim s]     -- Non-indented lines are 'Header'.   | otherwise   =-    case break (==':') s of+    case break (== ':') s of       -- Headers are single words followed by a colon.       -- Anything after the colon that is not whitespace is 'Content'.       (h, ':' : r) ->         case words h of           [h] -> pure $ Header l h : [Content l r' | let r' = ltrim r, not (null r')]-          []  -> throwError $ show l ++ ": Missing field name"-          hs  -> throwError $ show l ++ ": Bad field name " ++ show h-      _ -> throwError $ show l ++ ": Missing ':' for field " ++ show (ltrim s)+          []  -> throwError $ MissingFieldName l+          hs  -> throwError $ BadFieldName l h+      _ -> throwError $ MissingColonForField l (ltrim s)  -- | Collect 'Header' and subsequent 'Content's into 'GenericEntry'. -----   Tailing 'Content's?  That's an error.+--   Leading 'Content's?  That's an error. -- groupLines :: [GenericLine] -> P GenericFile groupLines [] = pure []-groupLines (Content l c : _) = throwError $ show l ++ ": Missing field"+groupLines (Content l c : _) = throwError $ ContentWithoutField l groupLines (Header _ h : ls) = (GenericEntry h [ c | Content _ c <- cs ] :) <$> groupLines ls1   where     (cs, ls1) = span isContent ls@@ -250,7 +288,7 @@  -- | Break a comma-separated string.  Result strings are @trim@med. splitCommas :: String -> [String]-splitCommas s = words $ map (\c -> if c == ',' then ' ' else c) s+splitCommas = words . map (\c -> if c == ',' then ' ' else c)  -- | ...and trailing, but not leading, whitespace. stripComments :: String -> String
src/full/Agda/Interaction/MakeCase.hs view
@@ -1,13 +1,12 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE NondecreasingIndentation #-}  module Agda.Interaction.MakeCase where -import Prelude hiding (null)--import Control.Monad+import Prelude hiding ((!!), null)  import Data.Either-import Data.Function import qualified Data.List as List import Data.Maybe import Data.Monoid@@ -20,8 +19,10 @@ import qualified Agda.Syntax.Concrete.Pattern as C import qualified Agda.Syntax.Abstract as A import qualified Agda.Syntax.Abstract.Pattern as A+import qualified Agda.Syntax.Common.Pretty as P import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern+import Agda.Syntax.Parser.Helpers ( mkValidName ) import Agda.Syntax.Scope.Base  ( ResolvedName(..), BindingSource(..), KindOfName(..), exceptKindsOfNames ) import Agda.Syntax.Scope.Monad ( resolveName' ) import Agda.Syntax.Translation.InternalToAbstract@@ -31,23 +32,20 @@ import Agda.TypeChecking.Coverage.Match ( SplitPatVar(..) , SplitPattern , applySplitPSubst , fromSplitPatterns ) import Agda.TypeChecking.Empty ( isEmptyTel ) import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Reduce import Agda.TypeChecking.Rules.Def (checkClauseLHS) import Agda.TypeChecking.Rules.LHS (LHSResult(..)) import Agda.TypeChecking.Rules.LHS.Problem (AsBinding(..))  import Agda.Interaction.Options-import Agda.Interaction.BasicOps  import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Function import Agda.Utils.Functor+import Agda.Utils.Lens   (set) import Agda.Utils.List import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Pretty (prettyShow)-import qualified Agda.Utils.Pretty as P-import Agda.Utils.Size+import Agda.Utils.WithDefault (lensKeepDefault)  import Agda.Utils.Impossible @@ -76,7 +74,7 @@   -- Get into the context of the meta.   mId <- lookupInteractionId ii   updateMetaVarRange mId rng-  mi  <- getMetaInfo <$> lookupMeta mId+  mi  <- getMetaInfo <$> lookupLocalMeta mId   enterClosure mi $ \ r -> do    reportSDoc "interaction.case" 20 $ do@@ -99,7 +97,7 @@   -- Step 1: From strings to abstract names   abstractNames :: [(A.Name, Maybe BindingSource)] <- forM ss $ \s -> do -    let cname = C.QName $ C.Name r C.InScope $ C.stringNameParts s+    cname <- either failParseError (return . C.QName) $ mkValidName False r s     -- Note: the range in the concrete name is only approximate.     -- Jesper, 2018-12-19: Don't consider generalizable names since     -- they can be shadowed by hidden variables.@@ -122,12 +120,12 @@   -- Step 2: Resolve each abstract name to a de Bruijn index.    -- First, get context names of the clause.-  let clauseCxtNames = map (fst . unDom) cxt+  let clauseCxtNames = contextNames' cxt    -- Valid names to split on are pattern variables of the clause,   -- plus as-bindings that refer to a variable.   let clauseVars = zip clauseCxtNames (map var [0..]) ++-                   map (\(AsB name v _ _) -> (name,v)) asb+                   map (\(AsB name v _) -> (name,v)) asb    -- We cannot split on module parameters or make them visible   params <- moduleParamsToApply $ qnameModule f@@ -142,19 +140,21 @@       -- has been refined to a module parameter we do allow splitting       -- on it, since the instantiation could as well have been the       -- other way around (see #2183).-      (Just (Var i []), PatternBound) -> return (i, C.InScope)+      (Just (Var i []), PatternBound _) -> return (i, C.InScope)       -- Case 1b: the variable has been refined.-      (Just v         , PatternBound) -> failInstantiatedVar s v+      (Just v         , PatternBound _) -> failInstantiatedVar s v       -- Case 1c: the variable is bound locally (e.g. a record let)-      (Nothing        , PatternBound) -> failCaseLet s+      (Nothing        , PatternBound _) -> failCaseLet s       -- Case 1d: module parameter       (Just (Var i []), LambdaBound ) -> failModuleBound s       -- Case 1e: locally lambda-bound variable       (_              , LambdaBound ) -> failLocal s       -- Case 1f: let-bound variable       (_              , LetBound    ) -> failLetBound s-      -- Case 1g: with-bound variable (not used?)-      (_              , WithBound   ) -> __IMPOSSIBLE__+      -- Case 1g: with-bound variable+      (_              , WithBound   ) -> failWithBound s+      -- Case 1h: macro-bound variable (interactive command impossible in macro context)+      (_              , MacroBound   ) -> __IMPOSSIBLE__     -- Case 2: variable has no binding site, so we check if it can be     -- made visible.     Nothing -> case List.find (((==) `on` nameConcrete) name . fst) clauseVars of@@ -173,24 +173,28 @@    where -  failNotVar s      = typeError $ GenericError $ "Not a variable: " ++ s-  failUnbound s     = typeError $ GenericError $ "Unbound variable " ++ s-  failAmbiguous s   = typeError $ GenericError $ "Ambiguous variable " ++ s-  failLocal s       = typeError $ GenericError $+  failParseError s  = interactionError $ CaseSplitError $ P.text s+  failNotVar s      = interactionError $ CaseSplitError $ P.text $ "Not a variable: " ++ s+  failUnbound s     = interactionError $ CaseSplitError $ P.text $ "Unbound variable " ++ s+  failAmbiguous s   = interactionError $ CaseSplitError $ P.text $ "Ambiguous variable " ++ s+  failLocal s       = interactionError $ CaseSplitError $ P.text $     "Cannot split on local variable " ++ s-  failHiddenLocal s = typeError $ GenericError $+  failHiddenLocal s = interactionError $ CaseSplitError $ P.text $     "Cannot make hidden lambda-bound variable " ++ s ++ " visible"-  failModuleBound s = typeError $ GenericError $+  failModuleBound s = interactionError $ CaseSplitError $ P.text $     "Cannot split on module parameter " ++ s-  failHiddenModuleBound s = typeError $ GenericError $+  failHiddenModuleBound s = interactionError $ CaseSplitError $ P.text $     "Cannot make hidden module parameter " ++ s ++ " visible"-  failLetBound s = typeError . GenericError $+  failLetBound s = interactionError $ CaseSplitError $ P.text $     "Cannot split on let-bound variable " ++ s-  failInstantiatedVar s v = typeError . GenericDocError =<< sep+  failWithBound s = interactionError $ CaseSplitError $ P.text $+    "Cannot split on variable " ++ s +++    ", because it is an equality proof bound by a with-abstraction"+  failInstantiatedVar s v = interactionError . CaseSplitError =<< sep       [ text $ "Cannot split on variable " ++ s ++ ", because it is bound to"       , prettyTCM v       ]-  failCaseLet s     = typeError $ GenericError $+  failCaseLet s     = interactionError $ CaseSplitError $ P.text $     "Cannot split on variable " ++ s ++     ", because let-declarations may not be defined by pattern-matching" @@ -223,18 +227,18 @@  recheckAbstractClause :: Type -> Maybe Substitution -> A.SpineClause -> TCM (Clause, Context, [AsBinding]) recheckAbstractClause t sub acl = checkClauseLHS t sub acl $ \ lhs -> do-  let cl = Clause{ clauseLHSRange    = getRange acl-                 , clauseFullRange   = getRange acl-                 , clauseTel         = lhsVarTele lhs-                 , namedClausePats   = lhsPatterns lhs-                 , clauseBody        = Nothing -- We don't need the body for make case-                 , clauseType        = Just (lhsBodyType lhs)-                 , clauseCatchall    = False-                 , clauseExact       = Nothing-                 , clauseRecursive   = Nothing-                 , clauseUnreachable = Nothing-                 , clauseEllipsis    = lhsEllipsis $ A.spLhsInfo $ A.clauseLHS acl-                 }+  let cl = Clause { clauseLHSRange    = getRange acl+                  , clauseFullRange   = getRange acl+                  , clauseTel         = lhsVarTele lhs+                  , namedClausePats   = lhsPatterns lhs+                  , clauseBody        = Nothing -- We don't need the body for make case+                  , clauseType        = Just (lhsBodyType lhs)+                  , clauseCatchall    = empty+                  , clauseRecursive   = Nothing+                  , clauseUnreachable = Nothing+                  , clauseEllipsis    = lhsEllipsis $ A.spLhsInfo $ A.clauseLHS acl+                  , clauseWhereModule = A.whereModule $ A.clauseWhereDecls acl+                  }   cxt <- getContext   let asb = lhsAsBindings lhs   return (cl, cxt, asb)@@ -251,8 +255,8 @@   -- Get function clause which contains the interaction point.   InteractionPoint { ipMeta = mm, ipClause = ipCl} <- lookupInteractionPoint hole   (f, clauseNo, clTy, clWithSub, absCl@A.Clause{ clauseRHS = rhs }, clClos) <- case ipCl of-    IPClause f i t sub cl clo _ -> return (f, i, t, sub, cl, clo)-    IPNoClause                -> typeError $ GenericError $+    IPClause f i t sub cl clo -> return (f, i, t, sub, cl, clo)+    IPNoClause                -> interactionError $ CaseSplitError $       "Cannot split here, as we are not in a function definition"   (casectxt, (prevClauses0, _clause, follClauses0)) <- getClauseZipperForIP f clauseNo @@ -323,7 +327,7 @@     -- When we introduce projection patterns in an extended lambda,     -- we need to print them postfix.     let postProjInExtLam = applyWhen (isJust casectxt) $-          withPragmaOptions $ \ opt -> opt { optPostfixProjections = True }+          withPragmaOptions $ set (lensOptPostfixProjections . lensKeepDefault) True     (piTel, sc) <- insertTrailingArgs False $ clauseToSplitClause clause     -- Andreas, 2015-05-05 If we introduced new function arguments     -- do not split on result.  This might be more what the user wants.@@ -382,7 +386,7 @@      -- If any of the split variables is hidden by the ellipsis, we     -- should force the expansion of the ellipsis.-    let splitNames = map (\i -> fst $ unDom $ clauseCxt !! i) toSplit+    let splitNames = map (\i -> ctxEntryName $ clauseCxt !! i) toSplit     shouldExpandEllipsis <- return (not $ null toShow) `or2M` anyEllipsisVar f absCl splitNames     let ell' | shouldExpandEllipsis = NoEllipsis              | otherwise            = ell@@ -414,7 +418,7 @@       then Just <$> makeAbsurdClause f ell' sc       -- trivially empty clause due to the refined patterns       else-        ifM (liftTCM $ isEmptyTel (scTel sc))+        ifM (liftTCM $ (optInferAbsurdClauses <$> pragmaOptions) `and2M` isEmptyTel (scTel sc))           {- then -} (pure Nothing)           {- else -} (Just <$> makeAbstractClause f rhs ell' sc)     reportSLn "interaction.case" 70 $ "makeCase: survived filtering out impossible clauses"@@ -432,7 +436,7 @@     return (f, casectxt, cs)    where-  failNoCop = typeError $ GenericError $+  failNoCop = interactionError $ CaseSplitError $     "OPTION --copatterns needed to split on result here"    -- Split clause on given variables, return the resulting clauses together@@ -460,7 +464,7 @@   checkClauseIsClean ipCl = do     sips <- filter ipSolved . BiMap.elems <$> useTC stInteractionPoints     when (List.any ((== ipCl) . ipClause) sips) $-      typeError $ GenericError $ "Cannot split as clause rhs has been refined.  Please reload"+      interactionError $ CaseSplitError $ "Cannot split as clause rhs has been refined.  Please reload"  -- | Make the given pattern variables visible by marking their origin as --   'CaseSplit' and pattern origin as 'PatOSplit' in the 'SplitClause'.@@ -482,7 +486,7 @@ --   In this case, replace the rhs by @record{}@ makeRHSEmptyRecord :: A.RHS -> A.RHS makeRHSEmptyRecord = \case-  A.RHS{}            -> A.RHS{ rhsExpr = A.Rec empty empty, rhsConcrete = Nothing }+  A.RHS{}            -> A.RHS{ rhsExpr = A.Rec empty empty empty, rhsConcrete = Nothing }   rhs@A.RewriteRHS{} -> rhs{ A.rewriteRHS = makeRHSEmptyRecord $ A.rewriteRHS rhs }   A.AbsurdRHS        -> __IMPOSSIBLE__   A.WithRHS{}        -> __IMPOSSIBLE__@@ -501,15 +505,20 @@       , "ell     =" <+> text (show ell)       ]     ]-  withCurrentModule (qnameModule f) $ do-    -- Andreas, 2015-05-29 Issue 635-    -- Contract implicit record patterns before printing.-    -- c <- translateRecordPatterns $ Clause noRange tel perm ps NoBody t False-    -- Jesper, 2015-09-19 Don't contract, since we do on-demand splitting-    let c = Clause noRange noRange tel ps Nothing (argFromDom <$> t) False Nothing Nothing Nothing ell-    let ps = namedClausePats c-    inTopContext $ reify $ QNamed f $ c { namedClausePats = ps }-+  withCurrentModule (qnameModule f) $+    inTopContext $ reify $ QNamed f $ Clause+      { clauseLHSRange  = noRange+      , clauseFullRange = noRange+      , clauseTel       = tel+      , namedClausePats = ps+      , clauseBody      = Nothing+      , clauseType      = argFromDom <$> t+      , clauseCatchall    = empty+      , clauseRecursive   = Nothing+      , clauseUnreachable = Nothing+      , clauseEllipsis    = ell+      , clauseWhereModule = Nothing+      }  -- | Make a clause with a question mark as rhs. @@ -518,7 +527,7 @@    lhs <- A.clauseLHS <$> makeAbsurdClause f ell cl   reportSDoc "interaction.case" 60 $ "reified lhs: " <+> prettyA lhs-  return $ A.Clause lhs [] rhs A.noWhereDecls False+  return $ A.Clause lhs [] rhs A.noWhereDecls empty   -- let ii = InteractionId (-1)  -- Dummy interaction point since we never type check this.   --                              -- Can end up in verbose output though (#1842), hence not __IMPOSSIBLE__.   -- let info = A.emptyMetaInfo   -- metaNumber = Nothing in order to print as ?, not ?n
src/full/Agda/Interaction/Monad.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# OPTIONS_GHC -fwarn-orphans #-} {-# LANGUAGE CPP               #-} @@ -7,8 +9,19 @@   , readline   ) where +import Control.Exception (throwIO)+import Control.Monad.Except (MonadError (..))+import Control.Monad.Trans (MonadIO, lift, liftIO)+import qualified System.Console.Haskeline as Haskeline++-- MonadException is replaced by MonadCatch in haskeline 0.8+#if MIN_VERSION_haskeline(0,8,0)+import qualified Control.Monad.Catch as Haskeline (catch)+#endif+ import Agda.TypeChecking.Monad   ( HasOptions+  , MonadFileId   , MonadTCEnv   , MonadTCM   , MonadTCState@@ -17,21 +30,14 @@   , TCM, TCMT(..)   , mapTCMT   )-import Control.Exception (throwIO)-import Control.Monad.Except (MonadError (..))-import Control.Monad.Trans (MonadIO, lift, liftIO)-import qualified System.Console.Haskeline as Haskeline --- MonadException is replaced by MonadCatch in haskeline 0.8-#if MIN_VERSION_haskeline(0,8,0)-import qualified Control.Monad.Catch as Haskeline (catch)-#endif- -- | Interaction monad. newtype IM a = IM {unIM :: TCMT (Haskeline.InputT IO) a}   deriving   ( Functor, Applicative, Monad, MonadIO-  , HasOptions, MonadTCEnv, ReadTCState, MonadTCState, MonadTCM )+  , HasOptions, MonadTCEnv, ReadTCState, MonadTCState, MonadTCM+  , MonadFileId+  )  runIM :: IM a -> TCM a runIM = mapTCMT (Haskeline.runInputT Haskeline.defaultSettings) . unIM
src/full/Agda/Interaction/Options.hs view
@@ -1,7 +1,11 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Interaction.Options-    ( module Opts.Base-    , module Opts.HasOptions+    ( module Agda.Interaction.Options.Base+    , module Agda.Interaction.Options.HasOptions+    , module Agda.Interaction.Options.Types     ) where -import Agda.Interaction.Options.Base as Opts.Base-import Agda.Interaction.Options.HasOptions as Opts.HasOptions+import Agda.Interaction.Options.Base+import Agda.Interaction.Options.HasOptions+import Agda.Interaction.Options.Types
src/full/Agda/Interaction/Options/Base.hs view
@@ -1,1134 +1,1848 @@ {-# LANGUAGE CPP       #-} {-# LANGUAGE DataKinds #-}--module Agda.Interaction.Options.Base-    ( CommandLineOptions(..)-    , PragmaOptions(..)-    , OptionsPragma-    , Flag, OptM, runOptM, OptDescr(..), ArgDescr(..)-    , Verbosity, VerboseKey, VerboseLevel-    , WarningMode(..)-    , ConfluenceCheck(..)-    , UnicodeOrAscii(..)-    , checkOpts-    , parsePragmaOptions-    , parsePluginOptions-    , stripRTS-    , defaultOptions-    , defaultInteractionOptions-    , defaultVerbosity-    , defaultCutOff-    , defaultPragmaOptions-    , standardOptions_-    , unsafePragmaOptions-    , restartOptions-    , infectiveOptions-    , coinfectiveOptions-    , safeFlag-    , mapFlag-    , usage-    -- Reused by PandocAgda-    , inputFlag-    , standardOptions, deadStandardOptions-    , getOptSimple-    ) where--import Control.DeepSeq-import Control.Monad ( when, void )-import Control.Monad.Except ( Except, MonadError(throwError), runExcept )--import qualified System.IO.Unsafe as UNSAFE (unsafePerformIO)-import Data.Maybe-import Data.Map                 ( Map )-import qualified Data.Map as Map-import Data.List                ( intercalate )-import qualified Data.Set as Set--import GHC.Generics (Generic)--import System.Console.GetOpt    ( getOpt', usageInfo, ArgOrder(ReturnInOrder)-                                , OptDescr(..), ArgDescr(..)-                                )-import Text.EditDistance-import Text.Read                ( readMaybe )--import Agda.Termination.CutOff  ( CutOff(..), defaultCutOff )--import Agda.Interaction.Library ( ExeName, LibName )-import Agda.Interaction.Options.Help-  ( Help(HelpFor, GeneralHelp)-  , string2HelpTopic-  , allHelpTopics-  , helpTopicUsage-  )-import Agda.Interaction.Options.Warnings-import Agda.Syntax.Concrete.Glyph ( unsafeSetUnicodeOrAscii, UnicodeOrAscii(..) )-import Agda.Syntax.Common (Cubical(..))--import Agda.Utils.FileName      ( AbsolutePath )-import Agda.Utils.Functor       ( (<&>) )-import Agda.Utils.Lens          ( Lens', over )-import Agda.Utils.List          ( groupOn, initLast1, wordsBy )-import Agda.Utils.Pretty        ( singPlural )-import Agda.Utils.Trie          ( Trie )-import qualified Agda.Utils.Trie as Trie-import Agda.Utils.WithDefault--import Agda.Version---- OptDescr is a Functor ----------------------------------------------------type VerboseKey   = String-type VerboseLevel = Int-type Verbosity    = Trie VerboseKey VerboseLevel---- Don't forget to update---   doc/user-manual/tools/command-line-options.rst--- if you make changes to the command-line options!--data CommandLineOptions = Options-  { optProgramName           :: String-  , optInputFile             :: Maybe FilePath-  , optIncludePaths          :: [FilePath]-  , optAbsoluteIncludePaths  :: [AbsolutePath]-    -- ^ The list should not contain duplicates.-  , optLibraries             :: [LibName]-  , optOverrideLibrariesFile :: Maybe FilePath-  -- ^ Use this (if Just) instead of .agda/libraries-  , optDefaultLibs           :: Bool-  -- ^ Use ~/.agda/defaults-  , optUseLibs               :: Bool-  -- ^ look for .agda-lib files-  , optTrustedExecutables             :: Map ExeName FilePath-  -- ^ Map names of trusted executables to absolute paths-  , optPrintAgdaDir          :: Bool-  , optPrintVersion          :: Bool-  , optPrintHelp             :: Maybe Help-  , optInteractive           :: Bool-      -- ^ Agda REPL (-I).-  , optGHCiInteraction       :: Bool-  , optJSONInteraction       :: Bool-  , optOptimSmashing         :: Bool-  , optCompileDir            :: Maybe FilePath-  -- ^ In the absence of a path the project root is used.-  , optGenerateVimFile       :: Bool-  , optIgnoreInterfaces      :: Bool-  , optIgnoreAllInterfaces   :: Bool-  , optLocalInterfaces       :: Bool-  , optPragmaOptions         :: PragmaOptions-  , optOnlyScopeChecking     :: Bool-    -- ^ Should the top-level module only be scope-checked, and not-    --   type-checked?-  }-  deriving (Show, Generic)--instance NFData CommandLineOptions---- | Options which can be set in a pragma.--data PragmaOptions = PragmaOptions-  { optShowImplicit              :: Bool-  , optShowIrrelevant            :: Bool-  , optUseUnicode                :: UnicodeOrAscii-  , optVerbose                   :: Verbosity-  , optProp                      :: Bool-  , optTwoLevel                  :: WithDefault 'False-  , optAllowUnsolved             :: Bool-  , optAllowIncompleteMatch      :: Bool-  , optDisablePositivity         :: Bool-  , optTerminationCheck          :: Bool-  , optTerminationDepth          :: CutOff-    -- ^ Cut off structural order comparison at some depth in termination checker?-  , optCompletenessCheck         :: Bool-  , optUniverseCheck             :: Bool-  , optOmegaInOmega              :: Bool-  , optSubtyping                 :: WithDefault 'False-  , optCumulativity              :: Bool-  , optSizedTypes                :: WithDefault 'False-  , optGuardedness               :: WithDefault 'False-  , optInjectiveTypeConstructors :: Bool-  , optUniversePolymorphism      :: Bool-  , optIrrelevantProjections     :: Bool-  , optExperimentalIrrelevance   :: Bool  -- ^ irrelevant levels, irrelevant data matching-  , optWithoutK                  :: WithDefault 'False-  , optCopatterns                :: Bool  -- ^ Allow definitions by copattern matching?-  , optPatternMatching           :: Bool  -- ^ Is pattern matching allowed in the current file?-  , optExactSplit                :: Bool-  , optEta                       :: Bool-  , optForcing                   :: Bool  -- ^ Perform the forcing analysis on data constructors?-  , optProjectionLike            :: Bool  -- ^ Perform the projection-likeness analysis on functions?-  , optRewriting                 :: Bool  -- ^ Can rewrite rules be added and used?-  , optCubical                   :: Maybe Cubical-  , optGuarded                   :: Bool-  , optFirstOrder                :: Bool  -- ^ Should we speculatively unify function applications as if they were injective?-  , optPostfixProjections        :: Bool-      -- ^ Should system generated projections 'ProjSystem' be printed-      --   postfix (True) or prefix (False).-  , optKeepPatternVariables      :: Bool-      -- ^ Should case splitting replace variables with dot patterns-      --   (False) or keep them as variables (True).-  , optInstanceSearchDepth       :: Int-  , optOverlappingInstances      :: Bool-  , optQualifiedInstances        :: Bool  -- ^ Should instance search consider instances with qualified names?-  , optInversionMaxDepth         :: Int-  , optSafe                      :: Bool-  , optDoubleCheck               :: Bool-  , optSyntacticEquality         :: Bool  -- ^ Should conversion checker use syntactic equality shortcut?-  , optWarningMode               :: WarningMode-  , optCompileNoMain             :: Bool-  , optCaching                   :: Bool-  , optCountClusters             :: Bool-    -- ^ Count extended grapheme clusters rather than code points when-    -- generating LaTeX.-  , optAutoInline                :: Bool-    -- ^ Automatic compile-time inlining for simple definitions (unless marked-    --   NOINLINE).-  , optPrintPatternSynonyms      :: Bool-  , optFastReduce                :: Bool-    -- ^ Use the Agda abstract machine (fastReduce)?-  , optCallByName                :: Bool-    -- ^ Use call-by-name instead of call-by-need-  , optConfluenceCheck           :: Maybe ConfluenceCheck-    -- ^ Check confluence of rewrite rules?-  , optFlatSplit                 :: Bool-     -- ^ Can we split on a (@flat x : A) argument?-  , optImportSorts               :: Bool-     -- ^ Should every top-level module start with an implicit statement-     --   @open import Agda.Primitive using (Set; Prop)@?-  , optAllowExec                 :: Bool-  , optShowIdentitySubstitutions :: Bool-    -- ^ Show identity substitutions when pretty-printing terms-    --   (i.e. always show all arguments of a metavariable)-  }-  deriving (Show, Eq, Generic)--instance NFData PragmaOptions--data ConfluenceCheck-  = LocalConfluenceCheck-  | GlobalConfluenceCheck-  deriving (Show, Eq, Generic)--instance NFData ConfluenceCheck---- | The options from an @OPTIONS@ pragma.------ In the future it might be nice to switch to a more structured--- representation. Note that, currently, there is not a one-to-one--- correspondence between list elements and options.-type OptionsPragma = [String]---- | Map a function over the long options. Also removes the short options.---   Will be used to add the plugin name to the plugin options.-mapFlag :: (String -> String) -> OptDescr a -> OptDescr a-mapFlag f (Option _ long arg descr) = Option [] (map f long) arg descr--defaultVerbosity :: Verbosity-defaultVerbosity = Trie.singleton [] 1--defaultInteractionOptions :: PragmaOptions-defaultInteractionOptions = defaultPragmaOptions--defaultOptions :: CommandLineOptions-defaultOptions = Options-  { optProgramName      = "agda"-  , optInputFile             = Nothing-  , optIncludePaths          = []-  , optAbsoluteIncludePaths  = []-  , optLibraries             = []-  , optOverrideLibrariesFile = Nothing-  , optDefaultLibs           = True-  , optUseLibs               = True-  , optTrustedExecutables    = Map.empty-  , optPrintAgdaDir          = False-  , optPrintVersion          = False-  , optPrintHelp             = Nothing-  , optInteractive           = False-  , optGHCiInteraction       = False-  , optJSONInteraction       = False-  , optOptimSmashing         = True-  , optCompileDir            = Nothing-  , optGenerateVimFile       = False-  , optIgnoreInterfaces      = False-  , optIgnoreAllInterfaces   = False-  , optLocalInterfaces       = False-  , optPragmaOptions         = defaultPragmaOptions-  , optOnlyScopeChecking     = False-  }--defaultPragmaOptions :: PragmaOptions-defaultPragmaOptions = PragmaOptions-  { optShowImplicit              = False-  , optShowIrrelevant            = False-  , optUseUnicode                = UnicodeOk-  , optVerbose                   = defaultVerbosity-  , optProp                      = False-  , optTwoLevel                  = Default-  , optExperimentalIrrelevance   = False-  , optIrrelevantProjections     = False -- off by default in > 2.5.4, see issue #2170-  , optAllowUnsolved             = False-  , optAllowIncompleteMatch      = False-  , optDisablePositivity         = False-  , optTerminationCheck          = True-  , optTerminationDepth          = defaultCutOff-  , optCompletenessCheck         = True-  , optUniverseCheck             = True-  , optOmegaInOmega              = False-  , optSubtyping                 = Default-  , optCumulativity              = False-  , optSizedTypes                = Default-  , optGuardedness               = Default-  , optInjectiveTypeConstructors = False-  , optUniversePolymorphism      = True-  , optWithoutK                  = Default-  , optCopatterns                = True-  , optPatternMatching           = True-  , optExactSplit                = False-  , optEta                       = True-  , optForcing                   = True-  , optProjectionLike            = True-  , optRewriting                 = False-  , optCubical                   = Nothing-  , optGuarded                   = False-  , optFirstOrder                = False-  , optPostfixProjections        = False-  , optKeepPatternVariables      = False-  , optInstanceSearchDepth       = 500-  , optOverlappingInstances      = False-  , optQualifiedInstances        = True-  , optInversionMaxDepth         = 50-  , optSafe                      = False-  , optDoubleCheck               = False-  , optSyntacticEquality         = True-  , optWarningMode               = defaultWarningMode-  , optCompileNoMain             = False-  , optCaching                   = True-  , optCountClusters             = False-  , optAutoInline                = False-  , optPrintPatternSynonyms      = True-  , optFastReduce                = True-  , optCallByName                = False-  , optConfluenceCheck           = Nothing-  , optFlatSplit                 = True-  , optImportSorts               = True-  , optAllowExec                 = False-  , optShowIdentitySubstitutions = False-  }--type OptM = Except String--runOptM :: Monad m => OptM opts -> m (Either String opts)-runOptM = pure . runExcept--{- | @f :: Flag opts@  is an action on the option record that results from-     parsing an option.  @f opts@ produces either an error message or an-     updated options record--}-type Flag opts = opts -> OptM opts---- | Checks that the given options are consistent.--checkOpts :: Flag CommandLineOptions-checkOpts opts = do-  -- NOTE: This is a temporary hold-out until --vim can be converted into a backend or plugin,-  -- whose options compatibility currently is checked in `Agda.Compiler.Backend`.-  ---  -- Additionally, note that some options checking is performed in `Agda.Main`-  -- in which the top-level frontend and backend interactors are selected.-  ---  -- Those checks are not represented here, because:-  --   - They are used solely for selecting the initial executon mode; they-  --     don't need to be checked on a per-module etc basis.-  --   - I hope/expect that the presence of those specific flags will be eventually-  --     abstracted out (like the Backends' internal flags), so that they are invisible-  --     to the rest of the type-checking system.-  when (optGenerateVimFile opts && optOnlyScopeChecking opts) $-    throwError $ "The --only-scope-checking flag cannot be combined with --vim."-  return opts---- | Check for unsafe pragmas. Gives a list of used unsafe flags.--unsafePragmaOptions :: CommandLineOptions -> PragmaOptions -> [String]-unsafePragmaOptions clo opts =-  [ "--allow-unsolved-metas"                     | optAllowUnsolved opts             ] ++-  [ "--allow-incomplete-matches"                 | optAllowIncompleteMatch opts      ] ++-  [ "--no-positivity-check"                      | optDisablePositivity opts         ] ++-  [ "--no-termination-check"                     | not (optTerminationCheck opts)    ] ++-  [ "--type-in-type"                             | not (optUniverseCheck opts)       ] ++-  [ "--omega-in-omega"                           | optOmegaInOmega opts              ] ++-  [ "--sized-types"                              | collapseDefault (optSizedTypes opts) ] ++-  [ "--injective-type-constructors"              | optInjectiveTypeConstructors opts ] ++-  [ "--irrelevant-projections"                   | optIrrelevantProjections opts     ] ++-  [ "--experimental-irrelevance"                 | optExperimentalIrrelevance opts   ] ++-  [ "--rewriting"                                | optRewriting opts                 ] ++-  [ "--cubical and --with-K"                     | optCubical opts == Just CFull-                                                 , not (collapseDefault $ optWithoutK opts) ] ++-  [ "--erased-cubical and --with-K"              | optCubical opts == Just CErased-                                                 , not (collapseDefault $ optWithoutK opts) ] ++-  [ "--cumulativity"                             | optCumulativity opts              ] ++-  [ "--allow-exec"                               | optAllowExec opts                 ] ++-  []---- | If any these options have changed, then the file will be---   rechecked. Boolean options are negated to mention non-default---   options, where possible.--restartOptions :: [(PragmaOptions -> RestartCodomain, String)]-restartOptions =-  [ (C . optTerminationDepth, "--termination-depth")-  , (B . (/= UnicodeOk) . optUseUnicode, "--no-unicode")-  , (B . optAllowUnsolved, "--allow-unsolved-metas")-  , (B . optAllowIncompleteMatch, "--allow-incomplete-matches")-  , (B . optDisablePositivity, "--no-positivity-check")-  , (B . optTerminationCheck,  "--no-termination-check")-  , (B . not . optUniverseCheck, "--type-in-type")-  , (B . optOmegaInOmega, "--omega-in-omega")-  , (B . collapseDefault . optSubtyping, "--subtyping")-  , (B . optCumulativity, "--cumulativity")-  , (B . collapseDefault . optSizedTypes, "--no-sized-types")-  , (B . collapseDefault . optGuardedness, "--no-guardedness")-  , (B . optInjectiveTypeConstructors, "--injective-type-constructors")-  , (B . optProp, "--prop")-  , (B . collapseDefault . optTwoLevel, "--two-level")-  , (B . not . optUniversePolymorphism, "--no-universe-polymorphism")-  , (B . optIrrelevantProjections, "--irrelevant-projections")-  , (B . optExperimentalIrrelevance, "--experimental-irrelevance")-  , (B . collapseDefault . optWithoutK, "--without-K")-  , (B . optExactSplit, "--exact-split")-  , (B . not . optEta, "--no-eta-equality")-  , (B . optRewriting, "--rewriting")-  , (B . (== Just CFull) . optCubical, "--cubical")-  , (B . (== Just CErased) . optCubical, "--erased-cubical")-  , (B . optGuarded, "--guarded")-  , (B . optOverlappingInstances, "--overlapping-instances")-  , (B . optQualifiedInstances, "--qualified-instances")-  , (B . not . optQualifiedInstances, "--no-qualified-instances")-  , (B . optSafe, "--safe")-  , (B . optDoubleCheck, "--double-check")-  , (B . not . optSyntacticEquality, "--no-syntactic-equality")-  , (B . not . optAutoInline, "--no-auto-inline")-  , (B . not . optFastReduce, "--no-fast-reduce")-  , (B . optCallByName, "--call-by-name")-  , (I . optInstanceSearchDepth, "--instance-search-depth")-  , (I . optInversionMaxDepth, "--inversion-max-depth")-  , (W . optWarningMode, "--warning")-  , (B . (== Just LocalConfluenceCheck) . optConfluenceCheck, "--local-confluence-check")-  , (B . (== Just GlobalConfluenceCheck) . optConfluenceCheck, "--confluence-check")-  , (B . not . optImportSorts, "--no-import-sorts")-  , (B . optAllowExec, "--allow-exec")-  ]---- to make all restart options have the same type-data RestartCodomain = C CutOff | B Bool | I Int | W WarningMode-  deriving Eq---- | An infective option is an option that if used in one module, must---   be used in all modules that depend on this module.------ Note that @--cubical@ and @--erased-cubical@ are \"jointly--- infective\": if one of them is used in one module, then one or the--- other must be used in all modules that depend on this module.--infectiveOptions :: [(PragmaOptions -> Bool, String)]-infectiveOptions =-  [ (isJust . optCubical, "--cubical/--erased-cubical")-  , (optGuarded, "--guarded")-  , (optProp, "--prop")-  , (collapseDefault . optTwoLevel, "--two-level")-  , (optRewriting, "--rewriting")-  , (collapseDefault . optSizedTypes, "--sized-types")-  , (collapseDefault . optGuardedness, "--guardedness")-  ]---- | A coinfective option is an option that if used in one module, must---   be used in all modules that this module depends on.--coinfectiveOptions :: [(PragmaOptions -> Bool, String)]-coinfectiveOptions =-  [ (optSafe, "--safe")-  , (collapseDefault . optWithoutK, "--without-K")-  , (not . optUniversePolymorphism, "--no-universe-polymorphism")-  , (not . collapseDefault . optSubtyping, "--no-subtyping")-  , (not . optCumulativity, "--no-cumulativity")-  ]--inputFlag :: FilePath -> Flag CommandLineOptions-inputFlag f o =-    case optInputFile o of-        Nothing  -> return $ o { optInputFile = Just f }-        Just _   -> throwError "only one input file allowed"--printAgdaDirFlag :: Flag CommandLineOptions-printAgdaDirFlag o = return $ o { optPrintAgdaDir = True }--versionFlag :: Flag CommandLineOptions-versionFlag o = return $ o { optPrintVersion = True }--helpFlag :: Maybe String -> Flag CommandLineOptions-helpFlag Nothing    o = return $ o { optPrintHelp = Just GeneralHelp }-helpFlag (Just str) o = case string2HelpTopic str of-  Just hpt -> return $ o { optPrintHelp = Just (HelpFor hpt) }-  Nothing -> throwError $ "unknown help topic " ++ str ++ " (available: " ++-                           intercalate ", " (map fst allHelpTopics) ++ ")"--safeFlag :: Flag PragmaOptions-safeFlag o = do-  let sizedTypes  = optSizedTypes o-  return $ o { optSafe        = True-             , optSizedTypes  = setDefault False sizedTypes-             }--flatSplitFlag :: Flag PragmaOptions-flatSplitFlag o = return $ o { optFlatSplit = True }--noFlatSplitFlag :: Flag PragmaOptions-noFlatSplitFlag o = return $ o { optFlatSplit = False }--doubleCheckFlag :: Bool -> Flag PragmaOptions-doubleCheckFlag b o = return $ o { optDoubleCheck = b }--noSyntacticEqualityFlag :: Flag PragmaOptions-noSyntacticEqualityFlag o = return $ o { optSyntacticEquality = False }--noSortComparisonFlag :: Flag PragmaOptions-noSortComparisonFlag o = return o--sharingFlag :: Bool -> Flag CommandLineOptions-sharingFlag _ _ = throwError $-  "Feature --sharing has been removed (in favor of the Agda abstract machine)."--cachingFlag :: Bool -> Flag PragmaOptions-cachingFlag b o = return $ o { optCaching = b }--propFlag :: Flag PragmaOptions-propFlag o = return $ o { optProp = True }--noPropFlag :: Flag PragmaOptions-noPropFlag o = return $ o { optProp = False }--twoLevelFlag :: Flag PragmaOptions-twoLevelFlag o = return $ o { optTwoLevel = Value True }--experimentalIrrelevanceFlag :: Flag PragmaOptions-experimentalIrrelevanceFlag o = return $ o { optExperimentalIrrelevance = True }--irrelevantProjectionsFlag :: Flag PragmaOptions-irrelevantProjectionsFlag o = return $ o { optIrrelevantProjections = True }--noIrrelevantProjectionsFlag :: Flag PragmaOptions-noIrrelevantProjectionsFlag o = return $ o { optIrrelevantProjections = False }--ignoreInterfacesFlag :: Flag CommandLineOptions-ignoreInterfacesFlag o = return $ o { optIgnoreInterfaces = True }--ignoreAllInterfacesFlag :: Flag CommandLineOptions-ignoreAllInterfacesFlag o = return $ o { optIgnoreAllInterfaces = True }--localInterfacesFlag :: Flag CommandLineOptions-localInterfacesFlag o = return $ o { optLocalInterfaces = True }--allowUnsolvedFlag :: Flag PragmaOptions-allowUnsolvedFlag o = do-  let upd = over warningSet (Set.\\ unsolvedWarnings)-  return $ o { optAllowUnsolved = True-             , optWarningMode   = upd (optWarningMode o)-             }--allowIncompleteMatchFlag :: Flag PragmaOptions-allowIncompleteMatchFlag o = do-  let upd = over warningSet (Set.\\ incompleteMatchWarnings)-  return $ o { optAllowIncompleteMatch = True-             , optWarningMode          = upd (optWarningMode o)-             }--showImplicitFlag :: Flag PragmaOptions-showImplicitFlag o = return $ o { optShowImplicit = True }--showIrrelevantFlag :: Flag PragmaOptions-showIrrelevantFlag o = return $ o { optShowIrrelevant = True }--showIdentitySubstitutionsFlag :: Flag PragmaOptions-showIdentitySubstitutionsFlag o = return $ o { optShowIdentitySubstitutions = True }--asciiOnlyFlag :: Flag PragmaOptions-asciiOnlyFlag o = return $ UNSAFE.unsafePerformIO $ do-  unsafeSetUnicodeOrAscii AsciiOnly-  return $ o { optUseUnicode = AsciiOnly }--ghciInteractionFlag :: Flag CommandLineOptions-ghciInteractionFlag o = return $ o { optGHCiInteraction = True }--jsonInteractionFlag :: Flag CommandLineOptions-jsonInteractionFlag o = return $ o { optJSONInteraction = True }--vimFlag :: Flag CommandLineOptions-vimFlag o = return $ o { optGenerateVimFile = True }--onlyScopeCheckingFlag :: Flag CommandLineOptions-onlyScopeCheckingFlag o = return $ o { optOnlyScopeChecking = True }--countClustersFlag :: Flag PragmaOptions-countClustersFlag o =-#ifdef COUNT_CLUSTERS-  return $ o { optCountClusters = True }-#else-  throwError-    "Cluster counting has not been enabled in this build of Agda."-#endif--noAutoInlineFlag :: Flag PragmaOptions-noAutoInlineFlag o = return $ o { optAutoInline = False }--autoInlineFlag :: Flag PragmaOptions-autoInlineFlag o = return $ o { optAutoInline = True }--noPrintPatSynFlag :: Flag PragmaOptions-noPrintPatSynFlag o = return $ o { optPrintPatternSynonyms = False }--noFastReduceFlag :: Flag PragmaOptions-noFastReduceFlag o = return $ o { optFastReduce = False }--callByNameFlag :: Flag PragmaOptions-callByNameFlag o = return $ o { optCallByName = True }--noPositivityFlag :: Flag PragmaOptions-noPositivityFlag o = do-  let upd = over warningSet (Set.delete NotStrictlyPositive_)-  return $ o { optDisablePositivity = True-             , optWarningMode   = upd (optWarningMode o)-             }--dontTerminationCheckFlag :: Flag PragmaOptions-dontTerminationCheckFlag o = do-  let upd = over warningSet (Set.delete TerminationIssue_)-  return $ o { optTerminationCheck = False-             , optWarningMode   = upd (optWarningMode o)-             }---- The option was removed. See Issue 1918.-dontCompletenessCheckFlag :: Flag PragmaOptions-dontCompletenessCheckFlag _ =-  throwError "The --no-coverage-check option has been removed."--dontUniverseCheckFlag :: Flag PragmaOptions-dontUniverseCheckFlag o = return $ o { optUniverseCheck = False }--omegaInOmegaFlag :: Flag PragmaOptions-omegaInOmegaFlag o = return $ o { optOmegaInOmega = True }--subtypingFlag :: Flag PragmaOptions-subtypingFlag o = return $ o { optSubtyping = Value True }--noSubtypingFlag :: Flag PragmaOptions-noSubtypingFlag o = return $ o { optSubtyping = Value False }--cumulativityFlag :: Flag PragmaOptions-cumulativityFlag o =-  return $ o { optCumulativity = True-             , optSubtyping    = setDefault True $ optSubtyping o-             }--noCumulativityFlag :: Flag PragmaOptions-noCumulativityFlag o = return $ o { optCumulativity = False }----UNUSED Liang-Ting Chen 2019-07-16---etaFlag :: Flag PragmaOptions---etaFlag o = return $ o { optEta = True }--noEtaFlag :: Flag PragmaOptions-noEtaFlag o = return $ o { optEta = False }--sizedTypes :: Flag PragmaOptions-sizedTypes o =-  return $ o { optSizedTypes = Value True-             --, optSubtyping  = setDefault True $ optSubtyping o-             }--noSizedTypes :: Flag PragmaOptions-noSizedTypes o = return $ o { optSizedTypes = Value False }--guardedness :: Flag PragmaOptions-guardedness o = return $ o { optGuardedness = Value True }--noGuardedness :: Flag PragmaOptions-noGuardedness o = return $ o { optGuardedness = Value False }--injectiveTypeConstructorFlag :: Flag PragmaOptions-injectiveTypeConstructorFlag o = return $ o { optInjectiveTypeConstructors = True }--guardingTypeConstructorFlag :: Flag PragmaOptions-guardingTypeConstructorFlag _ = throwError $-  "Experimental feature --guardedness-preserving-type-constructors has been removed."--universePolymorphismFlag :: Flag PragmaOptions-universePolymorphismFlag o = return $ o { optUniversePolymorphism = True }--noUniversePolymorphismFlag :: Flag PragmaOptions-noUniversePolymorphismFlag  o = return $ o { optUniversePolymorphism = False }--noForcingFlag :: Flag PragmaOptions-noForcingFlag o = return $ o { optForcing = False }--noProjectionLikeFlag :: Flag PragmaOptions-noProjectionLikeFlag o = return $ o { optProjectionLike = False }--withKFlag :: Flag PragmaOptions-withKFlag o = return $ o { optWithoutK = Value False }--withoutKFlag :: Flag PragmaOptions-withoutKFlag o = return $ o { optWithoutK = Value True }--copatternsFlag :: Flag PragmaOptions-copatternsFlag o = return $ o { optCopatterns = True }--noCopatternsFlag :: Flag PragmaOptions-noCopatternsFlag o = return $ o { optCopatterns = False }--noPatternMatchingFlag :: Flag PragmaOptions-noPatternMatchingFlag o = return $ o { optPatternMatching = False }--exactSplitFlag :: Flag PragmaOptions-exactSplitFlag o = do-  let upd = over warningSet (Set.insert CoverageNoExactSplit_)-  return $ o { optExactSplit = True-             , optWarningMode   = upd (optWarningMode o)-             }--noExactSplitFlag :: Flag PragmaOptions-noExactSplitFlag o = do-  let upd = over warningSet (Set.delete CoverageNoExactSplit_)-  return $ o { optExactSplit = False-             , optWarningMode   = upd (optWarningMode o)-             }--rewritingFlag :: Flag PragmaOptions-rewritingFlag o = return $ o { optRewriting = True }--firstOrderFlag :: Flag PragmaOptions-firstOrderFlag o = return $ o { optFirstOrder = True }--cubicalFlag-  :: Cubical  -- ^ Which variant of Cubical Agda?-  -> Flag PragmaOptions-cubicalFlag variant o = do-  let withoutK = optWithoutK o-  return $ o { optCubical  = Just variant-             , optWithoutK = setDefault True withoutK-             , optTwoLevel = setDefault True $ optTwoLevel o-             }--guardedFlag :: Flag PragmaOptions-guardedFlag o = do-  return $ o { optGuarded  = True }--postfixProjectionsFlag :: Flag PragmaOptions-postfixProjectionsFlag o = return $ o { optPostfixProjections = True }--keepPatternVariablesFlag :: Flag PragmaOptions-keepPatternVariablesFlag o = return $ o { optKeepPatternVariables = True }--instanceDepthFlag :: String -> Flag PragmaOptions-instanceDepthFlag s o = do-  d <- integerArgument "--instance-search-depth" s-  return $ o { optInstanceSearchDepth = d }--overlappingInstancesFlag :: Flag PragmaOptions-overlappingInstancesFlag o = return $ o { optOverlappingInstances = True }--noOverlappingInstancesFlag :: Flag PragmaOptions-noOverlappingInstancesFlag o = return $ o { optOverlappingInstances = False }--qualifiedInstancesFlag :: Flag PragmaOptions-qualifiedInstancesFlag o = return $ o { optQualifiedInstances = True }--noQualifiedInstancesFlag :: Flag PragmaOptions-noQualifiedInstancesFlag o = return $ o { optQualifiedInstances = False }--inversionMaxDepthFlag :: String -> Flag PragmaOptions-inversionMaxDepthFlag s o = do-  d <- integerArgument "--inversion-max-depth" s-  return $ o { optInversionMaxDepth = d }--interactiveFlag :: Flag CommandLineOptions-interactiveFlag  o = return $ o { optInteractive = True }--compileFlagNoMain :: Flag PragmaOptions-compileFlagNoMain o = return $ o { optCompileNoMain = True }--compileDirFlag :: FilePath -> Flag CommandLineOptions-compileDirFlag f o = return $ o { optCompileDir = Just f }--includeFlag :: FilePath -> Flag CommandLineOptions-includeFlag d o = return $ o { optIncludePaths = d : optIncludePaths o }--libraryFlag :: String -> Flag CommandLineOptions-libraryFlag s o = return $ o { optLibraries = optLibraries o ++ [s] }--overrideLibrariesFileFlag :: String -> Flag CommandLineOptions-overrideLibrariesFileFlag s o =-  return $ o-    { optOverrideLibrariesFile = Just s-    , optUseLibs = True-    }--noDefaultLibsFlag :: Flag CommandLineOptions-noDefaultLibsFlag o = return $ o { optDefaultLibs = False }--noLibsFlag :: Flag CommandLineOptions-noLibsFlag o = return $ o { optUseLibs = False }--verboseFlag :: String -> Flag PragmaOptions-verboseFlag s o =-    do  (k,n) <- parseVerbose s-        return $ o { optVerbose = Trie.insert k n $ optVerbose o }-  where-    parseVerbose :: String -> OptM ([VerboseKey], VerboseLevel)-    parseVerbose s = case wordsBy (`elem` (":." :: String)) s of-      []  -> usage-      s0:ss0 -> do-        let (ss, s) = initLast1 s0 ss0-        n <- maybe usage return $ readMaybe s-        return (ss, n)-    usage = throwError "argument to verbose should be on the form x.y.z:N or N"--warningModeFlag :: String -> Flag PragmaOptions-warningModeFlag s o = case warningModeUpdate s of-  Right upd -> return $ o { optWarningMode = upd (optWarningMode o) }-  Left err  -> throwError $ prettyWarningModeError err ++ " See --help=warning."--terminationDepthFlag :: String -> Flag PragmaOptions-terminationDepthFlag s o =-    do k <- maybe usage return $ readMaybe s-       when (k < 1) $ usage -- or: turn termination checking off for 0-       return $ o { optTerminationDepth = CutOff $ k-1 }-    where usage = throwError "argument to termination-depth should be >= 1"--confluenceCheckFlag :: ConfluenceCheck -> Flag PragmaOptions-confluenceCheckFlag f o = return $ o { optConfluenceCheck = Just f }--noConfluenceCheckFlag :: Flag PragmaOptions-noConfluenceCheckFlag o = return $ o { optConfluenceCheck = Nothing }--noImportSorts :: Flag PragmaOptions-noImportSorts o = return $ o { optImportSorts = False }--allowExec :: Flag PragmaOptions-allowExec o = return $ o { optAllowExec = True }--integerArgument :: String -> String -> OptM Int-integerArgument flag s = maybe usage return $ readMaybe s-  where-  usage = throwError $ "option '" ++ flag ++ "' requires an integer argument"--standardOptions :: [OptDescr (Flag CommandLineOptions)]-standardOptions =-    [ Option ['V']  ["version"] (NoArg versionFlag)-                    ("print version number and exit")--    , Option ['?']  ["help"]    (OptArg helpFlag "TOPIC") $ concat-                    [ "print help and exit; available "-                    , singPlural allHelpTopics "TOPIC" "TOPICs"-                    , ": "-                    , intercalate ", " $ map fst allHelpTopics-                    ]--    , Option []     ["print-agda-dir"] (NoArg printAgdaDirFlag)-                    ("print $AGDA_DIR and exit")--    , Option ['I']  ["interactive"] (NoArg interactiveFlag)-                    "start in interactive mode"-    , Option []     ["interaction"] (NoArg ghciInteractionFlag)-                    "for use with the Emacs mode"-    , Option []     ["interaction-json"] (NoArg jsonInteractionFlag)-                    "for use with other editors such as Atom"--    , Option []     ["compile-dir"] (ReqArg compileDirFlag "DIR")-                    ("directory for compiler output (default: the project root)")--    , Option []     ["vim"] (NoArg vimFlag)-                    "generate Vim highlighting files"-    , Option []     ["ignore-interfaces"] (NoArg ignoreInterfacesFlag)-                    "ignore interface files (re-type check everything)"-    , Option []     ["local-interfaces"] (NoArg localInterfacesFlag)-                    "put interface files next to the Agda files they correspond to"-    , Option ['i']  ["include-path"] (ReqArg includeFlag "DIR")-                    "look for imports in DIR"-    , Option ['l']  ["library"] (ReqArg libraryFlag "LIB")-                    "use library LIB"-    , Option []     ["library-file"] (ReqArg overrideLibrariesFileFlag "FILE")-                    "use FILE instead of the standard libraries file"-    , Option []     ["no-libraries"] (NoArg noLibsFlag)-                    "don't use any library files"-    , Option []     ["no-default-libraries"] (NoArg noDefaultLibsFlag)-                    "don't use default libraries"-    , Option []     ["only-scope-checking"] (NoArg onlyScopeCheckingFlag)-                    "only scope-check the top-level module, do not type-check it"-    ] ++ map (fmap lensPragmaOptions) pragmaOptions---- | Defined locally here since module ''Agda.Interaction.Options.Lenses''---   has cyclic dependency.-lensPragmaOptions :: Lens' PragmaOptions CommandLineOptions-lensPragmaOptions f st = f (optPragmaOptions st) <&> \ opts -> st { optPragmaOptions = opts }---- | Command line options of previous versions of Agda.---   Should not be listed in the usage info, put parsed by GetOpt for good error messaging.-deadStandardOptions :: [OptDescr (Flag CommandLineOptions)]-deadStandardOptions =-    [ Option []     ["sharing"] (NoArg $ sharingFlag True)-                    "DEPRECATED: does nothing"-    , Option []     ["no-sharing"] (NoArg $ sharingFlag False)-                    "DEPRECATED: does nothing"-    , Option []     ["ignore-all-interfaces"] (NoArg ignoreAllInterfacesFlag) -- not deprecated! Just hidden-                    "ignore all interface files (re-type check everything, including builtin files)"-    ] ++ map (fmap lensPragmaOptions) deadPragmaOptions--pragmaOptions :: [OptDescr (Flag PragmaOptions)]-pragmaOptions =-    [ Option []     ["show-implicit"] (NoArg showImplicitFlag)-                    "show implicit arguments when printing"-    , Option []     ["show-irrelevant"] (NoArg showIrrelevantFlag)-                    "show irrelevant arguments when printing"-    , Option []     ["show-identity-substitutions"] (NoArg showIdentitySubstitutionsFlag)-                    "show all arguments of metavariables when printing terms"-    , Option []     ["no-unicode"] (NoArg asciiOnlyFlag)-                    "don't use unicode characters when printing terms"-    , Option ['v']  ["verbose"] (ReqArg verboseFlag "N")-                    "set verbosity level to N"-    , Option []     ["allow-unsolved-metas"] (NoArg allowUnsolvedFlag)-                    "succeed and create interface file regardless of unsolved meta variables"-    , Option []     ["allow-incomplete-matches"] (NoArg allowIncompleteMatchFlag)-                    "succeed and create interface file regardless of incomplete pattern matches"-    , Option []     ["no-positivity-check"] (NoArg noPositivityFlag)-                    "do not warn about not strictly positive data types"-    , Option []     ["no-termination-check"] (NoArg dontTerminationCheckFlag)-                    "do not warn about possibly nonterminating code"-    , Option []     ["termination-depth"] (ReqArg terminationDepthFlag "N")-                    "allow termination checker to count decrease/increase upto N (default N=1)"-    , Option []     ["type-in-type"] (NoArg dontUniverseCheckFlag)-                    "ignore universe levels (this makes Agda inconsistent)"-    , Option []     ["omega-in-omega"] (NoArg omegaInOmegaFlag)-                    "enable typing rule Setω : Setω (this makes Agda inconsistent)"-    , Option []     ["subtyping"] (NoArg subtypingFlag)-                    "enable subtyping rules in general (e.g. for irrelevance and erasure)"-    , Option []     ["no-subtyping"] (NoArg noSubtypingFlag)-                    "disable subtyping rules in general (e.g. for irrelevance and erasure) (default)"-    , Option []     ["cumulativity"] (NoArg cumulativityFlag)-                    "enable subtyping of universes (e.g. Set =< Set₁) (implies --subtyping)"-    , Option []     ["no-cumulativity"] (NoArg noCumulativityFlag)-                    "disable subtyping of universes (default)"-    , Option []     ["prop"] (NoArg propFlag)-                    "enable the use of the Prop universe"-    , Option []     ["no-prop"] (NoArg noPropFlag)-                    "disable the use of the Prop universe (default)"-    , Option []     ["two-level"] (NoArg twoLevelFlag)-                    "enable the use of SSet* universes"-    , Option []     ["sized-types"] (NoArg sizedTypes)-                    "enable sized types (default, inconsistent with --guardedness, implies --subtyping)"-    , Option []     ["no-sized-types"] (NoArg noSizedTypes)-                    "disable sized types"-    , Option []     ["flat-split"] (NoArg flatSplitFlag)-                    "allow split on (@flat x : A) arguments (default)"-    , Option []     ["no-flat-split"] (NoArg noFlatSplitFlag)-                    "disable split on (@flat x : A) arguments"-    , Option []     ["guardedness"] (NoArg guardedness)-                    "enable constructor-based guarded corecursion (default, inconsistent with --sized-types)"-    , Option []     ["no-guardedness"] (NoArg noGuardedness)-                    "disable constructor-based guarded corecursion"-    , Option []     ["injective-type-constructors"] (NoArg injectiveTypeConstructorFlag)-                    "enable injective type constructors (makes Agda anti-classical and possibly inconsistent)"-    , Option []     ["no-universe-polymorphism"] (NoArg noUniversePolymorphismFlag)-                    "disable universe polymorphism"-    , Option []     ["universe-polymorphism"] (NoArg universePolymorphismFlag)-                    "enable universe polymorphism (default)"-    , Option []     ["irrelevant-projections"] (NoArg irrelevantProjectionsFlag)-                    "enable projection of irrelevant record fields and similar irrelevant definitions (inconsistent)"-    , Option []     ["no-irrelevant-projections"] (NoArg noIrrelevantProjectionsFlag)-                    "disable projection of irrelevant record fields and similar irrelevant definitions (default)"-    , Option []     ["experimental-irrelevance"] (NoArg experimentalIrrelevanceFlag)-                    "enable potentially unsound irrelevance features (irrelevant levels, irrelevant data matching)"-    , Option []     ["with-K"] (NoArg withKFlag)-                    "enable the K rule in pattern matching (default)"-    , Option []     ["without-K"] (NoArg withoutKFlag)-                    "disable the K rule in pattern matching"-    , Option []     ["copatterns"] (NoArg copatternsFlag)-                    "enable definitions by copattern matching (default)"-    , Option []     ["no-copatterns"] (NoArg noCopatternsFlag)-                    "disable definitions by copattern matching"-    , Option []     ["no-pattern-matching"] (NoArg noPatternMatchingFlag)-                    "disable pattern matching completely"-    , Option []     ["exact-split"] (NoArg exactSplitFlag)-                    "require all clauses in a definition to hold as definitional equalities (unless marked CATCHALL)"-    , Option []     ["no-exact-split"] (NoArg noExactSplitFlag)-                    "do not require all clauses in a definition to hold as definitional equalities (default)"-    , Option []     ["no-eta-equality"] (NoArg noEtaFlag)-                    "default records to no-eta-equality"-    , Option []     ["no-forcing"] (NoArg noForcingFlag)-                    "disable the forcing analysis for data constructors (optimisation)"-    , Option []     ["no-projection-like"] (NoArg noProjectionLikeFlag)-                    "disable the analysis whether function signatures liken those of projections (optimisation)"-    , Option []     ["rewriting"] (NoArg rewritingFlag)-                    "enable declaration and use of REWRITE rules"-    , Option []     ["local-confluence-check"] (NoArg $ confluenceCheckFlag LocalConfluenceCheck)-                    "enable checking of local confluence of REWRITE rules"-    , Option []     ["confluence-check"] (NoArg $ confluenceCheckFlag GlobalConfluenceCheck)-                    "enable global confluence checking of REWRITE rules (more restrictive than --local-confluence-check)"-    , Option []     ["no-confluence-check"] (NoArg noConfluenceCheckFlag)-                    "disable confluence checking of REWRITE rules (default)"-    , Option []     ["cubical"] (NoArg $ cubicalFlag CFull)-                    "enable cubical features (e.g. overloads lambdas for paths), implies --without-K"-    , Option []     ["erased-cubical"] (NoArg $ cubicalFlag CErased)-                    "enable cubical features (some only in erased settings), implies --without-K"-    , Option []     ["guarded"] (NoArg guardedFlag)-                    "enable @lock/@tick attributes"-    , Option []     ["experimental-lossy-unification"] (NoArg firstOrderFlag)-                    "enable heuristically unifying `f es = f es'` by unifying `es = es'`, even when it could lose solutions."-    , Option []     ["postfix-projections"] (NoArg postfixProjectionsFlag)-                    "make postfix projection notation the default"-    , Option []     ["keep-pattern-variables"] (NoArg keepPatternVariablesFlag)-                    "don't replace variables with dot patterns during case splitting"-    , Option []     ["instance-search-depth"] (ReqArg instanceDepthFlag "N")-                    "set instance search depth to N (default: 500)"-    , Option []     ["overlapping-instances"] (NoArg overlappingInstancesFlag)-                    "consider recursive instance arguments during pruning of instance candidates"-    , Option []     ["no-overlapping-instances"] (NoArg noOverlappingInstancesFlag)-                    "don't consider recursive instance arguments during pruning of instance candidates (default)"-    , Option []     ["qualified-instances"] (NoArg qualifiedInstancesFlag)-                    "use instances with qualified names (default)"-    , Option []     ["no-qualified-instances"] (NoArg noQualifiedInstancesFlag)-                    "don't use instances with qualified names"-    , Option []     ["inversion-max-depth"] (ReqArg inversionMaxDepthFlag "N")-                    "set maximum depth for pattern match inversion to N (default: 50)"-    , Option []     ["safe"] (NoArg safeFlag)-                    "disable postulates, unsafe OPTION pragmas and primEraseEquality, implies --no-sized-types"-    , Option []     ["double-check"] (NoArg (doubleCheckFlag True))-                    "enable double-checking of all terms using the internal typechecker"-    , Option []     ["no-double-check"] (NoArg (doubleCheckFlag False))-                    "disable double-checking of terms (default)"-    , Option []     ["no-syntactic-equality"] (NoArg noSyntacticEqualityFlag)-                    "disable the syntactic equality shortcut in the conversion checker"-    , Option ['W']  ["warning"] (ReqArg warningModeFlag "FLAG")-                    ("set warning flags. See --help=warning.")-    , Option []     ["no-main"] (NoArg compileFlagNoMain)-                    "do not treat the requested module as the main module of a program when compiling"-    , Option []     ["caching"] (NoArg $ cachingFlag True)-                    "enable caching of typechecking (default)"-    , Option []     ["no-caching"] (NoArg $ cachingFlag False)-                    "disable caching of typechecking"-    , Option []     ["count-clusters"] (NoArg countClustersFlag)-                    ("count extended grapheme clusters when " ++-                     "generating LaTeX (note that this flag " ++-#ifdef COUNT_CLUSTERS-                     "is not enabled in all builds of Agda)"-#else-                     "has not been enabled in this build of Agda)"-#endif-                    )-    , Option []     ["auto-inline"] (NoArg autoInlineFlag)-                    "enable automatic compile-time inlining"-    , Option []     ["no-auto-inline"] (NoArg noAutoInlineFlag)-                    ("disable automatic compile-time inlining (default), " ++-                     "only definitions marked INLINE will be inlined")-    , Option []     ["no-print-pattern-synonyms"] (NoArg noPrintPatSynFlag)-                    "expand pattern synonyms when printing terms"-    , Option []     ["no-fast-reduce"] (NoArg noFastReduceFlag)-                    "disable reduction using the Agda Abstract Machine"-    , Option []     ["call-by-name"] (NoArg callByNameFlag)-                    "use call-by-name evaluation instead of call-by-need"-    , Option []     ["no-import-sorts"] (NoArg noImportSorts)-                    "disable the implicit import of Agda.Primitive using (Set; Prop) at the start of each top-level module"-    , Option []     ["allow-exec"] (NoArg allowExec)-                    "allow system calls to trusted executables with primExec"-    ]---- | Pragma options of previous versions of Agda.---   Should not be listed in the usage info, put parsed by GetOpt for good error messaging.-deadPragmaOptions :: [OptDescr (Flag PragmaOptions)]-deadPragmaOptions =-    [ Option []     ["guardedness-preserving-type-constructors"] (NoArg guardingTypeConstructorFlag)-                    "treat type constructors as inductive constructors when checking productivity"-    , Option []     ["no-coverage-check"] (NoArg dontCompletenessCheckFlag)-                    "the option has been removed"-    , Option []     ["no-sort-comparison"] (NoArg noSortComparisonFlag)-                    "disable the comparison of sorts when checking conversion of types"-    ]---- | Used for printing usage info.---   Does not include the dead options.-standardOptions_ :: [OptDescr ()]-standardOptions_ = map void standardOptions---- | Simple interface for System.Console.GetOpt---   Could be moved to Agda.Utils.Options (does not exist yet)-getOptSimple-  :: [String]               -- ^ command line argument words-  -> [OptDescr (Flag opts)] -- ^ options handlers-  -> (String -> Flag opts)  -- ^ handler of non-options (only one is allowed)-  -> Flag opts              -- ^ combined opts data structure transformer-getOptSimple argv opts fileArg = \ defaults ->-  case getOpt' (ReturnInOrder fileArg) opts argv of-    (o, _, []          , [] )  -> foldl (>>=) (return defaults) o-    (_, _, unrecognized, errs) -> throwError $ umsg ++ emsg--      where-      ucap = "Unrecognized " ++ plural unrecognized "option" ++ ":"-      ecap = plural errs "Option error" ++ ":"-      umsg = if null unrecognized then "" else unlines $-       ucap : map suggest unrecognized-      emsg = if null errs then "" else unlines $-       ecap : errs-      plural [_] x = x-      plural _   x = x ++ "s"--      -- Suggest alternatives that are at most 3 typos away--      longopts :: [String]-      longopts = map ("--" ++) $ concatMap (\ (Option _ long _ _) -> long) opts--      dist :: String -> String -> Int-      dist s t = restrictedDamerauLevenshteinDistance defaultEditCosts s t--      close :: String -> String -> Maybe (Int, String)-      close s t = let d = dist s t in if d <= 3 then Just (d, t) else Nothing--      closeopts :: String -> [(Int, String)]-      closeopts s = mapMaybe (close s) longopts--      alts :: String -> [[String]]-      alts s = map (map snd) $ groupOn fst $ closeopts s--      suggest :: String -> String-      suggest s = case alts s of-        []     -> s-        as : _ -> s ++ " (did you mean " ++ sugs as ++ " ?)"--      sugs :: [String] -> String-      sugs [a] = a-      sugs as  = "any of " ++ unwords as--{- No longer used in favour of parseBackendOptions in Agda.Compiler.Backend--- | Parse the standard options.-parseStandardOptions :: [String] -> OptM CommandLineOptions-parseStandardOptions argv = parseStandardOptions' argv defaultOptions--parseStandardOptions' :: [String] -> Flag CommandLineOptions-parseStandardOptions' argv opts = do-  opts <- getOptSimple (stripRTS argv) (deadStandardOptions ++ standardOptions) inputFlag opts-  checkOpts opts--}---- | Parse options from an options pragma.-parsePragmaOptions-  :: [String]-     -- ^ Pragma options.-  -> CommandLineOptions-     -- ^ Command-line options which should be updated.-  -> OptM PragmaOptions-parsePragmaOptions argv opts = do-  ps <- getOptSimple argv (deadPragmaOptions ++ pragmaOptions)-          (\s _ -> throwError $ "Bad option in pragma: " ++ s)-          (optPragmaOptions opts)-  _ <- checkOpts (opts { optPragmaOptions = ps })-  return ps+{-# LANGUAGE PartialTypeSignatures #-}++{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}++module Agda.Interaction.Options.Base+    ( CommandLineOptions(..)+    , PragmaOptions(..)+    , OptionError+    , OptionWarning(..), optionWarningName+    , Flag, OptM, runOptM, OptDescr(..), ArgDescr(..)+    , Verbosity, VerboseKey, VerboseLevel+    , ConfluenceCheck(..)+    , DiagnosticsColours(..)+    , EmacsModeCommand(..)+    , PrintAgdaVersion(..)+    , UnicodeOrAscii(..)+    , WarningMode(..)+    , checkOpts+    , parsePragmaOptions+    , parsePluginOptions+    , parseVerboseKey+    , stripRTS+    , defaultOptions+    , defaultInteractionOptions+    , defaultCutOff+    , defaultPragmaOptions+    , standardOptions_+    , unsafePragmaOptions+    , recheckBecausePragmaOptionsChanged+    , InfectiveCoinfective(..)+    , InfectiveCoinfectiveOption(..)+    , infectiveCoinfectiveOptions+    , ImpliedPragmaOption(..)+    , impliedPragmaOptions+    , safeFlag+    , mapFlag+    , usage+    -- Reused by PandocAgda+    , inputFlag+    , standardOptions, deadStandardOptions+    , getOptSimple+    -- * Lenses for 'PragmaOptions'+    , lensOptShowImplicit+    , lensOptShowIrrelevant+    , lensOptUseUnicode+    , lensOptVerbose+    , lensOptProfiling+    , lensOptProp+    , lensOptLevelUniverse+    , lensOptTwoLevel+    , lensOptAllowUnsolved+    , lensOptAllowIncompleteMatch+    , lensOptPositivityCheck+    , lensOptTerminationCheck+    , lensOptTerminationDepth+    , lensOptUniverseCheck, lensOptNoUniverseCheck+    , lensOptOmegaInOmega+    , lensOptCumulativity+    , lensOptSizedTypes+    , lensOptGuardedness+    , lensOptInjectiveTypeConstructors+    , lensOptUniversePolymorphism+    , lensOptIrrelevantProjections+    , lensOptExperimentalIrrelevance+    , lensOptExperimentalLazyInstances+    , lensOptWithoutK+    , lensOptCubicalCompatible+    , lensOptCopatterns+    , lensOptPatternMatching+    , lensOptExactSplit+    , lensOptHiddenArgumentPuns+    , lensOptEta+    , lensOptForcing+    , lensOptProjectionLike+    , lensOptErasure+    , lensOptErasedMatches+    , lensOptEraseRecordParameters+    , lensOptRewriting+    , lensOptCubical+    , lensOptGuarded+    , lensOptFirstOrder+    , lensOptRequireUniqueMetaSolutions+    , lensOptPostfixProjections+    , lensOptKeepPatternVariables+    , lensOptInferAbsurdClauses+    , lensOptInstanceSearchDepth+    , lensOptBacktrackingInstances+    , lensOptQualifiedInstances+    , lensOptInversionMaxDepth+    , lensOptSafe+    , lensOptDoubleCheck+    , lensOptSyntacticEquality+    , lensOptWarningMode+    , lensOptCompileMain+    , lensOptCaching+    , lensOptCountClusters+    , lensOptAutoInline+    , lensOptPrintPatternSynonyms+    , lensOptFastReduce+    , lensOptCallByName+    , lensOptConfluenceCheck+    , lensOptCohesion+    , lensOptFlatSplit+    , lensOptPolarity+    , lensOptImportSorts+    , lensOptLoadPrimitives+    , lensOptAllowExec+    , lensOptSaveMetas+    , lensOptShowIdentitySubstitutions+    , lensOptKeepCoveringClauses+    -- * Boolean accessors to 'PragmaOptions' collapsing default+    , optShowImplicit+    , optShowGeneralized+    , optShowIrrelevant+    , optProp+    , optLevelUniverse+    , optTwoLevel+    , optAllowUnsolved+    , optAllowIncompleteMatch+    , optPositivityCheck+    , optTerminationCheck+    , optUniverseCheck+    , optOmegaInOmega+    , optCumulativity+    , optSizedTypes+    , optGuardedness+    , optInjectiveTypeConstructors+    , optUniversePolymorphism+    , optIrrelevantProjections+    , optExperimentalIrrelevance+    , optWithoutK+    , optCubicalCompatible+    , optCopatterns+    , optPatternMatching+    , optHiddenArgumentPuns+    , optEta+    , optForcing+    , optProjectionLike+    , optErasure+    , optErasedMatches+    , optEraseRecordParameters+    , optRewriting+    , optGuarded+    , optFirstOrder+    , optRequireUniqueMetaSolutions+    , optPostfixProjections+    , optKeepPatternVariables+    , optInferAbsurdClauses+    , optBacktrackingInstances+    , optQualifiedInstances+    , optSafe+    , optDoubleCheck+    , optCompileNoMain+    , optCaching+    , optCountClusters+    , optAutoInline+    , optPrintPatternSynonyms+    , optFastReduce+    , optCallByName+    , optCohesion+    , optFlatSplit+    , optPolarity+    , optImportSorts+    , optLoadPrimitives+    , optAllowExec+    , optSaveMetas+    , optShowIdentitySubstitutions+    , optKeepCoveringClauses+    , optLargeIndices+    , optForcedArgumentRecursion+    -- * Non-boolean accessors to 'PragmaOptions'+    , optConfluenceCheck+    , optCubical+    , optInstanceSearchDepth+    , optInversionMaxDepth+    , optProfiling+    , optSyntacticEquality+    , optTerminationDepth+    , optUseUnicode+    , optVerbose+    , optWarningMode+    ) where++import Prelude hiding ( null, not, (&&), (||) )++import Control.DeepSeq+import Control.Monad        ( (>=>), when, unless, void )+import Control.Monad.Except ( ExceptT, MonadError(throwError), runExceptT )+import Control.Monad.Writer ( Writer, runWriter, MonadWriter(..) )++import Data.Function            ( (&) )+import Data.List                ( intercalate )+import Data.Maybe+import Data.Map                 ( Map )+import qualified Data.Map as Map+import Data.Set                 ( Set )+import qualified Data.Set as Set+import qualified Data.Text as T++import GHC.Generics (Generic)++import Agda.Utils.GetOpt        ( getOpt', usageInfo, ArgOrder(ReturnInOrder)+                                , OptDescr(..), ArgDescr(..)+                                )+import qualified System.IO.Unsafe as UNSAFE (unsafePerformIO)++import Text.EditDistance+import Text.Read                ( readMaybe )++import Agda.Termination.CutOff  ( CutOff(..), defaultCutOff )++import Agda.Interaction.Library ( ExeName, LibName, OptionsPragma(..), parseLibName )+import Agda.Interaction.Options.Help+  ( Help(HelpFor, GeneralHelp)+  , string2HelpTopic+  , allHelpTopics+  , helpTopicUsage+  )+import Agda.Interaction.Options.Types+import Agda.Interaction.Options.Warnings++import Agda.Syntax.Concrete.Glyph ( unsafeSetUnicodeOrAscii, UnicodeOrAscii(..) )+import Agda.Syntax.Common (Cubical(..))+import Agda.Syntax.Common.Pretty+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName)++import qualified Agda.Setup.EmacsMode as EmacsMode++import Agda.Utils.Boolean+import Agda.Utils.FileName      ( AbsolutePath )+import Agda.Utils.Function      ( applyWhen, applyUnless )+import Agda.Utils.Functor       ( (<&>) )+import Agda.Utils.Lens          ( Lens', (^.), over, set )+import Agda.Utils.List          ( headWithDefault, initLast1 )+import Agda.Utils.List1         ( List1, String1, pattern (:|), toList )+import qualified Agda.Utils.List1        as List1+import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.Monad         ( tell1 )+import Agda.Utils.Null+import Agda.Utils.ProfileOptions+import Agda.Utils.String        ( unwords1 )+import qualified Agda.Utils.String       as String+import Agda.Utils.Trie          ( Trie )+import qualified Agda.Utils.Trie as Trie+import Agda.Utils.TypeLits+import Agda.Utils.WithDefault++import Agda.Utils.Impossible++import Agda.Version++parseVerboseKey :: VerboseKey -> [VerboseKeyItem]+parseVerboseKey = List1.wordsBy (`elem` ['.', ':'])++data ImpliedPragmaOption where+  ImpliesPragmaOption+    :: String -> Bool -> (PragmaOptions -> WithDefault a)+    -> String -> Bool -> (PragmaOptions -> WithDefault b)+    -> ImpliedPragmaOption+    -- ^ The first option having the given value implies the second option having its given value.+    --   For instance, `ImpliesPragmaOption "lossy-unification" True _optFirstOrder+    --                                      "require-unique-meta-solutions" False _optRequireUniqueMetaSolutions`+    --   encodes the fact that --lossy-unification implies --no-require-unique-meta-solutions.++impliedPragmaOptions :: [ImpliedPragmaOption]+impliedPragmaOptions =+  [ ("erase-record-parameters", _optEraseRecordParameters) ==> ("erasure",                          _optErasure)+  , ("erased-matches",          _optErasedMatches)         ==> ("erasure",                          _optErasure)+  , ("flat-split",              _optFlatSplit)             ==> ("cohesion",                         _optCohesion)+  , ("no-load-primitives",      _optLoadPrimitives)        ==> ("no-import-sorts",                  _optImportSorts)+  , ("lossy-unification",       _optFirstOrder)            ==> ("no-require-unique-meta-solutions", _optRequireUniqueMetaSolutions)+  ]+  where+    yesOrNo ('n':'o':'-':s) = (False, s)+    yesOrNo s               = (True, s)+    (nameA, optA) ==> (nameB, optB) = ImpliesPragmaOption stemA valA optA stemB valB optB+      where+        (valA, stemA) = yesOrNo nameA+        (valB, stemB) = yesOrNo nameB++-- collapse defaults+optShowImplicit              :: PragmaOptions -> Bool+optShowGeneralized           :: PragmaOptions -> Bool+optShowIrrelevant            :: PragmaOptions -> Bool+optProp                      :: PragmaOptions -> Bool+optLevelUniverse             :: PragmaOptions -> Bool+optTwoLevel                  :: PragmaOptions -> Bool+optAllowUnsolved             :: PragmaOptions -> Bool+optAllowIncompleteMatch      :: PragmaOptions -> Bool+optPositivityCheck           :: PragmaOptions -> Bool+optTerminationCheck          :: PragmaOptions -> Bool+optUniverseCheck             :: PragmaOptions -> Bool+optOmegaInOmega              :: PragmaOptions -> Bool+optCumulativity              :: PragmaOptions -> Bool+optSizedTypes                :: PragmaOptions -> Bool+optGuardedness               :: PragmaOptions -> Bool+optInjectiveTypeConstructors :: PragmaOptions -> Bool+optUniversePolymorphism      :: PragmaOptions -> Bool+optIrrelevantProjections     :: PragmaOptions -> Bool+optExperimentalIrrelevance   :: PragmaOptions -> Bool+optWithoutK                  :: PragmaOptions -> Bool+optCubicalCompatible         :: PragmaOptions -> Bool+optCopatterns                :: PragmaOptions -> Bool+optPatternMatching           :: PragmaOptions -> Bool+optHiddenArgumentPuns        :: PragmaOptions -> Bool+optEta                       :: PragmaOptions -> Bool+optForcing                   :: PragmaOptions -> Bool+optProjectionLike            :: PragmaOptions -> Bool+-- | 'optErasure' is implied by 'optEraseRecordParameters'.+--   'optErasure' is also implied by an explicitly given `--erased-matches`.+optErasure                   :: PragmaOptions -> Bool+optErasedMatches             :: PragmaOptions -> Bool+optEraseRecordParameters     :: PragmaOptions -> Bool+optRewriting                 :: PragmaOptions -> Bool+optGuarded                   :: PragmaOptions -> Bool+optFirstOrder                :: PragmaOptions -> Bool+optRequireUniqueMetaSolutions :: PragmaOptions -> Bool+optPostfixProjections        :: PragmaOptions -> Bool+optKeepPatternVariables      :: PragmaOptions -> Bool+optInferAbsurdClauses        :: PragmaOptions -> Bool+optBacktrackingInstances     :: PragmaOptions -> Bool+optQualifiedInstances        :: PragmaOptions -> Bool+optSafe                      :: PragmaOptions -> Bool+optDoubleCheck               :: PragmaOptions -> Bool+optCompileNoMain             :: PragmaOptions -> Bool+optCaching                   :: PragmaOptions -> Bool+optCountClusters             :: PragmaOptions -> Bool+optAutoInline                :: PragmaOptions -> Bool+optPrintPatternSynonyms      :: PragmaOptions -> Bool+optFastReduce                :: PragmaOptions -> Bool+optCallByName                :: PragmaOptions -> Bool+-- | 'optCohesion' is implied by 'optFlatSplit'.+optCohesion                  :: PragmaOptions -> Bool+optFlatSplit                 :: PragmaOptions -> Bool+optPolarity                  :: PragmaOptions -> Bool+-- | 'optImportSorts' requires 'optLoadPrimitives'.+optImportSorts               :: PragmaOptions -> Bool+optLoadPrimitives            :: PragmaOptions -> Bool+optAllowExec                 :: PragmaOptions -> Bool+optSaveMetas                 :: PragmaOptions -> Bool+optShowIdentitySubstitutions :: PragmaOptions -> Bool+optKeepCoveringClauses       :: PragmaOptions -> Bool+optLargeIndices              :: PragmaOptions -> Bool+optForcedArgumentRecursion   :: PragmaOptions -> Bool++optShowImplicit              = collapseDefault . _optShowImplicit+optShowGeneralized           = collapseDefault . _optShowGeneralized+optShowIrrelevant            = collapseDefault . _optShowIrrelevant+optProp                      = collapseDefault . _optProp+optLevelUniverse             = collapseDefault . _optLevelUniverse+optTwoLevel                  = collapseDefault . _optTwoLevel+optAllowUnsolved             = collapseDefault . _optAllowUnsolved+optAllowIncompleteMatch      = collapseDefault . _optAllowIncompleteMatch+optPositivityCheck           = collapseDefault . _optPositivityCheck+optTerminationCheck          = collapseDefault . _optTerminationCheck+optUniverseCheck             = collapseDefault . _optUniverseCheck+optOmegaInOmega              = collapseDefault . _optOmegaInOmega+optCumulativity              = collapseDefault . _optCumulativity+optSizedTypes                = collapseDefault . _optSizedTypes+optGuardedness               = collapseDefault . _optGuardedness+optInjectiveTypeConstructors = collapseDefault . _optInjectiveTypeConstructors+optUniversePolymorphism      = collapseDefault . _optUniversePolymorphism+optIrrelevantProjections     = collapseDefault . _optIrrelevantProjections+optExperimentalIrrelevance   = collapseDefault . _optExperimentalIrrelevance+optWithoutK                  = collapseDefault . _optWithoutK+optCubicalCompatible         = collapseDefault . _optCubicalCompatible+optCopatterns                = collapseDefault . _optCopatterns+optPatternMatching           = collapseDefault . _optPatternMatching+optHiddenArgumentPuns        = collapseDefault . _optHiddenArgumentPuns+optEta                       = collapseDefault . _optEta+optForcing                   = collapseDefault . _optForcing+optProjectionLike            = collapseDefault . _optProjectionLike+-- --erase-record-parameters implies --erasure+optErasure                   = collapseDefault . _optErasure || optEraseRecordParameters || (Value True ==) . _optErasedMatches+optErasedMatches             = collapseDefault . _optErasedMatches && optErasure+optEraseRecordParameters     = collapseDefault . _optEraseRecordParameters+optRewriting                 = collapseDefault . _optRewriting+optGuarded                   = collapseDefault . _optGuarded+optFirstOrder                = collapseDefault . _optFirstOrder+optRequireUniqueMetaSolutions = collapseDefault . _optRequireUniqueMetaSolutions && not . optFirstOrder+-- --lossy-unification implies --no-require-unique-meta-solutions+optPostfixProjections        = collapseDefault . _optPostfixProjections+optKeepPatternVariables      = collapseDefault . _optKeepPatternVariables+optInferAbsurdClauses        = collapseDefault . _optInferAbsurdClauses+optBacktrackingInstances     = collapseDefault . _optBacktrackingInstances+optQualifiedInstances        = collapseDefault . _optQualifiedInstances+optSafe                      = collapseDefault . _optSafe+optDoubleCheck               = collapseDefault . _optDoubleCheck+optCompileNoMain             = not . collapseDefault . _optCompileMain+optCaching                   = collapseDefault . _optCaching+optCountClusters             = collapseDefault . _optCountClusters+optAutoInline                = collapseDefault . _optAutoInline+optPrintPatternSynonyms      = collapseDefault . _optPrintPatternSynonyms+optFastReduce                = collapseDefault . _optFastReduce+optCallByName                = collapseDefault . _optCallByName+-- --flat-split implies --cohesion+optCohesion                  = collapseDefault . _optCohesion      || optFlatSplit+optFlatSplit                 = collapseDefault . _optFlatSplit+optPolarity                  = collapseDefault . _optPolarity+-- --no-load-primitives implies --no-import-sorts+optImportSorts               = collapseDefault . _optImportSorts   && optLoadPrimitives+optLoadPrimitives            = collapseDefault . _optLoadPrimitives+optAllowExec                 = collapseDefault . _optAllowExec+optSaveMetas                 = collapseDefault . _optSaveMetas+optShowIdentitySubstitutions = collapseDefault . _optShowIdentitySubstitutions+optKeepCoveringClauses       = collapseDefault . _optKeepCoveringClauses+optLargeIndices              = collapseDefault . _optLargeIndices+optForcedArgumentRecursion   = collapseDefault . _optForcedArgumentRecursion++-- Collapse defaults (non-Bool)++optUseUnicode                :: PragmaOptions -> UnicodeOrAscii+optUseUnicode                = collapseDefault . _optUseUnicode++-- Extra trivial accessors (keep in alphabetical order)++optConfluenceCheck     :: PragmaOptions -> _+optCubical             :: PragmaOptions -> _+optInstanceSearchDepth :: PragmaOptions -> _+optInversionMaxDepth   :: PragmaOptions -> _+optProfiling           :: PragmaOptions -> _+optSyntacticEquality   :: PragmaOptions -> _+optTerminationDepth    :: PragmaOptions -> _+optVerbose             :: PragmaOptions -> _+optWarningMode         :: PragmaOptions -> _++optConfluenceCheck     = _optConfluenceCheck+optCubical             = _optCubical+optInstanceSearchDepth = _optInstanceSearchDepth+optInversionMaxDepth   = _optInversionMaxDepth+optProfiling           = _optProfiling+optSyntacticEquality   = _optSyntacticEquality+optTerminationDepth    = _optTerminationDepth+optVerbose             = _optVerbose+optWarningMode         = _optWarningMode++-- Lenses for PragmaOptions+-- N.B.: We use PartialTypeSignatures here to not repeat default values (DRY!).++lensOptShowImplicit :: Lens' PragmaOptions _+lensOptShowImplicit f o = f (_optShowImplicit o) <&> \ i -> o{ _optShowImplicit = i }++lensOptShowIrrelevant :: Lens' PragmaOptions _+lensOptShowIrrelevant f o = f (_optShowIrrelevant o) <&> \ i -> o{ _optShowIrrelevant = i }++lensOptUseUnicode :: Lens' PragmaOptions _+lensOptUseUnicode f o = f (_optUseUnicode o) <&> \ i -> o{ _optUseUnicode = i }++lensOptVerbose :: Lens' PragmaOptions _+lensOptVerbose f o = f (_optVerbose o) <&> \ i -> o{ _optVerbose = i }++lensOptProfiling :: Lens' PragmaOptions _+lensOptProfiling f o = f (_optProfiling o) <&> \ i -> o{ _optProfiling = i }++lensOptProp :: Lens' PragmaOptions _+lensOptProp f o = f (_optProp o) <&> \ i -> o{ _optProp = i }++lensOptLevelUniverse :: Lens' PragmaOptions _+lensOptLevelUniverse f o = f (_optLevelUniverse o) <&> \ i -> o{ _optLevelUniverse = i }++lensOptTwoLevel :: Lens' PragmaOptions _+lensOptTwoLevel f o = f (_optTwoLevel o) <&> \ i -> o{ _optTwoLevel = i }++lensOptAllowUnsolved :: Lens' PragmaOptions _+lensOptAllowUnsolved f o = f (_optAllowUnsolved o) <&> \ i -> o{ _optAllowUnsolved = i }++lensOptAllowIncompleteMatch :: Lens' PragmaOptions _+lensOptAllowIncompleteMatch f o = f (_optAllowIncompleteMatch o) <&> \ i -> o{ _optAllowIncompleteMatch = i }++lensOptPositivityCheck :: Lens' PragmaOptions _+lensOptPositivityCheck f o = f (_optPositivityCheck o) <&> \ i -> o{ _optPositivityCheck = i }++lensOptTerminationCheck :: Lens' PragmaOptions _+lensOptTerminationCheck f o = f (_optTerminationCheck o) <&> \ i -> o{ _optTerminationCheck = i }++lensOptTerminationDepth :: Lens' PragmaOptions _+lensOptTerminationDepth f o = f (_optTerminationDepth o) <&> \ i -> o{ _optTerminationDepth = i }++lensOptUniverseCheck :: Lens' PragmaOptions _+lensOptUniverseCheck f o = f (_optUniverseCheck o) <&> \ i -> o{ _optUniverseCheck = i }++lensOptNoUniverseCheck :: Lens' PragmaOptions _+lensOptNoUniverseCheck f o = f (mapValue not $ _optUniverseCheck o) <&> \ i -> o{ _optUniverseCheck = mapValue not i }++lensOptOmegaInOmega :: Lens' PragmaOptions _+lensOptOmegaInOmega f o = f (_optOmegaInOmega o) <&> \ i -> o{ _optOmegaInOmega = i }++lensOptCumulativity :: Lens' PragmaOptions _+lensOptCumulativity f o = f (_optCumulativity o) <&> \ i -> o{ _optCumulativity = i }++lensOptSizedTypes :: Lens' PragmaOptions _+lensOptSizedTypes f o = f (_optSizedTypes o) <&> \ i -> o{ _optSizedTypes = i }++lensOptGuardedness :: Lens' PragmaOptions _+lensOptGuardedness f o = f (_optGuardedness o) <&> \ i -> o{ _optGuardedness = i }++lensOptInjectiveTypeConstructors :: Lens' PragmaOptions _+lensOptInjectiveTypeConstructors f o = f (_optInjectiveTypeConstructors o) <&> \ i -> o{ _optInjectiveTypeConstructors = i }++lensOptUniversePolymorphism :: Lens' PragmaOptions _+lensOptUniversePolymorphism f o = f (_optUniversePolymorphism o) <&> \ i -> o{ _optUniversePolymorphism = i }++lensOptIrrelevantProjections :: Lens' PragmaOptions _+lensOptIrrelevantProjections f o = f (_optIrrelevantProjections o) <&> \ i -> o{ _optIrrelevantProjections = i }++lensOptExperimentalIrrelevance :: Lens' PragmaOptions _+lensOptExperimentalIrrelevance f o = f (_optExperimentalIrrelevance o) <&> \ i -> o{ _optExperimentalIrrelevance = i }++lensOptWithoutK :: Lens' PragmaOptions _+lensOptWithoutK f o = f (_optWithoutK o) <&> \ i -> o{ _optWithoutK = i }++lensOptCubicalCompatible :: Lens' PragmaOptions _+lensOptCubicalCompatible f o = f (_optCubicalCompatible o) <&> \ i -> o{ _optCubicalCompatible = i }++lensOptCopatterns :: Lens' PragmaOptions _+lensOptCopatterns f o = f (_optCopatterns o) <&> \ i -> o{ _optCopatterns = i }++lensOptPatternMatching :: Lens' PragmaOptions _+lensOptPatternMatching f o = f (_optPatternMatching o) <&> \ i -> o{ _optPatternMatching = i }++lensOptExactSplit :: Lens' PragmaOptions _+lensOptExactSplit f o = f (_optExactSplit o) <&> \ i -> o{ _optExactSplit = i }++lensOptHiddenArgumentPuns :: Lens' PragmaOptions _+lensOptHiddenArgumentPuns f o = f (_optHiddenArgumentPuns o) <&> \ i -> o{ _optHiddenArgumentPuns = i }++lensOptEta :: Lens' PragmaOptions _+lensOptEta f o = f (_optEta o) <&> \ i -> o{ _optEta = i }++lensOptForcing :: Lens' PragmaOptions _+lensOptForcing f o = f (_optForcing o) <&> \ i -> o{ _optForcing = i }++lensOptProjectionLike :: Lens' PragmaOptions _+lensOptProjectionLike f o = f (_optProjectionLike o) <&> \ i -> o{ _optProjectionLike = i }++lensOptErasure :: Lens' PragmaOptions _+lensOptErasure f o = f (_optErasure o) <&> \ i -> o{ _optErasure = i }++lensOptErasedMatches :: Lens' PragmaOptions _+lensOptErasedMatches f o = f (_optErasedMatches o) <&> \ i -> o{ _optErasedMatches = i }++lensOptEraseRecordParameters :: Lens' PragmaOptions _+lensOptEraseRecordParameters f o = f (_optEraseRecordParameters o) <&> \ i -> o{ _optEraseRecordParameters = i }++lensOptRewriting :: Lens' PragmaOptions _+lensOptRewriting f o = f (_optRewriting o) <&> \ i -> o{ _optRewriting = i }++lensOptCubical :: Lens' PragmaOptions _+lensOptCubical f o = f (_optCubical o) <&> \ i -> o{ _optCubical = i }++lensOptGuarded :: Lens' PragmaOptions _+lensOptGuarded f o = f (_optGuarded o) <&> \ i -> o{ _optGuarded = i }++lensOptFirstOrder :: Lens' PragmaOptions _+lensOptFirstOrder f o = f (_optFirstOrder o) <&> \ i -> o{ _optFirstOrder = i }++lensOptRequireUniqueMetaSolutions :: Lens' PragmaOptions _+lensOptRequireUniqueMetaSolutions f o = f (_optRequireUniqueMetaSolutions o) <&> \ i -> o{ _optRequireUniqueMetaSolutions = i }++lensOptPostfixProjections :: Lens' PragmaOptions _+lensOptPostfixProjections f o = f (_optPostfixProjections o) <&> \ i -> o{ _optPostfixProjections = i }++lensOptKeepPatternVariables :: Lens' PragmaOptions _+lensOptKeepPatternVariables f o = f (_optKeepPatternVariables o) <&> \ i -> o{ _optKeepPatternVariables = i }++lensOptInferAbsurdClauses :: Lens' PragmaOptions _+lensOptInferAbsurdClauses f o = f (_optInferAbsurdClauses o) <&> \ i -> o{ _optInferAbsurdClauses = i }++lensOptInstanceSearchDepth :: Lens' PragmaOptions _+lensOptInstanceSearchDepth f o = f (_optInstanceSearchDepth o) <&> \ i -> o{ _optInstanceSearchDepth = i }++lensOptBacktrackingInstances :: Lens' PragmaOptions _+lensOptBacktrackingInstances f o = f (_optBacktrackingInstances o) <&> \ i -> o{ _optBacktrackingInstances = i }++lensOptQualifiedInstances :: Lens' PragmaOptions _+lensOptQualifiedInstances f o = f (_optQualifiedInstances o) <&> \ i -> o{ _optQualifiedInstances = i }++lensOptInversionMaxDepth :: Lens' PragmaOptions _+lensOptInversionMaxDepth f o = f (_optInversionMaxDepth o) <&> \ i -> o{ _optInversionMaxDepth = i }++lensOptSafe :: Lens' PragmaOptions _+lensOptSafe f o = f (_optSafe o) <&> \ i -> o{ _optSafe = i }++lensOptDoubleCheck :: Lens' PragmaOptions _+lensOptDoubleCheck f o = f (_optDoubleCheck o) <&> \ i -> o{ _optDoubleCheck = i }++lensOptSyntacticEquality :: Lens' PragmaOptions _+lensOptSyntacticEquality f o = f (_optSyntacticEquality o) <&> \ i -> o{ _optSyntacticEquality = i }++lensOptWarningMode :: Lens' PragmaOptions _+lensOptWarningMode f o = f (_optWarningMode o) <&> \ i -> o{ _optWarningMode = i }++lensOptCompileMain :: Lens' PragmaOptions _+lensOptCompileMain f o = f (_optCompileMain o) <&> \ i -> o{ _optCompileMain = i }++lensOptCaching :: Lens' PragmaOptions _+lensOptCaching f o = f (_optCaching o) <&> \ i -> o{ _optCaching = i }++lensOptCountClusters :: Lens' PragmaOptions _+lensOptCountClusters f o = f (_optCountClusters o) <&> \ i -> o{ _optCountClusters = i }++lensOptAutoInline :: Lens' PragmaOptions _+lensOptAutoInline f o = f (_optAutoInline o) <&> \ i -> o{ _optAutoInline = i }++lensOptPrintPatternSynonyms :: Lens' PragmaOptions _+lensOptPrintPatternSynonyms f o = f (_optPrintPatternSynonyms o) <&> \ i -> o{ _optPrintPatternSynonyms = i }++lensOptFastReduce :: Lens' PragmaOptions _+lensOptFastReduce f o = f (_optFastReduce o) <&> \ i -> o{ _optFastReduce = i }++lensOptCallByName :: Lens' PragmaOptions _+lensOptCallByName f o = f (_optCallByName o) <&> \ i -> o{ _optCallByName = i }++lensOptConfluenceCheck :: Lens' PragmaOptions _+lensOptConfluenceCheck f o = f (_optConfluenceCheck o) <&> \ i -> o{ _optConfluenceCheck = i }++lensOptCohesion :: Lens' PragmaOptions _+lensOptCohesion f o = f (_optCohesion o) <&> \ i -> o{ _optCohesion = i }++lensOptFlatSplit :: Lens' PragmaOptions _+lensOptFlatSplit f o = f (_optFlatSplit o) <&> \ i -> o{ _optFlatSplit = i }++lensOptPolarity :: Lens' PragmaOptions _+lensOptPolarity f o = f (_optPolarity o) <&> \ i -> o{ _optPolarity = i}++lensOptImportSorts :: Lens' PragmaOptions _+lensOptImportSorts f o = f (_optImportSorts o) <&> \ i -> o{ _optImportSorts = i }++lensOptLoadPrimitives :: Lens' PragmaOptions _+lensOptLoadPrimitives f o = f (_optLoadPrimitives o) <&> \ i -> o{ _optLoadPrimitives = i }++lensOptAllowExec :: Lens' PragmaOptions _+lensOptAllowExec f o = f (_optAllowExec o) <&> \ i -> o{ _optAllowExec = i }++lensOptSaveMetas :: Lens' PragmaOptions _+lensOptSaveMetas f o = f (_optSaveMetas o) <&> \ i -> o{ _optSaveMetas = i }++lensOptShowIdentitySubstitutions :: Lens' PragmaOptions _+lensOptShowIdentitySubstitutions f o = f (_optShowIdentitySubstitutions o) <&> \ i -> o{ _optShowIdentitySubstitutions = i }++lensOptKeepCoveringClauses :: Lens' PragmaOptions _+lensOptKeepCoveringClauses f o = f (_optKeepCoveringClauses o) <&> \ i -> o{ _optKeepCoveringClauses = i }++lensOptLargeIndices :: Lens' PragmaOptions _+lensOptLargeIndices f o = f (_optLargeIndices o) <&> \ i -> o{ _optLargeIndices = i }++lensOptForcedArgumentRecursion :: Lens' PragmaOptions _+lensOptForcedArgumentRecursion f o = f (_optForcedArgumentRecursion o) <&> \ i -> o{ _optForcedArgumentRecursion = i }++lensOptExperimentalLazyInstances :: Lens' PragmaOptions _+lensOptExperimentalLazyInstances f o = f (_optExperimentalLazyInstances o) <&> \ i -> o{ _optExperimentalLazyInstances = i }+++-- | Map a function over the long options. Also removes the short options.+--   Will be used to add the plugin name to the plugin options.+mapFlag :: (String -> String) -> OptDescr a -> OptDescr a+mapFlag f (Option _ long arg descr) = Option [] (map f long) arg descr++defaultInteractionOptions :: PragmaOptions+defaultInteractionOptions = defaultPragmaOptions++defaultOptions :: CommandLineOptions+defaultOptions = Options+  { optProgramName      = "agda"+  , optInputFile             = Nothing+  , optIncludePaths          = []+  , optAbsoluteIncludePaths  = []+  , optLibraries             = []+  , optOverrideLibrariesFile = Nothing+  , optDefaultLibs           = True+  , optUseLibs               = True+  , optTraceImports          = 1+  , optTrustedExecutables    = Map.empty+  , optPrintAgdaDataDir      = False+  , optPrintAgdaAppDir       = False+  , optPrintVersion          = Nothing+  , optPrintHelp             = Nothing+  , optBuildLibrary          = False+  , optSetup                 = False+  , optEmacsMode             = Set.empty+  , optInteractive           = False+  , optGHCiInteraction       = False+  , optJSONInteraction       = False+  , optExitOnError           = False+  , optCompileDir            = Nothing+  , optGenerateVimFile       = False+  , optIgnoreInterfaces      = False+  , optIgnoreAllInterfaces   = False+  , optPragmaOptions         = defaultPragmaOptions+  , optOnlyScopeChecking     = False+  , optTransliterate         = False+  , optDiagnosticsColour     = AutoColour+  }++defaultPragmaOptions :: PragmaOptions+defaultPragmaOptions = PragmaOptions+  { _optShowImplicit              = Default+  , _optShowGeneralized           = Default+  , _optShowIrrelevant            = Default+  , _optUseUnicode                = Default -- UnicodeOk+  , _optVerbose                   = Strict.Nothing+  , _optProfiling                 = noProfileOptions+  , _optProp                      = Default+  , _optLevelUniverse             = Default+  , _optTwoLevel                  = Default+  , _optAllowUnsolved             = Default+  , _optAllowIncompleteMatch      = Default+  , _optPositivityCheck           = Default+  , _optTerminationCheck          = Default+  , _optTerminationDepth          = defaultCutOff+  , _optUniverseCheck             = Default+  , _optOmegaInOmega              = Default+  , _optCumulativity              = Default+  , _optSizedTypes                = Default+  , _optGuardedness               = Default+  , _optInjectiveTypeConstructors = Default+  , _optUniversePolymorphism      = Default+  , _optIrrelevantProjections     = Default+  , _optExperimentalIrrelevance   = Default+  , _optWithoutK                  = Default+  , _optCubicalCompatible         = Default+  , _optCopatterns                = Default+  , _optPatternMatching           = Default+  , _optExactSplit                = Default+  , _optHiddenArgumentPuns        = Default+  , _optEta                       = Default+  , _optForcing                   = Default+  , _optProjectionLike            = Default+  , _optErasure                   = Default+  , _optErasedMatches             = Default+  , _optEraseRecordParameters     = Default+  , _optRewriting                 = Default+  , _optCubical                   = Nothing+  , _optGuarded                   = Default+  , _optFirstOrder                = Default+  , _optRequireUniqueMetaSolutions = Default+  , _optPostfixProjections        = Default+  , _optKeepPatternVariables      = Default+  , _optInferAbsurdClauses        = Default+  , _optInstanceSearchDepth       = 500+  , _optBacktrackingInstances     = Default+  , _optQualifiedInstances        = Default+  , _optInversionMaxDepth         = 50+  , _optSafe                      = Default+  , _optDoubleCheck               = Default+  , _optSyntacticEquality         = Strict.Nothing+  , _optWarningMode               = defaultWarningMode+  , _optCompileMain               = Default+  , _optCaching                   = Default+  , _optCountClusters             = Default+  , _optAutoInline                = Default+  , _optPrintPatternSynonyms      = Default+  , _optFastReduce                = Default+  , _optCallByName                = Default+  , _optConfluenceCheck           = Nothing+  , _optCohesion                  = Default+  , _optFlatSplit                 = Default+  , _optPolarity                  = Default+  , _optImportSorts               = Default+  , _optLoadPrimitives            = Default+  , _optAllowExec                 = Default+  , _optSaveMetas                 = Default+  , _optShowIdentitySubstitutions = Default+  , _optKeepCoveringClauses       = Default+  , _optForcedArgumentRecursion   = Default+  , _optLargeIndices              = Default+  , _optExperimentalLazyInstances = Default+  }++-- | The options parse monad 'OptM' collects warnings that are not discarded+--   when a fatal error occurrs+newtype OptM a = OptM { unOptM :: ExceptT OptionError (Writer OptionWarnings) a }+  deriving (Functor, Applicative, Monad, MonadError OptionError, MonadWriter OptionWarnings)++type OptionError = String+type OptionWarnings = [OptionWarning]++runOptM :: OptM opts -> (Either OptionError opts, OptionWarnings)+runOptM = runWriter . runExceptT . unOptM++{- | @f :: Flag opts@  is an action on the option record that results from+     parsing an option.  @f opts@ produces either an error message or an+     updated options record+-}+type Flag opts = opts -> OptM opts++-- | Warnings when parsing options.++data OptionWarning+  = OptionRenamed { oldOptionName :: String, newOptionName :: String }+      -- ^ Name of option changed in a newer version of Agda.+  | WarningProblem WarningModeError+      -- ^ A problem with setting or unsetting a warning.+  deriving (Show, Generic)++instance NFData OptionWarning++instance Pretty OptionWarning where+  pretty = \case+    OptionRenamed old new -> hsep+      [ "Option", option old, "is deprecated, please use", option new, "instead" ]+    WarningProblem err -> pretty (prettyWarningModeError err) <+> "See --help=warning."+    where+    option = text . ("--" ++)++optionWarningName :: OptionWarning -> WarningName+optionWarningName = \case+  OptionRenamed{} -> OptionRenamed_+  WarningProblem{} -> WarningProblem_++-- | Checks that the given options are consistent.+--   Also makes adjustments (e.g. when one option implies another).++checkOpts :: MonadError OptionError m => CommandLineOptions -> m CommandLineOptions+checkOpts opts = do+  -- NOTE: This is a temporary hold-out until --vim can be converted into a backend or plugin,+  -- whose options compatibility currently is checked in `Agda.Compiler.Backend`.+  --+  -- Additionally, note that some options checking is performed in `Agda.Main`+  -- in which the top-level frontend and backend interactors are selected.+  --+  -- Those checks are not represented here, because:+  --   - They are used solely for selecting the initial executon mode; they+  --     don't need to be checked on a per-module etc basis.+  --   - I hope/expect that the presence of those specific flags will be eventually+  --     abstracted out (like the Backends' internal flags), so that they are invisible+  --     to the rest of the type-checking system.+  when (optGenerateVimFile opts && optOnlyScopeChecking opts) $+    throwError $ "The --only-scope-checking flag cannot be combined with --vim."++  lensPragmaOptions checkPragmaOptions opts++-- | Check for pragma option consistency and make adjustments.++checkPragmaOptions :: MonadError OptionError m => PragmaOptions -> m PragmaOptions+checkPragmaOptions opts = do++  -- Check for errors in pragma options.++  when ((optEraseRecordParameters `butNot` optErasure) opts) $+    throwError+      "The option --erase-record-parameters requires the use of --erasure"++#ifndef COUNT_CLUSTERS+  when (optCountClusters opts) $+    throwError+      "Cluster counting has not been enabled in this build of Agda."+#endif++  -- Perform corrections in pragma options.++  return $ opts++    -- -WTerminationIssue iff --termination-check+    & conformWarningToOption TerminationIssue_ optTerminationCheck++    -- -WNotStrictlyPositive iff --positivity-check+    . conformWarningToOption NotStrictlyPositive_ optPositivityCheck++    -- unsolvedWarnings iff --no-allow-unsolved-metas+    . conformWarningsToOption unsolvedWarnings (not . optAllowUnsolved)++    -- incompleteMatchWarnings iff --no-allow-incomplete-matches+    . conformWarningsToOption incompleteMatchWarnings (not . optAllowIncompleteMatch)++-- | Activate warning when and only when option is on.+conformWarningToOption ::+     WarningName+       -- ^ Warning to toggle.+  -> (PragmaOptions -> Bool)+       -- ^ Which flag to conform to?+  -> PragmaOptions+       -- ^ Options to modify.+  -> PragmaOptions+       -- ^ Modified options.+conformWarningToOption = conformWarningsToOption . Set.singleton++-- | Activate warnings when option is on and deactivate them when option is off.+conformWarningsToOption ::+     Set WarningName+       -- ^ Warnings to toggle.+  -> (PragmaOptions -> Bool)+       -- ^ Which flag to conform to?+  -> PragmaOptions+       -- ^ Options to modify.+  -> PragmaOptions+       -- ^ Modified options.+conformWarningsToOption ws f opts =+  over (lensOptWarningMode . warningSet) (if f opts then (`Set.union` ws) else (Set.\\ ws)) opts++-- | Check for unsafe pragmas. Gives a list of used unsafe flags.++unsafePragmaOptions :: PragmaOptions -> [String]+unsafePragmaOptions opts =+  [ "--allow-unsolved-metas"            | optAllowUnsolved opts                             ] +++  [ "--allow-incomplete-matches"        | optAllowIncompleteMatch opts                      ] +++  [ "--no-positivity-check"             | not (optPositivityCheck opts)                     ] +++  [ "--no-termination-check"            | not (optTerminationCheck opts)                    ] +++  [ "--type-in-type"                    | not (optUniverseCheck opts)                       ] +++  [ "--omega-in-omega"                  | optOmegaInOmega opts                              ] +++  [ "--sized-types"                     | optSizedTypes opts                                ] +++  [ "--injective-type-constructors"     | optInjectiveTypeConstructors opts                 ] +++  [ "--irrelevant-projections"          | optIrrelevantProjections opts                     ] +++  [ "--experimental-irrelevance"        | optExperimentalIrrelevance opts                   ] +++  [ "--rewriting"                       | optRewriting opts                                 ] +++  [ "--cubical-compatible and --with-K" | optCubicalCompatible opts, not (optWithoutK opts) ] +++  [ "--without-K and --flat-split"      | optWithoutK opts, optFlatSplit opts               ] +++  [ "--cumulativity"                    | optCumulativity opts                              ] +++  [ "--allow-exec"                      | optAllowExec opts                                 ] +++  [ "--no-load-primitives"              | not $ optLoadPrimitives opts                      ] +++  [ "--without-K and --large-indices"   | optWithoutK opts, optLargeIndices opts            ] +++  [ "--large-indices and --forced-argument-recursion"+  | optLargeIndices opts, optForcedArgumentRecursion opts ] +++  []++-- | This function returns 'True' if the file should be rechecked.++recheckBecausePragmaOptionsChanged+  :: PragmaOptions+     -- ^ The options that were used to check the file.+  -> PragmaOptions+     -- ^ The options that are currently in effect.+  -> Bool+recheckBecausePragmaOptionsChanged used current =+  blankOut used /= blankOut current+  where+  -- "Blank out" irrelevant options.+  -- It does not matter what we replace them with, so we take the null value.+  blankOut opts = opts+    { _optShowImplicit              = empty+    , _optShowIrrelevant            = empty+    , _optVerbose                   = empty+    , _optProfiling                 = empty+    , _optPostfixProjections        = empty+    , _optCompileMain               = empty+    , _optCaching                   = empty+    , _optCountClusters             = empty+    , _optPrintPatternSynonyms      = empty+    , _optShowIdentitySubstitutions = empty+    , _optKeepPatternVariables      = empty+    }++-- | Descriptions of infective and coinfective options.++data InfectiveCoinfectiveOption = ICOption+  { icOptionActive :: PragmaOptions -> Bool+    -- ^ Is the option active?+  , icOptionDescription :: String+    -- ^ A description of the option (typically a flag that activates+    -- the option).+  , icOptionKind :: InfectiveCoinfective+    -- ^ Is the option (roughly speaking) infective or coinfective?+  , icOptionOK :: PragmaOptions -> PragmaOptions -> Bool+    -- ^ This function returns 'True' exactly when, from the+    -- perspective of the option in question, the options in the+    -- current module (the first argument) are compatible with the+    -- options in a given imported module (the second argument).+  , icOptionWarning :: TopLevelModuleName -> Doc+    -- ^ A warning message that should be used if this option is not+    -- used correctly. The given module name is the name of an+    -- imported module for which 'icOptionOK' failed.+  }++-- | A standard infective option: If the option is active in an+-- imported module, then it must be active in the current module.++infectiveOption+  :: (PragmaOptions -> Bool)+     -- ^ Is the option active?+  -> String+    -- ^ A description of the option.+  -> InfectiveCoinfectiveOption+infectiveOption opt s = ICOption+  { icOptionActive      = opt+  , icOptionDescription = s+  , icOptionKind        = Infective+  , icOptionOK          = \current imported ->+                           opt imported <= opt current+  , icOptionWarning     = \m -> fsep $+      pwords "Importing module" ++ [pretty m] ++ pwords "using the" +++      [text s] ++ pwords "flag from a module which does not."+  }++-- | A standard coinfective option: If the option is active in the+-- current module, then it must be active in all imported modules.++coinfectiveOption+  :: (PragmaOptions -> Bool)+     -- ^ Is the option active?+  -> String+    -- ^ A description of the option.+  -> InfectiveCoinfectiveOption+coinfectiveOption opt s = ICOption+  { icOptionActive      = opt+  , icOptionDescription = s+  , icOptionKind        = Coinfective+  , icOptionOK          = \current imported ->+                           opt current <= opt imported+  , icOptionWarning     = \m -> fsep $+      pwords "Importing module" ++ [pretty m] +++      pwords "not using the" ++ [text s] +++      pwords "flag from a module which does."+  }++-- | Infective and coinfective options.+--+-- Note that @--cubical@ and @--erased-cubical@ are \"jointly+-- infective\": if one of them is used in one module, then one or the+-- other must be used in all modules that depend on this module.++infectiveCoinfectiveOptions :: [InfectiveCoinfectiveOption]+infectiveCoinfectiveOptions =+  [ coinfectiveOption optSafe                 "--safe"+  , coinfectiveOption optWithoutK             "--without-K"+  , cubicalCompatible+  , coinfectiveOption (not . optUniversePolymorphism)+                                              "--no-universe-polymorphism"+  , coinfectiveOption (not . optCumulativity) "--no-cumulativity"+  , coinfectiveOption optLevelUniverse        "--level-universe"+  , infectiveOption (isJust . optCubical)     "--cubical/--erased-cubical"+  , infectiveOption optGuarded                "--guarded"+  , infectiveOption optProp                   "--prop"+  , infectiveOption optTwoLevel               "--two-level"+  , infectiveOption optRewriting              "--rewriting"+  , infectiveOption optSizedTypes             "--sized-types"+  , infectiveOption optGuardedness            "--guardedness"+  , infectiveOption optFlatSplit              "--flat-split"+  , infectiveOption optPolarity               "--polarity"+  , infectiveOption optCohesion               "--cohesion"+  , infectiveOption optErasure                "--erasure"+  , infectiveOption optErasedMatches          "--erased-matches"+  ]+  where+  cubicalCompatible =+    (coinfectiveOption optCubicalCompatible "--cubical-compatible")+      { icOptionOK = \current imported ->+        -- One must use --cubical-compatible in the imported module if+        -- it is used in the current module, except if the current+        -- module also uses --with-K and not --safe, and the imported+        -- module uses --with-K.+        if optCubicalCompatible current+        then optCubicalCompatible imported+               ||+             not (optWithoutK imported)+               &&+             not (optWithoutK current)+               &&+             not (optSafe current)+        else True+      }++inputFlag :: FilePath -> Flag CommandLineOptions+inputFlag f o =+    case optInputFile o of+        Nothing  -> return $ o { optInputFile = Just f }+        Just _   -> throwError "only one input file allowed"++printAgdaDataDirFlag :: Flag CommandLineOptions+printAgdaDataDirFlag o = return $ o { optPrintAgdaDataDir = True }++printAgdaAppDirFlag :: Flag CommandLineOptions+printAgdaAppDirFlag o = return $ o { optPrintAgdaAppDir = True }++setupFlag :: Flag CommandLineOptions+setupFlag o = return $ o { optSetup = True }++versionFlag :: Flag CommandLineOptions+versionFlag o = return $ o { optPrintVersion = Just PrintAgdaVersion }++numericVersionFlag :: Flag CommandLineOptions+numericVersionFlag o = return $ o { optPrintVersion = Just PrintAgdaNumericVersion }++helpFlag :: Maybe String -> Flag CommandLineOptions+helpFlag Nothing    o = return $ o { optPrintHelp = Just GeneralHelp }+helpFlag (Just str) o = case string2HelpTopic str of+  Just hpt -> return $ o { optPrintHelp = Just (HelpFor hpt) }+  Nothing -> throwError $ concat+    [ "unknown help topic ", str, " (", printHelpTopics "topic", ")" ]++-- | Helper to explain @--help@.+printHelpTopics :: String -> String+printHelpTopics mvar = concat+  [ "available"+  , ifNull mvar "" {-else-} \ topic -> " " ++ String.pluralS allHelpTopics topic+  , ": "+  , intercalate ", " $ map fst allHelpTopics+  ]++emacsModeFlag :: String -> Flag CommandLineOptions+emacsModeFlag s o+  | s == EmacsMode.setupFlag   = add EmacsModeSetup+  | s == EmacsMode.compileFlag = add EmacsModeCompile+  | s == EmacsMode.locateFlag  = add EmacsModeLocate+  | otherwise = throwError $ concat+     [ "unknown emacs-mode command "+     , s+     , " ("+     , printEmacsModeCommands "commands"+     , ")"+     ]+  where+    add m = return o{ optEmacsMode = Set.insert m $ optEmacsMode o }++printEmacsModeCommands :: String -> String+printEmacsModeCommands mvar = concat+  [ "available"+  , ifNull mvar "" {-else-} \ cmd -> " " ++ cmd+  , ": "+  , intercalate ", " emacsModeCommands+  ]++emacsModeCommands :: [String]+emacsModeCommands = [EmacsMode.setupFlag, EmacsMode.compileFlag, EmacsMode.locateFlag]++safeFlag :: Flag PragmaOptions+safeFlag o = do+  return $ o { _optSafe        = Value True+             , _optSizedTypes  = setDefault False (_optSizedTypes o)+             }++syntacticEqualityFlag :: Maybe String -> Flag PragmaOptions+syntacticEqualityFlag s o =+  case fuel of+    Left err   -> throwError err+    Right fuel -> return $ o { _optSyntacticEquality = fuel }+  where+  fuel = case s of+    Nothing -> Right Strict.Nothing+    Just s  -> case readMaybe s of+      Just n | n >= 0 -> Right (Strict.Just n)+      _               -> Left $ "Not a natural number: " ++ s++ignoreInterfacesFlag :: Flag CommandLineOptions+ignoreInterfacesFlag o = return $ o { optIgnoreInterfaces = True }++ignoreAllInterfacesFlag :: Flag CommandLineOptions+ignoreAllInterfacesFlag o = return $ o { optIgnoreAllInterfaces = True }++traceImportsFlag :: Maybe String -> Flag CommandLineOptions+traceImportsFlag arg o = do+  mode <- case arg of+            Nothing -> return 2+            Just str -> case reads str :: [(Integer, String)] of+                          [(n, "")] -> return n+                          _ -> throwError $ "unknown printing option " ++ str ++ ". Please specify a number."+  return $ o { optTraceImports = mode }++diagnosticsColour :: Maybe String -> Flag CommandLineOptions+diagnosticsColour arg o = case arg of+  Just "auto"   -> pure o { optDiagnosticsColour = AutoColour }+  Just "always" -> pure o { optDiagnosticsColour = AlwaysColour }+  Just "never"  -> pure o { optDiagnosticsColour = NeverColour }+  Just str -> throwError $ "unknown colour option " ++ str ++ ". Please specify one of auto, always, or never."+  Nothing -> pure o { optDiagnosticsColour = AutoColour }++-- | Side effect for setting '_optUseUnicode'.+--+unicodeOrAsciiEffect :: UnicodeOrAscii -> Flag PragmaOptions+unicodeOrAsciiEffect a o = return $ UNSAFE.unsafePerformIO $ do+  unsafeSetUnicodeOrAscii a+  return o++ghciInteractionFlag :: Flag CommandLineOptions+ghciInteractionFlag o = return $ o { optGHCiInteraction = True }++jsonInteractionFlag :: Flag CommandLineOptions+jsonInteractionFlag o = return $ o { optJSONInteraction = True }++interactionExitFlag :: Flag CommandLineOptions+interactionExitFlag o = return $ o { optExitOnError = True }++vimFlag :: Flag CommandLineOptions+vimFlag o = return $ o { optGenerateVimFile = True }++onlyScopeCheckingFlag :: Flag CommandLineOptions+onlyScopeCheckingFlag o = return $ o { optOnlyScopeChecking = True }++transliterateFlag :: Flag CommandLineOptions+transliterateFlag o = return $ o { optTransliterate = True }++withKFlag :: Flag PragmaOptions+withKFlag =+  -- with-K is the opposite of --without-K, so collapse default when disabling --without-K+  lensOptWithoutK (lensCollapseDefault $ const $ pure False)+  >=>+  -- with-K only restores any unsetting of --erased-matches, so keep its default+  lensOptErasedMatches (lensKeepDefault $ const $ pure True)+++withoutKFlag :: Flag PragmaOptions+withoutKFlag o = return $ o+  { _optWithoutK                = Value True+  , _optFlatSplit               = setDefault False $ _optFlatSplit o+  , _optErasedMatches           = setDefault False $ _optErasedMatches o+  }++cubicalCompatibleFlag :: Flag PragmaOptions+cubicalCompatibleFlag o =+  return $ o+  { _optCubicalCompatible       = Value True+  , _optWithoutK                = setDefault True  $ _optWithoutK o+  , _optFlatSplit               = setDefault False $ _optFlatSplit o+  , _optErasedMatches           = setDefault False $ _optErasedMatches o+  }++cubicalFlag+  :: Cubical  -- ^ Which variant of Cubical Agda?+  -> Flag PragmaOptions+cubicalFlag variant o =+  return $ o+  { _optCubical                 = Just variant+  , _optCubicalCompatible       = setDefault True  $ _optCubicalCompatible o+  , _optWithoutK                = setDefault True  $ _optWithoutK o+  , _optTwoLevel                = setDefault True  $ _optTwoLevel o+  , _optFlatSplit               = setDefault False $ _optFlatSplit o+  , _optErasedMatches           = setDefault False $ _optErasedMatches o+  }++instanceDepthFlag :: String -> Flag PragmaOptions+instanceDepthFlag s o = do+  d <- integerArgument "--instance-search-depth" s+  return $ o { _optInstanceSearchDepth = d }++inversionMaxDepthFlag :: String -> Flag PragmaOptions+inversionMaxDepthFlag s o = do+  d <- integerArgument "--inversion-max-depth" s+  return $ o { _optInversionMaxDepth = d }++interactiveFlag :: Flag CommandLineOptions+interactiveFlag  o = return $ o { optInteractive = True }++compileDirFlag :: FilePath -> Flag CommandLineOptions+compileDirFlag f o = return $ o { optCompileDir = Just f }++includeFlag :: FilePath -> Flag CommandLineOptions+includeFlag d o = return $ o { optIncludePaths = d : optIncludePaths o }++libraryFlag :: String -> Flag CommandLineOptions+libraryFlag s o = return $ o { optLibraries = optLibraries o ++ [parseLibName s] }++overrideLibrariesFileFlag :: String -> Flag CommandLineOptions+overrideLibrariesFileFlag s o =+  return $ o+    { optOverrideLibrariesFile = Just s+    , optUseLibs = True+    }++noDefaultLibsFlag :: Flag CommandLineOptions+noDefaultLibsFlag o = return $ o { optDefaultLibs = False }++noLibsFlag :: Flag CommandLineOptions+noLibsFlag o = return $ o { optUseLibs = False }++verboseFlag :: String -> Flag PragmaOptions+verboseFlag s o =+    do  (k,n) <- parseVerbose s+        return $+          o { _optVerbose =+                Strict.Just $ Trie.insert k n $+                case _optVerbose o of+                  Strict.Nothing -> Trie.singleton [] 1+                  Strict.Just v  -> v+            }+  where+    parseVerbose :: String -> OptM ([VerboseKeyItem], VerboseLevel)+    parseVerbose s = case parseVerboseKey s of+      []  -> usage+      s0:ss0 -> do+        let (ss, s) = initLast1 s0 ss0+        -- The last entry must be a number.+        n <- maybe usage return $ readMaybe $ toList s+        return (ss, n)+    usage = throwError "argument to verbose should be on the form x.y.z:N or N"++profileFlag :: String -> Flag PragmaOptions+profileFlag s o =+  case addProfileOption s (_optProfiling o) of+    Left err   -> throwError err+    Right prof -> pure o{ _optProfiling = prof }++warningModeFlag :: String -> Flag PragmaOptions+warningModeFlag s o = case warningModeUpdate s of+  Right upd -> return $ o { _optWarningMode = upd (_optWarningMode o) }+  Left err  -> o <$ tell1 (WarningProblem err)++terminationDepthFlag :: String -> Flag PragmaOptions+terminationDepthFlag s o =+    do k <- maybe usage return $ readMaybe s+       when (k < 1) $ usage -- or: turn termination checking off for 0+       return $ o { _optTerminationDepth = CutOff $ k-1 }+    where usage = throwError "argument to termination-depth should be >= 1"++confluenceCheckFlag :: ConfluenceCheck -> Flag PragmaOptions+confluenceCheckFlag f o = return $ o { _optConfluenceCheck = Just f }++noConfluenceCheckFlag :: Flag PragmaOptions+noConfluenceCheckFlag o = return $ o { _optConfluenceCheck = Nothing }++exactSplitFlag :: Bool -> Flag PragmaOptions+exactSplitFlag b o = do+  return $ conformWarningsToOption exactSplitWarnings (const b)+         $ o { _optExactSplit  = Value b }+++integerArgument :: String -> String -> OptM Int+integerArgument flag s = maybe usage return $ readMaybe s+  where+  usage = throwError $ "option '" ++ flag ++ "' requires an integer argument"++standardOptions :: [OptDescr (Flag CommandLineOptions)]+standardOptions =+    [ Option ['V']  ["version"] (NoArg versionFlag)+                    ("print version information")++    , Option []     ["numeric-version"] (NoArg numericVersionFlag)+                    ("print version number")++    , Option ['?']  ["help"]    (OptArg helpFlag "TOPIC")+                    ("print help; " ++ printHelpTopics "TOPIC")++    , Option []     ["emacs-mode"] (ReqArg emacsModeFlag "COMMAND") $ concat+                    [ "administer the Emacs Agda mode; "+                    , printEmacsModeCommands "COMMANDs"+                    , "; confer --help=emacs-mode"+                    ]++    , Option []     ["print-agda-dir"] (NoArg printAgdaDataDirFlag)+                    ("print the Agda data directory")++    , Option []     ["print-agda-app-dir"] (NoArg printAgdaAppDirFlag)+                    ("print $AGDA_DIR")++    , Option []     ["print-agda-data-dir"] (NoArg printAgdaDataDirFlag)+                    ("print the Agda data directory")++    , Option []     ["build-library"] (NoArg \ o -> return o{ optBuildLibrary = True })+                    "build all modules included by the @.agda-lib@ file in the current directory"++    , Option []     ["setup"] (NoArg setupFlag)+                    ("setup the Agda data directory")++    , Option ['I']  ["interactive"] (NoArg interactiveFlag)+                    "start in interactive mode"+    , Option []     ["interaction"] (NoArg ghciInteractionFlag)+                    "for use with the Emacs mode"+    , Option []     ["interaction-json"] (NoArg jsonInteractionFlag)+                    "for use with other editors such as Atom"+    , Option []     ["interaction-exit-on-error"]+                    (NoArg interactionExitFlag)+                    "exit if a type error is encountered"++    , Option []     ["compile-dir"] (ReqArg compileDirFlag "DIR")+                    ("directory for compiler output (default: the project root)")++    , Option []     ["trace-imports"] (OptArg traceImportsFlag "LEVEL")+                    ("print information about accessed modules during type-checking (where LEVEL=0|1|2|3, default: 2)")++    , Option []     ["vim"] (NoArg vimFlag)+                    "generate Vim highlighting files"+    , Option []     ["ignore-interfaces"] (NoArg ignoreInterfacesFlag)+                    "ignore interface files (re-type check everything)"+    , Option ['i']  ["include-path"] (ReqArg includeFlag "DIR")+                    "look for imports in DIR"+    , Option ['l']  ["library"] (ReqArg libraryFlag "LIB")+                    "use library LIB"+    , Option []     ["library-file"] (ReqArg overrideLibrariesFileFlag "FILE")+                    "use FILE instead of the standard libraries file"+    , Option []     ["no-libraries"] (NoArg noLibsFlag)+                    "don't use any library files"+    , Option []     ["no-default-libraries"] (NoArg noDefaultLibsFlag)+                    "don't use default libraries"+    , Option []     ["only-scope-checking"] (NoArg onlyScopeCheckingFlag)+                    "only scope-check the top-level module, do not type-check it"+    , Option []     ["transliterate"] (NoArg transliterateFlag)+                    "transliterate unsupported code points when printing to stdout/stderr"+    , Option []     ["colour", "color"] (OptArg diagnosticsColour "always|auto|never")+                    ("whether or not to colour diagnostics output. The default is auto.")+    ] ++ map (fmap lensPragmaOptions) pragmaOptions++-- | Command line options of previous versions of Agda.+--   Should not be listed in the usage info, put parsed by GetOpt for good error messaging.+deadStandardOptions :: [OptDescr (Flag CommandLineOptions)]+deadStandardOptions =+    [ removedOption "sharing"    msgSharing+    , removedOption "no-sharing" msgSharing+    , removedOption "local-interfaces" "(in 2.8.0)"+    , Option []     ["ignore-all-interfaces"] (NoArg ignoreAllInterfacesFlag) -- not deprecated! Just hidden+                    "ignore all interface files (re-type check everything, including builtin files)"+      -- https://github.com/agda/agda/issues/3522#issuecomment-461010898+      -- The option is "developer only", so it is hidden.+      -- However, it is documented in the user manual.+    ] ++ map (fmap lensPragmaOptions) deadPragmaOptions+  where+    msgSharing = "(in favor of the Agda abstract machine)"++-- | Construct a flag of type @WithDefault _@+--+pragmaFlag :: (IsBool a, KnownBool b)+  => String+       -- ^ Long option name.  Prepended with @no-@ for negative version.+  -> Lens' PragmaOptions (WithDefault' a b)+       -- ^ Field to switch.+  -> String+       -- ^ Explanation for positive option.+  -> String+       -- ^ Additional info for positive option (not repeated for negative option).+  -> Maybe String+       -- ^ Explanation for negative option.+  -> [OptDescr (Flag PragmaOptions)]+pragmaFlag long field = pragmaFlag' long field (const return)++-- | Construct a flag of type @WithDefault _@+--+pragmaFlag' :: (IsBool a, KnownBool b)+  => String+       -- ^ Long option name.  Prepended with @no-@ for negative version.+  -> Lens' PragmaOptions (WithDefault' a b)+       -- ^ Field to switch.+  -> (a -> Flag PragmaOptions)+       -- ^ Given the new value, perform additional effect (can override field setting).+  -> String+       -- ^ Explanation for positive option.+  -> String+       -- ^ Additional info for positive option (not repeated for negative option).+  -> Maybe String+       -- ^ Explanation for negative option.+  -> [OptDescr (Flag PragmaOptions)]+       -- ^ Pair of option descriptors (positive, negative)+pragmaFlag' long field = pragmaFlagBool' long (field . lensCollapseDefault)++-- | Construct a flag of type 'IsBool'.+--+pragmaFlagBool :: (IsBool a)+  => String+       -- ^ Long option name.  Prepended with @no-@ for negative version.+  -> Lens' PragmaOptions a+       -- ^ Field to switch.+  -> String+       -- ^ Explanation for positive option.+  -> String+       -- ^ Additional info for positive option (not repeated for negative option).+  -> Maybe String+       -- ^ Explanation for negative option.+  -> [OptDescr (Flag PragmaOptions)]+pragmaFlagBool long field = pragmaFlagBool' long field (const return)++-- | Construct a flag of type 'IsBool' with extra effect.+--+pragmaFlagBool' :: IsBool a+  => String+       -- ^ Long option name.  Prepended with @no-@ for negative version.+  -> Lens' PragmaOptions a+       -- ^ Field to switch.+  -> (a -> Flag PragmaOptions)+       -- ^ Given the new value, perform additional effect (can override field setting).+  -> String+       -- ^ Explanation for positive option.+  -> String+       -- ^ Additional info for positive option (not repeated for negative option).+  -> Maybe String+       -- ^ Explanation for negative option.+  -> [OptDescr (Flag PragmaOptions)]+       -- ^ Pair of option descriptors (positive, negative)+pragmaFlagBool' long field effect pos info neg =+  [ Option [] [no b long] (flag b) (def b $ expl b) | b <- [True,False] ]+  where+  b0     = defaultPragmaOptions ^. field+  no   b = applyUnless b ("no-" ++)+  flag b = NoArg $ effect a . set field a+    where a = fromBool b+  def  b = applyWhen (fromBool b == b0) (++ " (default)")+  expl b = if b then unwords1 [pos, info] else fromMaybe ("do not " ++ pos) neg+++pragmaOptions :: [OptDescr (Flag PragmaOptions)]+pragmaOptions = concat+  [ pragmaFlag      "show-implicit" lensOptShowImplicit+                    "show implicit arguments when printing" ""+                    Nothing+  , pragmaFlag      "show-irrelevant" lensOptShowIrrelevant+                    "show irrelevant arguments when printing" ""+                    Nothing+  , pragmaFlag      "show-identity-substitutions" lensOptShowIdentitySubstitutions+                    "show all arguments of metavariables when printing terms" ""+                    Nothing+  , pragmaFlag'     "unicode" lensOptUseUnicode unicodeOrAsciiEffect+                    "use unicode characters when printing terms" ""+                    Nothing+  , [ Option ['v']  ["verbose"] (ReqArg verboseFlag "N")+                    "set verbosity level to N. Only has an effect if Agda was built with the \"debug\" flag."+    , Option []     ["profile"] (ReqArg profileFlag "TYPE")+                    ("turn on profiling for TYPE (where TYPE=" ++ intercalate "|" validProfileOptionStrings ++ ")")+    ]+  , pragmaFlag      "allow-unsolved-metas" lensOptAllowUnsolved+                    "succeed and create interface file regardless of unsolved meta variables" ""+                    Nothing+  , pragmaFlag      "allow-incomplete-matches" lensOptAllowIncompleteMatch+                    "succeed and create interface file regardless of incomplete pattern matches" ""+                    Nothing+  , pragmaFlag      "positivity-check" lensOptPositivityCheck+                    "warn about not strictly positive data types" ""+                    Nothing+  , pragmaFlag      "termination-check" lensOptTerminationCheck+                    "warn about possibly nonterminating code" ""+                    Nothing+  , [ Option []     ["termination-depth"] (ReqArg terminationDepthFlag "N")+                    "allow termination checker to count decrease/increase upto N (default N=1)"+    ]+  , pragmaFlag      "type-in-type" lensOptNoUniverseCheck+                    "ignore universe levels"  "(this makes Agda inconsistent)"+                    Nothing+  , pragmaFlag      "omega-in-omega" lensOptOmegaInOmega+                    "enable typing rule Setω : Setω" "(this makes Agda inconsistent)"+                    Nothing+  , pragmaFlag      "cumulativity" lensOptCumulativity+                    "enable subtyping of universes" "(e.g. Set =< Set₁)"+                    $ Just "disable subtyping of universes"+  , pragmaFlag      "prop" lensOptProp+                    "enable the use of the Prop universe" ""+                    $ Just "disable the use of the Prop universe"+  , pragmaFlag      "level-universe" lensOptLevelUniverse+                    "place type Level in a dedicated LevelUniv universe" ""+                    Nothing+  , pragmaFlag      "two-level" lensOptTwoLevel+                    "enable the use of SSet* universes" ""+                    Nothing+  , pragmaFlag      "sized-types" lensOptSizedTypes+                    "enable sized types" "(inconsistent with --guardedness)"+                    $ Just "disable sized types"+  , pragmaFlag      "cohesion" lensOptCohesion+                    "enable the cohesion modalities" "(in particular @flat)"+                    Nothing+  , pragmaFlag      "flat-split" lensOptFlatSplit+                    "allow splitting on `(@flat x : A)' arguments" "(implies --cohesion)"+                    Nothing+  , pragmaFlag      "polarity" lensOptPolarity+                    "enable the polarity modalities (@++, @mixed, etc.) and their integration in the positivity checker" ""+                    Nothing+  , pragmaFlag      "guardedness" lensOptGuardedness+                    "enable constructor-based guarded corecursion" "(inconsistent with --sized-types)"+                    $ Just "disable constructor-based guarded corecursion"+  , pragmaFlag      "injective-type-constructors" lensOptInjectiveTypeConstructors+                    "enable injective type constructors" "(makes Agda anti-classical and possibly inconsistent)"+                    $ Just "disable injective type constructors"+  , pragmaFlag      "universe-polymorphism" lensOptUniversePolymorphism+                    "enable universe polymorphism" ""+                    $ Just "disable universe polymorphism"+  , pragmaFlag      "irrelevant-projections" lensOptIrrelevantProjections+                    "enable projection of irrelevant record fields and similar irrelevant definitions" "(inconsistent)"+                    $ Just "disable projection of irrelevant record fields and similar irrelevant definitions"+  , pragmaFlag      "experimental-irrelevance" lensOptExperimentalIrrelevance+                    "enable potentially unsound irrelevance features" "(irrelevant levels, irrelevant data matching)"+                    Nothing+  , [ Option []     ["with-K"] (NoArg withKFlag)+                    "enable the K rule in pattern matching (default)"+    , Option []     ["cubical-compatible"] (NoArg cubicalCompatibleFlag)+                    "turn on generation of auxiliary code required for --cubical, implies --without-K"+    , Option []     ["without-K"] (NoArg withoutKFlag)+                    "turn on checks to make code compatible with HoTT (e.g. disabling the K rule). Implies --no-flat-split."+    ]+  , pragmaFlag      "copatterns" lensOptCopatterns+                    "enable definitions by copattern matching" ""+                    $ Just "disable definitions by copattern matching"+  , pragmaFlag      "pattern-matching" lensOptPatternMatching+                    "enable pattern matching" ""+                    $ Just "disable pattern matching completely"+  , [ Option []     ["exact-split"] (NoArg $ exactSplitFlag True)+                    "require all clauses in a definition to hold as definitional equalities (unless marked CATCHALL)"+    , Option []     ["no-exact-split"] (NoArg $ exactSplitFlag False)+                    "do not require all clauses in a definition to hold as definitional equalities (default)"+    ]+  , pragmaFlag      "hidden-argument-puns" lensOptHiddenArgumentPuns+                    "interpret the patterns {x} and {{x}} as puns" ""+                    Nothing+  , pragmaFlag      "eta-equality" lensOptEta+                    "default records to eta-equality" ""+                    $ Just "default records to no-eta-equality"+  , pragmaFlag      "forcing" lensOptForcing+                    "enable the forcing analysis for data constructors" "(optimisation)"+                    $ Just "disable the forcing analysis"+  , pragmaFlag      "projection-like" lensOptProjectionLike+                    "enable the analysis whether function signatures liken those of projections" "(optimisation)"+                    $ Just "disable the projection-like analysis"+  , pragmaFlag      "erasure" lensOptErasure+                    "enable erasure" ""+                    Nothing+  , pragmaFlag      "erased-matches" lensOptErasedMatches+                    "allow matching in erased positions for single-constructor types" "(implies --erasure if supplied explicitly)"+                    Nothing+  , pragmaFlag      "erase-record-parameters" lensOptEraseRecordParameters+                    "mark all parameters of record modules as erased" "(implies --erasure)"+                    Nothing+  , pragmaFlag      "rewriting" lensOptRewriting+                    "enable declaration and use of REWRITE rules" ""+                    $ Just "disable declaration and use of REWRITE rules"+  , [ Option []     ["local-confluence-check"] (NoArg $ confluenceCheckFlag LocalConfluenceCheck)+                    "enable checking of local confluence of REWRITE rules"+    , Option []     ["confluence-check"] (NoArg $ confluenceCheckFlag GlobalConfluenceCheck)+                    "enable global confluence checking of REWRITE rules (more restrictive than --local-confluence-check)"+    , Option []     ["no-confluence-check"] (NoArg noConfluenceCheckFlag)+                    "disable confluence checking of REWRITE rules (default)"+    , Option []     ["cubical"] (NoArg $ cubicalFlag CFull)+                    "enable cubical features (e.g. overloads lambdas for paths), implies --cubical-compatible"+    , Option []     ["erased-cubical"] (NoArg $ cubicalFlag CErased)+                    "enable cubical features (some only in erased settings), implies --cubical-compatible"+    ]+  , pragmaFlag      "guarded" lensOptGuarded+                    "enable @lock/@tick attributes" ""+                    $ Just "disable @lock/@tick attributes"+  , lossyUnificationOption+  , requireUniqueMetaSolutionsOptions+  , pragmaFlag      "postfix-projections" lensOptPostfixProjections+                    "prefer postfix projection notation" ""+                    $ Just "prefer prefix projection notation"+  , pragmaFlag      "keep-pattern-variables" lensOptKeepPatternVariables+                    "don't replace variables with dot patterns during case splitting" ""+                    $ Just "replace variables with dot patterns during case splitting"+  , pragmaFlag      "infer-absurd-clauses" lensOptInferAbsurdClauses+                    "eliminate absurd clauses in case splitting and coverage checking" ""+                    $ Just "do not automatically eliminate absurd clauses in case splitting and coverage checking (can speed up type-checking)"+  , [ Option []     ["instance-search-depth"] (ReqArg instanceDepthFlag "N")+                    "set instance search depth to N (default: 500)"+    ]+  , backtrackingInstancesOption+  , pragmaFlag      "qualified-instances" lensOptQualifiedInstances+                    "use instances with qualified names" ""+                    Nothing+  , [ Option []     ["inversion-max-depth"] (ReqArg inversionMaxDepthFlag "N")+                    "set maximum depth for pattern match inversion to N (default: 50)"+    , Option []     ["safe"] (NoArg safeFlag)+                    "disable postulates, unsafe OPTION pragmas and primEraseEquality, implies --no-sized-types"+    ]+  , pragmaFlag      "double-check" lensOptDoubleCheck+                    "enable double-checking of all terms using the internal typechecker" ""+                    $ Just "disable double-checking of terms"+  , [ Option []     ["no-syntactic-equality"] (NoArg $ syntacticEqualityFlag (Just "0"))+                    "disable the syntactic equality shortcut in the conversion checker"+    , Option []     ["syntactic-equality"] (OptArg syntacticEqualityFlag "FUEL")+                    "give the syntactic equality shortcut FUEL units of fuel (default: unlimited)"+    , Option ['W']  ["warning"] (ReqArg warningModeFlag "FLAG")+                    ("set warning flags. See --help=warning.")+    ]+  , pragmaFlag      "main" lensOptCompileMain+                    "treat the requested module as the main module of a program when compiling" ""+                    Nothing+  , pragmaFlag      "caching" lensOptCaching+                    "enable caching of typechecking" ""+                    $ Just "disable caching of typechecking"+  , pragmaFlag      "count-clusters" lensOptCountClusters+                    "count extended grapheme clusters when generating LaTeX"+                    ("(note that this flag " +++#ifdef COUNT_CLUSTERS+                      "is not enabled in all builds"+#else+                      "has not been enabled in this build"+#endif+                      ++ " of Agda)")+                    Nothing+  , pragmaFlag      "auto-inline" lensOptAutoInline+                    "enable automatic compile-time inlining" ""+                    $ Just "disable automatic compile-time inlining, only definitions marked INLINE will be inlined"+  , pragmaFlag      "print-pattern-synonyms" lensOptPrintPatternSynonyms+                    "keep pattern synonyms when printing terms" ""+                    $ Just "expand pattern synonyms when printing terms"+  , pragmaFlag      "fast-reduce" lensOptFastReduce+                    "enable reduction using the Agda Abstract Machine" ""+                    $ Just "disable reduction using the Agda Abstract Machine"+  , pragmaFlag      "call-by-name" lensOptCallByName+                    "use call-by-name evaluation instead of call-by-need" ""+                    $ Just "use call-by-need evaluation"++  , pragmaFlag      "import-sorts" lensOptImportSorts+                    "implicitly import Agda.Primitive using (Set; Prop) at the start of each top-level module" ""+                    $ Just "disable the implicit import of Agda.Primitive using (Set; Prop) at the start of each top-level module"+  , pragmaFlag      "load-primitives" lensOptLoadPrimitives+                    "load primitives modules" ""+                    $ Just "disable loading of primitive modules completely (implies --no-import-sorts)"+  , pragmaFlag      "allow-exec" lensOptAllowExec+                    "allow system calls to trusted executables with primExec" ""+                    Nothing+  , pragmaFlag      "save-metas" lensOptSaveMetas+                    "save meta-variables" ""+                    Nothing+  , pragmaFlag      "keep-covering-clauses" lensOptKeepCoveringClauses+                    "do not discard covering clauses" "(required for some external backends)"+                    $ Just "discard covering clauses"+  , pragmaFlag      "large-indices" lensOptLargeIndices+                    "allow constructors with large indices" ""+                    $ Just "always check that constructor arguments live in universes compatible with that of the datatype"+  , pragmaFlag      "forced-argument-recursion" lensOptForcedArgumentRecursion+                    "allow recursion on forced constructor arguments" ""+                    Nothing+  , pragmaFlag      "experimental-lazy-instances" lensOptExperimentalLazyInstances+                    "enable experimental, faster implementation of instance search" ""+                    Nothing+  ]++pragmaOptionDefault :: KnownBool b => (PragmaOptions -> WithDefault b) -> Bool -> String+pragmaOptionDefault f b =+  if b == collapseDefault (f defaultPragmaOptions) then " (default)" else ""++lossyUnificationOption :: [OptDescr (Flag PragmaOptions)]+lossyUnificationOption =+  pragmaFlag "lossy-unification" lensOptFirstOrder+    "enable heuristically unifying `f es = f es'` by unifying `es = es'`"+    "even when it could lose solutions"+    Nothing++requireUniqueMetaSolutionsOptions :: [OptDescr (Flag PragmaOptions)]+requireUniqueMetaSolutionsOptions =+  pragmaFlag "require-unique-meta-solutions" lensOptRequireUniqueMetaSolutions+    "require unique solutions to meta variables"+    "even when it could lose solutions"+    Nothing++backtrackingInstancesOption :: [OptDescr (Flag PragmaOptions)]+backtrackingInstancesOption =+  pragmaFlag "backtracking-instance-search" lensOptBacktrackingInstances+    "allow backtracking during instance search"+    ""+    Nothing++-- | Pragma options of previous versions of Agda.+--   Should not be listed in the usage info, put parsed by GetOpt for good error messaging.+deadPragmaOptions :: [OptDescr (Flag PragmaOptions)]+deadPragmaOptions = concat+  [ map (uncurry removedOption)+    [ ("guardedness-preserving-type-constructors"+      , "")+    , ("no-coverage-check"+      , inVersion "2.5.1") -- see issue #1918+    , ("no-sort-comparison"+      , "")+    , ("subtyping"+      , inVersion "2.6.3") -- see issue #5427+    , ("no-subtyping"+      , inVersion "2.6.3") -- see issue #5427+    , ("no-flat-split", inVersion "2.6.3")  -- See issue #6263.+    ]+  , map (uncurry renamedNoArgOption)+    [ ( "experimental-lossy-unification"+      , headWithDefault __IMPOSSIBLE__ lossyUnificationOption+      )+    , ( "overlapping-instances"+      , headWithDefault __IMPOSSIBLE__ backtrackingInstancesOption+      )+    ]+  ]+  where+    inVersion = ("in version " ++)++-- | Generate a dead options that just error out saying this option has been removed.+removedOption ::+     String+       -- ^ The name of the removed option.+  -> String+       -- ^ Optional: additional remark, like in which version the option was removed.+  -> OptDescr (Flag a)+removedOption name remark = Option [] [name] (NoArg $ const $ throwError msg) msg+  where+  msg = unwords ["Option", "--" ++ name, "has been removed", remark]++-- | Generate a deprecated option that resolves to another option.+renamedNoArgOption ::+     String+       -- ^ The deprecated long option name.+  -> OptDescr (Flag a)+       -- ^ The new option.+  -> OptDescr (Flag a)+       -- ^ The old option which additionally emits a 'RenamedOption' warning.+renamedNoArgOption old = \case+  Option _ [new] (NoArg flag) description ->+    Option [] [old] (NoArg flag') $ concat [description, " (DEPRECATED, use --", new, ")"]+    where+    flag' o = tell1 (OptionRenamed old new) >> flag o+  _ -> __IMPOSSIBLE__++-- | Used for printing usage info.+--   Does not include the dead options.+standardOptions_ :: [OptDescr ()]+standardOptions_ = map void standardOptions++-- | Simple interface for Agda.Utils.GetOpt+--   Could be moved to Agda.Utils.Options (does not exist yet)+getOptSimple+  :: [String]               -- ^ command line argument words+  -> [OptDescr (Flag opts)] -- ^ options handlers+  -> (String -> Flag opts)  -- ^ handler of non-options (only one is allowed)+  -> Flag opts              -- ^ combined opts data structure transformer+getOptSimple argv opts fileArg = \ defaults ->+  case getOpt' (ReturnInOrder fileArg) opts argv of+    (o, _, []          , [] )  -> foldl (>>=) (return defaults) o+    (_, _, unrecognized, errs) -> throwError $ umsg ++ emsg++      where+      ucap = "Unrecognized " ++ String.pluralS unrecognized "option" ++ ":"+      ecap = String.pluralS errs "Option error" ++ ":"+      umsg = if null unrecognized then "" else unlines $+       ucap : map suggest unrecognized+      emsg = if null errs then "" else unlines $+       ecap : errs++      -- Suggest alternatives that are at most 3 typos away++      longopts :: [String]+      longopts = map ("--" ++) $ concatMap (\ (Option _ long _ _) -> long) opts++      dist :: String -> String -> Int+      dist s t = restrictedDamerauLevenshteinDistance defaultEditCosts s t++      close :: String -> String -> Maybe (Int, String)+      close s t = let d = dist s t in if d <= 3 then Just (d, t) else Nothing++      closeopts :: String -> [(Int, String)]+      closeopts s = mapMaybe (close s) longopts++      alts :: String -> [List1 String]+      alts s = map (fmap snd) $ List1.groupOn fst $ closeopts s++      suggest :: String -> String+      suggest s = case alts s of+        []     -> s+        as : _ -> s ++ " (did you mean " ++ sugs as ++ " ?)"++      sugs :: List1 String -> String+      sugs (a :| []) = a+      sugs as  = "any of " ++ List1.unwords as++-- | Parse options from an options pragma.+parsePragmaOptions+  :: OptionsPragma+     -- ^ Pragma options.+  -> CommandLineOptions+     -- ^ Command-line options which should be updated.+  -> OptM PragmaOptions+parsePragmaOptions argv opts = do+  ps <- getOptSimple+          (pragmaStrings argv)+          (deadPragmaOptions ++ pragmaOptions)+          (\s _ -> throwError $ "Bad option in pragma: " ++ s)+          (optPragmaOptions opts)+  checkPragmaOptions ps  -- | Parse options for a plugin. parsePluginOptions :: [String] -> [OptDescr (Flag opts)] -> Flag opts
+ src/full/Agda/Interaction/Options/Errors.hs view
@@ -0,0 +1,553 @@+-- | Provide names for the errors Agda throws.Options/Er++module Agda.Interaction.Options.Errors where++import Control.DeepSeq        ( NFData )+import Data.List              ( sort )+import Generic.Data           ( FiniteEnumeration(..) )+import GHC.Generics           ( Generic )++import Agda.Syntax.Common     ( ConstructorOrPatternSynonym(..) )++import Agda.Utils.Function    ( applyWhenJust )+import Agda.Utils.List        ( initWithDefault )+import Agda.Utils.Impossible  ( __IMPOSSIBLE__ )++-- | Extra information for error 'CannotQuoteTerm'.++data CannotQuoteTerm+  = CannotQuoteTermHidden+  | CannotQuoteTermNothing+  deriving (Show, Generic, Enum, Bounded)++-- | What kind of declaration?+--+--   See also 'Agda.Syntax.Concrete.Definitions.Types.DataRecOrFun'.++data DataRecOrFun_+  = DataName_  -- ^ Name of a data type.+  | RecName_   -- ^ Name of a record type.+  | FunName_   -- ^ Name of a function.+  deriving (Show, Generic, Enum, Bounded)++-- | The reason for an 'ErasedDatatype' error.++data ErasedDatatypeReason+  = SeveralConstructors+    -- ^ There are several constructors.+  | NoErasedMatches+    -- ^ The flag @--erased-matches@ is not used.+  | NoK+    -- ^ The K rule is not activated.+  deriving (Show, Generic, Enum, Bounded)++-- | Things not allowed in dot patterns.++data NotAllowedInDotPatterns+  = LetExpressions+  | PatternLambdas+  deriving (Show, Generic, Enum, Bounded)++-- | Reasons for error 'NotAValidLetBinding'.++data NotAValidLetBinding+  = MissingRHS+  | NotAValidLetPattern+  | WhereClausesNotAllowed+  -- These cannot be triggered:+  -- -- | CopatternsNotAllowed+  -- -- | EllipsisNotAllowed+  -- -- | WithPatternsNotAllowed+  deriving (Show, Generic, Enum, Bounded)++-- | Reasons for error 'NotAValidLetExpression'.++data NotAValidLetExpression+  = MissingBody+  deriving (Show, Generic, Enum, Bounded)++-- | Symbolic name of an Agda error.++data ErrorName+  -- Error groups (alphabetically) with named sub errors+  = ExecError_             ExecError_+  | GHCBackendError_       GHCBackendError_+  | ImpossibleConstructor_ NegativeUnification_+  | InteractionError_      InteractionError_+  | JSBackendError_        JSBackendError_+  | NicifierError_         DeclarationException_+  | SplitError_            SplitError_+  | UnquoteError_          UnquoteError_+  -- Generic errors (alphabetically)+  | CompilationError_+  | CustomBackendError_+  | GenericError_+  | GenericDocError_+  | InternalError_+  | LibraryError_+  | NonFatalErrors_+  | NotImplemented_+  | NotSupported_+  | OptionError_+  | SyntaxError_+  -- Other errors (alphabetically)+  | AbsentRHSRequiresAbsurdPattern_+  | AbstractConstructorNotInScope_+  | AmbiguousConstructor_+  | AmbiguousField_+  | AmbiguousModule_+  | AmbiguousName_+  | AmbiguousOverloadedProjection_+  | AmbiguousParseForApplication_+  | AmbiguousParseForLHS_+  | AmbiguousProjection_+  | AmbiguousTopLevelModuleName_+  | AsPatternInPatternSynonym_+  | AttributeKindNotEnabled_+  | BackendDoesNotSupportOnlyScopeChecking_+  | BadArgumentsToPatternSynonym_+  | BothWithAndRHS_+  | BuiltinInParameterisedModule_+  | BuiltinMustBeConstructor_+  | BuiltinMustBeData_+  | BuiltinMustBeDef_+  | BuiltinMustBeFunction_+  | BuiltinMustBePostulate_+  | CannotApply_+  | CannotEliminateWithPattern_+  | CannotEliminateWithProjection_+  | CannotGenerateHCompClause_+  | CannotGenerateTransportClause_+  | CannotQuote_ CannotQuote_+  | CannotQuoteTerm_ CannotQuoteTerm+  | CannotResolveAmbiguousPatternSynonym_+  | CannotRewriteByNonEquation_+  | CannotSolveSizeConstraints_+  | CantResolveOverloadedConstructorsTargetingSameDatatype_+  | ClashingDefinition_+  | ClashingModule_+  | ComatchingDisabledForRecord_+  | ConstructorDoesNotTargetGivenType_+  | ConstructorPatternInWrongDatatype_+  | ContradictorySizeConstraint_+  | CopatternHeadNotProjection_+  | CubicalCompilationNotSupported_+  | CubicalNotErasure_+  | CubicalPrimitiveNotFullyApplied_+  | CyclicModuleDependency_+  | DatatypeIndexPolarity_+  | DeBruijnIndexOutOfScope_+  | DeclarationsAfterTopLevelModule_+  | DefinitionInDifferentModule_+  | DefinitionIsErased_+  | DefinitionIsIrrelevant_+  | DoNotationError_+  | DoesNotMentionTicks_+  | DotPatternInPatternSynonym_+  | DuplicateBuiltinBinding_+  | DuplicateConstructors_+  | DuplicateFields_+  | DuplicateImports_+  | DuplicateOverlapPragma_+  | DuplicatePrimitiveBinding_+  | EmptyTypeOfSizes_+  | ExpectedBindingForParameter_+  | ExpectedIntervalLiteral_+  | FieldOutsideRecord_+  | FaceConstraintDisjunction_+  | FaceConstraintUnsatisfiable_+  | FileNotFound_+  | ForcedConstructorNotInstantiated_+  | FunctionTypeInSizeUniv_+  | GeneralizeCyclicDependency_+  | GeneralizeNotSupportedHere_+  | GeneralizedVarInLetOpenedModule_+  | ModuleNameHashCollision_+  | HidingMismatch_+  | IdiomBracketError_+  | InvalidBuiltin_+  | InvalidDottedExpression_+  | IllTypedPatternAfterWithAbstraction_+  | IllegalDeclarationBeforeTopLevelModule_+  | IllegalDeclarationInDataDefinition_+  | IllegalHidingInPostfixProjection_+  | IllegalInstanceVariableInPatternSynonym_+  | IllegalLetInTelescope_+  | IllegalPatternInTelescope_+  | IllformedProjectionPatternAbstract_+  | IllformedProjectionPatternConcrete_+  | IncorrectTypeForRewriteRelation_+  | InstanceNoCandidate_+  | InstanceSearchDepthExhausted_+  | InvalidFileName_+  | InvalidModalTelescopeUse_+  | InvalidPattern_+  | InvalidProjectionParameter_+  | InvalidPun_ ConstructorOrPatternSynonym+  | InvalidTypeSort_+  | LambdaIsErased_+  | LibTooFarDown_+  | LiteralTooBig_+  | MacroResultTypeMismatch_+  | MetaCannotDependOn_+  | MetaErasedSolution_+  | MetaIrrelevantSolution_+  | MismatchedProjectionsError_+  | MissingTypeSignature_ DataRecOrFun_+  | ModuleArityMismatch_+  | ModuleDefinedInOtherFile_+  | ModuleNameDoesntMatchFileName_+  | ModuleNameUnexpected_+  | MultipleFixityDecls_+  | MultiplePolarityPragmas_+  | ExplicitPolarityVsPragma_+  | ConstructorNameOfNonRecord_+  | NamedWhereModuleInRefinedContext_+  | NeedOptionAllowExec_+  | NeedOptionCopatterns_+  | NeedOptionCubical_+  | NeedOptionPatternMatching_+  | NeedOptionProp_+  | NeedOptionRewriting_+  | NeedOptionSizedTypes_+  | NeedOptionTwoLevel_+  | NeedOptionUniversePolymorphism_+  | NegativeLiteralInPattern_+  | NoBindingForBuiltin_+  | NoBindingForPrimitive_+  | NoKnownRecordWithSuchFields_+  | NoParameterOfName_+  | NoParseForApplication_+  | NoParseForLHS_+  | NoSuchBuiltinName_+  | NoSuchModule_+  | NoSuchPrimitiveFunction_+  | NotAValidLetBinding_ (Maybe NotAValidLetBinding)+  | NotAValidLetExpression_ NotAValidLetExpression+  | NotAllowedInDotPatterns_ NotAllowedInDotPatterns+  | NotAnExpression_+  | NotInScope_+  | NotLeqSort_+  | NotValidBeforeField_+  | OverlappingProjects_+  | PathAbstractionFailed_+  | PatternInPathLambda_+  | PatternInSystem_+  | PatternSynonymArgumentShadows_ ConstructorOrPatternSynonym+  | PostulatedSizeInModule_+  | PrivateRecordField_+  | ProjectionIsIrrelevant_+  | QualifiedLocalModule_+  | QuantityMismatch_+  | RecordIsErased_+  | RecursiveRecordNeedsInductivity_+  | ReferencesFutureVariables_+  | RelevanceMismatch_+  | RepeatedNamesInImportDirective_+  | RepeatedVariablesInPattern_+  | ShadowedModule_+  | ShouldBeASort_+  | ShouldBeEmpty_+  | ShouldBePath_+  | ShouldBePi_+  | ShouldBeRecordPattern_+  | ShouldBeRecordType_+  | ShouldEndInApplicationOfTheDatatype_+  | SolvedButOpenHoles_+  | SortCannotDependOnItsIndex_+  | SortDoesNotAdmitDataDefinitions_+  | SortOfSplitVarError_+  | SplitInProp_+  | SplitOnAbstract_+  | SplitOnCoinductive_+  | SplitOnIrrelevant_+  | SplitOnNonEtaRecord_+  | SplitOnNonVariable_+  | SplitOnPartial_+  | SplitOnUnchecked_+  | SplitOnUnusableCohesion_+  | SplitOnUnusablePolarity_+  | TacticAttributeNotAllowed_+  | TooFewArgumentsToPatternSynonym_+  | TooFewPatternsInWithClause_+  | TooManyFields_+  | TooManyPatternsInWithClause_+  | TriedToCopyConstrainedPrim_+  | InvalidInstanceHeadType_+  | UnboundVariablesInPatternSynonym_+  | UnequalCohesion_+  | UnequalFiniteness_+  | UnequalHiding_+  | UnequalLevel_+  | UnequalQuantity_+  | UnequalRelevance_+  | UnequalPolarity_+  | UnequalSorts_+  | UnequalTerms_+  | UnexpectedModalityAnnotationInParameter_+  | UnexpectedParameter_+  | UnexpectedTypeSignatureForParameter_+  | UnexpectedWithPatterns_+  | UnknownBackend_+  | UnusableAtModality_+  | UnusedVariableInPatternSynonym_+  | VariableIsErased_+  | VariableIsIrrelevant_+  | VariableIsOfUnusableCohesion_+  | VariableIsOfUnusablePolarity_+  | WithClausePatternMismatch_+  | WithOnFreeVariable_+  | WrongAnnotationInLambda_+  | WrongArgInfoForPrimitive_+  | WrongCohesionInLambda_+  | WrongPolarityInLambda_+  | WrongHidingInApplication_+  | WrongHidingInLHS_+  | WrongHidingInLambda_+  | WrongHidingInProjection_+  | WrongIrrelevanceInLambda_+  | WrongNamedArgument_+  | WrongNumberOfConstructorArguments_+  | WrongQuantityInLambda_+  | WrongSharpArity_+  deriving (Show, Generic)+  deriving (Enum, Bounded) via (FiniteEnumeration ErrorName)++-- | Nicifier errors.+--+data DeclarationException_+  = AmbiguousConstructorN_+  | AmbiguousFunClauses_+  | BadMacroDef_+  | DisallowedInterleavedMutual_+  | DuplicateAnonDeclaration_+  | DuplicateDefinition_+  | InvalidMeasureMutual_+  | MissingWithClauses_+  | MultipleEllipses_+  | OpaqueInMutual_+  | UnfoldingOutsideOpaque_+  | UnquoteDefRequiresSignature_+  | WrongContentBlock_+  | WrongDefinition_+  deriving (Show, Generic)+  deriving (Enum, Bounded) via (FiniteEnumeration DeclarationException_)++data GHCBackendError_+  = ConstructorCountMismatch_+  | NotAHaskellType_ NotAHaskellType_+  | WrongTypeOfMain_+  deriving (Show, Generic)+  deriving (Enum, Bounded) via (FiniteEnumeration GHCBackendError_)++data JSBackendError_+  = BadCompilePragma_+  deriving (Show, Generic)+  deriving (Enum, Bounded) via (FiniteEnumeration JSBackendError_)++data InteractionError_+  = CannotGive_+  | CannotRefine_+  | CaseSplitError_+  | ExpectedIdentifier_+  | ExpectedApplication_+  | NoActionForInteractionPoint_+  | NoSuchInteractionPoint_+  | UnexpectedWhere_+  deriving (Show, Generic, Enum, Bounded)++data NegativeUnification_+  = UnifyConflict_+  | UnifyCycle_+  deriving (Show, Generic, Enum, Bounded)++data NotAHaskellType_+  = BadDontCare_+  | BadLambda_+  | BadMeta_+  | NoPragmaFor_+  | NotCompiled_+  | WrongPragmaFor_+  deriving (Show, Generic, Enum, Bounded)++data SplitError_+  = ErasedDatatype_ ErasedDatatypeReason+  | GenericSplitError_+  -- Specific errors+  | BlockedType_+  | CannotCreateMissingClause_+  | CoinductiveDatatype_+  | CosplitCatchall_+  | CosplitNoRecordType_+  | CosplitNoTarget_+  | NotADatatype_+  | UnificationStuck_+  deriving (Show, Generic)+  deriving (Enum, Bounded) via (FiniteEnumeration SplitError_)++data CannotQuote_+  = CannotQuoteAmbiguous_+  | CannotQuoteExpression_+  | CannotQuoteHidden_+  | CannotQuoteNothing_+  | CannotQuotePattern_+  deriving (Show, Generic, Enum, Bounded)++data ExecError_+  = ExeNotTrusted_+  | ExeNotFound_+  | ExeNotExecutable_+  deriving (Show, Generic, Enum, Bounded)++data UnquoteError_+  = BlockedOnMeta_+  | CannotDeclareHiddenFunction_+  | CommitAfterDef_+  | ConInsteadOfDef_+  | DefineDataNotData_+  | DefInsteadOfCon_+  | MissingDeclaration_+  | MissingDefinition_+  | NakedUnquote_+  | NonCanonical_+  | PatLamWithoutClauses_+  | StaleMeta_+  | TooManyParameters_+  | UnboundName_+  deriving (Show, Generic, Enum, Bounded)++-- * Printing error names+------------------------------------------------------------------------++defaultErrorNameString :: Show a => a -> String+defaultErrorNameString = initWithDefault __IMPOSSIBLE__ . show++erasedDatatypeReasonString :: ErasedDatatypeReason -> String+erasedDatatypeReasonString = show++errorNameString :: ErrorName -> String+errorNameString = \case+  ExecError_              err -> "Exec." ++ execErrorNameString err+  GHCBackendError_        err -> "GHCBackend." ++ ghcBackendErrorNameString err+  ImpossibleConstructor_  err -> "ImpossibleConstructor." ++ negativeUnificationErrorNameString err+  InteractionError_       err -> "Interaction." ++ interactionErrorNameString err+  JSBackendError_         err -> "JSBackend." ++ jsBackendErrorNameString err+  NicifierError_          err -> "Syntax." ++ declarationExceptionNameString err+  SplitError_             err -> "SplitError." ++ splitErrorNameString err+  UnquoteError_           err -> "Unquote." ++ unquoteErrorNameString err+  CannotQuote_             err -> "CannotQuote." ++ cannotQuoteNameString err+  CannotQuoteTerm_         err -> "CannotQuoteTerm." ++ cannotQuoteTermNameString err+  InvalidPun_              err -> "InvalidPun." ++ constructorOrPatternSynonymNameString err+  MissingTypeSignature_    err -> "MissingTypeSignature." ++ dataRecOrFunString err+  NotAllowedInDotPatterns_ err -> "NotAllowedInDotPatterns." ++ notAllowedInDotPatternsString err+  NotAValidLetBinding_    merr -> applyWhenJust merr (\ err hd -> hd ++ "." ++ notAValidLetBindingString err) "NotAValidLetBinding"+  NotAValidLetExpression_  err -> "NotAValidLetExpression." ++ notAValidLetExpressionString err+  PatternSynonymArgumentShadows_ err -> "PatternSynonymArgumentShadows." ++ constructorOrPatternSynonymNameString err+  err -> defaultErrorNameString err++constructorOrPatternSynonymNameString :: ConstructorOrPatternSynonym -> String+constructorOrPatternSynonymNameString = \case+  IsConstructor    -> "Constructor"+  IsPatternSynonym -> "PatternSynonym"++dataRecOrFunString :: DataRecOrFun_ -> String+dataRecOrFunString = \case+  DataName_ -> "Data"+  RecName_  -> "Record"+  FunName_  -> "Function"++declarationExceptionNameString :: DeclarationException_ -> String+declarationExceptionNameString = \case+  AmbiguousConstructorN_ -> "AmbiguousConstructor"+  err -> defaultErrorNameString err++ghcBackendErrorNameString :: GHCBackendError_ -> String+ghcBackendErrorNameString = \case+  NotAHaskellType_ err -> "NotAHaskellType." ++ notAHaskellTypeErrorNameString err+  err -> defaultErrorNameString err++jsBackendErrorNameString :: JSBackendError_ -> String+jsBackendErrorNameString = defaultErrorNameString++interactionErrorNameString :: InteractionError_ -> String+interactionErrorNameString = defaultErrorNameString++negativeUnificationErrorNameString :: NegativeUnification_ -> String+negativeUnificationErrorNameString = defaultErrorNameString++notAHaskellTypeErrorNameString :: NotAHaskellType_ -> String+notAHaskellTypeErrorNameString = defaultErrorNameString++notAValidLetBindingString :: NotAValidLetBinding -> String+notAValidLetBindingString = show++notAValidLetExpressionString :: NotAValidLetExpression -> String+notAValidLetExpressionString = show++notAllowedInDotPatternsString :: NotAllowedInDotPatterns -> String+notAllowedInDotPatternsString = show++splitErrorNameString :: SplitError_ -> String+splitErrorNameString = \case+  ErasedDatatype_ err -> "ErasedDatatype." ++ erasedDatatypeReasonString err+  err -> defaultErrorNameString err++cannotQuoteNameString :: CannotQuote_ -> String+cannotQuoteNameString = \case+  CannotQuoteAmbiguous_  -> "Ambiguous"+  CannotQuoteExpression_ -> "Expression"+  CannotQuoteHidden_     -> "Hidden"+  CannotQuoteNothing_    -> "Nothing"+  CannotQuotePattern_    -> "Pattern"++cannotQuoteTermNameString :: CannotQuoteTerm -> String+cannotQuoteTermNameString = \case+  CannotQuoteTermHidden      -> "Hidden"+  CannotQuoteTermNothing     -> "Nothing"++execErrorNameString :: ExecError_ -> String+execErrorNameString = defaultErrorNameString++unquoteErrorNameString :: UnquoteError_ -> String+unquoteErrorNameString = defaultErrorNameString++-- | Print list of errors.++helpErrors :: String+helpErrors = unlines $ concat+  [ [ "Agda's errors:"+    , ""+    ]+  , sort $ map errorNameString [minBound..maxBound]+  ]++-- * Print error messages+------------------------------------------------------------------------++verbalizeNotAValidLetBinding :: NotAValidLetBinding -> String+verbalizeNotAValidLetBinding = \case+  MissingRHS             -> "Missing right hand side in let binding"+  NotAValidLetPattern    -> "Not a valid let pattern"+  WhereClausesNotAllowed -> "`where` clauses not allowed in let bindings"+  -- These cannot be triggered:+  -- CopatternsNotAllowed   -> "Copatterns not allowed in let bindings"+  -- EllipsisNotAllowed     -> "`...` not allowed in let bindings"+  -- WithPatternsNotAllowed -> "`with` patterns not allowed in let bindings"++verbalizeNotAValidLetExpression :: NotAValidLetExpression -> String+verbalizeNotAValidLetExpression = \case+  MissingBody -> "Missing body in let-expression"++-- Instances+------------------------------------------------------------------------++deriving via (FiniteEnumeration (Maybe a))+  instance (Bounded a, Enum a) => Enum (Maybe a)+deriving via (FiniteEnumeration (Maybe a))+  instance (Bounded a, Enum a) => Bounded (Maybe a)++instance NFData CannotQuoteTerm+instance NFData ErasedDatatypeReason+instance NFData NotAllowedInDotPatterns+instance NFData NotAValidLetBinding+instance NFData NotAValidLetExpression
src/full/Agda/Interaction/Options/HasOptions.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Interaction.Options.HasOptions   ( HasOptions (pragmaOptions, commandLineOptions)   ) where@@ -10,7 +12,7 @@ import Control.Monad.Trans.Maybe (MaybeT) import Control.Monad.Writer (WriterT) -import Agda.Interaction.Options.Base (PragmaOptions, CommandLineOptions)+import Agda.Interaction.Options.Types (PragmaOptions, CommandLineOptions) import Agda.Utils.Update (ChangeT) import Agda.Utils.ListT (ListT)
src/full/Agda/Interaction/Options/Help.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Interaction.Options.Help        (@@ -11,8 +12,11 @@  import GHC.Generics (Generic) +import Agda.Interaction.Options.Errors import Agda.Interaction.Options.Warnings +import qualified Agda.Setup.EmacsMode as EmacsMode+ -- | Interface to the @help@ function data Help   = GeneralHelp@@ -29,23 +33,31 @@  data HelpTopic   = Warning+  | Error+  | EmacsMode   deriving (Eq, Show, Generic)  instance NFData HelpTopic  allHelpTopics :: [(String, HelpTopic)]-allHelpTopics = [("warning", Warning)]+allHelpTopics =+  [ ("warning"   , Warning  )+  , ("error"     , Error    )+  , ("emacs-mode", EmacsMode)+  ]  -- | Usage information generation  helpTopicUsage :: HelpTopic -> String-helpTopicUsage tp = case tp of-  Warning -> usageWarning+helpTopicUsage = \case+  Warning   -> usageWarning+  Error     -> helpErrors+  EmacsMode -> EmacsMode.help  -- | Conversion functions to strings  string2HelpTopic :: String -> Maybe HelpTopic-string2HelpTopic str = lookup str allHelpTopics+string2HelpTopic = flip lookup allHelpTopics  -- UNUSED Liang-Ting Chen 2019-07-15 --helpTopic2String :: HelpTopic -> String
src/full/Agda/Interaction/Options/Lenses.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Lenses for 'CommandLineOptions' and 'PragmaOptions'. -- --   Add as needed.@@ -6,46 +8,16 @@  module Agda.Interaction.Options.Lenses where -import Control.Monad.IO.Class   ( MonadIO(..) )--import Data.Set (Set)-import qualified Data.Set as Set--import System.FilePath ((</>))- import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.State-import Agda.Interaction.Library (getPrimitiveLibDir) import Agda.Interaction.Options -import Agda.Utils.Lens-import Agda.Utils.FileName+import Agda.Utils.WithDefault (pattern Value)  --------------------------------------------------------------------------- -- * Pragma options --------------------------------------------------------------------------- -class LensPragmaOptions a where-  getPragmaOptions  :: a -> PragmaOptions-  setPragmaOptions  :: PragmaOptions -> a -> a-  mapPragmaOptions  :: (PragmaOptions -> PragmaOptions) -> a -> a-  lensPragmaOptions :: Lens' PragmaOptions a-  -- lensPragmaOptions :: forall f. Functor f => (PragmaOptions -> f PragmaOptions) -> a -> f a--  -- default implementations-  setPragmaOptions     = mapPragmaOptions . const-  mapPragmaOptions f a = setPragmaOptions (f $ getPragmaOptions a) a--instance LensPragmaOptions CommandLineOptions where-  getPragmaOptions = optPragmaOptions-  setPragmaOptions opts st = st { optPragmaOptions = opts }-  lensPragmaOptions f st = f (optPragmaOptions st) <&> \ opts -> st { optPragmaOptions = opts }--instance LensPragmaOptions TCState where-  getPragmaOptions = (^.stPragmaOptions)-  setPragmaOptions = set stPragmaOptions-  lensPragmaOptions = stPragmaOptions- modifyPragmaOptions :: MonadTCState m => (PragmaOptions -> PragmaOptions) -> m () modifyPragmaOptions = modifyTC . mapPragmaOptions @@ -63,8 +35,8 @@   mapVerbosity f a = setVerbosity (f $ getVerbosity a) a  instance LensVerbosity PragmaOptions where-  getVerbosity = optVerbose-  setVerbosity is opts = opts { optVerbose = is }+  getVerbosity = _optVerbose+  setVerbosity is opts = opts { _optVerbose = is }  instance LensVerbosity TCState where   getVerbosity = getVerbosity . getPragmaOptions@@ -117,7 +89,7 @@  instance LensSafeMode PragmaOptions where   getSafeMode = optSafe-  setSafeMode is opts = opts { optSafe = is } -- setSafeOption+  setSafeMode is opts = opts { _optSafe = Value is } -- setSafeOption  instance LensSafeMode CommandLineOptions where   getSafeMode = getSafeMode . getPragmaOptions@@ -136,80 +108,6 @@  putSafeMode :: MonadTCState m => SafeMode -> m () putSafeMode = modifyTC . setSafeMode---- | These builtins may use postulates, and are still considered --safe--builtinModulesWithSafePostulates :: Set FilePath-builtinModulesWithSafePostulates =-  primitiveModules `Set.union` (Set.fromList-  [ "Agda" </> "Builtin" </> "Bool.agda"-  , "Agda" </> "Builtin" </> "Char.agda"-  , "Agda" </> "Builtin" </> "Char" </> "Properties.agda"-  , "Agda" </> "Builtin" </> "Coinduction.agda"-  , "Agda" </> "Builtin" </> "Cubical" </> "Glue.agda"-  , "Agda" </> "Builtin" </> "Cubical" </> "HCompU.agda"-  , "Agda" </> "Builtin" </> "Cubical" </> "Id.agda"-  , "Agda" </> "Builtin" </> "Cubical" </> "Path.agda"-  , "Agda" </> "Builtin" </> "Cubical" </> "Sub.agda"-  , "Agda" </> "Builtin" </> "Equality" </> "Erase.agda"-  , "Agda" </> "Builtin" </> "Equality.agda"-  , "Agda" </> "Builtin" </> "Float.agda"-  , "Agda" </> "Builtin" </> "Float" </> "Properties.agda"-  , "Agda" </> "Builtin" </> "FromNat.agda"-  , "Agda" </> "Builtin" </> "FromNeg.agda"-  , "Agda" </> "Builtin" </> "FromString.agda"-  , "Agda" </> "Builtin" </> "Int.agda"-  , "Agda" </> "Builtin" </> "IO.agda"-  , "Agda" </> "Builtin" </> "List.agda"-  , "Agda" </> "Builtin" </> "Maybe.agda"-  , "Agda" </> "Builtin" </> "Nat.agda"-  , "Agda" </> "Builtin" </> "Reflection.agda"-  , "Agda" </> "Builtin" </> "Reflection" </> "Properties.agda"-  , "Agda" </> "Builtin" </> "Reflection" </> "External.agda"-  , "Agda" </> "Builtin" </> "Sigma.agda"-  , "Agda" </> "Builtin" </> "Size.agda"-  , "Agda" </> "Builtin" </> "Strict.agda"-  , "Agda" </> "Builtin" </> "String.agda"-  , "Agda" </> "Builtin" </> "String" </> "Properties.agda"-  , "Agda" </> "Builtin" </> "Unit.agda"-  , "Agda" </> "Builtin" </> "Word.agda"-  , "Agda" </> "Builtin" </> "Word" </> "Properties.agda"-  ])---- | These builtins may not use postulates under --safe. They are not---   automatically unsafe, but will be if they use an unsafe feature.--builtinModulesWithUnsafePostulates :: Set FilePath-builtinModulesWithUnsafePostulates = Set.fromList-  [ "Agda" </> "Builtin" </> "TrustMe.agda"-  , "Agda" </> "Builtin" </> "Equality" </> "Rewrite.agda"-  ]--primitiveModules :: Set FilePath-primitiveModules = Set.fromList-  [ "Agda" </> "Primitive.agda"-  , "Agda" </> "Primitive" </> "Cubical.agda"-  ]--builtinModules :: Set FilePath-builtinModules = builtinModulesWithSafePostulates `Set.union`-                 builtinModulesWithUnsafePostulates--isPrimitiveModule :: MonadIO m => FilePath -> m Bool-isPrimitiveModule file = do-  libdirPrim <- liftIO getPrimitiveLibDir-  return (file `Set.member` Set.map (libdirPrim </>) primitiveModules)--isBuiltinModule :: MonadIO m => FilePath -> m Bool-isBuiltinModule file = do-  libdirPrim <- liftIO getPrimitiveLibDir-  return (file `Set.member` Set.map (libdirPrim </>) builtinModules)--isBuiltinModuleWithSafePostulates :: MonadIO m => FilePath -> m Bool-isBuiltinModuleWithSafePostulates file = do-  libdirPrim <- liftIO getPrimitiveLibDir-  let safeBuiltins   = Set.map (libdirPrim </>) builtinModulesWithSafePostulates-  return (file `Set.member` safeBuiltins)  --------------------------------------------------------------------------- -- ** Include directories
+ src/full/Agda/Interaction/Options/Types.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE DataKinds #-}++{-# OPTIONS_GHC -Wunused-imports #-}++-- | A module defining the types exported by "Agda.Interaction.Options" for use in the rest of the codebase.+--+-- This is a boot module to avoid cyclic module dependencies.+-- Only put types and trivial instances here.++module Agda.Interaction.Options.Types where++import           Control.DeepSeq                   ( NFData )+import           Data.Functor                      ( (<&>) )+import           Data.Map                          ( Map )+import           Data.Set                          ( Set )+import           GHC.Generics                      ( Generic )++import           Agda.Syntax.Common                ( Cubical )+import           Agda.Syntax.Concrete.Glyph        ( UnicodeOrAscii )+import           Agda.Interaction.Library          ( ExeName, LibName )+import           Agda.Interaction.Options.Help     ( Help )+import           Agda.Interaction.Options.Warnings ( WarningMode )+import           Agda.Termination.CutOff           ( CutOff )++import           Agda.Utils.FileName               ( AbsolutePath )+import           Agda.Utils.Lens                   ( Lens', (^.), over )+import           Agda.Utils.List1                  ( String1 )+import qualified Agda.Utils.Maybe.Strict           as Strict+import           Agda.Utils.ProfileOptions         ( ProfileOptions )+import           Agda.Utils.Trie                   ( Trie )+import           Agda.Utils.WithDefault            ( WithDefault, WithDefault' )++---------------------------------------------------------------------------+-- * Option records++-- Don't forget to update+--   doc/user-manual/tools/command-line-options.rst+-- if you make changes to the command-line options!++data CommandLineOptions = Options+  { optProgramName           :: String+  , optInputFile             :: Maybe FilePath+  , optIncludePaths          :: [FilePath]+  , optAbsoluteIncludePaths  :: [AbsolutePath]+      -- ^ The list should not contain duplicates.+  , optLibraries             :: [LibName]+  , optOverrideLibrariesFile :: Maybe FilePath+      -- ^ Use this (if 'Just') instead of @~\/.agda\/libraries@.+  , optDefaultLibs           :: Bool+       -- ^ Use @~\/.agda\/defaults@.+  , optUseLibs               :: Bool+       -- ^ look for @.agda-lib@ files.+  , optTraceImports          :: Integer+       -- ^ Configure notifications about imported modules.+  , optTrustedExecutables    :: Map ExeName FilePath+       -- ^ Map names of trusted executables to absolute paths.++  -- Setup and printing+  , optPrintAgdaDataDir      :: Bool+  , optPrintAgdaAppDir       :: Bool+  , optPrintVersion          :: Maybe PrintAgdaVersion+  , optPrintHelp             :: Maybe Help+  , optBuildLibrary          :: Bool+      -- ^ @--build-library@: Build all modules in the current library.+  , optSetup                 :: Bool+      -- ^ Force Agda to self-setup at startup.+  , optEmacsMode             :: Set EmacsModeCommand+      -- ^ Emacs mode administration+      --   (formerly done by the @agda-mode@ executable).+      --   Accepted subcommands: @locate@, @setup@, @compile@.+      --   Can be given several times,+      --   subcommands are accumulated in the set.++  , optInteractive           :: Bool+      -- ^ Agda REPL (@-I@).+  , optGHCiInteraction       :: Bool+      -- ^ @--interaction@ mode.+  , optJSONInteraction       :: Bool+      -- ^ @--interaction-json@ mode.+  , optExitOnError           :: !Bool+      -- ^ Exit if an interactive command fails.+  , optCompileDir            :: Maybe FilePath+      -- ^ In the absence of a path the project root is used.+  , optGenerateVimFile       :: Bool+  , optIgnoreInterfaces      :: Bool+  , optIgnoreAllInterfaces   :: Bool+  , optPragmaOptions         :: PragmaOptions+  , optOnlyScopeChecking     :: Bool+      -- ^ Should the top-level module only be scope-checked, and not type-checked?+  , optTransliterate         :: Bool+      -- ^ Should code points that are not supported by the locale be transliterated?+  , optDiagnosticsColour     :: DiagnosticsColours+      -- ^ Configure colour output.+  }+  deriving (Show, Generic)++-- | Options which can be set in a pragma.++data PragmaOptions = PragmaOptions+  { _optShowImplicit              :: WithDefault 'False+  , _optShowGeneralized           :: WithDefault 'True+      -- ^ Show generalized parameters in Pi types+  , _optShowIrrelevant            :: WithDefault 'False+  , _optUseUnicode                :: WithDefault' UnicodeOrAscii 'True -- Would like to write UnicodeOk instead of True here+  , _optVerbose                   :: !Verbosity+  , _optProfiling                 :: ProfileOptions+  , _optProp                      :: WithDefault 'False+  , _optLevelUniverse             :: WithDefault 'False+  , _optTwoLevel                  :: WithDefault 'False+  , _optAllowUnsolved             :: WithDefault 'False+  , _optAllowIncompleteMatch      :: WithDefault 'False+  , _optPositivityCheck           :: WithDefault 'True+  , _optTerminationCheck          :: WithDefault 'True+  , _optTerminationDepth          :: CutOff+      -- ^ Cut off structural order comparison at some depth in termination checker?+  , _optUniverseCheck             :: WithDefault 'True+  , _optOmegaInOmega              :: WithDefault 'False+  , _optCumulativity              :: WithDefault 'False+  , _optSizedTypes                :: WithDefault 'False+  , _optGuardedness               :: WithDefault 'False+  , _optInjectiveTypeConstructors :: WithDefault 'False+  , _optUniversePolymorphism      :: WithDefault 'True+  , _optIrrelevantProjections     :: WithDefault 'False+      -- off by default in > 2.5.4, see issue #2170+  , _optExperimentalIrrelevance   :: WithDefault 'False+      -- ^ irrelevant levels, irrelevant data matching+  , _optWithoutK                  :: WithDefault 'False+  , _optCubicalCompatible         :: WithDefault 'False+  , _optCopatterns                :: WithDefault 'True+      -- ^ Allow definitions by copattern matching?+  , _optPatternMatching           :: WithDefault 'True+      -- ^ Is pattern matching allowed in the current file?+  , _optExactSplit                :: WithDefault 'False+  , _optHiddenArgumentPuns        :: WithDefault 'False+      -- ^ Should patterns of the form @{x}@ or @⦃ x ⦄@ be interpreted as puns?+  , _optEta                       :: WithDefault 'True+  , _optForcing                   :: WithDefault 'True+      -- ^ Perform the forcing analysis on data constructors?+  , _optProjectionLike            :: WithDefault 'True+      -- ^ Perform the projection-likeness analysis on functions?+  , _optErasure                   :: WithDefault 'False+  , _optErasedMatches             :: WithDefault 'True+      -- ^ Allow matching in erased positions for single-constructor,+      -- non-indexed data/record types. (This kind of matching is always+      -- allowed for record types with η-equality.)+  , _optEraseRecordParameters     :: WithDefault 'False+      -- ^ Mark parameters of record modules as erased?+  , _optRewriting                 :: WithDefault 'False+      -- ^ Can rewrite rules be added and used?+  , _optCubical                   :: Maybe Cubical+  , _optGuarded                   :: WithDefault 'False+  , _optFirstOrder                :: WithDefault 'False+      -- ^ Should we speculatively unify function applications as if they were injective? Implies+      --   optRequireUniqueMetaSolutions.+  , _optRequireUniqueMetaSolutions :: WithDefault 'True+      -- ^ Forbid non-unique meta solutions allowed. For instance from INJECTIVE_FOR_INFERENCE pragmas.+  , _optPostfixProjections        :: WithDefault 'True+      -- ^ Should system generated projections 'ProjSystem' be printed+      --   postfix (True) or prefix (False).+  , _optKeepPatternVariables      :: WithDefault 'True+      -- ^ Should case splitting replace variables with dot patterns+      --   (False) or keep them as variables (True).+  , _optInferAbsurdClauses        :: WithDefault 'True+      -- ^ Should case splitting and coverage checking try to discharge absurd clauses?+      --   Default: 'True', but 'False' might make coverage checking considerably faster in some cases.+  , _optInstanceSearchDepth       :: Int+  , _optBacktrackingInstances     :: WithDefault 'False+  , _optQualifiedInstances        :: WithDefault 'True+      -- ^ Should instance search consider instances with qualified names?+  , _optInversionMaxDepth         :: Int+  , _optSafe                      :: WithDefault 'False+  , _optDoubleCheck               :: WithDefault 'False+  , _optSyntacticEquality         :: !(Strict.Maybe Int)+      -- ^ Should the conversion checker use the syntactic equality shortcut?+      -- 'Nothing' means that it should.+      -- @'Just' n@, for a non-negative number @n@, means that syntactic equality+      -- checking gets @n@ units of fuel.+      -- If the fuel becomes zero, then syntactic equality checking is turned off.+      -- The fuel counter is decreased in the failure continuation of+      -- 'Agda.TypeChecking.SyntacticEquality.checkSyntacticEquality'.+  , _optWarningMode               :: WarningMode+  , _optCompileMain               :: WithDefault 'True+      -- ^ Treat the module given at the command line or via interaction as main module in compilation?+  , _optCaching                   :: WithDefault 'True+  , _optCountClusters             :: WithDefault 'False+      -- ^ Count extended grapheme clusters rather than code points+      --   when generating LaTeX.+  , _optAutoInline                :: WithDefault 'False+      -- ^ Automatic compile-time inlining for simple definitions+      --   (unless marked @NOINLINE@).+  , _optPrintPatternSynonyms      :: WithDefault 'True+  , _optFastReduce                :: WithDefault 'True+      -- ^ Use the Agda abstract machine ('fastReduce')?+  , _optCallByName                :: WithDefault 'False+      -- ^ Use call-by-name instead of call-by-need.+  , _optConfluenceCheck           :: Maybe ConfluenceCheck+      -- ^ Check confluence of rewrite rules?+  , _optCohesion                  :: WithDefault 'False+      -- ^ Are the cohesion modalities available?+  , _optFlatSplit                 :: WithDefault 'False+      -- ^ Can we split on a @(\@flat x : A)@ argument?+  , _optPolarity                  :: WithDefault 'False+      -- ^ Can we use modal polarities (@++, @+, etc.)?+  , _optImportSorts               :: WithDefault 'True+      -- ^ Should every top-level module start with an implicit statement+      --   @open import Agda.Primitive using (Set; Prop)@?+  , _optLoadPrimitives            :: WithDefault 'True+      -- ^ Should we load the primitive modules at all?+      --   This is a stronger form of 'optImportSorts'.+  , _optAllowExec                 :: WithDefault 'False+      -- ^ Allow running external @executables@ from meta programs.+  , _optSaveMetas                 :: WithDefault 'False+      -- ^ Save meta-variables to interface files.+  , _optShowIdentitySubstitutions :: WithDefault 'False+      -- ^ Show identity substitutions when pretty-printing terms+      --   (i.e. always show all arguments of a metavariable).+  , _optKeepCoveringClauses       :: WithDefault 'False+      -- ^ Do not discard clauses constructed by the coverage checker+      --   (needed for some external backends).+  , _optLargeIndices              :: WithDefault 'False+      -- ^ Allow large indices, and large forced arguments in+      -- constructors.+  , _optForcedArgumentRecursion   :: WithDefault 'True+      -- ^ Allow recursion on forced constructor arguments.+  , _optExperimentalLazyInstances :: WithDefault 'False+      -- ^ Defer instance search based on discrimination tree results+  }+  deriving (Show, Eq, Generic)++---------------------------------------------------------------------------+-- * Auxiliary structures (by default in alphabetic order)++data ConfluenceCheck+  = LocalConfluenceCheck+  | GlobalConfluenceCheck+  deriving (Show, Eq, Generic)++data DiagnosticsColours+  = AlwaysColour+  | NeverColour+  | AutoColour+  deriving (Show, Generic)++-- | If several @--emacs-mode@ commands are given,+--   they are executed in the order as given in this datatype.+data EmacsModeCommand+  = EmacsModeCompile+      -- ^ Compile the @.el@ files to @.elc@.+  | EmacsModeSetup+      -- ^ Add the initialization lines to @.emacs@.+  | EmacsModeLocate+      -- ^ Print the installation location of @agda2.el@.+  deriving (Eq, Ord, Show, Generic)++-- | Infective or coinfective?+data InfectiveCoinfective+  = Infective+  | Coinfective+  deriving (Eq, Show, Generic)++-- | Options @--version@ and @--numeric-version@ (last wins).+data PrintAgdaVersion+  = PrintAgdaVersion+      -- ^ Print Agda version information.+  | PrintAgdaNumericVersion+      -- ^ Print Agda version number.+  deriving (Show, Generic)++type VerboseKey     = String+type VerboseKeyItem = String1+type VerboseLevel   = Int++-- | 'Strict.Nothing' is used if no verbosity options have been given,+-- thus making it possible to handle the default case relatively+-- quickly. Note that 'Strict.Nothing' corresponds to a trie with+-- verbosity level 1 for the empty path.+type Verbosity = Strict.Maybe (Trie VerboseKeyItem VerboseLevel)++---------------------------------------------------------------------------+-- * Lenses++class LensPragmaOptions a where+  getPragmaOptions  :: a -> PragmaOptions+  setPragmaOptions  :: PragmaOptions -> a -> a+  mapPragmaOptions  :: (PragmaOptions -> PragmaOptions) -> a -> a+  lensPragmaOptions :: Lens' a PragmaOptions++  {-# MINIMAL lensPragmaOptions #-}+  getPragmaOptions = (^. lensPragmaOptions)+  setPragmaOptions = mapPragmaOptions . const+  mapPragmaOptions = over lensPragmaOptions++instance LensPragmaOptions CommandLineOptions where+  lensPragmaOptions f st = f (optPragmaOptions st) <&> \ opts -> st { optPragmaOptions = opts }++---------------------------------------------------------------------------+-- NFData instances++instance NFData CommandLineOptions+instance NFData PragmaOptions++instance NFData ConfluenceCheck+instance NFData DiagnosticsColours+instance NFData EmacsModeCommand+instance NFData InfectiveCoinfective+instance NFData PrintAgdaVersion
src/full/Agda/Interaction/Options/Warnings.hs view
@@ -4,6 +4,7 @@          WarningMode (..)        , warningSet        , warn2Error+       , lensSingleWarning        , defaultWarningSet        , allWarnings        , usualWarnings@@ -11,6 +12,7 @@        , unsolvedWarnings        , incompleteMatchWarnings        , errorWarnings+       , exactSplitWarnings        , defaultWarningMode        , WarningModeError(..)        , prettyWarningModeError@@ -26,14 +28,20 @@ import Control.Arrow ( (&&&) ) import Control.DeepSeq import Control.Monad ( guard, when )+import Control.Monad.Except ( throwError ) -import Text.Read ( readMaybe )-import Data.Set (Set)+import qualified Data.HashMap.Strict as HMap+import Data.List ( stripPrefix, intercalate, partition, sort )+import Data.Set  ( Set ) import qualified Data.Set as Set-import Data.List ( stripPrefix, intercalate )+import Data.Text ( Text )+import qualified Data.Text as Text  import GHC.Generics (Generic) +import Agda.Utils.Either ( maybeToEither )+import Agda.Utils.Function+import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.Maybe@@ -50,12 +58,17 @@  instance NFData WarningMode -warningSet :: Lens' (Set WarningName) WarningMode+-- Lenses++warningSet :: Lens' WarningMode (Set WarningName) warningSet f o = (\ ws -> o { _warningSet = ws }) <$> f (_warningSet o) -warn2Error :: Lens' Bool WarningMode+warn2Error :: Lens' WarningMode Bool warn2Error f o = (\ ws -> o { _warn2Error = ws }) <$> f (_warn2Error o) +lensSingleWarning :: WarningName -> Lens' WarningMode Bool+lensSingleWarning w = warningSet . contains w+ -- | The @defaultWarningMode@ is a curated set of warnings covering non-fatal -- errors and disabling style-related ones @@ -67,14 +80,23 @@   ws = fst $ fromMaybe __IMPOSSIBLE__ $ lookup defaultWarningSet warningSets  -- | Some warnings are errors and cannot be turned off.-data WarningModeError = Unknown String | NoNoError String+data WarningModeError+  = Unknown Text+      -- ^ Unknown warning.+  | NoNoError Text+      -- ^ Warning that cannot be disabled.+  deriving (Show, Generic) -prettyWarningModeError :: WarningModeError -> String+instance NFData WarningModeError++prettyWarningModeError :: WarningModeError -> Text prettyWarningModeError = \case-  Unknown str -> concat [ "Unknown warning flag: ", str, "." ]-  NoNoError str -> concat [ "You may only turn off benign warnings. The warning "-                          , str-                          ," is a non-fatal error and thus cannot be ignored." ]+  Unknown   w -> Text.concat [ "Unknown warning flag: ", w, "." ]+  NoNoError w -> Text.concat+    [ "You may only turn off benign warnings. The warning "+    , w+    , " is a non-fatal error and thus cannot be ignored."+    ]  -- | From user-given directives we compute WarningMode updates type WarningModeUpdate = WarningMode -> WarningMode@@ -91,13 +113,18 @@             -> pure $ set warningSet ws   _ -> case stripPrefix "no" str of     Nothing   -> do-      wname <- maybe (Left (Unknown str)) Right (string2WarningName str)+      wname <- stringToWarningName str       pure (over warningSet $ Set.insert wname)     Just str' -> do-      wname <- maybe (Left (Unknown str')) Right (string2WarningName str')-      when (wname `elem` errorWarnings) (Left (NoNoError str'))+      wname <- stringToWarningName str'+      when (wname `elem` errorWarnings) $+        throwError $ NoNoError $ Text.pack str'       pure (over warningSet $ Set.delete wname)+  where+    stringToWarningName :: String -> Either WarningModeError WarningName+    stringToWarningName str = maybeToEither (Unknown $ Text.pack str) $ string2WarningName str + -- | Common sets of warnings  warningSets :: [(String, (Set WarningName, String))]@@ -122,11 +149,12 @@ errorWarnings :: Set WarningName errorWarnings = Set.fromList   [ CoverageIssue_-  , GenericNonFatalError_+  , InvalidCharacterLiteral_   , MissingDefinitions_-  , MissingDeclarations_+  , MissingDataDeclaration_   , NotAllowedInMutual_   , NotStrictlyPositive_+  , ConstructorDoesNotFitInData_   , OverlappingTokensWarning_   , PragmaCompiled_   , SafeFlagPostulate_@@ -141,34 +169,59 @@   , SafeFlagInjective_   , SafeFlagNoCoverageCheck_   , TerminationIssue_+  , TooManyArgumentsToSort_   , UnsolvedMetaVariables_   , UnsolvedInteractionMetas_   , UnsolvedConstraints_   , InfectiveImport_   , CoInfectiveImport_+  -- Andreas, 2024-02-15: the following warning used to be a GenericWarning (not an error warning).+  -- Maybe revisit.+  -- , ConfluenceCheckingIncompleteBecauseOfMeta_   , RewriteNonConfluent_   , RewriteMaybeNonConfluent_   , RewriteAmbiguousRules_   , RewriteMissingRule_+  , TopLevelPolarity_++  -- Recoverable scope-checking errors+  , HiddenNotInArgumentPosition_+  , InstanceNotInArgumentPosition_+  , MacroInLetBindings_+  , AbstractInLetBindings_   ]  allWarnings :: Set WarningName allWarnings = Set.fromList [minBound..maxBound]  usualWarnings :: Set WarningName-usualWarnings = allWarnings Set.\\ Set.fromList-              [ UnknownFixityInMixfixDecl_-              , CoverageNoExactSplit_-              , ShadowingInTelescope_-              ]+usualWarnings =+  allWarnings Set.\\ exactSplitWarnings Set.\\ Set.fromList+    [ UnknownFixityInMixfixDecl_+    , ShadowingInTelescope_+    ] +-- | Warnings enabled by @--exact-split@.+--+exactSplitWarnings :: Set WarningName+exactSplitWarnings = Set.fromList+  [ CoverageNoExactSplit_+  , InlineNoExactSplit_+  ]+ -- | The @WarningName@ data enumeration is meant to have a one-to-one correspondance -- to existing warnings in the codebase.  data WarningName-  =+  -- Option Warnings+  = OptionRenamed_+  | WarningProblem_+      -- ^ Some warning could not be set or unset.   -- Parser Warnings-    OverlappingTokensWarning_+  | OverlappingTokensWarning_+  | MisplacedAttributes_+  | UnknownPolarity_+  | UnknownAttribute_   | UnsupportedAttribute_   | MultipleAttributes_   -- Library Warnings@@ -186,19 +239,20 @@   | EmptyPrivate_   | EmptyRewritePragma_   | EmptyWhere_+  | EmptyPolarityPragma_+  | HiddenGeneralize_   | InvalidCatchallPragma_-  | InvalidConstructor_   | InvalidConstructorBlock_   | InvalidCoverageCheckPragma_   | InvalidNoPositivityCheckPragma_   | InvalidNoUniverseCheckPragma_-  | InvalidRecordDirective_+  | DuplicateRecordDirective_   | InvalidTerminationCheckPragma_-  | MissingDeclarations_+  | MissingDataDeclaration_   | MissingDefinitions_   | NotAllowedInMutual_-  | OpenPublicAbstract_-  | OpenPublicPrivate_+  | OpenImportAbstract_+  | OpenImportPrivate_   | PolarityPragmasButNotPostulates_   | PragmaCompiled_   | PragmaNoTerminationCheck_@@ -208,35 +262,74 @@   | UnknownNamesInPolarityPragmas_   | UselessAbstract_   | UselessInstance_+  | UselessMacro_   | UselessPrivate_   -- Scope and Type Checking Warnings-  | AbsurdPatternRequiresNoRHS_+  | AbsurdPatternRequiresAbsentRHS_   | AsPatternShadowsConstructorOrPatternSynonym_+  | PatternShadowsConstructor_   | CantGeneralizeOverSorts_   | ClashesViaRenaming_                -- issue #4154   | CoverageIssue_   | CoverageNoExactSplit_+  | InlineNoExactSplit_   | DeprecationWarning_   | DuplicateUsing_+  | FixingCohesion_+  | FixingPolarity_+  | FixingRelevance_+  -- TODO: linearity+  -- -- | FixingQuantity_   | FixityInRenamingModule_-  | GenericNonFatalError_-  | GenericUseless_-  | GenericWarning_+  | InvalidCharacterLiteral_+  | UselessPragma_   | IllformedAsClause_   | InstanceArgWithExplicitArg_   | InstanceWithExplicitArg_   | InstanceNoOutputTypeName_+  | InteractionMetaBoundaries_   | InversionDepthReached_   | ModuleDoesntExport_-  | NoGuardednessFlag_   | NotInScope_   | NotStrictlyPositive_+  | ConstructorDoesNotFitInData_+  | CoinductiveEtaRecord_+  | UnsupportedIndexedMatch_   | OldBuiltin_+  | BuiltinDeclaresIdentifier_+  | PlentyInHardCompileTimeMode_   | PragmaCompileErased_+  | PragmaCompileList_+  | PragmaCompileMaybe_+  | PragmaCompileUnparsable_+  | PragmaCompileWrong_+  | PragmaCompileWrongName_+  | PragmaExpectsDefinedSymbol_+  | PragmaExpectsUnambiguousConstructorOrFunction_+  | PragmaExpectsUnambiguousProjectionOrFunction_+  | NoMain_+  | NotARewriteRule_+  | RewriteLHSNotDefinitionOrConstructor_+  | RewriteVariablesNotBoundByLHS_+  | RewriteVariablesBoundMoreThanOnce_+  | RewriteLHSReduces_+  | RewriteHeadSymbolIsProjectionLikeFunction_+  | RewriteHeadSymbolIsTypeConstructor_+  | RewriteHeadSymbolContainsMetas_+  | RewriteConstructorParametersNotGeneral_+  | RewriteContainsUnsolvedMetaVariables_+  | RewriteBlockedOnProblems_+  | RewriteRequiresDefinitions_+  | RewriteDoesNotTargetRewriteRelation_+  | RewriteBeforeFunctionDefinition_+  | RewriteBeforeMutualFunctionDefinition_+  | ConfluenceCheckingIncompleteBecauseOfMeta_+  | ConfluenceForCubicalNotSupported_   | RewriteMaybeNonConfluent_   | RewriteNonConfluent_   | RewriteAmbiguousRules_   | RewriteMissingRule_+  | DuplicateRewriteRule_   | SafeFlagEta_   | SafeFlagInjective_   | SafeFlagNoCoverageCheck_@@ -249,6 +342,7 @@   | SafeFlagTerminating_   | SafeFlagWithoutKFlagPrimEraseEquality_   | TerminationIssue_+  | TooManyArgumentsToSort_   | UnreachableClauses_   | UnsolvedConstraints_   | UnsolvedInteractionMetas_@@ -257,15 +351,39 @@   | UselessInline_   | UselessPatternDeclarationForRecord_   | UselessPublic_+  | UselessTactic_   | UserWarning_+  | InvalidDisplayForm_+  | UnusedVariablesInDisplayForm_+  | RewritesNothing_+  | WithClauseProjectionFixityMismatch_   | WithoutKFlagPrimEraseEquality_+  | ConflictingPragmaOptions_   | WrongInstanceDeclaration_+  | TooManyPolarities_+  | TopLevelPolarity_   -- Checking consistency of options   | CoInfectiveImport_   | InfectiveImport_   -- Record field warnings-  | DuplicateFieldsWarning_-  | TooManyFieldsWarning_+  | DuplicateFields_+  | TooManyFields_+  -- Opaque/unfolding+  | MissingTypeSignatureForOpaque_+  | NotAffectedByOpaque_+  | UnfoldingWrongName_+  | UnfoldTransparentName_+  | UselessOpaque_+  -- Recoverable scope checking errors+  | HiddenNotInArgumentPosition_+  | InstanceNotInArgumentPosition_+  | MacroInLetBindings_+  | AbstractInLetBindings_+  -- Cubical+  | FaceConstraintCannotBeHidden_+  | FaceConstraintCannotBeNamed_+  -- Backends+  | CustomBackendWarning_   deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic)  instance NFData WarningName@@ -273,9 +391,9 @@ -- | The flag corresponding to a warning is precisely the name of the constructor -- minus the trailing underscore. --- sorry string2WarningName :: String -> Maybe WarningName-string2WarningName = readMaybe . (++ "_")+string2WarningName = (`HMap.lookup` warnings) where+  warnings = HMap.fromList $ map (\x -> (warningName2String x, x)) [minBound..maxBound]  warningName2String :: WarningName -> String warningName2String = initWithDefault __IMPOSSIBLE__ . show@@ -293,40 +411,58 @@     \ one of the following:"   , ""   , untable (fmap (fst &&& snd . snd) warningSets)+   , "Individual benign warnings can be turned on and off by -W Name and\     \ -W noName, respectively, where Name comes from the following\-    \ list (warnings marked with 'd' are turned on by default, and 'b'\-    \ stands for \"benign warning\"):"+    \ list (warnings marked with 'd' are turned on by default):"   , ""-  , untable $ forMaybe [minBound..maxBound] $ \ w ->-    let wnd = warningNameDescription w in-    ( warningName2String w-    , (if w `Set.member` usualWarnings then "d" else " ") ++-      (if not (w `Set.member` errorWarnings) then "b" else " ") ++-      " " ++-      wnd-    ) <$ guard (not $ null wnd)+  , warningTable True benign++  , "Error warnings are always on and cannot be turned off:"+  , ""+  , warningTable False severe   ]    where +    (severe, benign) = partition (`Set.member` errorWarnings) [minBound..maxBound]++    warningTable printD ws =+      untable $ forMaybe ws $ \ w ->+        let wnd = warningNameDescription w in+        ( warningName2String w+        , applyWhen printD ((if w `Set.member` usualWarnings then "d" else " ") ++)+          " " +++          wnd+        ) <$ guard (not $ null wnd)+     untable :: [(String, String)] -> String     untable rows =       let len = maximum (map (length . fst) rows) in-      unlines $ flip map rows $ \ (hdr, cnt) ->+      unlines $ for (sort rows) $ \ (hdr, cnt) ->         concat [ hdr, replicate (1 + len - length hdr) ' ', cnt ] + -- | @WarningName@ descriptions used for generating usage information -- Leave String empty to skip that name.-+--+-- The description should be a completion of the sentence "This warning is about ...".+-- So, typically the subject is in plural.+-- warningNameDescription :: WarningName -> String warningNameDescription = \case+  -- Option Warnings+  OptionRenamed_                   -> "Renamed options."+  WarningProblem_                  -> "Problems with switching warnings."   -- Parser Warnings   OverlappingTokensWarning_        -> "Multi-line comments spanning one or more literate text blocks."+  MisplacedAttributes_             -> "Attributes where they are not supported."+  UnknownPolarity_                 -> "Unknown polarities."+  UnknownAttribute_                -> "Unknown attributes."   UnsupportedAttribute_            -> "Unsupported attributes."   MultipleAttributes_              -> "Multiple attributes."   -- Library Warnings-  LibUnknownField_                 -> "Unknown field in library file."+  LibUnknownField_                 -> "Unknown fields in library files."   -- Nicifer Warnings   EmptyAbstract_                   -> "Empty `abstract' blocks."   EmptyConstructor_                -> "Empty `constructor' blocks."@@ -340,23 +476,24 @@   EmptyPrivate_                    -> "Empty `private' blocks."   EmptyRewritePragma_              -> "Empty `REWRITE' pragmas."   EmptyWhere_                      -> "Empty `where' blocks."+  EmptyPolarityPragma_             -> "`POLARITY' pragmas giving no polarities."+  HiddenGeneralize_                -> "Hidden identifiers in variable blocks."   InvalidCatchallPragma_           -> "`CATCHALL' pragmas before a non-function clause."-  InvalidConstructor_              -> "`constructor' blocks may only contain type signatures for constructors."-  InvalidConstructorBlock_         -> "No `constructor' blocks outside of `interleaved mutual' blocks."+  InvalidConstructorBlock_         -> "`constructor' blocks outside of `interleaved mutual' blocks."   InvalidCoverageCheckPragma_      -> "Coverage checking pragmas before non-function or `mutual' blocks."-  InvalidNoPositivityCheckPragma_  -> "No positivity checking pragmas before non-`data', `record' or `mutual' blocks."-  InvalidNoUniverseCheckPragma_    -> "No universe checking pragmas before non-`data' or `record' declaration."-  InvalidRecordDirective_          -> "No record directive outside of record definition / below field declarations."+  InvalidNoPositivityCheckPragma_  -> "Positivity checking pragmas before non-`data', `record' or `mutual' blocks."+  InvalidNoUniverseCheckPragma_    -> "Universe checking pragmas before non-`data' or `record' declaration."+  DuplicateRecordDirective_        -> "Conflicting directives in a record declaration."   InvalidTerminationCheckPragma_   -> "Termination checking pragmas before non-function or `mutual' blocks."-  MissingDeclarations_             -> "Definitions not associated to a declaration."+  MissingDataDeclaration_          -> "Constructor definitions not associated to a data declaration."   MissingDefinitions_              -> "Declarations not associated to a definition."   NotAllowedInMutual_              -> "Declarations not allowed in a mutual block."-  OpenPublicAbstract_              -> "'open public' directive in an 'abstract' block."-  OpenPublicPrivate_               -> "'open public' directive in a 'private' block."+  OpenImportAbstract_              -> "`open' or `import' statements in 'abstract' blocks."+  OpenImportPrivate_               -> "`open' or `import' statements in 'private' blocks."   PolarityPragmasButNotPostulates_ -> "Polarity pragmas for non-postulates."-  PragmaCompiled_                  -> "'COMPILE' pragmas not allowed in safe mode."-  PragmaNoTerminationCheck_        -> "`NO_TERMINATION_CHECK' pragmas are deprecated"-  ShadowingInTelescope_            -> "Repeated variable name in telescope."+  PragmaCompiled_                  -> "'COMPILE' pragmas in safe mode."+  PragmaNoTerminationCheck_        -> "`NO_TERMINATION_CHECK' pragmas; such are deprecated."+  ShadowingInTelescope_            -> "Repeated variable names in telescopes."   UnknownFixityInMixfixDecl_       -> "Mixfix names without an associated fixity declaration."   UnknownNamesInFixityDecl_        -> "Names not declared in the same scope as their syntax or fixity declaration."   UnknownNamesInPolarityPragmas_   -> "Names not declared in the same scope as their polarity pragmas."@@ -364,37 +501,76 @@   UselessHiding_                   -> "Names in `hiding' directive that are anyway not imported."   UselessInline_                   -> "`INLINE' pragmas where they have no effect."   UselessInstance_                 -> "`instance' blocks where they have no effect."+  UselessMacro_                    -> "`macro' blocks where they have no effect."   UselessPrivate_                  -> "`private' blocks where they have no effect."-  UselessPublic_                   -> "`public' blocks where they have no effect."+  UselessPublic_                   -> "`public' directives that have no effect."   UselessPatternDeclarationForRecord_ -> "`pattern' attributes where they have no effect."+  UselessTactic_                   -> "`@tactic` attributes where they have no effect."   -- Scope and Type Checking Warnings-  AbsurdPatternRequiresNoRHS_      -> "A clause with an absurd pattern does not need a Right Hand Side."+  AbsurdPatternRequiresAbsentRHS_  -> "Clauses with an absurd pattern that have a right hand side."   AsPatternShadowsConstructorOrPatternSynonym_ -> "@-patterns that shadow constructors or pattern synonyms."-  CantGeneralizeOverSorts_         -> "Attempt to generalize over sort metas in 'variable' declaration."+  PatternShadowsConstructor_       -> "Pattern variables that shadow constructors."+  CantGeneralizeOverSorts_         -> "Attempts to generalize over sort metas in 'variable' declaration."   ClashesViaRenaming_              -> "Clashes introduced by `renaming'."  -- issue #4154   CoverageIssue_                   -> "Failed coverage checks."   CoverageNoExactSplit_            -> "Failed exact split checks."-  DeprecationWarning_              -> "Feature deprecation."-  GenericNonFatalError_            -> ""-  GenericUseless_                  -> "Useless code."-  GenericWarning_                  -> ""+  InlineNoExactSplit_              -> "Failed exact split checks after inlining record constructors."+  DeprecationWarning_              -> "Deprecated features."+  -- TODO: linearity+  -- FixingQuantity_                  -> "Correcting invalid user-written quantity."+  FixingRelevance_                 -> "Correcting invalid user-written relevance attribute."+  FixingCohesion_                  -> "Correcting invalid user-written cohesion attribute."+  FixingPolarity_                  -> "Correcting invalid user-written polarity attribute."+  InvalidCharacterLiteral_         -> "Illegal character literals."+  UselessPragma_                   -> "Pragmas that get ignored."   IllformedAsClause_               -> "Illformed `as'-clauses in `import' statements."-  InstanceNoOutputTypeName_        -> "instance arguments whose type does not end in a named or variable type are never considered by instance search."-  InstanceArgWithExplicitArg_      -> "instance arguments with explicit arguments are never considered by instance search."-  InstanceWithExplicitArg_         -> "`instance` declarations with explicit arguments are never considered by instance search."-  InversionDepthReached_           -> "Inversions of pattern-matching failed due to exhausted inversion depth."-  NoGuardednessFlag_               -> "Coinductive record but no --guardedness flag."-  ModuleDoesntExport_              -> "Imported name is not actually exported."+  InstanceNoOutputTypeName_        -> "Instance arguments whose type does not end in a named or variable type; those are never considered by instance search."+  InstanceArgWithExplicitArg_      -> "Instance arguments with explicit arguments; those are never considered by instance search."+  InstanceWithExplicitArg_         -> "`instance` declarations with explicit arguments; those are never considered by instance search."+  InversionDepthReached_           -> "Inversions of pattern-matching failures due to exhausted inversion depth."+  ModuleDoesntExport_              -> "Imported names that are not actually exported."   DuplicateUsing_                  -> "Repeated names in using directive."-  FixityInRenamingModule_          -> "Found fixity annotation in renaming directive for module."-  NotInScope_                      -> "Out of scope name."+  FixityInRenamingModule_          -> "Fixity annotations in `renaming' directive for `module'."+  NotInScope_                      -> "Out of scope names."   NotStrictlyPositive_             -> "Failed strict positivity checks."+  ConstructorDoesNotFitInData_     -> "Failed constructor size checks."+  CoinductiveEtaRecord_            -> "Record type declared as both coinductive and having eta-equality."+  UnsupportedIndexedMatch_         -> "Failures to compute full equivalence when splitting on indexed family."   OldBuiltin_                      -> "Deprecated `BUILTIN' pragmas."-  PragmaCompileErased_             -> "`COMPILE' pragma targeting an erased symbol."-  RewriteMaybeNonConfluent_        -> "Failed local confluence check while computing overlap."-  RewriteNonConfluent_             -> "Failed local confluence check while joining critical pairs."-  RewriteAmbiguousRules_           -> "Failed global confluence check because of overlapping rules."-  RewriteMissingRule_              -> "Failed global confluence check because of missing rule."+  BuiltinDeclaresIdentifier_       -> "`BUILTIN' pragmas that declare a new identifier but have been given an existing one."+  PlentyInHardCompileTimeMode_     -> "Uses of @ω or @plenty in hard compile-time mode."+  PragmaCompileErased_             -> "`COMPILE' pragmas targeting an erased symbol."+  PragmaCompileList_               -> "`COMPILE GHC' pragmas for lists."+  PragmaCompileMaybe_              -> "`COMPILE GHC' pragmas for `MAYBE'."+  PragmaCompileUnparsable_         -> "Unparsable `COMPILE GHC' pragmas."+  PragmaCompileWrong_              -> "Ill-formed `COMPILE GHC' pragmas."+  PragmaCompileWrongName_          -> "`COMPILE' pragmas referring to identifiers that are neither definitions nor constructors.'"+  PragmaExpectsDefinedSymbol_      -> "Pragmas referrings to identifiers that are not defined symbols."+  PragmaExpectsUnambiguousConstructorOrFunction_    -> "Pragmas referring to identifiers that are not unambiguous constructors or functions.'"+  PragmaExpectsUnambiguousProjectionOrFunction_     -> "Pragmas referring to identifiers that are not unambiguous projections or functions.'"+  NoMain_                          -> "Compilation of modules that do not define `main'."+  NotARewriteRule_                 -> "`REWRITE pragmas referring to identifiers that are neither definitions nor constructors.'"+  RewriteLHSNotDefinitionOrConstructor_             -> "Rewrite rule head symbol is not a defined symbol or constructor."+  RewriteVariablesNotBoundByLHS_                    -> "Rewrite rule does not bind all of its variables."+  RewriteVariablesBoundMoreThanOnce_                -> "Constructor-headed rewrite rule has non-linear parameters."+  RewriteLHSReduces_                                -> "Rewrite rule LHS is not in weak-head normal form."+  RewriteHeadSymbolIsProjectionLikeFunction_        -> "Rewrite rule head symbol is a projection-like function."+  RewriteHeadSymbolIsTypeConstructor_               -> "Rewrite rule head symbol is a type constructor."+  RewriteHeadSymbolContainsMetas_                   -> "Definition of rewrite rule head symbol contains unsolved metas."+  RewriteConstructorParametersNotGeneral_           -> "Constructor-headed rewrite rule parameters are not fully general."+  RewriteContainsUnsolvedMetaVariables_             -> "Rewrite rule contains unsolved metas."+  RewriteBlockedOnProblems_                         -> "Checking rewrite rule blocked by unsolved constraint."+  RewriteRequiresDefinitions_                       -> "Checking rewrite rule blocked by missing definition."+  RewriteDoesNotTargetRewriteRelation_              -> "Rewrite rule does not target the rewrite relation."+  RewriteBeforeFunctionDefinition_                  -> "Rewrite rule is not yet defined."+  RewriteBeforeMutualFunctionDefinition_            -> "Mutually declaration with the rewrite rule is not yet defined."+  ConfluenceCheckingIncompleteBecauseOfMeta_ -> "Incomplete confluence checks because of unsolved metas."+  ConfluenceForCubicalNotSupported_ -> "Incomplete confluence checks because of `--cubical'."+  RewriteMaybeNonConfluent_        -> "Failed local confluence checks while computing overlap."+  RewriteNonConfluent_             -> "Failed local confluence checks while joining critical pairs."+  RewriteAmbiguousRules_           -> "Failed global confluence checks because of overlapping rules."+  RewriteMissingRule_              -> "Failed global confluence checks because of missing rule."+  DuplicateRewriteRule_            -> "Duplicate rewrite rules."   SafeFlagEta_                     -> "`ETA' pragmas with the safe flag."   SafeFlagInjective_               -> "`INJECTIVE' pragmas with the safe flag."   SafeFlagNoCoverageCheck_         -> "`NON_COVERING` pragmas with the safe flag."@@ -406,17 +582,44 @@   SafeFlagPragma_                  -> "Unsafe `OPTIONS' pragmas with the safe flag."   SafeFlagTerminating_             -> "`TERMINATING' pragmas with the safe flag."   SafeFlagWithoutKFlagPrimEraseEquality_ -> "`primEraseEquality' used with the safe and without-K flags."+  ConflictingPragmaOptions_        -> "Conflicting pragma options."   TerminationIssue_                -> "Failed termination checks."   UnreachableClauses_              -> "Unreachable function clauses."   UnsolvedConstraints_             -> "Unsolved constraints."   UnsolvedInteractionMetas_        -> "Unsolved interaction meta variables."+  InteractionMetaBoundaries_       -> "Interaction meta variables that have unsolved boundary constraints."   UnsolvedMetaVariables_           -> "Unsolved meta variables."-  UserWarning_                     -> "User-defined warning added using one of the 'WARNING_ON_*' pragmas."-  WithoutKFlagPrimEraseEquality_   -> "`primEraseEquality' usages with the without-K flags."-  WrongInstanceDeclaration_        -> "Terms marked as eligible for instance search should end with a name."+  UserWarning_                     -> "User-defined warnings via one of the 'WARNING_ON_*' pragmas."+  InvalidDisplayForm_              -> "Invalid display forms."+  UnusedVariablesInDisplayForm_    -> "Bound but unused variables in display forms."+  TooManyArgumentsToSort_          -> "Extra arguments given to a sort."+  RewritesNothing_                 -> "`rewrite' clauses that do not fire."+  WithClauseProjectionFixityMismatch_ -> "With clauses using projections in different fixities than their parent clauses."+  WithoutKFlagPrimEraseEquality_   -> "Uses of `primEraseEquality' with the without-K flags."+  WrongInstanceDeclaration_        -> "Instances that do not adhere to the required format."+  TooManyPolarities_               -> "Too many polarities given in POLARITY pragma."+  TopLevelPolarity_                -> "Declaring definitions with an explicit polarity annotation."   -- Checking consistency of options   CoInfectiveImport_               -> "Importing a file not using e.g. `--safe'  from one which does."-  InfectiveImport_                 -> "Importing a file using e.g. `--cubical' into one which doesn't."+  InfectiveImport_                 -> "Importing a file using e.g. `--cubical' into one which does not."   -- Record field warnings-  DuplicateFieldsWarning_          -> "Record expression with duplicate field names."-  TooManyFieldsWarning_            -> "Record expression with invalid field names."+  DuplicateFields_                 -> "Record expressions with duplicate field names."+  TooManyFields_                   -> "Record expressions with invalid field names."+  -- Opaque/unfolding warnings+  MissingTypeSignatureForOpaque_   -> "Definitions that are `abstract` or `opaque` yet lack type signatures."+  NotAffectedByOpaque_             -> "Declarations unaffected by enclosing `opaque` blocks."+  UnfoldingWrongName_              -> "Names in `unfolding` clause that are not unambiguous functions."+  UnfoldTransparentName_           -> "Non-`opaque` names mentioned in an `unfolding` clause."+  UselessOpaque_                   -> "`opaque` blocks that have no effect."++  -- Recoverable scope-checking errors+  HiddenNotInArgumentPosition_     -> "Hidden argument with no matching function."+  InstanceNotInArgumentPosition_   -> "Instance argument with no matching function."+  MacroInLetBindings_              -> "Macros can not be let-bound."+  AbstractInLetBindings_           -> "Let bindings can not contain abstract declarations."++  -- Cubical+  FaceConstraintCannotBeHidden_    -> "Face constraint patterns that are given as implicit arguments."+  FaceConstraintCannotBeNamed_     -> "Face constraint patterns that are given as named arguments."+  -- Backends+  CustomBackendWarning_            -> "Custom warnings from backends."
+ src/full/Agda/Interaction/Output.hs view
@@ -0,0 +1,14 @@++module Agda.Interaction.Output where++import Agda.Interaction.Base++import Agda.TypeChecking.Monad.Base (TCErr)++--------------------------+-- * TCM-aware aliases+--------------------------++type OutputForm a b = OutputForm_boot TCErr a b++type OutputConstraint a b = OutputConstraint_boot TCErr a b
src/full/Agda/Interaction/Response.hs view
@@ -1,219 +1,25 @@---------------------------------------------------------------------------- | Data type for all interactive responses-------------------------------------------------------------------------  module Agda.Interaction.Response-  ( Response (..)-  , RemoveTokenBasedHighlighting (..)-  , MakeCaseVariant (..)-  , DisplayInfo (..)-  , GoalDisplayInfo(..)-  , Goals-  , WarningsAndNonFatalErrors-  , Info_Error(..)-  , GoalTypeAux(..)-  , ResponseContextEntry(..)-  , Status (..)-  , GiveResult (..)-  , InteractionOutputCallback-  , defaultInteractionOutputCallback-  ) where--import Agda.Interaction.Base-  ( CommandState-  , CompilerBackend-  , ComputeMode-  , OutputConstraint-  , OutputConstraint'-  , OutputForm-  , Rewrite-  )-import Agda.Interaction.Highlighting.Precise-import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Common   (InteractionId(..), Arg)-import Agda.Syntax.Concrete (Expr, Name)-import Agda.Syntax.Concrete.Name (NameInScope)-import Agda.Syntax.Scope.Base (AbstractModule, AbstractName, LocalVar)-import qualified Agda.Syntax.Internal as I-import {-# SOURCE #-} Agda.TypeChecking.Monad.Base-  (TCM, TCErr, TCWarning, HighlightingMethod, ModuleToSource, NamedMeta, TCWarning, IPBoundary')-import Agda.TypeChecking.Warnings (WarningsAndNonFatalErrors)-import Agda.Utils.Impossible-import Agda.Utils.Time--import Control.Monad.Trans-import Data.Int-import System.IO---- | Responses for any interactive interface------   Note that the response is given in pieces and incrementally,---   so the user can have timely response even during long computations.--data Response-    = Resp_HighlightingInfo-        HighlightingInfo-        RemoveTokenBasedHighlighting-        HighlightingMethod-        ModuleToSource-    | Resp_Status Status-    | Resp_JumpToError FilePath Int32-    | Resp_InteractionPoints [InteractionId]-    | Resp_GiveAction InteractionId GiveResult-    | Resp_MakeCase InteractionId MakeCaseVariant [String]-      -- ^ Response is list of printed clauses.-    | Resp_SolveAll [(InteractionId, Expr)]-      -- ^ Solution for one or more meta-variables.-    | Resp_DisplayInfo DisplayInfo-    | Resp_RunningInfo Int String-      -- ^ The integer is the message's debug level.-    | Resp_ClearRunningInfo-    | Resp_ClearHighlighting TokenBased-      -- ^ Clear highlighting of the given kind.-    | Resp_DoneAborting-      -- ^ A command sent when an abort command has completed-      -- successfully.-    | Resp_DoneExiting-      -- ^ A command sent when an exit command is about to be-      -- completed.---- | Should token-based highlighting be removed in conjunction with--- the application of new highlighting (in order to reduce the risk of--- flicker)?--data RemoveTokenBasedHighlighting-  = RemoveHighlighting-    -- ^ Yes, remove all token-based highlighting from the file.-  | KeepHighlighting-    -- ^ No.---- | There are two kinds of \"make case\" commands.--data MakeCaseVariant = Function | ExtendedLambda---- | Info to display at the end of an interactive command--data DisplayInfo-    = Info_CompilationOk CompilerBackend WarningsAndNonFatalErrors-    | Info_Constraints [OutputForm Expr Expr]-    | Info_AllGoalsWarnings Goals WarningsAndNonFatalErrors-    | Info_Time CPUTime-    | Info_Error Info_Error-        -- ^ When an error message is displayed this constructor should be-        -- used, if appropriate.-    | Info_Intro_NotFound-    | Info_Intro_ConstructorUnknown [String]-    | Info_Auto String-        -- ^ 'Info_Auto' denotes either an error or a success (when 'Resp_GiveAction' is present)-        --   TODO: split these into separate constructors-    | Info_ModuleContents [Name] I.Telescope [(Name, I.Type)]-    | Info_SearchAbout [(Name, I.Type)] String-    | Info_WhyInScope String FilePath (Maybe LocalVar) [AbstractName] [AbstractModule]-    | Info_NormalForm CommandState ComputeMode (Maybe CPUTime) A.Expr-    | Info_InferredType CommandState (Maybe CPUTime) A.Expr-    | Info_Context InteractionId [ResponseContextEntry]-    | Info_Version-    | Info_GoalSpecific InteractionId GoalDisplayInfo--data GoalDisplayInfo-    = Goal_HelperFunction (OutputConstraint' A.Expr A.Expr)-    | Goal_NormalForm ComputeMode A.Expr-    | Goal_GoalType Rewrite GoalTypeAux [ResponseContextEntry] [IPBoundary' Expr] [OutputForm Expr Expr]-    | Goal_CurrentGoal Rewrite-    | Goal_InferredType A.Expr---- | Goals & Warnings-type Goals = ( [OutputConstraint A.Expr InteractionId] -- visible metas (goals)-             , [OutputConstraint A.Expr NamedMeta]     -- hidden (unsolved) metas-             )---- | Errors that goes into Info_Error------   When an error message is displayed this constructor should be---   used, if appropriate.-data Info_Error-    = Info_GenericError TCErr-    | Info_CompilationError [TCWarning]-    | Info_HighlightingParseError InteractionId-    | Info_HighlightingScopeCheckError InteractionId---- | Auxiliary information that comes with Goal Type--data GoalTypeAux-    = GoalOnly-    | GoalAndHave A.Expr-    | GoalAndElaboration I.Term---- | Entry in context.--data ResponseContextEntry = ResponseContextEntry-  { respOrigName :: Name        -- ^ The original concrete name.-  , respReifName :: Name        -- ^ The name reified from abstract syntax.-  , respType     :: Arg A.Expr  -- ^ The type.-  , respLetValue :: Maybe A.Expr -- ^ The value (if it is a let-bound variable)-  , respInScope  :: NameInScope -- ^ Whether the 'respReifName' is in scope.-  }----- | Status information.--data Status = Status-  { sShowImplicitArguments :: Bool-    -- ^ Are implicit arguments displayed?-  , sShowIrrelevantArguments :: Bool-    -- ^ Are irrelevant arguments displayed?-  , sChecked               :: Bool-    -- ^ Has the module been successfully type checked?-  }---- | Give action result------   Comment derived from agda2-mode.el------   If 'GiveResult' is 'Give_String s', then the goal is replaced by 's',---   and otherwise the text inside the goal is retained (parenthesised---   if 'GiveResult' is 'Give_Paren').--data GiveResult-    = Give_String String-    | Give_Paren-    | Give_NoParen+    ( module Agda.Interaction.Response+    , module Agda.Interaction.Response.Base+    , WarningsAndNonFatalErrors+    , InteractionOutputCallback+    , defaultInteractionOutputCallback+    )+    where --- | Callback fuction to call when there is a response---   to give to the interactive frontend.------   Note that the response is given in pieces and incrementally,---   so the user can have timely response even during long computations.------   Typical 'InteractionOutputCallback' functions:------    * Convert the response into a 'String' representation and---      print it on standard output---      (suitable for inter-process communication).------    * Put the response into a mutable variable stored in the---      closure of the 'InteractionOutputCallback' function.---      (suitable for intra-process communication).+import Agda.Interaction.Response.Base -type InteractionOutputCallback = Response -> TCM ()+import Agda.TypeChecking.Monad.Base+  (TCM, TCErr, TCWarning, InteractionOutputCallback, defaultInteractionOutputCallback)+import Agda.TypeChecking.Warnings (WarningsAndNonFatalErrors) --- | The default 'InteractionOutputCallback' function prints certain--- things to stdout (other things generate internal errors).+--------------------------+-- * TCM-aware aliases+-------------------------- -defaultInteractionOutputCallback :: InteractionOutputCallback-defaultInteractionOutputCallback = \case-  Resp_HighlightingInfo {}  -> __IMPOSSIBLE__-  Resp_Status {}            -> __IMPOSSIBLE__-  Resp_JumpToError {}       -> __IMPOSSIBLE__-  Resp_InteractionPoints {} -> __IMPOSSIBLE__-  Resp_GiveAction {}        -> __IMPOSSIBLE__-  Resp_MakeCase {}          -> __IMPOSSIBLE__-  Resp_SolveAll {}          -> __IMPOSSIBLE__-  Resp_DisplayInfo {}       -> __IMPOSSIBLE__-  Resp_RunningInfo _ s      -> liftIO $ do-                                 putStr s-                                 hFlush stdout-  Resp_ClearRunningInfo {}  -> __IMPOSSIBLE__-  Resp_ClearHighlighting {} -> __IMPOSSIBLE__-  Resp_DoneAborting {}      -> __IMPOSSIBLE__-  Resp_DoneExiting {}       -> __IMPOSSIBLE__+type Response        = Response_boot        TCErr TCWarning WarningsAndNonFatalErrors+type DisplayInfo     = DisplayInfo_boot     TCErr TCWarning WarningsAndNonFatalErrors+type Info_Error      = Info_Error_boot      TCErr TCWarning+type GoalDisplayInfo = GoalDisplayInfo_boot TCErr+type Goals           = Goals_boot           TCErr
− src/full/Agda/Interaction/Response.hs-boot 
@@ -1,40 +0,0 @@-module Agda.Interaction.Response where--import Data.Int (Int32)--import Agda.Syntax.Common   (InteractionId)-import Agda.Syntax.Concrete (Expr)--import {-# SOURCE #-} Agda.TypeChecking.Monad.Base-    (TCM, ModuleToSource, HighlightingMethod)--import Agda.Interaction.Highlighting.Precise-    (TokenBased, HighlightingInfo)--data Response-    = Resp_HighlightingInfo-        HighlightingInfo-        RemoveTokenBasedHighlighting-        HighlightingMethod-        ModuleToSource-    | Resp_Status Status-    | Resp_JumpToError FilePath Int32-    | Resp_InteractionPoints [InteractionId]-    | Resp_GiveAction InteractionId GiveResult-    | Resp_MakeCase InteractionId MakeCaseVariant [String]-    | Resp_SolveAll [(InteractionId, Expr)]-    | Resp_DisplayInfo DisplayInfo-    | Resp_RunningInfo Int String-    | Resp_ClearRunningInfo-    | Resp_ClearHighlighting TokenBased-    | Resp_DoneAborting-    | Resp_DoneExiting--data MakeCaseVariant-data DisplayInfo-data RemoveTokenBasedHighlighting-data GiveResult-data Status--type InteractionOutputCallback = Response -> TCM ()-defaultInteractionOutputCallback :: InteractionOutputCallback
+ src/full/Agda/Interaction/Response/Base.hs view
@@ -0,0 +1,178 @@+------------------------------------------------------------------------+-- | Data type for all interactive responses+------------------------------------------------------------------------++module Agda.Interaction.Response.Base+  ( Response_boot (..)+  , RemoveTokenBasedHighlighting (..)+  , MakeCaseVariant (..)+  , DisplayInfo_boot (..)+  , GoalDisplayInfo_boot(..)+  , Goals_boot+  , Info_Error_boot(..)+  , GoalTypeAux(..)+  , ResponseContextEntry(..)+  , Status (..)+  , GiveResult (..)+  ) where++import Control.Monad.Trans ( MonadIO(liftIO) )+import Data.Set (Set)+import Data.Word (Word32)++import Agda.Interaction.Base+  ( CommandState+  , CompilerBackend+  , ComputeMode+  , OutputConstraint_boot+  , OutputConstraint'+  , OutputForm_boot+  , Rewrite+  )+import Agda.Interaction.Highlighting.Precise+import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Common         (InteractionId(..), Arg)+import Agda.Syntax.Concrete       (Expr)+import Agda.Syntax.Concrete.Name  (Name, QName, NameInScope)+import Agda.Syntax.Scope.Base     (WhyInScopeData)+import qualified Agda.Syntax.Internal as I+import Agda.TypeChecking.Monad.Base.Types+  (HighlightingMethod, ModuleToSource, NamedMeta, IPFace')+import Agda.Utils.Impossible+import Agda.Utils.Time++-- | Responses for any interactive interface+--+--   Note that the response is given in pieces and incrementally,+--   so the user can have timely response even during long computations.++data Response_boot tcErr tcWarning warningsAndNonFatalErrors+    = Resp_HighlightingInfo+        HighlightingInfo+        RemoveTokenBasedHighlighting+        HighlightingMethod+        ModuleToSource+    | Resp_Status Status+    | Resp_JumpToError FilePath Word32+    | Resp_InteractionPoints [InteractionId]+    | Resp_GiveAction InteractionId GiveResult+    | Resp_MakeCase InteractionId MakeCaseVariant [String]+      -- ^ Response is list of printed clauses.+    | Resp_SolveAll [(InteractionId, Expr)]+      -- ^ Solution for one or more meta-variables.+    | Resp_Mimer InteractionId (Maybe String)+    | Resp_DisplayInfo (DisplayInfo_boot tcErr tcWarning warningsAndNonFatalErrors)+    | Resp_RunningInfo Int String+      -- ^ The integer is the message's debug level.+    | Resp_ClearRunningInfo+    | Resp_ClearHighlighting TokenBased+      -- ^ Clear highlighting of the given kind.+    | Resp_DoneAborting+      -- ^ A command sent when an abort command has completed+      -- successfully.+    | Resp_DoneExiting+      -- ^ A command sent when an exit command is about to be+      -- completed.++-- | Should token-based highlighting be removed in conjunction with+-- the application of new highlighting (in order to reduce the risk of+-- flicker)?++data RemoveTokenBasedHighlighting+  = RemoveHighlighting+    -- ^ Yes, remove all token-based highlighting from the file.+  | KeepHighlighting+    -- ^ No.++-- | There are two kinds of \"make case\" commands.++data MakeCaseVariant = Function | ExtendedLambda++-- | Info to display at the end of an interactive command++data DisplayInfo_boot tcErr tcWarning warningsAndNonFatalErrors+    = Info_CompilationOk CompilerBackend warningsAndNonFatalErrors+    | Info_Constraints [OutputForm_boot tcErr Expr Expr]+    | Info_AllGoalsWarnings (Goals_boot tcErr) warningsAndNonFatalErrors+    | Info_Time CPUTime+    | Info_Error (Info_Error_boot tcErr tcWarning)+        -- ^ When an error message is displayed this constructor should be+        -- used, if appropriate.+    | Info_Intro_NotFound+    | Info_Intro_ConstructorUnknown [String]+    | Info_Auto String+        -- ^ 'Info_Auto' denotes either an error or a success (when 'Resp_GiveAction' is present)+        --   TODO: split these into separate constructors+    | Info_ModuleContents [Name] I.Telescope [(Name, I.Type)]+    | Info_SearchAbout [(Name, I.Type)] String+    | Info_WhyInScope WhyInScopeData+    | Info_NormalForm CommandState ComputeMode (Maybe CPUTime) A.Expr+    | Info_InferredType CommandState (Maybe CPUTime) A.Expr+    | Info_Context InteractionId [ResponseContextEntry]+    | Info_Version+    | Info_GoalSpecific InteractionId (GoalDisplayInfo_boot tcErr)++data GoalDisplayInfo_boot tcErr+    = Goal_HelperFunction (OutputConstraint' A.Expr A.Expr)+    | Goal_NormalForm ComputeMode A.Expr+    | Goal_GoalType Rewrite GoalTypeAux [ResponseContextEntry] [IPFace' Expr] [OutputForm_boot tcErr Expr Expr]+    | Goal_CurrentGoal Rewrite+    | Goal_InferredType A.Expr++-- | Goals & Warnings+type Goals_boot tcErr =+    ( [OutputConstraint_boot tcErr A.Expr InteractionId] -- visible metas (goals)+    , [OutputConstraint_boot tcErr A.Expr NamedMeta]     -- hidden (unsolved) metas+    )++-- | Errors that goes into Info_Error+--+--   When an error message is displayed this constructor should be+--   used, if appropriate.+data Info_Error_boot tcErr tcWarning+    = Info_GenericError tcErr+    | Info_CompilationError (Set tcWarning)+    | Info_HighlightingParseError InteractionId+    | Info_HighlightingScopeCheckError InteractionId++-- | Auxiliary information that comes with Goal Type++data GoalTypeAux+    = GoalOnly+    | GoalAndHave A.Expr [IPFace' Expr]+    | GoalAndElaboration A.Expr++-- | Entry in context.++data ResponseContextEntry = ResponseContextEntry+  { respOrigName :: Name        -- ^ The original concrete name.+  , respReifName :: Name        -- ^ The name reified from abstract syntax.+  , respType     :: Arg A.Expr  -- ^ The type.+  , respLetValue :: Maybe A.Expr -- ^ The value (if it is a let-bound variable)+  , respInScope  :: NameInScope -- ^ Whether the 'respReifName' is in scope.+  }+++-- | Status information.++data Status = Status+  { sShowImplicitArguments :: Bool+    -- ^ Are implicit arguments displayed?+  , sShowIrrelevantArguments :: Bool+    -- ^ Are irrelevant arguments displayed?+  , sChecked               :: Bool+    -- ^ Has the module been successfully type checked?+  }++-- | Give action result+--+--   Comment derived from agda2-mode.el+--+--   If 'GiveResult' is 'Give_String s', then the goal is replaced by 's',+--   and otherwise the text inside the goal is retained (parenthesised+--   if 'GiveResult' is 'Give_Paren').++data GiveResult+    = Give_String String+    | Give_Paren+    | Give_NoParen
src/full/Agda/Interaction/SearchAbout.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Interaction.SearchAbout (findMentions) where  import Control.Monad@@ -21,7 +23,8 @@ import qualified Agda.Syntax.Internal as I  import Agda.Utils.List   ( initLast1  )-import Agda.Utils.Pretty ( prettyShow )+import qualified Agda.Utils.List1 as List1+import Agda.Syntax.Common.Pretty ( prettyShow )  findMentions :: Rewrite -> Range -> String -> ScopeM [(C.Name, I.Type)] findMentions norm rg nm = do@@ -45,7 +48,7 @@   -- don't have a type. Looking it up makes Agda panic!   snms <- fmap (nsNames . allThingsInScope) $ getNamedScope =<< currentModule   let namesInScope = filter ((PatternSynName /=) . anameKind . snd)-                   $ concatMap (uncurry $ map . (,)) $ Map.toList snms+                   $ List1.concat $ map (\ (c, as) -> fmap (c,) as) $ Map.toList snms    -- Once we have the user-provided names and the names of all the   -- thing in scope we can start the search: for each name in scope,
src/full/Agda/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-}  {-| Agda main module. -}@@ -5,20 +6,27 @@  import Prelude hiding (null) +import qualified Control.Exception as E import Control.Monad          ( void ) import Control.Monad.Except   ( MonadError(..), ExceptT(..), runExceptT ) import Control.Monad.IO.Class ( MonadIO(..) )  import qualified Data.List as List+import Data.Function          ( (&) )+import Data.Functor import Data.Maybe--import System.Environment-import System.Console.GetOpt+import qualified Data.Set as Set+import qualified Data.Text as T -import Paths_Agda            ( getDataDir )+import System.Environment ( getArgs, getProgName )+import System.Exit ( exitSuccess, ExitCode )+import System.FilePath ( takeFileName )+import Agda.Utils.GetOpt+import qualified System.IO as IO +import Agda.Interaction.BuildLibrary (buildLibrary) import Agda.Interaction.CommandLine-import Agda.Interaction.ExitCode (AgdaError(..), exitSuccess, exitAgdaWith)+import Agda.Interaction.ExitCode as ExitCode (AgdaError(..), exitSuccess, exitAgdaWith) import Agda.Interaction.Options import Agda.Interaction.Options.Help (Help (..)) import Agda.Interaction.EmacsTop (mimicGHCi)@@ -27,6 +35,7 @@ import qualified Agda.Interaction.Imports as Imp  import Agda.TypeChecking.Monad+import Agda.TypeChecking.Errors import qualified Agda.TypeChecking.Monad.Benchmark as Bench import Agda.TypeChecking.Errors import Agda.TypeChecking.Warnings@@ -35,13 +44,18 @@ import Agda.Compiler.Backend import Agda.Compiler.Builtin -import Agda.VersionCommit+import Agda.Setup ( getAgdaAppDir, getDataDir, setup )+import Agda.Setup.EmacsMode+import Agda.VersionCommit ( versionWithCommitInfo ) +import qualified Agda.Utils.Benchmark as UtilsBench+import qualified Agda.Syntax.Common.Pretty.ANSI as ANSI+import qualified Agda.Syntax.Common.Pretty as P import Agda.Utils.FileName (absolute, filePath, AbsolutePath)+import Agda.Utils.String+import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.String-import qualified Agda.Utils.Benchmark as UtilsBench  import Agda.Utils.Impossible @@ -54,42 +68,81 @@ runAgda' backends = do   progName <- getProgName   argv     <- getArgs+  let (z, warns) = runOptM $ parseBackendOptions backends argv defaultOptions   conf     <- runExceptT $ do-    (bs, opts) <- ExceptT $ runOptM $ parseBackendOptions backends argv defaultOptions+    (bs, opts) <- ExceptT $ pure z     -- The absolute path of the input file, if provided     inputFile <- liftIO $ mapM absolute $ optInputFile opts-    mode      <- getMainMode bs inputFile opts+    mode      <- getInteractor bs inputFile opts     return (bs, opts, mode)    case conf of     Left err -> optionError err-    Right (bs, opts, mode) -> case mode of-      MainModePrintHelp hp   -> printUsage bs hp-      MainModePrintVersion   -> printVersion bs-      MainModePrintAgdaDir   -> printAgdaDir-      MainModeRun interactor -> runTCMPrettyErrors $ do-        setTCLens stBackends bs-        runAgdaWithOptions interactor progName opts+    Right (bs, opts, mode) -> do --- | Main execution mode-data MainMode-  = MainModeRun (Interactor ())-  | MainModePrintHelp Help-  | MainModePrintVersion-  | MainModePrintAgdaDir+      -- Setup Agda if requested+      when (optSetup opts) $ Agda.Setup.setup True --- | Determine the main execution mode to run, based on the configured backends and command line options.--- | This is pure.-getMainMode :: MonadError String m => [Backend] -> Maybe AbsolutePath -> CommandLineOptions -> m MainMode-getMainMode configuredBackends maybeInputFile opts-  | Just hp <- optPrintHelp opts = return $ MainModePrintHelp hp-  | optPrintVersion opts         = return $ MainModePrintVersion-  | optPrintAgdaDir opts         = return $ MainModePrintAgdaDir-  | otherwise                    = do-      mi <- getInteractor configuredBackends maybeInputFile opts-      -- If there was no selection whatsoever (e.g. just invoked "agda"), we just show help and exit.-      return $ maybe (MainModePrintHelp GeneralHelp) MainModeRun mi+      -- Print information as requested+      whenJust (optPrintVersion opts) $ printVersion bs+      whenJust (optPrintHelp    opts) $ printUsage   bs+      when (optPrintAgdaAppDir  opts) $ printAgdaAppDir+      when (optPrintAgdaDataDir opts) $ printAgdaDataDir +      -- Setup emacs mode+      when (EmacsModeSetup `Set.member` optEmacsMode opts) do+        unless (optSetup opts) $ Agda.Setup.setup False+        setupDotEmacs $ takeFileName progName++      -- Compile emacs mode+      when (EmacsModeCompile `Set.member` optEmacsMode opts) do+        unless (optSetup opts) $ Agda.Setup.setup False+        compileElispFiles++      -- Locate emacs mode+      when (EmacsModeLocate `Set.member` optEmacsMode opts) do+        unless (optSetup opts) $ Agda.Setup.setup False+        printEmacsModeFile++      case mode of+        Nothing -> do+          let+            something = or+              [ opts & optSetup+              , opts & optPrintVersion & isJust+              , opts & optPrintHelp    & isJust+              , opts & optPrintAgdaAppDir+              , opts & optPrintAgdaDataDir+              , opts & optEmacsMode    & not . null+              ]+          -- if no task was given to Agda+          unless something $ optionError "No task given."++        Just interactor -> do+         unless (optSetup opts) $ Agda.Setup.setup False++         runTCMPrettyErrors do++          mapM_ (warning . OptionWarning) warns++          when (optTransliterate opts) $ liftIO $ do+            -- When --interaction or --interaction-json is used, then we+            -- use UTF-8 when writing to stdout (and when reading from+            -- stdin).+            if optGHCiInteraction opts || optJSONInteraction opts+            then optionError $+                   "The option --transliterate must not be combined with " +++                   "--interaction or --interaction-json"+            else do+              -- Transliterate unsupported code points.+              enc <- IO.mkTextEncoding (show IO.localeEncoding ++ "//TRANSLIT")+              IO.hSetEncoding IO.stdout enc+              IO.hSetEncoding IO.stderr enc++          setTCLens stBackends bs+          runAgdaWithOptions interactor progName opts++ type Interactor a     -- Setup/initialization action.     -- This is separated so that errors can be reported in the appropriate format.@@ -99,42 +152,79 @@     -- Main transformed action.     -> TCM a +-- | Major mode of operation, not including the standard mode (checking the given main module). data FrontendType-  = FrontEndEmacs-  | FrontEndJson+  = FrontEndInteraction InteractionFormat+      -- ^ @--interaction@ or @--interaction-json@.   | FrontEndRepl+      -- ^ @--interactive@.+  | FrontEndBuildLibrary+      -- ^ @--build-library@. --- Emacs mode. Note that it ignores the "check" action because it calls typeCheck directly.-emacsModeInteractor :: Interactor ()-emacsModeInteractor setup _check = mimicGHCi setup+data InteractionFormat+  = InteractionEmacs+      -- ^ @--interaction@.+  | InteractionJson+      -- ^ @--interaction-json@. --- JSON mode. Note that it ignores the "check" action because it calls typeCheck directly.-jsonModeInteractor :: Interactor ()-jsonModeInteractor setup _check = jsonREPL setup+pattern FrontEndEmacs :: FrontendType+pattern FrontEndEmacs = FrontEndInteraction InteractionEmacs --- The deprecated repl mode.+pattern FrontEndJson :: FrontendType+pattern FrontEndJson  = FrontEndInteraction InteractionJson++{-# COMPLETE FrontEndBuildLibrary, FrontEndEmacs, FrontEndJson, FrontEndRepl #-}++buildLibraryInteractor :: Interactor ()+buildLibraryInteractor setup _check = do setup; buildLibrary++-- | Emacs/JSON mode. Note that it ignores the "check" action because it calls typeCheck directly.+interactionInteractor :: InteractionFormat -> Interactor ()+interactionInteractor InteractionEmacs setup _check = mimicGHCi setup+interactionInteractor InteractionJson  setup _check = jsonREPL  setup++-- | The (deprecated) repl mode. replInteractor :: Maybe AbsolutePath -> Interactor () replInteractor = runInteractionLoop --- The interactor to use when there are no frontends or backends specified.+-- | The interactor to use when there are no frontends or backends specified. defaultInteractor :: AbsolutePath -> Interactor () defaultInteractor file setup check = do setup; void $ check file  getInteractor :: MonadError String m => [Backend] -> Maybe AbsolutePath -> CommandLineOptions -> m (Maybe (Interactor ()))-getInteractor configuredBackends maybeInputFile opts =-  case (maybeInputFile, enabledFrontends, enabledBackends) of-    (Just inputFile, [],             _:_) -> return $ Just $ backendInteraction inputFile enabledBackends-    (Just inputFile, [],              []) -> return $ Just $ defaultInteractor inputFile-    (Nothing,        [],              []) -> return Nothing -- No backends, frontends, or input files specified.-    (Nothing,        [],             _:_) -> throwError $ concat ["No input file specified for ", enabledBackendNames]-    (_,              _:_,            _:_) -> throwError $ concat ["Cannot mix ", enabledFrontendNames, " with ", enabledBackendNames]-    (_,              _:_:_,           []) -> throwError $ concat ["Must not specify multiple ", enabledFrontendNames]-    (_,              [fe],            []) | optOnlyScopeChecking opts -> errorFrontendScopeChecking fe-    (_,              [FrontEndRepl],  []) -> return $ Just $ replInteractor maybeInputFile-    (Nothing,        [FrontEndEmacs], []) -> return $ Just $ emacsModeInteractor-    (Nothing,        [FrontEndJson],  []) -> return $ Just $ jsonModeInteractor-    (Just inputFile, [FrontEndEmacs], []) -> errorFrontendFileDisallowed inputFile FrontEndEmacs-    (Just inputFile, [FrontEndJson],  []) -> errorFrontendFileDisallowed inputFile FrontEndJson+getInteractor configuredBackends maybeInputFile opts = do++  case enabledFrontends of+    _:_:_ -> throwError $ concat ["Must not specify multiple ", enabledFrontendNames]++    -- standard mode of operation+    [] -> do+      case (maybeInputFile, enabledBackends) of+        (Just inputFile, _:_) -> return $ Just $ backendInteraction inputFile enabledBackends+        (Just inputFile,  []) -> return $ Just $ defaultInteractor inputFile+        (Nothing,         []) -> return Nothing -- No backends, frontends, or input files specified.+        (Nothing,        _:_) -> throwError $ concat ["No input file specified for ", enabledBackendNames]++    -- special mode of operation+    [fe] -> do+      case fe of+        -- --interactive+        FrontEndRepl -> do+          noBackends fe+          notJustScopeChecking fe+          return $ Just $ replInteractor maybeInputFile+        -- --interaction(-json)+        FrontEndInteraction i -> do+          noBackends fe+          notJustScopeChecking fe+          noInputFile fe+          return $ Just $ interactionInteractor i+        -- --build-library+        FrontEndBuildLibrary -> do+          unless (optUseLibs opts) $+            throwError "--build-library cannot be combined with --no-libraries"+          noInputFile fe+          return $ Just buildLibraryInteractor   where     -- NOTE: The notion of a backend being "enabled" *just* refers to this top-level interaction mode selection. The     -- interaction/interactive front-ends may still invoke available backends even if they are not "enabled".@@ -144,17 +234,23 @@       [ [ FrontEndRepl  | optInteractive     opts ]       , [ FrontEndEmacs | optGHCiInteraction opts ]       , [ FrontEndJson  | optJSONInteraction opts ]+      , [ FrontEndBuildLibrary | optBuildLibrary opts ]       ]     -- Constructs messages like "(no backend)", "backend ghc", "backends (ghc, ocaml)"     pluralize w []  = concat ["(no ", w, ")"]     pluralize w [x] = concat [w, " ", x]     pluralize w xs  = concat [w, "s (", List.intercalate ", " xs, ")"]-    enabledBackendNames  = pluralize "backend" [ backendName b | Backend b <- enabledBackends ]+    enabledBackendNames  = pluralize "backend" [ T.unpack $ backendName b | Backend b <- enabledBackends ]     enabledFrontendNames = pluralize "frontend" (frontendFlagName <$> enabledFrontends)     frontendFlagName = ("--" ++) . \case       FrontEndEmacs -> "interaction"       FrontEndJson -> "interaction-json"       FrontEndRepl -> "interactive"+      FrontEndBuildLibrary -> "build-library"+    noBackends fe = unless (null enabledBackends) $+      throwError $ concat ["Cannot mix ", frontendFlagName fe, " with ", enabledBackendNames]+    noInputFile fe = whenJust maybeInputFile \ inputFile -> errorFrontendFileDisallowed inputFile fe+    notJustScopeChecking = when (optOnlyScopeChecking opts) . errorFrontendScopeChecking     errorFrontendScopeChecking fe = throwError $       concat ["The --only-scope-checking flag cannot be combined with ", frontendFlagName fe]     errorFrontendFileDisallowed inputFile fe = throwError $@@ -182,7 +278,7 @@             Bench.print              -- Print accumulated statistics.-            printStatistics 1 Nothing =<< useTC lensAccumStatistics+            printStatistics Nothing =<< useTC lensAccumStatistics   where     -- Options are fleshed out here so that (most) errors like     -- "bad library path" are validated within the interactor,@@ -203,20 +299,20 @@                      then Imp.ScopeCheck                      else Imp.TypeCheck -          result <- Imp.typeCheckMain mode =<< Imp.parseSource (SourceFile inputFile)+          src <- srcFromPath inputFile+          result <- Imp.typeCheckMain mode =<< Imp.parseSource src            unless (crMode result == ModuleScopeChecked) $-            unlessNullM (applyFlagsToTCWarnings (crWarnings result)) $ \ ws ->-              typeError $ NonFatalErrors ws+            Imp.raiseNonFatalErrors result            let i = crInterface result           reportSDoc "main" 50 $ pretty i            -- Print accumulated warnings-          unlessNullM (tcWarnings . classifyWarnings <$> getAllWarnings AllWarnings) $ \ ws -> do+          unlessNullM (tcWarnings . classifyWarnings . Set.toAscList <$> getAllWarnings AllWarnings) $ \ ws -> do             let banner = text $ "\n" ++ delimiter "All done; warnings encountered"-            reportSDoc "warning" 1 $-              vcat $ punctuate "\n" $ banner : (prettyTCM <$> ws)+            alwaysReportSDoc "warning" 1 $+              vsep $ (banner :) $ map prettyTCM $ Set.toAscList ws            return result @@ -231,39 +327,151 @@  backendUsage :: Backend -> String backendUsage (Backend b) =-  usageInfo ("\n" ++ backendName b ++ " backend options") $+  usageInfo ("\n" ++ T.unpack (backendName b) ++ " backend options") $     map void (commandLineFlags b)  -- | Print version information.-printVersion :: [Backend] -> IO ()-printVersion backends = do+printVersion :: [Backend] -> PrintAgdaVersion -> IO ()+printVersion _ PrintAgdaNumericVersion = putStrLn versionWithCommitInfo+printVersion backends PrintAgdaVersion = do   putStrLn $ "Agda version " ++ versionWithCommitInfo+  unless (null flags) $+    mapM_ putStrLn $ ("Built with flags (cabal -f)" :) $ map bullet flags   mapM_ putStrLn-    [ "  - " ++ name ++ " backend version " ++ ver+    [ bullet $ T.unpack $ T.unwords [ name, "backend version", ver ]     | Backend Backend'{ backendName = name, backendVersion = Just ver } <- backends ]+  where+  bullet = (" - " ++)+  -- Print cabal flags that were involved in compilation.+  flags =+#ifdef COUNT_CLUSTERS+    "enable-cluster-counting: unicode cluster counting in LaTeX backend using the ICU library" :+#endif+#ifdef OPTIMISE_HEAVILY+    "optimise-heavily: extra optimisations" :+#endif+#ifdef DEBUG+    "debug: enable debug printing ('-v' verbosity flags)" :+#endif+#ifdef DEBUG_PARSING+    "debug-parsing: enable printing grammars for operator parsing via '-v scope.grammar:10'" :+#endif+#ifdef DEBUG_SERIALISATION+    "debug-serialisation: extra debug info during serialisation into '.agdai' files" :+#endif+#ifdef USE_XDG_DATA_HOME+    concat+      [ "use-xdg-data-home: install and locate data files under $XDG_DATA_HOME/agda/"+      , "$AGDA_VERSION" -- , versionWithCommitInfo+           -- Andreas, 2025-06-28, we could put in the actual version here+           -- but I think the text is clearer in the generic form+      , " by default instead of the location defined by Cabal"+      ]+    :+#endif+    [] -printAgdaDir :: IO ()-printAgdaDir = putStrLn =<< getDataDir+printAgdaDataDir :: IO ()+printAgdaDataDir = putStrLn =<< getDataDir +printAgdaAppDir :: IO ()+printAgdaAppDir = putStrLn =<< getAgdaAppDir+ -- | What to do for bad options. optionError :: String -> IO () optionError err = do   prog <- getProgName   putStrLn $ "Error: " ++ err ++ "\nRun '" ++ prog ++ " --help' for help on command line options."-  exitAgdaWith OptionError+  exitAgdaWith ExitCode.OptionError  -- | Run a TCM action in IO; catch and pretty print errors.++-- If some error message cannot be printed due to locale issues, then+-- one may get the "Error when handling error" error message. There is+-- currently no test case for this error, but on some systems one can+-- (at the time of writing) trigger it by running @LC_CTYPE=C agda+-- --no-libraries Bug.agda@, where @Bug.agda@ contains the following+-- code (if there is some other file in the same directory, for+-- instance @Bug.lagda@, then the error message may be different):+--+-- @+-- _ : Set+-- _ = Set+-- @+ runTCMPrettyErrors :: TCM () -> IO () runTCMPrettyErrors tcm = do-    r <- runTCMTop $ tcm `catchError` \err -> do-      s2s <- prettyTCWarnings' =<< getAllWarningsOfTCErr err-      s1  <- prettyError err-      let ss = filter (not . null) $ s2s ++ [s1]-      unless (null s1) (liftIO $ putStr $ unlines ss)-      throwError err-    case r of-      Right _ -> exitSuccess-      Left _  -> exitAgdaWith TCMError-  `catchImpossible` \e -> do-    putStr $ show e-    exitAgdaWith ImpossibleError+  r <- runTCMTop+    ( ( (Nothing <$ tcm)+          `catchError` \err -> do+            s2s <- prettyTCWarnings' =<< getAllWarningsOfTCErr err+            s1  <- prettyError err+            ANSI.putDoc $ P.vsep $ s2s ++ [ s1 ]+            liftIO $ do+              helpForLocaleError err+            return (Just TCMError)+      ) `catchImpossible` \e -> do+          printException e+          return (Just ImpossibleError)+    ) `E.catches`+        -- Catch all exceptions except for those of type ExitCode+        -- (which are thrown by exitWith) and asynchronous exceptions+        -- (which are for instance raised when Ctrl-C is used, or if+        -- the program runs out of heap or stack space).+        [ E.Handler $ \(e :: ExitCode)         -> E.throw e+        , E.Handler $ \(e :: E.AsyncException) -> E.throw e+        , E.Handler $ \(e :: E.SomeException)  -> do+            printException e+            return $ Right (Just UnknownError)+        ]+  case r of+    Right Nothing       -> exitSuccess+    Right (Just reason) -> exitAgdaWith reason+    Left err            -> do+      liftIO $ do+        putStrLn "\n\nError when handling error:"+        putStrLn $ tcErrString err+        helpForLocaleError err+      exitAgdaWith UnknownError+  where+    printException e = liftIO $ putStr $+      -- Andreas, 2024-07-03, issue #7299+      -- Regression in base-4.20: printing of exception produces trailing whitespace.+      -- https://gitlab.haskell.org/ghc/ghc/-/issues/25052+#if MIN_VERSION_base(4,20,0)+      rtrim $+#endif+      E.displayException e++-- | If the error is an IO error, and the error message suggests that+-- the problem is related to locales or code pages, print out some+-- extra information.++helpForLocaleError :: TCErr -> IO ()+helpForLocaleError e = case e of+  (IOException _ _ e)+    | "invalid argument" `List.isInfixOf` show e -> msg+  _                                              -> return ()+  where+  msg = putStr $ unlines+    [ ""+    , "This error may be due to the use of a locale or code page that does not"+    , "support some character used in the program being type-checked."+    , ""+    , "If it is, then one option is to use the option --transliterate, in which"+    , "case unsupported characters are (hopefully) replaced with something else,"+    , "perhaps question marks. However, that could make the output harder to"+    , "read."+    , ""+    , "If you want to fix the problem \"properly\", then you could try one of the"+    , "following suggestions:"+    , ""+    , "* If you are using Windows, try switching to a different code page (for"+    , "  instance by running the command 'CHCP 65001')."+    , ""+    , "* If you are using a Unix-like system, try using a different locale. The"+    , "  installed locales are perhaps printed by the command 'locale -a'. If"+    , "  you have a UTF-8 locale installed (for instance sv_SE.UTF-8), then you"+    , "  can perhaps make Agda use this locale by running something like"+    , "  'LC_ALL=sv_SE.UTF-8 agda <...>'."+    ]
+ src/full/Agda/Mimer/Mimer.hs view
@@ -0,0 +1,1777 @@+-- | This module contains the implementation of Mimer, the current+-- implementation of the auto interactive command (C-c C-a) and the successor of+-- Agsy.+--+-- The overall idea is that Mimer gathers a collection of "components" that it+-- could use for building a solution and tries to refine the goal iteratively+-- using these components. Components include global definitions, local variables,+-- let-bound variables, and recursive calls to the function being defined.+--+-- Mimer manages multiple branches of the search at the same time and assigns a+-- cost to each branch, which is the sum of the costs of all its components. The+-- cost of a component in turn is determined by its type and the number of new+-- metas it introduces.+--+-- A branch can be refined by picking one of its unsolved metavariables and+-- refining it with all available components, resulting in a number of new+-- branches (each one with a higher cost than the original).+--+-- Mimer iteratively refines the branch with the lowest cost until it finds a+-- solution or runs out of time.++module Agda.Mimer.Mimer+  ( MimerResult(..)+  , mimer+  )+  where++import Prelude hiding (null)++import Control.DeepSeq (force, NFData(..))+import Control.Monad+import Control.Monad.Except (catchError)+import Control.Monad.Error.Class (MonadError)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (ReaderT(..), runReaderT, asks, ask, lift)+import Data.Function (on)+import Data.Functor ((<&>))+import Data.List (sortOn, intersect, transpose, (\\))+import qualified Data.List.NonEmpty as NonEmptyList (head)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Maybe (maybeToList, fromMaybe, maybe, isNothing)+import Data.PQueue.Min (MinQueue)+import qualified Data.PQueue.Min as Q+import GHC.Generics (Generic)+import qualified Text.PrettyPrint.Boxes as Box+import qualified Data.Text as Text++import qualified Agda.Benchmarking as Bench+import Agda.Interaction.MakeCase (makeCase, getClauseZipperForIP, recheckAbstractClause)+import Agda.Syntax.Abstract (Expr(AbsurdLam))+import qualified Agda.Syntax.Abstract as A+import qualified Agda.Syntax.Abstract.Views as A+import Agda.Syntax.Abstract.Name (QName(..), Name(..))+import Agda.Syntax.Common (InteractionId(..), MetaId(..), ArgInfo(..), defaultArgInfo, Origin(..), ConOrigin(..), Hiding(..), setOrigin, NameId, Nat, namedThing, Arg(..), setHiding, getHiding, ProjOrigin(..), rangedThing, woThing, nameOf, visible)+import Agda.Syntax.Common.Pretty (Pretty)+import qualified Agda.Syntax.Common.Pretty as P+import qualified Agda.Syntax.Concrete.Name as C+import Agda.Syntax.Info (pattern UnificationMeta, exprNoRange)+import Agda.Syntax.Internal+import Agda.Syntax.Internal.MetaVars (AllMetas(..))+import Agda.Syntax.Internal.Pattern (clausePerm)+import Agda.Syntax.Position (Range, rangeFile, rangeFilePath, noRange)+import qualified Agda.Syntax.Scope.Base as Scope+import Agda.Syntax.Translation.InternalToAbstract (reify, NamedClause(..), blankNotInScope)+import Agda.Syntax.Translation.AbstractToConcrete (abstractToConcrete_)++import Agda.TypeChecking.Primitive (getBuiltinName)+import Agda.TypeChecking.Constraints (noConstraints)+import Agda.TypeChecking.Datatypes (isDataOrRecord)+import Agda.TypeChecking.Conversion (equalType)+import Agda.TypeChecking.Empty (isEmptyType)+import Agda.TypeChecking.Free (flexRigOccurrenceIn, freeVars)+import Agda.TypeChecking.Level (levelType)+import Agda.TypeChecking.MetaVars (newValueMeta)+import Agda.TypeChecking.Monad -- (MonadTCM, lookupInteractionId, getConstInfo, liftTCM, clScope, getMetaInfo, lookupMeta, MetaVariable(..), metaType, typeOfConst, getMetaType, MetaInfo(..), getMetaTypeInContext)+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Records (isRecord, isRecursiveRecord)+import Agda.TypeChecking.Reduce (reduce, instantiateFull, instantiate)+import Agda.TypeChecking.Rules.LHS.Problem (AsBinding(..))+import Agda.TypeChecking.Rules.Term  (makeAbsurdLambda)+import Agda.TypeChecking.Substitute (apply, applyE, piApply, NoSubst(..), pattern TelV, telView')+import Agda.TypeChecking.Telescope (piApplyM, flattenTel, teleArgs)++import Agda.Utils.Benchmark (billTo)+import Agda.Utils.FileName (filePath)+import Agda.Utils.Functor ((<.>))+import Agda.Utils.Impossible (__IMPOSSIBLE__)+import Agda.Utils.Maybe (catMaybes)+import Agda.Utils.Monad (ifM, and2M)+import qualified Agda.Utils.Maybe.Strict as SMaybe+-- import Agda.Utils.Permutation (idP, permute, takeP)+import Agda.Utils.Null+import Agda.Utils.Time (CPUTime(..), getCPUTime, fromMilliseconds)+import Agda.Utils.Tuple (mapFst, mapSnd)+import Agda.Utils.FileName (AbsolutePath(..))++import Agda.Mimer.Options++import System.IO.Unsafe (unsafePerformIO)+import Data.IORef (IORef, writeIORef, readIORef, newIORef, modifyIORef')++-- Temporary (used for custom cost verbosity hack)+import qualified Agda.Utils.Maybe.Strict as Strict+import qualified Agda.Utils.Trie as Trie+import Agda.Interaction.Base (Rewrite(..))+import Agda.Interaction.BasicOps (normalForm)+import Agda.Interaction.Options.Base (parseVerboseKey)+import Agda.Utils.List (lastWithDefault)++data MimerResult+  = MimerExpr String -- ^ Returns 'String' rather than 'Expr' because the give action expects a string.+  | MimerClauses QName [A.Clause]+  | MimerList [(Int, String)]+  | MimerNoResult+  deriving (Generic)++instance NFData MimerResult++-- | Entry point.+--   Run Mimer on the given interaction point, returning the desired solution(s).+--   Also debug prints timing statistics.+mimer :: MonadTCM tcm+  => Rewrite         -- ^ Degree of normalization of solution terms.+  -> InteractionId   -- ^ Hole to run on.+  -> Range           -- ^ Range of hole (for parse errors).+  -> String          -- ^ Content of hole (to parametrize Mimer).+  -> tcm MimerResult+mimer norm ii rng argStr = liftTCM $ do+    reportSDoc "mimer.top" 10 do+      "Running Mimer on interaction point" <+> pretty ii <+> "with argument string" <+> text (show argStr)++    start <- liftIO $ getCPUTime++    opts <- parseOptions ii rng argStr+    reportS "mimer.top" 15 ("Mimer options: " ++ show opts)++    -- Andreas, 2025-04-16, changing the plain getTC/putTC bracket to localTCState.+    -- localTCState should be used by default,+    -- it keeps the Statistics about metas and constraints.+    -- Was there a reason to use plain getTC/putTC or is it "don't care" since+    -- mimer is an interactive command and no one looks at the statistics?+    sols <- localTCState $ runSearch norm opts ii rng++    -- Turn the solutions into the desired results (first solution or list of solutions).+    sol <- case drop (optSkip opts) $ zip [0..] sols of+          [] -> do+            reportSLn "mimer.top" 10 "No solution found"+            return MimerNoResult+          sols' | optList opts -> pure $ MimerList [ (i, s) | (i, MimerExpr s) <- sols' ]+          (_, sol) : _ -> do+            reportSDoc "mimer.top" 10 $ "Solution:" <+> prettyTCM sol+            return sol++    -- Print timing statistic.+    stop <- liftIO $ getCPUTime+    let time = stop - start+    reportSDoc "mimer.top" 10 ("Total elapsed time:" <+> pretty time)+    verboseS "mimer.stats" 50 $ writeTime ii (if null sols then Nothing else Just time)++    return sol+++-- Order to try things in:+-- 1. Local variables (including let-bound)+-- 2. Data constructors+-- 3. Where clauses+-- 4. Lambda abstract+-- Other: Equality, empty type, record projections+-- - If we only use constructors if the target type is a data type, we might+--   generate η-reducible expressions, e.g. λ xs → _∷_ 0 xs+++------------------------------------------------------------------------------+-- * Data types+------------------------------------------------------------------------------++type SM a = ReaderT SearchOptions TCM a++data SearchBranch = SearchBranch+  { sbTCState :: TCState+  , sbGoals :: [Goal]+  , sbCost :: Int+  , sbCache :: Map CheckpointId ComponentCache+  , sbComponentsUsed :: Map Name Int -- ^ Number of times each component has been used+  }+  deriving (Generic)+instance NFData SearchBranch++-- | NOTE: Equality is only on the fields `sbCost` and `sbGoals`+instance Eq SearchBranch where+  sb1 == sb2 = sbCost sb1 == sbCost sb2 && sbGoals sb1 == sbGoals sb2++-- TODO: Explain+instance Ord SearchBranch where+  compare = compare `on` sbCost++-- Map source component to generated components+type ComponentCache = Map Component (Maybe [Component])++data Goal = Goal+  { goalMeta :: MetaId+  }+  deriving (Generic)+instance NFData Goal++-- TODO: Is this a reasonable Eq instance?+instance Eq Goal where+  g1 == g2 = goalMeta g1 == goalMeta g2++-- | Components that are not changed during search. Components that do change+-- (local variables and let bindings) are stored in each 'SearchBranch'.+data BaseComponents = BaseComponents+  { hintFns :: [Component]+  , hintDataTypes :: [Component]+  , hintRecordTypes :: [Component]+  , hintAxioms :: [Component]+  -- ^ Excluding those producing Level+  , hintLevel :: [Component]+  -- ^ A definition in a where clause+  , hintProjections :: [Component]+  -- ^ Variables that are candidates for arguments to recursive calls+  , hintThisFn :: Maybe Component+  , hintLetVars :: [Open Component]+  , hintRecVars :: Open [(Term, NoSubst Term Int)] -- ^ Variable terms and which argument they come from+  , hintSplitVars :: Open [Term]+  }+  deriving (Generic)++instance NFData BaseComponents++type CompId = Int+data Component = Component+  { compId    :: CompId -- ^ Unique id for the component. Used for the cache.+  , compName  :: Maybe Name -- ^ Used for keeping track of how many times a component has been used+  , compPars  :: Nat -- ^ How many arguments should be dropped (e.g. constructor parameters)+  , compTerm  :: Term+  , compType  :: Type+  , compRec   :: Bool -- ^ Is this a recursive call+  , compMetas :: [MetaId]+  , compCost  :: Cost+  }+  deriving (Eq, Generic)++instance NFData Component++-- TODO: Is this reasonable?+instance Ord Component where+  compare = compare `on` compId++data SearchStepResult+  = ResultExpr Expr+  | ResultClauses [A.Clause]+  | OpenBranch SearchBranch+  | NoSolution+  deriving (Generic)+instance NFData SearchStepResult+++data SearchOptions = SearchOptions+  { searchBaseComponents :: BaseComponents+  , searchHintMode :: HintMode+  , searchTimeout :: MilliSeconds+  , searchGenProjectionsLocal :: Bool+  , searchGenProjectionsLet :: Bool+  , searchGenProjectionsExternal :: Bool+  , searchGenProjectionsRec :: Bool+  , searchSpeculateProjections :: Bool+  , searchTopMeta :: MetaId+  , searchTopEnv :: TCEnv+  , searchTopCheckpoint :: CheckpointId+  , searchInteractionId :: InteractionId+  , searchFnName :: Maybe QName+  , searchCosts :: Costs+  , searchStats :: IORef MimerStats+  , searchRewrite :: Rewrite+  , searchBuiltinFlat :: Maybe QName+      -- Cache BUILTIN_FLAT for issue #7662 workaround+  }++type Cost = Int+data Costs = Costs+  { costLocal :: Cost+  , costFn :: Cost+  , costDataCon :: Cost+  , costRecordCon :: Cost+  , costSpeculateProj :: Cost+  , costProj :: Cost+  , costAxiom :: Cost+  , costLet :: Cost+  , costLevel :: Cost+  , costSet :: Cost -- Should probably be replaced with multiple different costs+  , costRecCall :: Cost+  , costNewMeta :: Cost -- ^ Cost of a new meta-variable appearing in a non-implicit position+  , costNewHiddenMeta :: Cost -- ^ Cost of a new meta-variable appearing in an implicit position+  , costCompReuse :: Nat -> Cost -- ^ Cost of reusing a component @n@ times. Only counted when @n>1@.+  }++noCost :: Cost+noCost = 0++defaultCosts :: Costs+defaultCosts = Costs+  { costLocal = 3+  , costFn = 10+  , costDataCon = 3+  , costRecordCon = 3+  , costSpeculateProj = 20+  , costProj = 3+  , costAxiom = 10+  , costLet = 5+  , costLevel = 3+  , costSet = 10+  , costRecCall = 8+  , costNewMeta = 10+  , costNewHiddenMeta = 1+  , costCompReuse = \uses -> 10 * (uses - 1) ^ 2+  }++------------------------------------------------------------------------------+-- * Helper functions+------------------------------------------------------------------------------++predNat :: Nat -> Nat+predNat n | n > 0 = n - 1+          | n == 0 = 0+          | otherwise = error "predNat of negative value"++getRecordFields :: (HasConstInfo tcm, MonadTCM tcm) => QName -> tcm [QName]+getRecordFields = fmap (map unDom . recFields . theDef) . getConstInfo++allOpenMetas :: (AllMetas t, ReadTCState tcm) => t -> tcm [MetaId]+allOpenMetas t = do+  openMetas <- getOpenMetas+  return $ allMetas (:[]) t `intersect` openMetas++getOpenComponent :: (MonadTCM tcm, MonadDebug tcm) => Open Component -> tcm Component+getOpenComponent openComp = do+  let comp = openThing openComp+  reportSDoc "mimer.components.open" 40 $ "Opening component" <+> prettyTCM (compId comp) <+> prettyTCM (compName comp)+  term <- getOpen $ compTerm <$> openComp+  reportSDoc "mimer.components.open" 40 $ "  term = " <+> prettyTCM term+  typ <- getOpen $ compType <$> openComp+  reportSDoc "mimer.components.open" 40 $ "  typ  =" <+> prettyTCM typ+  when (not $ null $ compMetas comp) __IMPOSSIBLE__+  return Component+    { compId    = compId comp+    , compName  = compName comp+    , compPars  = compPars comp+    , compTerm  = term+    , compType  = typ+    , compRec   = compRec comp+    , compMetas = compMetas comp+    , compCost  = compCost comp+    }++mkComponent :: CompId -> [MetaId] -> Cost -> Maybe Name -> Nat -> Term -> Type -> Component+mkComponent cId metaIds cost mName pars term typ = Component+  { compId    = cId+  , compName  = mName+  , compPars  = pars+  , compTerm  = term+  , compType  = typ+  , compRec   = False+  , compMetas = metaIds+  , compCost  = cost }++mkComponentQ :: CompId -> Cost -> QName -> Nat -> Term -> Type -> Component+mkComponentQ cId cost qname = mkComponent cId [] cost (Just $ qnameName qname)++noName :: Maybe Name+noName = Nothing++newComponent :: MonadFresh CompId m => [MetaId] -> Cost -> Maybe Name -> Nat -> Term -> Type -> m Component+newComponent metaIds cost mName pars term typ = fresh <&> \cId -> mkComponent cId metaIds cost mName pars term typ++newComponentQ :: MonadFresh CompId m => [MetaId] -> Cost -> QName -> Nat -> Term -> Type -> m Component+newComponentQ metaIds cost qname pars term typ = fresh <&> \cId -> mkComponent cId metaIds cost (Just $ qnameName qname) pars term typ++addCost :: Cost -> Component -> Component+addCost cost comp = comp { compCost = cost + compCost comp }++addBranchGoals :: [Goal] -> SearchBranch -> SearchBranch+addBranchGoals goals branch = branch {sbGoals = goals ++ sbGoals branch}++withBranchState :: SearchBranch -> SM a -> SM a+withBranchState br ma = do+  putTC (sbTCState br)+  ma++withBranchAndGoal :: SearchBranch -> Goal -> SM a -> SM a+withBranchAndGoal br goal ma = inGoalEnv goal $ withBranchState br ma++inGoalEnv :: Goal -> SM a -> SM a+inGoalEnv goal  ret = do+  reportSDoc "mimer.env" 70 $ "going into environment of goal" <+> prettyTCM (goalMeta goal)+  withMetaId (goalMeta goal) ret++-- | Take the first goal off a search branch.+--   Precondition: the set of goals is non-empty.+nextGoal :: SearchBranch -> (Goal, SearchBranch)+nextGoal branch =+  case sbGoals branch of+    [] -> __IMPOSSIBLE__+    goal : goals -> (goal, branch{ sbGoals = goals })++-- TODO: Rename (see metaInstantiation)+getMetaInstantiation :: (MonadTCM tcm, PureTCM tcm, MonadDebug tcm, MonadInteractionPoints tcm, MonadFresh NameId tcm)+  => MetaId -> tcm (Maybe Expr)+getMetaInstantiation = metaInstantiation >=> traverse (instantiateFull >=> reify)++metaInstantiation :: (MonadTCM tcm, MonadDebug tcm, ReadTCState tcm) => MetaId -> tcm (Maybe Term)+metaInstantiation metaId = lookupLocalMeta metaId <&> mvInstantiation >>= \case+  InstV inst -> return $ Just $ instBody inst+  _ -> return Nothing++-- TODO: why not also accept pattern record types here?+isTypeDatatype :: (MonadTCM tcm, MonadReduce tcm, HasConstInfo tcm) => Type -> tcm Bool+isTypeDatatype typ = liftTCM do+  reduce typ <&> unEl >>= isDataOrRecord <&> \case+    Just (_, IsData) -> True+    _ -> False++------------------------------------------------------------------------------+-- * Components+------------------------------------------------------------------------------++-- | NOTE: Collects components from the *current* context, not the context of+-- the 'InteractionId'.+collectComponents :: Options -> Costs -> InteractionId -> Maybe QName -> [QName] -> MetaId -> TCM BaseComponents+collectComponents opts costs ii mDefName whereNames metaId = do++  lhsVars <- collectLHSVars ii+  let recVars = lhsVars <&> \ vars -> [ (tm, NoSubst i) | (tm, Just i) <- vars ]++  -- TODO: implement case splitting+  -- splitVars <- getSplitVars lhsVars+  splitVars <- makeOpen []++  -- Prepare the initial component record+  letVars <- getLetVars (costLet costs)+  let components = BaseComponents+        { hintFns = []+        , hintDataTypes = []+        , hintRecordTypes = []+        , hintProjections = []+        , hintAxioms = []+        , hintLevel = []+        , hintThisFn = Nothing+        , hintRecVars = recVars+        , hintLetVars = letVars+        , hintSplitVars = splitVars+        }++  -- Extract additional components from the names given as hints.+  hintNames <- getEverythingInScope <$> lookupLocalMeta metaId+  isToLevel <- endsInLevelTester+  scope <- getScope+  components' <- foldM (go isToLevel scope) components $+    explicitHints ++ (hintNames \\ explicitHints)++  return BaseComponents+    { hintFns = doSort $ hintFns components'+    , hintDataTypes = doSort $ hintDataTypes components'+    , hintRecordTypes = doSort $ hintRecordTypes components'+    , hintProjections = doSort $ hintProjections components'+    , hintAxioms = doSort $ hintAxioms components'+    , hintLevel = doSort $ hintLevel components'+    , hintThisFn = hintThisFn components'+    , hintRecVars = recVars+    , hintLetVars = letVars+    , hintSplitVars = splitVars+    }+  where+    hintMode = optHintMode opts+    explicitHints = optExplicitHints opts+    -- Sort by the arity of the type+    doSort = sortOn (arity . compType)++    isNotMutual qname f = case mDefName of+      Nothing -> True+      Just defName -> defName /= qname && fmap (defName `elem`) (funMutual f) /= Just True++    go isToLevel scope comps qname = do+        def <- getConstInfo qname+        let typ = defType def+        case theDef def of+          Axiom{}+            | isToLevel typ -> addLevel+            | shouldKeep    -> addAxiom+            | otherwise     -> done+          -- We can't use pattern lambdas as components nor with-functions.+          -- If the function is in the same mutual block, do not include it.+          f@Function{ funWith = Nothing, funExtLam = Nothing }+            | Just qname == mDefName   -> addThisFn+            | notMutual, isToLevel typ -> addLevel+            | notMutual, shouldKeep    -> addFn+            where notMutual = isNotMutual qname f+          Function{} -> done+          Datatype{} -> addData+          Record{} -> do+            projections <- mapM (qnameToComponent (costSpeculateProj costs)) =<< getRecordFields qname+            comp <- qnameToComponent (costSet costs) qname+            return comps{ hintRecordTypes = comp : hintRecordTypes comps+                        , hintProjections = projections ++ hintProjections comps }+          -- We look up constructors when we need them+          Constructor{} -> done+          -- TODO: special treatment for primitives?+          Primitive{}+            | isToLevel typ  -> addLevel+            | shouldKeep     -> addFn+            | otherwise      -> done+          PrimitiveSort{}    -> done+          -- TODO: Check if we want to use these+          DataOrRecSig{}     -> done+          GeneralizableVar{} -> done+          AbstractDefn{}     -> done+        where+          done = return comps+          -- TODO: There is probably a better way of finding the module name+          mThisModule = qnameModule <$> mDefName++          shouldKeep = or+            [ qname `elem` explicitHints+            , qname `elem` whereNames+            , case hintMode of+                Unqualified -> Scope.isNameInScopeUnqualified qname scope+                AllModules  -> True+                Module      -> Just (qnameModule qname) == mThisModule+                NoHints     -> False+            ]+          addLevel  = qnameToComponent (costLevel   costs) qname <&> \ comp -> comps{hintLevel     = comp : hintLevel  comps}+          addAxiom  = qnameToComponent (costAxiom   costs) qname <&> \ comp -> comps{hintAxioms    = comp : hintAxioms comps}+          addThisFn = qnameToComponent (costRecCall costs) qname <&> \ comp -> comps{hintThisFn    = Just comp{ compRec = True }}+          addFn     = qnameToComponent (costFn      costs) qname <&> \ comp -> comps{hintFns       = comp : hintFns comps}+          addData   = qnameToComponent (costSet     costs) qname <&> \ comp -> comps{hintDataTypes = comp : hintDataTypes comps}++-- | Is an element of the given type computing a level?+--+-- The returned checker is only sound but not complete because the type is taken as-is+-- rather than being reduced.+endsInLevelTester :: TCM (Type -> Bool)+endsInLevelTester = do+  getBuiltinName builtinLevel >>= \case+    Nothing    -> return $ const False+    Just level -> return \ t ->+      -- NOTE: We do not reduce the type before checking, so some user definitions+      -- will not be included here.+      case telView' t of+        TelV _ (El _ (Def x _)) -> x == level+        _ -> False+++qnameToComponent :: (HasConstInfo tcm, ReadTCState tcm, MonadFresh CompId tcm, MonadTCM tcm)+  => Cost -> QName -> tcm Component+qnameToComponent cost qname = do+  defn <- getConstInfo qname+  -- #7120: we need to apply the module params to everything+  mParams <- freeVarsToApply qname+  let def = (Def qname [] `apply` mParams, 0)+  let (term, pars) = case theDef defn of+        c@Constructor{}    -> (Con (conSrcCon c) ConOCon [], conPars c - length mParams)+        Axiom{}            -> def+        GeneralizableVar{} -> def+        Function{}         -> def+        Datatype{}         -> def+        Record{}           -> def+        Primitive{}        -> def+        PrimitiveSort{}    -> def+        DataOrRecSig{}     -> __IMPOSSIBLE__+        AbstractDefn{}     -> __IMPOSSIBLE__+  newComponentQ [] cost qname pars term (defType defn `piApply` mParams)++-- | From the scope of the given meta variable,+--   extract all names in scope that we could use during synthesis.+--   (This excludes macros, generalizable variables, pattern synonyms.)+getEverythingInScope :: MetaVariable -> [QName]+getEverythingInScope metaVar = do+  let scope = clScope $ getMetaInfo metaVar+  let nameSpace = Scope.everythingInScope scope+      names = Scope.nsNames nameSpace+      validKind = \ case+        Scope.PatternSynName           -> False   -- could consider allowing pattern synonyms, but the problem is they can't be getConstInfo'd+        Scope.GeneralizeName           -> False   -- and any way finding the underlying constructors should be easy+        Scope.DisallowedGeneralizeName -> False+        Scope.MacroName                -> False+        Scope.QuotableName             -> False+        Scope.ConName                  -> True+        Scope.CoConName                -> True+        Scope.FldName                  -> True+        Scope.DataName                 -> True+        Scope.RecName                  -> True+        Scope.FunName                  -> True+        Scope.AxiomName                -> True+        Scope.PrimName                 -> True+        Scope.OtherDefName             -> True+      qnames = map Scope.anameName+             . filter (validKind . Scope.anameKind)+             . map NonEmptyList.head+             $ Map.elems names+  qnames++-- | Turn the let bindings of the current 'TCEnv' into components.+getLetVars :: forall tcm. (MonadFresh CompId tcm, MonadTCM tcm, Monad tcm) => Cost -> tcm [Open Component]+getLetVars cost = do+  bindings <- asksTC envLetBindings+  mapM makeComp $ Map.toAscList bindings+  where+    makeComp :: (Name, Open LetBinding) -> tcm (Open Component)+    makeComp (name, opn) = do+      cId <- fresh+      return $ opn <&> \ (LetBinding _origin term typ) ->+                mkComponent cId [] cost (Just name) 0 term (unDom typ)++-- IDEA for implementing case-splitting:+-- [x] 1. Modify the collectRecVarCandidates to get all variables.+-- [ ] 2. Go through all variables to see if they are data types (not records)+-- [ ] 3. Run makeCase for those variables.+-- [ ] 4. Find out how to get the new interaction points/metas from the cases+-- [ ] 5. After search is done, compute out-of-scope variables.+-- [ ] 6. Run make-case again to introduce those variables.+-- [ ] 7. Redo the reification in the new clauses.+-- [ ] 8. Return the new clauses and follow Auto for insertion.++getSplitVars :: Open [(Term, Maybe Int)] -> TCM (Open [Term])+getSplitVars lhsVars' = do++    -- Compute the hintSplitVars from the pattern variables of function at the interaction point.+    lhsVars <- getOpen $ map fst <$> lhsVars'+    typedLocals <- getLocalVarTerms 0+    reportSDoc "mimer.components" 40 $ "All LHS variables:" <+> prettyTCM lhsVars <+> parens ("or" <+> pretty lhsVars)+    let typedLhsVars = filter (\(term,typ) -> term `elem` lhsVars) typedLocals+    reportSDoc "mimer.components" 40 $+      "LHS variables with types:" <+> prettyList (map prettyTCMTypedTerm typedLhsVars) <+> parens ("or"+        <+> prettyList (map prettyTypedTerm typedLhsVars))+    -- TODO: For now, we *never* split on implicit arguments even if they are+    -- written explicitly on the LHS.+    splitVarsTyped <-+      filterM (\ (term, dom) -> pure (visible dom) `and2M` isTypeDatatype (unDom dom))+              typedLhsVars+    reportSDoc "mimer.components" 40 $+      "Splittable variables" <+> prettyList (map prettyTCMTypedTerm splitVarsTyped) <+> parens ("or"+        <+> prettyList (map prettyTypedTerm splitVarsTyped))+    makeOpen $ map fst splitVarsTyped+  where+    prettyTCMTypedTerm :: (PrettyTCM tm, PrettyTCM ty) => (tm, ty) -> TCM Doc+    prettyTCMTypedTerm (term, typ) = prettyTCM term <+> ":" <+> prettyTCM typ+    prettyTypedTerm (term, typ) = pretty term <+> ":" <+> pretty typ++-- | Returns the variables as terms together with whether they where found under+-- some constructor, and if so which argument of the function they appeared in. This+-- information is used when building recursive calls, where it's important that we don't try to+-- construct non-terminating solutions.+collectLHSVars :: (ReadTCState tcm, MonadError TCErr tcm, MonadTCM tcm, HasConstInfo tcm)+  => InteractionId -> tcm (Open [(Term, Maybe Int)])+collectLHSVars ii = do+  ipc <- ipClause <$> lookupInteractionPoint ii+  case ipc of+    IPNoClause -> makeOpen []+    IPClause{ipcQName = fnName, ipcClauseNo = clauseNr} -> do+      reportSDoc "mimer.components" 40 $ "Collecting LHS vars for" <+> prettyTCM ii+      info <- getConstInfo fnName+      parCount <- liftTCM getCurrentModuleFreeVars+      case theDef info of+        fnDef@Function{} -> do+          let clause = funClauses fnDef !! clauseNr+              naps = namedClausePats clause++          -- Telescope at interaction point+          iTel <- getContextTelescope+          -- Telescope for the body of the clause+          let cTel = clauseTel clause+          -- HACK: To get the correct indices, we shift by the difference in telescope lengths+          let shift = length (telToArgs iTel) - length (telToArgs cTel)++          reportSDoc "mimer" 60 $ vcat+            [ "Tel:"+            , nest 2 $ pretty iTel $$ prettyTCM iTel+            , "CTel:"+            , nest 2 $ pretty cTel $$ prettyTCM cTel+            ]+          reportSDoc "mimer" 60 $ "Shift:" <+> pretty shift++          makeOpen [ (Var (n + shift) [], (i - parCount) <$ guard underCon)    -- We count arguments excluding module parameters+                   | (i, nap) <- zip [0..] naps+                   , (n, underCon) <- go False $ namedThing $ unArg nap+                   ]+        _ -> do+          makeOpen []+  where+    go isUnderCon = \case+      VarP patInf x -> [(dbPatVarIndex x, isUnderCon)]+      DotP patInf t -> [] -- Ignore dot patterns+      ConP conHead conPatInf namedArgs -> concatMap (go True . namedThing . unArg) namedArgs+      LitP{} -> []+      ProjP{} -> []+      IApplyP{} -> [] -- Only for Cubical?+      DefP{} -> [] -- Only for Cubical?++declarationQnames :: A.Declaration -> [QName]+declarationQnames dec = [ q | Scope.WithKind _ q <- A.declaredNames dec ]++------------------------------------------------------------------------------+-- * Measure performance+------------------------------------------------------------------------------+data MimerStats = MimerStats+  { statCompHit :: Nat -- ^ Could make use of an already generated component+  , statCompGen :: Nat -- ^ Could use a generator for a component+  , statCompRegen :: Nat -- ^ Had to regenerate the cache (new context)+  , statCompNoRegen :: Nat -- ^ Did not have to regenerate the cache+  , statMetasCreated :: Nat -- ^ Total number of meta-variables created explicitly (not through unification)+  , statTypeEqChecks :: Nat -- ^ Number of times type equality is tested (with unification)+  , statRefineSuccess :: Nat -- ^ Number of times a refinement has been successful+  , statRefineFail :: Nat -- ^ Number of times a refinement has failed+  } deriving (Show, Eq, Generic)+instance NFData MimerStats++emptyMimerStats :: MimerStats+emptyMimerStats = MimerStats+  { statCompHit = 0, statCompGen = 0, statCompRegen = 0 , statCompNoRegen = 0 , statMetasCreated = 0, statTypeEqChecks = 0, statRefineSuccess = 0 , statRefineFail = 0}++incCompHit, incCompGen, incCompRegen, incCompNoRegen, incMetasCreated, incTypeEqChecks, incRefineSuccess, incRefineFail :: MimerStats -> MimerStats+incCompHit       stats = stats {statCompHit       = succ $ statCompHit stats}+incCompGen       stats = stats {statCompGen       = succ $ statCompGen stats}+incCompRegen     stats = stats {statCompRegen     = succ $ statCompRegen stats}+incCompNoRegen   stats = stats {statCompNoRegen   = succ $ statCompNoRegen stats}+incMetasCreated  stats = stats {statMetasCreated  = succ $ statMetasCreated stats}+incTypeEqChecks  stats = stats {statTypeEqChecks  = succ $ statTypeEqChecks stats}+incRefineSuccess stats = stats {statRefineSuccess = succ $ statRefineSuccess stats}+incRefineFail    stats = stats {statRefineFail    = succ $ statRefineFail stats}++updateStat :: (MimerStats -> MimerStats) -> SM ()+updateStat f = verboseS "mimer.stats" 10 $ do+  ref <- asks searchStats+  liftIO $ modifyIORef' ref f+++------------------------------------------------------------------------------+-- * Core algorithm+------------------------------------------------------------------------------++runSearch :: Rewrite -> Options -> InteractionId -> Range -> TCM [MimerResult]+runSearch norm options ii rng = withInteractionId ii $ do+  (mTheFunctionQName, whereNames) <- fmap ipClause (lookupInteractionPoint ii) <&> \case+    clause@IPClause{} -> ( Just $ ipcQName clause+                         , case A.whereDecls $ A.clauseWhereDecls $ ipcClause clause of+                             Just decl -> declarationQnames decl+                             _ -> []+                         )+    IPNoClause -> (Nothing, [])++  reportSDoc "mimer.init" 15 $ "Interaction point in function:" <+> pretty mTheFunctionQName+  reportSDoc "mimer.init" 25 $ "Names in where-block" <+> pretty whereNames++  metaId <- lookupInteractionId ii+  metaVar <- lookupLocalMeta metaId++  -- We want to be able to solve with recursive calls+  setMetaOccursCheck metaId DontRunMetaOccursCheck++  metaIds <- case mvInstantiation metaVar of+    InstV inst -> do++      metaIds <- allOpenMetas (instBody inst)++      -- TODO: Make pretty instantiation for 'Instantiation'?+      reportSDoc "mimer.init" 20 $ sep [ "Interaction point already instantiated:" <+> pretty (instBody inst)+                                       , "with args" <+> pretty (instTel inst) ]++      -- ctx <- getContextTelescope+      -- #7402: still solve the top-level meta, because we don't have the correct contexts for the+      --        submetas+      return [metaId | not $ null metaIds]+    OpenMeta UnificationMeta -> do+      reportSLn "mimer.init" 20 "Interaction point not instantiated."+      return [metaId]+    _ -> __IMPOSSIBLE__+  -- TODO: Print each meta-variable's full context telescope+  reportSDoc "mimer.init" 20 $ "Remaining meta-variables to solve:" <+> prettyTCM metaIds+  reportSDoc "mimer.init" 20 $ "Meta var args" <+> (prettyTCM =<< getMetaContextArgs metaVar)+++  fnArgs1 <- withShowAllArguments' False $ getContextArgs >>= mapM prettyTCM+  fnArgs2 <- withShowAllArguments' True  $ getContextArgs >>= mapM prettyTCM+  let bringScope = map snd $ filter (uncurry (/=)) $ zip fnArgs1 fnArgs2+      bringScopeNoBraces = map (filter (`notElem` ['{', '}']) . P.render) bringScope+  reportSDoc "mimer.temp" 20 $ vcat+    [ "Things to bring into scope:"+    , nest 2 $ vcat+      [ "Context args (don't show):" <+> pretty fnArgs1+      , "Context args (show all):  " <+> pretty fnArgs2+      , "To bring into scope:      " <+> pretty bringScope+      , "To bring into scope (str):" <+> pretty bringScopeNoBraces+      ]+    ]++  -- Check if there are any meta-variables to be solved+  case metaIds of+    -- No variables to solve, return the instantiation given+    [] -> do+      case mvInstantiation metaVar of+        InstV inst -> do+          expr <- withInteractionId ii $ do+            metaArgs <- getMetaContextArgs metaVar+            instantiateFull (apply (MetaV metaId []) metaArgs) >>= normalForm norm >>= reify+          str <- P.render <$> prettyTCM expr+          let sol = MimerExpr str+          reportSDoc "mimer.init" 10 $ "Goal already solved. Solution:" <+> text str+          return [sol]+        _ -> __IMPOSSIBLE__+    _ -> do+      costs <- ifM (hasVerbosity "mimer.cost.custom" 10)+                 {- then -} customCosts+                 {- else -} (return defaultCosts)+      reportSDoc "mimer.cost.custom" 10 $ "Using costs:" $$ nest 2 (pretty costs)+      components <- collectComponents options costs ii mTheFunctionQName whereNames metaId+      let startGoals = map Goal metaIds++      state <- getTC+      env <- askTC++      let startBranch = SearchBranch+            { sbTCState = state+            , sbGoals = startGoals+            , sbCost = 0+            , sbCache = Map.empty+            , sbComponentsUsed = Map.empty+            }++      statsRef <- liftIO $ newIORef emptyMimerStats+      checkpoint <- viewTC eCurrentCheckpoint+      mflat <- getBuiltinName BuiltinFlat+      let searchOptions = SearchOptions+            { searchBaseComponents = components+            , searchHintMode = optHintMode options+            , searchTimeout = optTimeout options+            , searchGenProjectionsLocal = True+            , searchGenProjectionsLet = True+            , searchGenProjectionsExternal = False+            , searchGenProjectionsRec = True+            , searchSpeculateProjections = True+            , searchTopMeta = metaId+            , searchTopEnv = env+            , searchTopCheckpoint = checkpoint+            , searchInteractionId = ii+            , searchFnName = mTheFunctionQName+            , searchCosts = costs+            , searchStats = statsRef+            , searchRewrite = norm+            , searchBuiltinFlat = mflat+            }++      reportSDoc "mimer.init" 20 $ "Using search options:" $$ nest 2 (prettyTCM searchOptions)+      reportSDoc "mimer.init" 20 $ "Initial search branch:" $$ nest 2 (pretty startBranch)++      flip runReaderT searchOptions $ bench [] $ do++        -- TODO: Check what timing stuff is used in Agda.Utils.Time+        timeout <- fromMilliseconds <$> asks searchTimeout+        startTime <- liftIO getCPUTime+        let go :: Int -> Int -> MinQueue SearchBranch -> SM ([MimerResult], Int)+            go 0 n _ = pure ([], n)+            go need n branchQueue = case Q.minView branchQueue of+              Nothing -> do+                reportSLn "mimer.search" 30 $ "No remaining search branches."+                return ([], n)+              Just (branch, branchQueue') -> do+                time <- liftIO getCPUTime+                mimerTrace 0 10 $ vcat+                  [ "Choosing branch"+                  , nest 2 $ sep+                    [ branchInstantiationDocCost branch <> ","+                    , nest 2 $ "metas:" <+> prettyTCM (map goalMeta $ sbGoals branch)+                    ]+                  ]+                reportSDoc "mimer.search" 50 $ "Full branch:" <+> pretty branch+                reportSMDoc "mimer.search" 50 $+                  "Instantiation of other branches:" <+> prettyList (map branchInstantiationDocCost $ Q.toAscList branchQueue')++                let elapsed = time - startTime+                if elapsed < timeout+                then do+                  (newBranches, sols) <- refine branch >>= partitionStepResult+                  let branchQueue'' = foldr Q.insert branchQueue' newBranches+                  reportSLn "mimer.search" 40 $ show (length sols) ++ " solutions found during cycle " ++ show (n + 1)+                  reportSMDoc "mimer.search" 45 $ "Solutions:" <+> prettyTCM sols+                  mimerTrace 0 40 $ vcat+                     [ "Cycle" <+> pretty (n + 1) <+> "branches"+                     , nest 2 $ vcat $ map branchInstantiationDocCost $ Q.toAscList branchQueue''+                     ]+                  unless (null sols) $ mimerTrace 0 20 $ vcat+                     [ "Cycle" <+> pretty (n + 1) <+> "solutions"+                     , nest 2 $ vcat $ map prettyTCM sols+                     ]++                  let sols' = take need sols+                  mapFst (sols' ++) <$> go (need - length sols') (n + 1) branchQueue''+                else do+                  reportSLn "mimer.search" 30 $ "Search time limit reached. Elapsed search time: " ++ show elapsed+                  return ([], n)+        let numSolutions | optList options = 10 + optSkip options+                         | otherwise       = 1 + optSkip options+        (sols, nrSteps) <- go numSolutions 0 $ Q.singleton startBranch+        reportSLn "mimer.search" 20 $ "Search ended after " ++ show (nrSteps + 1) ++ " cycles"+        -- results <- liftTCM $ mapM exprToStringAndVars sols+        reportSDoc "mimer.search" 15 $ "Solutions found: " <+> prettyList (map prettyTCM sols)+        reportSMDoc "mimer.stats" 10 $ do+          ref <- asks searchStats+          stats <- liftIO $ readIORef ref+          "Statistics:" <+> text (show stats)+        return sols++tryComponents :: Goal -> Type -> SearchBranch -> [(Component, [Component])] -> SM [SearchStepResult]+tryComponents goal goalType branch comps = withBranchAndGoal branch goal $ do+  checkpoint <- viewTC eCurrentCheckpoint+  let tryFor (sourceComp, comps') = do+        -- Clear out components that depend on meta-variables that have been used.+        let newCache = Map.insert sourceComp Nothing (sbCache branch Map.! checkpoint)+        newBranches <- catMaybes <$> mapM (tryRefineWith goal goalType branch) comps'+        return $ map (\br -> br{sbCache = Map.insert checkpoint newCache (sbCache branch)}) newBranches+  newBranches <- concatMapM tryFor comps+  mapM checkSolved newBranches++-- | If there is no cache entry for the checkpoint, create one. If there already+-- is one, even if the components are not yet generated for some entries, it is+-- returned as is.+prepareComponents :: Goal -> SearchBranch -> SM (SearchBranch, [(Component, [Component])])+prepareComponents goal branch = withBranchAndGoal branch goal $ do+  reportSDoc "mimer.components" 50 $ "Preparing components for goal" <+> prettyTCM (goalMeta goal)+  checkpoint <- viewTC eCurrentCheckpoint+  -- Check if we there is something in the cache for this checkpoint+  comps <- case Map.lookup checkpoint (sbCache branch) of+    -- No, generate components from scratch+    Nothing -> do+      updateStat incCompRegen+      reportSDoc "mimer.components" 20 $ vcat+        [ "No cache found checkpoint:" <+> pretty checkpoint+        , nest 2 $ "with context:" <+> (inTopContext . prettyTCM =<< getContextTelescope) ]+      -- Generate components for this context+      comps <- genComponents+      reportSDoc "mimer.components" 20 $ "Generated" <+> pretty (sum $ map (length . snd) comps) <+> "components"+      return comps+    -- Yes, just update the missing generated components+    Just cache -> mapM prepare (Map.toAscList cache)+  let newCache = Map.fromList $ map (mapSnd Just) comps+  branch' <- updateBranch [] branch{sbCache = Map.insert checkpoint newCache (sbCache branch)}+  return (branch', comps)+  where+  prepare :: (Component, Maybe [Component]) -> SM (Component, [Component])+  prepare (sourceComp, Just comps) = do+    updateStat incCompNoRegen+    return (sourceComp, comps)+  prepare (sourceComp, Nothing) = do+    updateStat incCompRegen+    (sourceComp,) <$> genComponentsFrom True sourceComp++localVarCount :: SM Int+localVarCount = do+  top <- asks $ length . envContext . searchTopEnv+  cur <- length <$> getContext+  pure $ cur - top++genComponents :: SM [(Component, [Component])]+genComponents = do+  opts <- ask+  let comps = searchBaseComponents opts+  n <- localVarCount+  localVars <- lift (getLocalVars n (costLocal $ searchCosts opts))+    >>= genAddSource (searchGenProjectionsLocal opts)+  recCalls <- genAddSource (searchGenProjectionsRec opts) (maybeToList $ hintThisFn comps)+  letVars <- mapM getOpenComponent (hintLetVars comps)+    >>= genAddSource (searchGenProjectionsLet opts)+  fns <- genAddSource (searchGenProjectionsExternal opts) (hintFns comps)+  axioms <- genAddSource (searchGenProjectionsExternal opts) (hintAxioms comps)+  return $ localVars ++ letVars ++ recCalls ++ fns ++ axioms+  where+    genAddSource :: Bool -> [Component] -> SM [(Component, [Component])]+    genAddSource genProj = mapM (\comp -> (comp,) <$> genComponentsFrom genProj comp)+++genComponentsFrom :: Bool -- ^ Apply record elimination+                  -> Component+                  -> SM [Component]+genComponentsFrom appRecElims origComp = do+  reportSDoc "mimer.components" 50 $ "Generating components from original component" <+> prettyTCM (compId origComp) <+> prettyTCM (compName origComp)+  comps <- if | compRec origComp -> mapM (applyToMetasG Nothing) =<< genRecCalls origComp+              | otherwise        -> (:[]) <$> applyToMetasG Nothing origComp+  if appRecElims+  then concat <$> mapM (applyProjections Set.empty) comps+  else return comps+  where+  applyProjections :: Set QName -> Component -> SM [Component]+  applyProjections seenRecords comp = do+    projComps <- getRecordInfo (compType comp) >>= \case+      Nothing -> return []+      Just (recordName, args, fields, isRecursive)+          | Set.member recordName seenRecords -> do+              reportSDoc "mimer.components" 60 $+                "Skipping projection because recursive record already seen:" <+> pretty recordName+              return []+          | otherwise -> do+              let seenRecords' = if isRecursive then Set.insert recordName seenRecords else seenRecords+              comps <- mapM (applyProj args comp >=> applyToMetasG Nothing) fields+              concatMapM (applyProjections seenRecords') comps+    return $ comp : projComps++getRecordInfo :: Type+  -> SM (Maybe ( QName     -- Record name+               , Args      -- Record parameters converted to (hidden) arguments+               , [QName]   -- Field names+               , Bool      -- Is recursive?+               ))+getRecordInfo typ = case unEl typ of+  Def qname elims -> isRecord qname >>= \case+    Nothing -> return Nothing+    Just defn -> do+      fields <- getRecordFields qname+      return $ Just (qname, argsFromElims elims, fields, recRecursive_ defn)+  _ -> return Nothing++applyProj :: Args -> Component -> QName -> SM Component+applyProj recordArgs comp' qname = do+  cost <- asks (costProj . searchCosts)+  -- Andreas, 2025-03-31, issue #7662: hack to prevent postfix printing of ♭+  projOrigin <- maybe ProjSystem (\ flat -> if qname == flat then ProjPrefix else ProjSystem)+    <$> asks searchBuiltinFlat+  let newTerm = applyE (compTerm comp') [Proj projOrigin qname]+  projType <- defType <$> getConstInfo qname+  projTypeWithArgs <- piApplyM projType recordArgs+  newType <- piApplyM projTypeWithArgs (compTerm comp')+  newComponentQ (compMetas comp') (compCost comp' + cost) qname 0 newTerm newType+++-- TODO: currently reducing twice+applyToMetasG+  :: Maybe Nat -- ^ Max number of arguments to apply.+  -> Component -> SM Component+applyToMetasG (Just m) comp | m <= 0 = return comp+applyToMetasG maxArgs comp = do+  reportSDoc "mimer.component" 25 $ "Applying component to metas" <+> prettyTCM (compId comp) <+> prettyTCM (compTerm comp)+  ctx <- getContextTelescope+  compTyp <- reduce $ compType comp+  case unEl compTyp of+    Pi dom abs -> do+      let domainType = unDom dom+      (metaId, metaTerm) <- createMeta domainType+      reportSDoc "mimer.component" 30 $ "New arg meta" <+> prettyTCM metaTerm+      let arg = setOrigin Inserted $ metaTerm <$ argFromDom dom+      newType <- reduce =<< piApplyM (compType comp) metaTerm+      -- Constructor parameters are not included in the term+      let skip = compPars comp+          newTerm | skip > 0  = compTerm comp+                  | otherwise = apply (compTerm comp) [arg]+      cost <- asks $ (if getHiding arg == Hidden then costNewHiddenMeta else costNewMeta) . searchCosts+      applyToMetasG (predNat <$> maxArgs)+                    comp{ compTerm = newTerm+                        , compType = newType+                        , compPars = predNat skip+                        , compMetas = metaId : compMetas comp+                        , compCost = cost + compCost comp+                        }+    _ ->+      -- Set the type to the reduced version+      return comp{compType = compTyp}++createMeta :: Type -> SM (MetaId, Term)+createMeta typ = do+  (metaId, metaTerm) <- newValueMeta DontRunMetaOccursCheck CmpLeq typ+  verboseS "mimer.stats" 20 $ updateStat incMetasCreated+  reportSDoc "mimer.components" 80 $ do+    "Created meta-variable (type in context):" <+> pretty metaTerm <+> ":" <+> (pretty =<< getMetaTypeInContext metaId)+  return (metaId, metaTerm)+++partitionStepResult :: [SearchStepResult] -> SM ([SearchBranch], [MimerResult])+partitionStepResult [] = return ([],[])+partitionStepResult (x:xs) = do+  let rest = partitionStepResult xs+  (brs',sols) <- rest+  case x of+    NoSolution -> rest+    OpenBranch br -> return (br:brs', sols)+    ResultExpr exp -> do+      str <- P.render <$> prettyTCM exp+      return $ (brs', MimerExpr str : sols)+    ResultClauses cls -> do+      f <- fromMaybe __IMPOSSIBLE__ <$> asks searchFnName+      return $ (brs', MimerClauses f cls : sols)+++topInstantiationDoc :: SM Doc+topInstantiationDoc = asks searchTopMeta >>= getMetaInstantiation >>= maybe (return "(nothing)") prettyTCM++prettyGoalInst :: Goal -> SM Doc+prettyGoalInst goal = inGoalEnv goal $ do+  args <- map Apply <$> getContextArgs+  prettyTCM =<< instantiate (MetaV (goalMeta goal) args)++branchInstantiationDocCost :: SearchBranch -> SM Doc+branchInstantiationDocCost branch = branchInstantiationDoc branch <+> parens ("cost:" <+> pretty (sbCost branch))++-- | For debug+branchInstantiationDoc :: SearchBranch -> SM Doc+branchInstantiationDoc branch = withBranchState branch topInstantiationDoc++refine :: SearchBranch -> SM [SearchStepResult]+refine branch = withBranchState branch $ do+  let (goal1, branch1) = nextGoal branch++  withBranchAndGoal branch1 goal1 $ do+    goalType1 <- bench [Bench.Reduce] $ reduce =<< getMetaTypeInContext (goalMeta goal1)++    mimerTrace 1 10 $ sep+      [ "Refining goal"+      , nest 2 $ prettyTCM (goalMeta goal1) <+> ":" <+> prettyTCM goalType1+      , nest 2 $ "in context" <+> (inTopContext . prettyTCM =<< getContextTelescope)+      ]++    reportSDoc "mimer.refine" 30 $ "Goal type:" <+> pretty goalType1+    reportSDoc "mimer.refine" 30 $ "Goal context:" <+> (pretty =<< getContextTelescope)++    -- Lambda-abstract as far as possible+    tryLamAbs goal1 goalType1 branch1 >>= \case+      -- Absurd lambda+      Left branch2 -> do+        mimerTrace 1 10 $ sep+              [ "Absurd bambda refinement", nest 2 $ prettyGoalInst goal1 ]+        args <- map Apply <$> getContextArgs+        e <- blankNotInScope =<< reify (MetaV (goalMeta goal1) args)+        return [ResultExpr e]+      -- Normal abstraction+      Right (goal2, goalType2, branch2) -> withBranchAndGoal branch2 goal2 $ do+        (branch3, components) <- prepareComponents goal2 branch2+        withBranchAndGoal branch3 goal2 $ do++          when (goalMeta goal2 /= goalMeta goal1) $ do+            mimerTrace 1 10 $ sep+              [ "Lambda refinement", nest 2 $ prettyGoalInst goal1 ]+            mimerTrace 1 10 $ sep+              [ "Refining goal"+              , nest 2 $ prettyTCM (goalMeta goal2) <+> ":" <+> prettyTCM goalType2+              , nest 2 $ "in context" <+> (inTopContext . prettyTCM =<< getContextTelescope)+              ]++          mimerTrace 2 40 $ vcat+            [ "Components:"+            , nest 2 $ vcat $ map prettyTCM $ concatMap snd components+            ]++          results1 <- tryComponents goal2 goalType2 branch3 components+          results2 <- tryDataRecord goal2 goalType2 branch3+          return $ results1 ++ results2++tryFns :: Goal -> Type -> SearchBranch -> SM [SearchStepResult]+tryFns goal goalType branch = withBranchAndGoal branch goal $ do+  reportSDoc "mimer.refine.fn" 50 $ "Trying functions"+  fns <- asks (hintFns . searchBaseComponents)+  newBranches <- catMaybes <$> mapM (tryRefineAddMetas goal goalType branch) fns+  mapM checkSolved newBranches++tryProjs :: Goal -> Type -> SearchBranch -> SM [SearchStepResult]+tryProjs goal goalType branch = withBranchAndGoal branch goal $ do+  projs <- asks (hintProjections . searchBaseComponents)+  newBranches <- catMaybes <$> mapM (tryRefineAddMetas goal goalType branch) projs+  mapM checkSolved newBranches++tryAxioms :: Goal -> Type -> SearchBranch -> SM [SearchStepResult]+tryAxioms goal goalType branch = withBranchAndGoal branch goal $ do+  axioms <- asks (hintAxioms . searchBaseComponents)+  newBranches <- catMaybes <$> mapM (tryRefineAddMetas goal goalType branch) axioms+  mapM checkSolved newBranches++tryLet :: Goal -> Type -> SearchBranch -> SM [SearchStepResult]+tryLet goal goalType branch = withBranchAndGoal branch goal $ do+  letVars <- asks (hintLetVars . searchBaseComponents) >>= mapM getOpenComponent+  newBranches <- catMaybes <$> mapM (tryRefineAddMetas goal goalType branch) letVars+  mapM checkSolved newBranches++-- | Returns @Right@ for normal lambda abstraction and @Left@ for absurd lambda.+tryLamAbs :: Goal -> Type -> SearchBranch -> SM (Either SearchBranch (Goal, Type, SearchBranch))+tryLamAbs goal goalType branch =+  case unEl goalType of+    Pi dom abs -> isEmptyType (unDom dom) >>= \case+      True -> do+        f <- liftTCM $ makeAbsurdLambda noRange dom abs+        args <- map Apply <$> getContextArgs+        newMetaIds <- assignMeta (goalMeta goal) (Def f args) goalType+        Left <$> updateBranch newMetaIds branch+      False -> do+        reportSDoc "mimer.lam" 40 $ "Trying lambda abstraction for pi type" <+> prettyTCM goalType+        let abs' | isNoName (absName abs) = abs { absName = "z" }+                 | otherwise = abs+        (metaId', bodyType, metaTerm, env) <- underAbstractionAbs dom abs' $ \bodyType -> do+          reportSDoc "mimer.lam" 40 $ "  bodyType = " <+> prettyTCM bodyType+          bodyType <- bench [Bench.Reduce] $ reduce bodyType -- TODO: Good place to reduce?+          reportSDoc "mimer.lam" 40 $ "  bodyType (reduced) = " <+> prettyTCM bodyType+          (metaId', metaTerm) <- bench [Bench.Free] $ newValueMeta DontRunMetaOccursCheck CmpLeq bodyType+          reportSDoc "mimer.lam" 40 $ "  metaId' = " <+> prettyTCM metaId'+          env <- askTC+          return (metaId', bodyType, metaTerm, env)++        let argInf = domInfo dom -- TODO: is this the correct arg info?+            newAbs = Abs (absName abs') metaTerm+            -- look at mkLam+            term = Lam argInf newAbs++        newMetaIds <- assignMeta (goalMeta goal) term goalType++        withEnv env $ do+          branch' <- updateBranch newMetaIds branch+          tryLamAbs (Goal metaId') bodyType branch'+    _ -> done+  where+    done = do+      branch' <- updateBranch [] branch -- TODO: Is this necessary?+      return $ Right (goal, goalType, branch')+++genRecCalls :: Component -> SM [Component]+genRecCalls thisFn = do+  reportSDoc "mimer.components.open" 40 $ "Generating recursive calls for component" <+> prettyTCM (compId thisFn) <+> prettyTCM (compName thisFn)+  reportSDoc "mimer.components.open" 60 $ "  checkpoint =" <+> (prettyTCM =<< viewTC eCurrentCheckpoint)+  -- TODO: Make sure there are no pruning problems+  asks (hintRecVars . searchBaseComponents) >>= getOpen >>= \case+    -- No candidate arguments for a recursive call+    [] -> return []+    recCandTerms -> do+      Costs{..} <- asks searchCosts+      n <- localVarCount+      localVars <- lift $ getLocalVars n costLocal+      let recCands = [ (t, i) | t@(compTerm -> v@Var{}) <- localVars, NoSubst i <- maybeToList $ lookup v recCandTerms ]++      let newRecCall = do+            -- Apply the recursive call to new metas+            (thisFnTerm, thisFnType, newMetas) <- applyToMetas 0 (compTerm thisFn) (compType thisFn)+            let argGoals = map Goal newMetas+            comp <- newComponent newMetas (compCost thisFn) (compName thisFn) 0 thisFnTerm thisFnType+            return (comp, zip argGoals [0..])++          -- go :: Component -- ^ Recursive call function applied to meta-variables+          --   -> [(Goal, Int)] -- ^ Remaining parameters to try to fill+          --   -> [(Component, Int)] -- ^ Remaining argument candidates for the current parameter+          --   -> SM [Component]+          go _thisFn [] _args = return []+          go thisFn (_ : goals) [] = go thisFn goals recCands+          go thisFn ((goal, i) : goals) ((arg, j) : args) | i == j = do+            reportSMDoc "mimer.components.rec" 80 $ hsep+              [ "Trying to generate recursive call"+              , prettyTCM (compTerm thisFn)+              , "with" <+> prettyTCM (compTerm arg)+              , "for" <+> prettyTCM (goalMeta goal) ]+            goalType <- getMetaTypeInContext (goalMeta goal)+            state <- getTC+            tryRefineWith' goal goalType arg >>= \case+              Nothing -> do+                putTC state+                go thisFn ((goal, i) : goals) args+              Just (newMetas1, newMetas2) -> do+                let newComp = thisFn{compMetas = newMetas1 ++ newMetas2 ++ (compMetas thisFn \\ [goalMeta goal])}+                (thisFn', goals') <- newRecCall+                (newComp:) <$> go thisFn' (drop (length goals' - length goals - 1) goals') args+          go thisFn goals (_ : args) = go thisFn goals args+      (thisFn', argGoals) <- newRecCall+      comps <- go thisFn' argGoals recCands+      -- Compute costs for the calls:+      --  - costNewMeta/costNewHiddenMeta for each unsolved argument+      --  - zero for solved arguments+      --  - costLocal for the parameter we recurse on+      let callCost comp = (costLocal +) . sum <$> argCosts (compTerm comp)+          argCosts (Def _ elims) = mapM argCost elims+          argCosts _ = __IMPOSSIBLE__+          argCost (Apply arg) = instantiate arg <&> \ case+            Arg h MetaV{} | visible h -> costNewMeta+                          | otherwise -> costNewHiddenMeta+            _ -> 0+          argCost Proj{}   = pure 0+          argCost IApply{} = pure 0+      mapM (\ c -> (`addCost` c) <$> callCost c) comps+++-- TODO: Factor out `checkSolved`+tryDataRecord :: Goal -> Type -> SearchBranch -> SM [SearchStepResult]+tryDataRecord goal goalType branch = withBranchAndGoal branch goal $ do+  -- TODO: There is a `isRecord` function, which performs a similar case+  -- analysis as here, but it does not work for data types.+  case unEl goalType of+    Def qname elims -> theDef <$> getConstInfo qname >>= \case+      recordDefn@Record{} -> do+        tryRecord recordDefn+      dataDefn@Datatype{} -> do+        tryData dataDefn+      primitive@Primitive{} -> do+        return []+      -- TODO: Better way of checking that type is Level+      Axiom{}+        | P.prettyShow qname == "Agda.Primitive.Level" -> do+            tryLevel+        | otherwise -> do+        return []+      DataOrRecSig{} -> do+        return []+      GeneralizableVar{} -> do+        return []+      AbstractDefn{} -> do+        return []+      Function{} -> do+        return []+      Constructor{} -> do+        return []+      PrimitiveSort{} -> do+        return []+    Sort (Type level) -> do+      trySet level+    Sort sort -> do+      return []+    _ -> return []+  where+      -- TODO: Alternatively, the constructor can be accessed via `getRecordConstructor`+      -- TODO: There might be a neater way of applying the constructor to new metas+    tryRecord :: Defn -> SM [SearchStepResult]+    tryRecord recordDefn = do+      cost <- asks (costRecordCon . searchCosts) -- TODO: Use lenses for this?+      comp <- qnameToComponent cost $ conName $ recConHead recordDefn+      -- NOTE: at most 1+      newBranches <- maybeToList <$> tryRefineAddMetas goal goalType branch comp+      mapM checkSolved newBranches++    tryData :: Defn -> SM [SearchStepResult]+    tryData dataDefn = do+      let constructors = dataCons dataDefn+      reportSDoc "mimer.try" 40 $ hsep $ "tryData" : map prettyTCM constructors+      cost <- asks (costDataCon . searchCosts)+      comps <- mapM (qnameToComponent cost) constructors+      newBranches <- mapM (tryRefineAddMetas goal goalType branch) comps+      -- TODO: Reduce overlap between e.g. tryLocals, this and tryRecord+      mapM checkSolved (catMaybes newBranches)++    tryLevel :: SM [SearchStepResult]+    tryLevel = do+      levelHints <- asks (hintLevel . searchBaseComponents)+      newBranches <- catMaybes <$> mapM (tryRefineAddMetas goal goalType branch) levelHints+      mapM checkSolved newBranches++    -- TODO: Add an extra filtering on the sort+    trySet :: Level -> SM [SearchStepResult]+    trySet level = do+      reducedLevel <- reduce level+      cost <- asks (costSet . searchCosts)+      setCandidates <- case reducedLevel of+        (Max i [])+          | i > 0 -> do+              comp <- newComponent [] cost Nothing 0 (Sort $ Type $ Max (i - 1) []) goalType+              return [(branch, comp)]+          | otherwise -> return []+        (Max i ps) -> do+              (metaId, metaTerm) <- createMeta =<< levelType+              comp <- newComponent [metaId] cost Nothing 0 (Sort $ Type $ Max (max 0 (i - 1)) [Plus 0 metaTerm]) goalType+              branch' <- updateBranch [metaId] branch+              return [(branch', comp)]+      reportSDoc "mimer.refine.set" 40 $+        "Trying" <+> prettyTCM (map snd setCandidates) <+> "for" <+> prettyTCM goalType+      newBranches <- catMaybes <$> mapM (\(br,c) -> tryRefineWith goal goalType br c) setCandidates+      components <- asks searchBaseComponents+      newBranches' <- catMaybes <$> mapM (tryRefineAddMetas goal goalType branch)+                      (concatMap ($ components)+                       [ hintDataTypes+                       , hintRecordTypes+                       , hintAxioms])+      mapM checkSolved (newBranches ++ newBranches')++-- | Type should already be reduced here+-- NOTE: Does not reset the state!+-- TODO: Make sure the type is always reduced+tryRefineWith :: Goal -> Type -> SearchBranch -> Component -> SM (Maybe SearchBranch)+tryRefineWith goal goalType branch comp = withBranchAndGoal branch goal $ do++  metasCreatedBy (dumbUnifierErr (compType comp) goalType) >>= \case+    (Nothing, newMetaStore) -> do+      updateStat incRefineSuccess+      -- TODO: Why is newMetaIds not used here?+      newMetaIds <- assignMeta (goalMeta goal) (compTerm comp) goalType+      let newMetaIds' = Map.keys (openMetas newMetaStore)+      reportSDoc "mimer.refine" 60 $+        "Refine: assignMeta created new metas:" <+> prettyTCM newMetaIds++      reportSMDoc "mimer.refine" 50 $ "Refinement succeeded"++      mimerTrace 2 10 $ sep+        [ "Found refinement"+        , nest 2 $ sep [ prettyTCM (compTerm comp)+                       , ":" <+> prettyTCM (compType comp) ] ]+      -- Take the metas stored in the component and add them as sub-goals+      Just <$> updateBranchCost comp (newMetaIds' ++ compMetas comp) branch+    (Just err, _) -> do+      updateStat incRefineFail+      reportSMDoc "mimer.refine" 50 $ "Refinement failed"++      mimerTrace 2 60 $ vcat+        [ "Failed refinement"+        , nest 2 $ sep [ prettyTCM (compTerm comp)+                       , ":" <+> prettyTCM (compType comp) ]+        , nest 2 $ prettyTCM err ]+      return Nothing++tryRefineWith' :: Goal -> Type -> Component -> SM (Maybe ([MetaId], [MetaId]))+tryRefineWith' goal goalType comp = do+  metasCreatedBy (dumbUnifier (compType comp) goalType) >>= \case+    (True, newMetaStore) -> do+      newMetaIds <- assignMeta (goalMeta goal) (compTerm comp) goalType+      let newMetaIds' = Map.keys (openMetas newMetaStore)+      return $ Just (newMetaIds, newMetaIds')+    (False, _) -> return Nothing++-- TODO: Make policy for when state should be put+tryRefineAddMetas :: Goal -> Type -> SearchBranch -> Component -> SM (Maybe SearchBranch)+tryRefineAddMetas goal goalType branch comp = withBranchAndGoal branch goal $ do+  -- Apply the hint to new metas (generating @c@, @c ?@, @c ? ?@, etc.)+  -- TODO: Where is the best place to reduce the hint type?+  comp' <- applyToMetasG Nothing comp+  branch' <- updateBranch [] branch+  tryRefineWith goal goalType branch' comp'++-- TODO: Make sure the type is reduced the first time this is called+-- TODO: Rewrite with Component?+-- NOTE: The new metas are in left-to-right order -- the opposite of the+-- order they should be solved in.+applyToMetas :: Nat -> Term -> Type -> SM (Term, Type, [MetaId])+applyToMetas skip term typ = do+  ctx <- getContextTelescope+  case unEl typ of+    Pi dom abs -> do+      let domainType = unDom dom+      -- TODO: What exactly does the occur check do?+      (metaId', metaTerm) <- bench [Bench.Free] $ newValueMeta DontRunMetaOccursCheck CmpLeq domainType+      let arg = setOrigin Inserted $ metaTerm <$ argFromDom dom+      newType <- bench [Bench.Reduce] $ reduce =<< piApplyM typ metaTerm -- TODO: Is this the best place to reduce?+      -- For records, the parameters are not included in the term+      let newTerm = if skip > 0 then term else apply term [arg]+      (term', typ', metas) <- applyToMetas (predNat skip) newTerm newType+      return (term', typ', metaId' : metas)+    _ -> return (term, typ, [])++normaliseSolution :: Term -> SM Term+normaliseSolution t = do+  norm <- asks searchRewrite+  lift . normalForm norm =<< instantiateFull t++checkSolved :: SearchBranch -> SM SearchStepResult+checkSolved branch = do+  reportSDoc "mimer" 20 $ "Checking if branch is solved"+  reportSDoc "mimer" 30 $ "  remaining subgoals: " <+> prettyTCM (map goalMeta $ sbGoals branch)+  topMetaId <- asks searchTopMeta+  topMeta <- lookupLocalMeta topMetaId+  ii <- asks searchInteractionId+  withInteractionId ii $ withBranchState branch $ do+    metaArgs <- getMetaContextArgs topMeta+    inst <- normaliseSolution $ apply (MetaV topMetaId []) metaArgs+    -- Issue #7639: The subgoals as generated by `applyToMetasG` (and other functions)+    -- are already stored in the `sbGoals` field of the branch.+    -- Here we just prune the subgoals that are already solved by unification.+    goals <- filterM (isNothing <.> getMetaInstantiation . goalMeta) $ sbGoals branch+    case goals of+      -- Issue #378: Blank out variables that are not in scope.+      -- This might leave unsolved metas but is probably better+      -- than generating out-of-scope variables.+      [] -> ResultExpr <$> (blankNotInScope =<< reify inst)+      _ -> do+        return $ OpenBranch branch { sbGoals = goals }++setAt :: Int -> a -> [a] -> [a]+setAt i x xs = case splitAt i xs of+  (ls, _r:rs) -> ls ++ (x : rs)+  _ -> error "setAt: index out of bounds"++updateBranch' :: Maybe Component -> [MetaId] -> SearchBranch -> SM SearchBranch+updateBranch' mComp newMetaIds branch = do+  state <- getTC+  let compsUsed = sbComponentsUsed branch+  (deltaCost, compsUsed') <- case mComp of+        Nothing -> return (0, compsUsed)+        Just comp -> do+          case compName comp of+            Nothing -> return (compCost comp, compsUsed)+            Just name -> case compsUsed Map.!? name of+              Nothing -> return (compCost comp, Map.insert name 1 compsUsed)+              Just uses -> do+                reuseCost <- asks (costCompReuse . searchCosts)+                return (compCost comp + reuseCost uses, Map.adjust succ name compsUsed)+  return branch{ sbTCState = state+               , sbGoals = map Goal newMetaIds ++ sbGoals branch+               , sbCost = sbCost branch + deltaCost+               , sbComponentsUsed = compsUsed'+               }++updateBranch :: [MetaId] -> SearchBranch -> SM SearchBranch+updateBranch = updateBranch' Nothing++updateBranchCost :: Component -> [MetaId] -> SearchBranch -> SM SearchBranch+updateBranchCost comp = updateBranch' (Just comp)++assignMeta :: MetaId -> Term -> Type -> SM [MetaId]+assignMeta metaId term metaType = bench [Bench.CheckRHS] $ do+  ((), newMetaStore) <- metasCreatedBy $ do+    metaVar <- lookupLocalMeta metaId+    metaArgs <- getMetaContextArgs metaVar++    reportSMDoc "mimer.assignMeta" 60 $ vcat+      [ "Assigning" <+> pretty term+      , nest 2 $ vcat [ "to" <+> pretty metaId <+> ":" <+> pretty metaType+                      , "in context" <+> (pretty =<< getContextTelescope)+                      ]+      ]++    assignV DirLeq metaId metaArgs term (AsTermsOf metaType) `catchError` \err -> do+      reportSMDoc "mimer.assignMeta" 30 $ vcat+        [ "Got error from assignV:" <+> prettyTCM err+        , nest 2 $ vcat+          [ "when trying to assign" <+> prettyTCM term+          , "to" <+> prettyTCM metaId <+> ":" <+> prettyTCM metaType+          , "in context" <+> (inTopContext . prettyTCM =<< getContextTelescope)+          ]+        ]++  let newMetaIds = Map.keys (openMetas newMetaStore)+  return newMetaIds++dumbUnifier :: Type -> Type -> SM Bool+dumbUnifier t1 t2 = isNothing <$> dumbUnifierErr t1 t2++dumbUnifierErr :: Type -> Type -> SM (Maybe TCErr)+dumbUnifierErr t1 t2 = bench [Bench.UnifyIndices] $ do+  updateStat incTypeEqChecks+  noConstraints (Nothing <$ equalType t2 t1) `catchError` \err -> do+    reportSDoc "mimer.unify" 80 $ sep [ "Unification failed with error:", nest 2 $ prettyTCM err ]+    return $ Just err++-- Duplicate of a local definition in Agda.Interaction.BasicOps+showTCM :: (MonadPretty tcm, PrettyTCM a) => a -> tcm String+showTCM v = P.render <$> prettyTCM v++bench :: NFData a => [Bench.Phase] -> SM a -> SM a+bench k ma = billTo (mimerAccount : k) ma+  where+    -- Dummy account to avoid updating Bench. Doesn't matter since this is only used interactively+    -- to debug Mimer performance.+    mimerAccount = Bench.Sort++-- Local variables:+-- getContext :: MonadTCEnv m => m [Dom (Name, Type)]+-- getContextArgs :: (Applicative m, MonadTCEnv m) => m Args+-- getContextTelescope :: (Applicative m, MonadTCEnv m) => m Telescope+-- getContextTerms :: (Applicative m, MonadTCEnv m) => m [Term]+getLocalVars :: Int -> Cost -> TCM [Component]+getLocalVars localCxt cost = do+  typedTerms <- getLocalVarTerms localCxt+  let varZeroDiscount (Var 0 []) = 1+      varZeroDiscount _          = 0+  mapM (\(term, domTyp) -> newComponent [] (cost - varZeroDiscount term) noName 0 term (unDom domTyp)) typedTerms++getLocalVarTerms :: Int -> TCM [(Term, Dom Type)]+getLocalVarTerms localCxt = do+  contextTerms <- getContextTerms+  contextTypes <- flattenTel <$> getContextTelescope+  let inScope i _ | i < localCxt = pure True   -- Ignore scope for variables we inserted ourselves+      inScope _ Dom{ unDom = name } = do+        x <- abstractToConcrete_ name+        pure $ C.isInScope x == C.InScope+  scope <- mapM (uncurry inScope) =<< getContextVars+  return [ e | (True, e) <- zip scope $ zip contextTerms contextTypes ]++++prettyBranch :: SearchBranch -> SM String+prettyBranch branch = withBranchState branch $ do+    metaId <- asks searchTopMeta+    P.render <$> "Branch" <> braces (sep $ punctuate ","+      [ "cost:" <+> pretty (sbCost branch)+      , "metas:" <+> prettyTCM (map goalMeta (sbGoals branch))+      , sep [ "instantiation:"+            , nest 2 $ pretty metaId <+> "=" <+> (prettyTCM =<< getMetaInstantiation metaId) ]+      , "used components:" <+> pretty (Map.toList $ sbComponentsUsed branch)+      ])+++instance Pretty Goal where+  pretty goal = P.pretty $ goalMeta goal++instance Pretty SearchBranch where+  pretty branch = keyValueList+    [ ("sbTCState", "[...]")+    , ("sbGoals", P.pretty $ sbGoals branch)+    , ("sbCost", P.pretty $ sbCost branch)+    , ("sbComponentsUsed", P.pretty $ sbComponentsUsed branch)+    ]+++instance PrettyTCM BaseComponents where+  prettyTCM comps = do+    let thisFn = case hintThisFn comps of+          Nothing -> "(nothing)"+          Just comp -> prettyComp comp+    vcat [ "Base components:"+         , nest 2 $ vcat+           [ f "hintFns" (hintFns comps)+           , f "hintDataTypes" (hintDataTypes comps)+           , f "hintRecordTypes" (hintRecordTypes comps)+           , f "hintAxioms" (hintAxioms comps)+           , f "hintLevel" (hintLevel comps)+           , f "hintProjections" (hintProjections comps)+           , "hintThisFn:" <+> thisFn+           , g prettyOpenComp "hintLetVars" (hintLetVars comps)+           , "hintRecVars: Open" <+> pretty (mapSnd unNoSubst <$> openThing (hintRecVars comps))+           , "hintSplitVars: Open" <+> pretty (openThing $ hintSplitVars comps)+           ]+         ]+    where+      prettyComp comp = pretty (compTerm comp) <+> ":" <+> pretty (compType comp)+      prettyOpenComp openComp = "Open" <+> parens (prettyComp $ openThing openComp)+      prettyTCMComp comp = prettyTCM (compTerm comp) <+> ":" <+> prettyTCM (compType comp)+      f = g prettyTCMComp+      g p n [] = n <> ": []"+      g p n xs = (n <> ":") $+$ nest 2 (vcat $ map p xs)+++-- -- TODO: Is it possible to derive the pretty instances?+instance Pretty BaseComponents where+  pretty comps = P.vcat+      [ f "hintFns" (hintFns comps)+      , f "hintDataTypes" (hintDataTypes comps)+      , f "hintRecordTypes" (hintRecordTypes comps)+      , f "hintAxioms" (hintAxioms comps)+      , f "hintLevel" (hintLevel comps)+      , f "hintProjections" (hintProjections comps)+      ]+    where+      f n [] = n P.<> ": []"+      f n xs = (n P.<> ":") P.$$ P.nest 2 (P.pretty xs)++instance Pretty SearchOptions where+  pretty opts = P.vcat+    [ "searchBaseComponents:"+    , P.nest 2 $ P.pretty $ searchBaseComponents opts+    , keyValueList+      [ ("searchHintMode", P.pretty $ searchHintMode opts)+      , ("searchTimeout",  P.pretty $ searchTimeout opts)+      , ("searchTopMeta",  P.pretty $ searchTopMeta opts)+      , ("searchTopEnv", "[...]")+      ]+    , "searchCosts:"+    , P.nest 2 (P.pretty $ searchCosts opts)+    ]++instance PrettyTCM SearchOptions where+  prettyTCM opts = vcat+    [ "searchBaseComponents:"+    , nest 2 $ prettyTCM $ searchBaseComponents opts+    , vcat+      [ "searchHintMode:" <+> pretty (searchHintMode opts)+      , "searchTimeout:" <+> pretty (searchTimeout opts)+      , "searchTopMeta:" <+> prettyTCM (searchTopMeta opts)+      , "searchTopEnv: [...]"+      , "searchTopCheckpoint:" <+> prettyTCM (searchTopCheckpoint opts)+      , "searchInteractionId:" <+> pretty (searchInteractionId opts)+      , "searchFnName:" <+> pretty (searchFnName opts)+      , "searchStats: [...]"+      ]+    , "searchCosts:"+    , nest 2 $ pretty $ searchCosts opts+    ]++instance Pretty Component where+  pretty comp = haskellRecord "Component"+    [ ("compId", P.pretty $ compId comp)+    , ("compTerm", P.pretty $ compTerm comp)+    , ("compType", P.pretty $ compType comp)+    , ("compMetas", P.pretty $ compMetas comp)+    , ("compCost", P.pretty $ compCost comp)+    ]++instance Pretty Costs where+  pretty costs = P.align 20 entries+    where+      entries =+        [ ("costLocal:"         , P.pretty $ costLocal costs)+        , ("costFn:"            , P.pretty $ costFn costs)+        , ("costDataCon:"       , P.pretty $ costDataCon costs)+        , ("costRecordCon:"     , P.pretty $ costRecordCon costs)+        , ("costSpeculateProj:" , P.pretty $ costSpeculateProj costs)+        , ("costProj:"          , P.pretty $ costProj costs)+        , ("costAxiom:"         , P.pretty $ costAxiom costs)+        , ("costLet:"           , P.pretty $ costLet costs)+        , ("costLevel:"         , P.pretty $ costLevel costs)+        , ("costSet:"           , P.pretty $ costSet costs)+        , ("costRecCall:"       , P.pretty $ costRecCall costs)+        , ("costNewMeta:"       , P.pretty $ costNewMeta costs)+        , ("costNewHiddenMeta:" , P.pretty $ costNewHiddenMeta costs)+        , ("costCompReuse:"     , "{function}")+        ]++instance PrettyTCM Component where+  prettyTCM Component{..} = parens (prettyTCM compId) <+> sep+    [ sep [ prettyTCM compTerm+          , ":" <+> prettyTCM compType ]+    , parens $ fsep $ punctuate ","+      [ "cost:" <+> prettyTCM compCost+      , "metas:" <+> prettyTCM compMetas+      ]+    ]++instance PrettyTCM MimerResult where+  prettyTCM = \case+    MimerExpr expr    -> pretty expr+    MimerClauses f cl -> "MimerClauses" <+> pretty f <+> "[..]" -- TODO: display the clauses+    MimerNoResult     -> "MimerNoResult"+    MimerList sols    -> "MimerList" <+> pretty sols++concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+concatMapM f = fmap concat . mapM f++reportSMDoc :: VerboseKey -> VerboseLevel -> SM Doc -> SM ()+reportSMDoc vk vl md = reportSDoc vk vl . runReaderT md =<< ask++mimerTrace :: Int -> VerboseLevel -> SM Doc -> SM ()+mimerTrace ilvl vlvl doc = reportSMDoc "mimer.trace" vlvl $ nest (2 * ilvl) $ "-" <+> doc++haskellRecord :: Doc -> [(Doc, Doc)] -> Doc+haskellRecord name fields = P.sep [ name, P.nest 2 $ P.braces (P.sep $ P.punctuate "," [ P.hang (k P.<+> "=") 2 v | (k, v) <- fields ]) ]++keyValueList :: [(Doc, Doc)] -> Doc+keyValueList kvs = P.braces $ P.sep $ P.punctuate "," [ P.hang (k P.<> ":") 2 v | (k, v) <- kvs ]++writeTime :: (ReadTCState m, MonadError TCErr m, MonadTCM m, MonadDebug m) => InteractionId -> Maybe CPUTime -> m ()+writeTime ii mTime = do+  let time = case mTime of+        Nothing -> "n/a"+        Just (CPUTime t) -> show t+  file <- rangeFile . ipRange <$> lookupInteractionPoint ii+  case file of+    SMaybe.Nothing ->+      reportSLn "mimer.stats" 2 "No file found for interaction id"+    SMaybe.Just file -> do+      let path = filePath (rangeFilePath file) ++ ".stats"+      liftIO $ appendFile path (show (interactionId ii) ++ " " ++ time ++ "\n")++-- Hack to let you experiment with costs using verbosity flags.+customCosts :: TCM Costs+customCosts = do+  costLocal         <- cost "local"+  costFn            <- cost "fn"+  costDataCon       <- cost "dataCon"+  costRecordCon     <- cost "recordCon"+  costSpeculateProj <- cost "speculateProj"+  costProj          <- cost "proj"+  costAxiom         <- cost "axiom"+  costLet           <- cost "let"+  costLevel         <- cost "level"+  costSet           <- cost "set"+  costRecCall       <- cost "recCall"+  costNewMeta       <- cost "newMeta"+  costNewHiddenMeta <- cost "newHiddenMeta"+  compReuse         <- cost "compReuse"+  let costCompReuse uses = compReuse * uses ^ 2+  pure Costs{..}+  where+    cost key = getVerbosityLevel ("mimer-cost." ++ key)++getVerbosityLevel :: MonadDebug m => VerboseKey -> m VerboseLevel+getVerbosityLevel k = do+  t <- getVerbosity+  return $ case t of+    Strict.Nothing -> 1+    Strict.Just t+      | t == Trie.singleton [] 0 -> 0+      | otherwise -> lastWithDefault 0 $ Trie.lookupPath ks t+  where ks = parseVerboseKey k
+ src/full/Agda/Mimer/Options.hs view
@@ -0,0 +1,89 @@+module Agda.Mimer.Options where++import Data.Char+import Data.Maybe+import Text.Read++import Agda.Interaction.BasicOps (parseExprIn)+import Agda.Syntax.Common (Nat)+import Agda.Syntax.Common.Pretty (Pretty, pretty, text)+import Agda.Syntax.Abstract.Name (QName)+import Agda.TypeChecking.Monad.Base (TCM)+import Agda.Interaction.Highlighting.Range (empty)+import Agda.Syntax.Common (InteractionId)+import Agda.Syntax.Position (Range)+import qualified Agda.Syntax.Abstract as A+import qualified Agda.Syntax.Abstract.Name as AN+import Agda.Utils.Maybe (catMaybes)++type MilliSeconds = Integer++data HintMode = Unqualified | AllModules | Module | NoHints+  deriving (Eq, Show)++data Options = Options+  { optTimeout :: MilliSeconds+  , optHintMode :: HintMode+  , optSkip :: Int  -- ^ Skip the first this many solutions+  , optList :: Bool -- ^ List solutions instead of filling the hole+  , optExplicitHints :: [QName]+  } deriving Show++parseOptions :: InteractionId -> Range -> String -> TCM Options+parseOptions ii range argStr = do+  let tokens = readTokens $ words argStr+  -- TODO: Use 'parseName' instead?+  hintExprs <- sequence [parseExprIn ii range h | H h <- tokens]+  let hints = catMaybes $ map hintExprToQName hintExprs+  return Options+    { optTimeout = firstOr 1000 [fromIntegral $ parseTime t | T t <- tokens]+    -- TODO: Do arg properly+    , optHintMode = firstOr NoHints ([Module | M <- tokens] ++ [Unqualified | U <- tokens])+    , optExplicitHints = hints+    , optList = L `elem` tokens+    , optSkip = firstOr 0 [ n | S s <- tokens, n <- maybeToList $ readMaybe s ]+    }++parseTime :: String -> Int+parseTime [] = 0+parseTime xs = read ds * modifier + parseTime r where+  (ds , modr) = span isDigit xs+  (mod , r)   = break isDigit modr++  modifier = case mod of+    "ms" -> 1+    "cs" -> 10+    "ds" -> 100+    "s"  -> 1000+    _    -> 1000++hintExprToQName :: A.Expr -> Maybe QName+hintExprToQName (A.ScopedExpr _ e) = hintExprToQName e+hintExprToQName (A.Def qname)      = Just $ qname+hintExprToQName (A.Proj _ qname)   = Just $ AN.headAmbQ qname+hintExprToQName (A.Con qname)      = Just $ AN.headAmbQ qname+hintExprToQName _ = Nothing++firstOr :: a -> [a] -> a+firstOr x [] = x+firstOr _ (x:_) = x+++data Token = T String | M | U | C | L | S String | H String+  deriving (Eq, Show)++readTokens :: [String] -> [Token]+readTokens []              = []+readTokens ("-t" : t : ws) = T t : readTokens ws+readTokens ("-s" : n : ws) = S n : readTokens ws+readTokens ("-l"     : ws) = L   : readTokens ws+readTokens ("-m"     : ws) = M   : readTokens ws+readTokens ("-c"     : ws) = C   : readTokens ws+readTokens ("-u"     : ws) = U   : readTokens ws+readTokens (h        : ws) = H h : readTokens ws++instance Pretty HintMode where+  pretty = text . show++-- instance Pretty Options where+--   prettyht
src/full/Agda/Syntax/Abstract.hs view
@@ -18,20 +18,19 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe-import Data.Sequence (Seq, (<|), (><))-import qualified Data.Sequence as Seq import qualified Data.Set as Set import Data.Set (Set) import Data.Void-import Data.Data (Data)  import GHC.Generics (Generic) -import Agda.Syntax.Concrete (FieldAssignment'(..), exprFieldA)--, HoleContent'(..))+import Agda.Syntax.Concrete (FieldAssignment'(..), TacticAttribute'(..)) import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Pretty () import Agda.Syntax.Abstract.Name import qualified Agda.Syntax.Internal as I import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty import Agda.Syntax.Info import Agda.Syntax.Literal import Agda.Syntax.Position@@ -39,11 +38,11 @@  import Agda.TypeChecking.Positivity.Occurrence -import Agda.Utils.Lens import Agda.Utils.List1 (List1, pattern (:|)) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Null-import Agda.Utils.Pretty+import Agda.Utils.Set1 (Set1)+import qualified Agda.Utils.Set1 as Set1  import Agda.Utils.Impossible @@ -56,7 +55,7 @@ -- e.g. in @{_ : A} -> ..@ vs. @{r : A} -> ..@.  newtype BindName = BindName { unBind :: Name }-  deriving (Show, Data, HasRange, KillRange, SetRange, NFData)+  deriving (Show, HasRange, KillRange, SetRange, NFData)  mkBindName :: Name -> BindName mkBindName x = BindName x@@ -73,6 +72,10 @@  type Args = [NamedArg Expr] +-- | Types are just expressions.+-- Use this type synonym for hinting that an expression should be a type.+type Type = Expr+ -- | Expressions after scope checking (operators parsed, names resolved). data Expr   = Var  Name                          -- ^ Bound variable.@@ -94,34 +97,33 @@     -- ^ Meta variable for hidden argument (must be inferred locally).   | Dot ExprInfo Expr                  -- ^ @.e@, for postfix projection.   | App  AppInfo Expr (NamedArg Expr)  -- ^ Ordinary (binary) application.-  | WithApp ExprInfo Expr [Expr]       -- ^ With application.+  | WithApp ExprInfo Expr (List1 Expr) -- ^ With application.   | Lam  ExprInfo LamBinding Expr      -- ^ @λ bs → e@.   | AbsurdLam ExprInfo Hiding          -- ^ @λ()@ or @λ{}@.   | ExtendedLam ExprInfo DefInfo Erased QName (List1 Clause)-  | Pi   ExprInfo Telescope1 Expr      -- ^ Dependent function space @Γ → A@.-  | Generalized (Set QName) Expr       -- ^ Like a Pi, but the ordering is not known-  | Fun  ExprInfo (Arg Expr) Expr      -- ^ Non-dependent function space.+  | Pi   ExprInfo Telescope1 Type      -- ^ Dependent function space @Γ → A@.+  | Generalized (Set1 QName) Type      -- ^ Like a Pi, but the ordering is not known+  | Fun  ExprInfo (Arg Type) Type      -- ^ Non-dependent function space.   | Let  ExprInfo (List1 LetBinding) Expr                                        -- ^ @let bs in e@.-  | ETel Telescope                     -- ^ Only used when printing telescopes.-  | Rec  ExprInfo RecordAssigns        -- ^ Record construction.-  | RecUpdate ExprInfo Expr Assigns    -- ^ Record update.+  | Rec  KwRange ExprInfo RecordAssigns+      -- ^ Record construction.  The 'KwRange' is for the @record@ kewyword.+  | RecUpdate KwRange ExprInfo Expr Assigns+      -- ^ Record update.  The 'KwRange' is for the @record@ kewyword.   | ScopedExpr ScopeInfo Expr          -- ^ Scope annotation.   | Quote ExprInfo                     -- ^ Quote an identifier 'QName'.   | QuoteTerm ExprInfo                 -- ^ Quote a term.   | Unquote ExprInfo                   -- ^ The splicing construct: unquote ...   | DontCare Expr                      -- ^ For printing @DontCare@ from @Syntax.Internal@.-  deriving (Data, Show, Generic)+  deriving (Show, Generic) --- | Pattern synonym for regular Def+-- | Pattern synonym for regular 'Def'. pattern Def :: QName -> Expr pattern Def x = Def' x NoSuffix --- | Smart constructor for Generalized-generalized :: Set QName -> Expr -> Expr-generalized s e-    | null s    = e-    | otherwise = Generalized s e+-- | Smart constructor for 'Generalized'.+generalized :: Set QName -> Type -> Type+generalized s e = Set1.ifNull s e \ s -> Generalized s e  -- | Record field assignment @f = e@. type Assign  = FieldAssignment' Expr@@ -135,7 +137,7 @@ data ScopeCopyInfo = ScopeCopyInfo   { renModules :: Ren ModuleName   , renNames   :: Ren QName }-  deriving (Eq, Show, Data, Generic)+  deriving (Eq, Show, Generic)  initCopyInfo :: ScopeCopyInfo initCopyInfo = ScopeCopyInfo@@ -152,41 +154,53 @@           xs = [ (k, v) | (k, vs) <- Map.toList r, v <- List1.toList vs ]       pr (x, y) = pretty x <+> "->" <+> pretty y -type RecordDirectives = RecordDirectives' QName+-- | How did we get our hands on the 'QName' for the constructor of this+-- record?+data RecordConName+  = NamedRecCon { recordConName :: !QName }+    -- ^ The user wrote it.+  | FreshRecCon { recordConName :: !QName }+    -- ^ We made it up.+  deriving (Eq, Show, Generic) +type RecordDirectives = RecordDirectives' RecordConName+ data Declaration-  = Axiom      KindOfName DefInfo ArgInfo (Maybe [Occurrence]) QName Expr+  = Axiom      KindOfName DefInfo ArgInfo (Maybe PragmaPolarities) QName Type     -- ^ Type signature (can be irrelevant, but not hidden).     --     -- The fourth argument contains an optional assignment of     -- polarities to arguments.-  | Generalize (Set QName) DefInfo ArgInfo QName Expr-    -- ^ First argument is set of generalizable variables used in the type.-  | Field      DefInfo QName (Arg Expr)              -- ^ record field-  | Primitive  DefInfo QName (Arg Expr)              -- ^ primitive function+  | Generalize (Set QName) DefInfo ArgInfo QName Type+    -- ^ The first argument is the (possibly empty) set of generalizable variables used in the type.+  | Field      DefInfo QName (Arg Type)              -- ^ record field+  | Primitive  DefInfo QName (Arg Type)              -- ^ primitive function   | Mutual     MutualInfo [Declaration]              -- ^ a bunch of mutually recursive definitions-  | Section    Range ModuleName GeneralizeTelescope [Declaration]-  | Apply      ModuleInfo ModuleName ModuleApplication ScopeCopyInfo ImportDirective+  | Section    Range Erased ModuleName GeneralizeTelescope [Declaration]+  | Apply      ModuleInfo Erased ModuleName ModuleApplication+               ScopeCopyInfo ImportDirective     -- ^ The @ImportDirective@ is for highlighting purposes.   | Import     ModuleInfo ModuleName ImportDirective     -- ^ The @ImportDirective@ is for highlighting purposes.   | Pragma     Range      Pragma   | Open       ModuleInfo ModuleName ImportDirective-    -- ^ only retained for highlighting purposes-  | FunDef     DefInfo QName Delayed [Clause] -- ^ sequence of function clauses-  | DataSig    DefInfo QName GeneralizeTelescope Expr -- ^ lone data signature+  | FunDef     DefInfo QName [Clause] -- ^ sequence of function clauses+  | DataSig    DefInfo Erased QName GeneralizeTelescope Type -- ^ lone data signature   | DataDef    DefInfo QName UniverseCheck DataDefParams [Constructor]-  | RecSig     DefInfo QName GeneralizeTelescope Expr -- ^ lone record signature-  | RecDef     DefInfo QName UniverseCheck RecordDirectives DataDefParams Expr [Declaration]-      -- ^ The 'Expr' gives the constructor type telescope, @(x1 : A1)..(xn : An) -> Prop@,+  | RecSig     DefInfo Erased QName GeneralizeTelescope Type -- ^ lone record signature+  | RecDef     DefInfo QName UniverseCheck RecordDirectives DataDefParams Type [Declaration]+      -- ^ The 'Type' gives the constructor type telescope, @(x1 : A1)..(xn : An) -> Dummy@,       --   and the optional name is the constructor's name.       --   The optional 'Range' is for the @pattern@ attribute.-  | PatternSynDef QName [Arg BindName] (Pattern' Void)+  | PatternSynDef QName [WithHiding BindName] (Pattern' Void)       -- ^ Only for highlighting purposes   | UnquoteDecl MutualInfo [DefInfo] [QName] Expr   | UnquoteDef  [DefInfo] [QName] Expr+  | UnquoteData [DefInfo] QName UniverseCheck [DefInfo] [QName] Expr   | ScopedDecl ScopeInfo [Declaration]  -- ^ scope annotation-  deriving (Data, Show, Generic)+  | UnfoldingDecl Range [QName]+    -- ^ Only for highlighting the unfolded names+  deriving (Show, Generic)  type DefInfo = DefInfo' Expr @@ -199,7 +213,7 @@       -- ^ @tel. M args@:  applies @M@ to @args@ and abstracts @tel@.     | RecordModuleInstance ModuleName       -- ^ @M {{...}}@-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  data Pragma   = OptionsPragma [String]@@ -211,68 +225,97 @@     --   but declare a name for an Agda concept.   | RewritePragma Range [QName]     -- ^ Range is range of REWRITE keyword.-  | CompilePragma RString QName String+  | CompilePragma (Ranged BackendName) QName String   | StaticPragma QName   | EtaPragma QName     -- ^ For coinductive records, use pragma instead of regular     --   @eta-equality@ definition (as it is might make Agda loop).   | InjectivePragma QName+  | InjectiveForInferencePragma QName   | InlinePragma Bool QName -- INLINE or NOINLINE+  | NotProjectionLikePragma QName+    -- ^ Mark the definition as not being projection-like+  | OverlapPragma QName OverlapMode+    -- ^ If the definition is an instance, set its overlap mode.   | DisplayPragma QName [NamedArg Pattern] Expr-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  -- | Bindings that are valid in a @let@. data LetBinding-  = LetBind LetInfo ArgInfo BindName Expr Expr+  = LetBind LetInfo ArgInfo BindName Type Expr     -- ^ @LetBind info rel name type defn@+  | LetAxiom LetInfo ArgInfo BindName Type+    -- ^ Function declarations in a let with no matching body.   | LetPatBind LetInfo Pattern Expr     -- ^ Irrefutable pattern binding.-  | LetApply ModuleInfo ModuleName ModuleApplication ScopeCopyInfo ImportDirective+  | LetApply ModuleInfo Erased ModuleName ModuleApplication+      ScopeCopyInfo ImportDirective     -- ^ @LetApply mi newM (oldM args) renamings dir@.     -- The @ImportDirective@ is for highlighting purposes.   | LetOpen ModuleInfo ModuleName ImportDirective     -- ^ only for highlighting and abstractToConcrete-  | LetDeclaredVariable BindName-    -- ^ Only used for highlighting. Refers to the first occurrence of-    -- @x@ in @let x : A; x = e@.---  | LetGeneralize DefInfo ArgInfo Expr-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  -- | Only 'Axiom's. type TypeSignature  = Declaration type Constructor    = TypeSignature type Field          = TypeSignature -type TacticAttr = Maybe Expr+type TacticAttribute = TacticAttribute' Expr  -- A Binder @x\@p@, the pattern is optional data Binder' a = Binder-  { binderPattern :: Maybe Pattern-  , binderName    :: a-  } deriving (Data, Show, Eq, Functor, Foldable, Traversable, Generic)+  { binderPattern    :: Maybe Pattern+  , binderNameOrigin :: BinderNameOrigin+  , binderName       :: a+  } deriving (Show, Eq, Functor, Foldable, Traversable, Generic)  type Binder = Binder' BindName  mkBinder :: a -> Binder' a-mkBinder = Binder Nothing+mkBinder = Binder Nothing UserBinderName  mkBinder_ :: Name -> Binder mkBinder_ = mkBinder . mkBindName +insertedBinder :: a -> Binder' a+insertedBinder = Binder Nothing InsertedBinderName++insertedBinder_ :: Name -> Binder+insertedBinder_ = insertedBinder . mkBindName+ extractPattern :: Binder' a -> Maybe (Pattern, a)-extractPattern (Binder p a) = (,a) <$> p+extractPattern (Binder p _ a) = (,a) <$> p  -- | A lambda binding is either domain free or typed. data LamBinding-  = DomainFree TacticAttr (NamedArg Binder)+  = DomainFree TacticAttribute (NamedArg Binder)     -- ^ . @x@ or @{x}@ or @.x@ or @{x = y}@ or @x\@p@ or @(p)@   | DomainFull TypedBinding     -- ^ . @(xs:e)@ or @{xs:e}@ or @(let Ds)@-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  mkDomainFree :: NamedArg Binder -> LamBinding-mkDomainFree = DomainFree Nothing+mkDomainFree = DomainFree empty +-- | Extra information that is attached to a typed binding, that plays a+-- role during type checking but strictly speaking is not part of the+-- @name : type@" relation which a makes up a binding.+data TypedBindingInfo+  = TypedBindingInfo+    { tbTacticAttr :: TacticAttribute+      -- ^ Does this binding have a tactic annotation?+    , tbFinite     :: Bool+      -- ^ Does this binding correspond to a Partial binder, rather than+      -- to a Pi binder? Must be present here to be reflected into+      -- abstract syntax later (and to be printed to the user later).+    }+  deriving (Show, Eq, Generic)++instance Null TypedBindingInfo where+  null (TypedBindingInfo tac fin) = null tac && not fin+  empty = TypedBindingInfo empty empty+ -- | A typed binding.  Appears in dependent function spaces, typed lambdas, and --   telescopes.  It might be tempting to simplify this to only bind a single --   name at a time, and translate, say, @(x y : A)@ to @(x : A)(y : A)@@@ -288,14 +331,14 @@ --   that the metas of the copy are aliases of the metas of the original.  data TypedBinding-  = TBind Range TacticAttr (List1 (NamedArg Binder)) Expr+  = TBind Range TypedBindingInfo (List1 (NamedArg Binder)) Type     -- ^ As in telescope @(x y z : A)@ or type @(x y z : A) -> B@.   | TLet Range (List1 LetBinding)     -- ^ E.g. @(let x = e)@ or @(let open M)@.-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic) -mkTBind :: Range -> List1 (NamedArg Binder) -> Expr -> TypedBinding-mkTBind r = TBind r Nothing+mkTBind :: Range -> List1 (NamedArg Binder) -> Type -> TypedBinding+mkTBind r = TBind r empty  mkTLet :: Range -> [LetBinding] -> Maybe TypedBinding mkTLet _ []     = Nothing@@ -304,7 +347,7 @@ type Telescope1 = List1 TypedBinding type Telescope  = [TypedBinding] -mkPi :: ExprInfo -> Telescope -> Expr -> Expr+mkPi :: ExprInfo -> Telescope -> Type -> Type mkPi i []     e = e mkPi i (x:xs) e = Pi i (x :| xs) e @@ -313,7 +356,7 @@     -- ^ Maps generalize variables to the corresponding bound variable (to be     --   introduced by the generalisation).   , generalizeTel     :: Telescope }-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  data DataDefParams = DataDefParams   { dataDefGeneralizedParams :: Set Name@@ -321,7 +364,7 @@     --   sig, so we keep these in a set on the side.   , dataDefParams :: [LamBinding]   }-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  noDataDefParams :: DataDefParams noDataDefParams = DataDefParams Set.empty []@@ -343,7 +386,7 @@   { problemInPat :: Pattern   , problemInst  :: I.Term   , problemType  :: I.Dom I.Type-  } deriving (Data, Show, Generic)+  } deriving (Show, Generic)  -- These are not relevant for caching purposes instance Eq ProblemEq where _ == _ = True@@ -358,19 +401,21 @@       --   These live in the context of the parent clause left-hand side.   , clauseRHS        :: RHS   , clauseWhereDecls :: WhereDeclarations-  , clauseCatchall   :: Bool-  } deriving (Data, Show, Functor, Foldable, Traversable, Eq, Generic)+  , clauseCatchall   :: Catchall+  } deriving (Show, Functor, Foldable, Traversable, Eq, Generic)  data WhereDeclarations = WhereDecls   { whereModule :: Maybe ModuleName       -- #2897: we need to restrict named where modules in refined contexts,       --        so remember whether it was named here-  , whereDecls  :: Maybe Declaration+  , whereAnywhere :: Bool+      -- ^ is it an ordinary unnamed @where@?+  , whereDecls :: Maybe Declaration       -- ^ The declaration is a 'Section'.-  } deriving (Data, Show, Eq, Generic)+  } deriving (Show, Eq, Generic)  instance Null WhereDeclarations where-  empty = WhereDecls empty empty+  empty = WhereDecls empty False empty  noWhereDecls :: WhereDeclarations noWhereDecls = empty@@ -390,7 +435,7 @@       --   'Nothing' for internally generated rhss.     }   | AbsurdRHS-  | WithRHS QName [WithExpr] [Clause]+  | WithRHS QName (List1 WithExpr) (List1 Clause)       -- ^ The 'QName' is the name of the with function.   | RewriteRHS     { rewriteExprs      :: [RewriteEqn]@@ -405,7 +450,7 @@       -- ^ The where clauses are attached to the @RewriteRHS@ by       ---  the scope checker (instead of to the clause).     }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  -- | Ignore 'rhsConcrete' when comparing 'RHS's. instance Eq RHS where@@ -423,7 +468,7 @@   , spLhsDefName  :: QName               -- ^ Name of function we are defining.   , spLhsPats     :: [NamedArg Pattern]  -- ^ Elimination by pattern, projections, with-patterns.   }-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  -- | Ignore 'Range' when comparing 'LHS's. instance Eq LHS where@@ -435,7 +480,7 @@   { lhsInfo     :: LHSInfo               -- ^ Range.   , lhsCore     :: LHSCore               -- ^ Copatterns.   }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  -- | The lhs in projection-application and with-pattern view. --   Parameterised over the type @e@ of dot patterns.@@ -457,13 +502,13 @@     -- | With patterns.   | LHSWith  { lhsHead         :: LHSCore' e                  -- ^ E.g. the 'LHSHead'.-             , lhsWithPatterns :: [Arg (Pattern' e)]+             , lhsWithPatterns :: List1 (Arg (Pattern' e))                  -- ^ Applied to with patterns @| p1 | ... | pn@.                  --   These patterns are not prefixed with @WithP@!              , lhsPats         :: [NamedArg (Pattern' e)]                  -- ^ Further applied to patterns.              }-  deriving (Data, Show, Functor, Foldable, Traversable, Eq, Generic)+  deriving (Show, Functor, Foldable, Traversable, Eq, Generic)  type LHSCore = LHSCore' Expr @@ -490,11 +535,10 @@   | AbsurdP PatInfo   | LitP PatInfo Literal   | PatternSynP PatInfo AmbiguousQName (NAPs e)-  | RecP PatInfo [FieldAssignment' (Pattern' e)]-  | EqualP PatInfo [(e, e)]+  | RecP KwRange ConPatInfo [FieldAssignment' (Pattern' e)]+  | EqualP PatInfo (List1 (e, e))   | WithP PatInfo (Pattern' e)  -- ^ @| p@, for with-patterns.-  | AnnP PatInfo e (Pattern' e) -- ^ Pattern with type annotation-  deriving (Data, Show, Functor, Foldable, Traversable, Eq, Generic)+  deriving (Show, Functor, Foldable, Traversable, Eq, Generic)  type NAPs e   = [NamedArg (Pattern' e)] type NAPs1 e  = List1 (NamedArg (Pattern' e))@@ -549,9 +593,8 @@   Generalized a1 b1          == Generalized a2 b2          = (a1, b1) == (a2, b2)   Fun a1 b1 c1               == Fun a2 b2 c2               = (a1, b1, c1) == (a2, b2, c2)   Let a1 b1 c1               == Let a2 b2 c2               = (a1, b1, c1) == (a2, b2, c2)-  ETel a1                    == ETel a2                    = a1 == a2-  Rec a1 b1                  == Rec a2 b2                  = (a1, b1) == (a2, b2)-  RecUpdate a1 b1 c1         == RecUpdate a2 b2 c2         = (a1, b1, c1) == (a2, b2, c2)+  Rec r1 a1 b1               == Rec r2 a2 b2               = (r1, a1, b1) == (r2, a2, b2)+  RecUpdate r1 a1 b1 c1      == RecUpdate r2 a2 b2 c2      = (r1, a1, b1, c1) == (r2, a2, b2, c2)   Quote a1                   == Quote a2                   = a1 == a2   QuoteTerm a1               == QuoteTerm a2               = a1 == a2   Unquote a1                 == Unquote a2                 = a1 == a2@@ -569,25 +612,28 @@   Field a1 b1 c1                 == Field a2 b2 c2                 = (a1, b1, c1) == (a2, b2, c2)   Primitive a1 b1 c1             == Primitive a2 b2 c2             = (a1, b1, c1) == (a2, b2, c2)   Mutual a1 b1                   == Mutual a2 b2                   = (a1, b1) == (a2, b2)-  Section a1 b1 c1 d1            == Section a2 b2 c2 d2            = (a1, b1, c1, d1) == (a2, b2, c2, d2)-  Apply a1 b1 c1 d1 e1           == Apply a2 b2 c2 d2 e2           = (a1, b1, c1, d1, e1) == (a2, b2, c2, d2, e2)+  Section a1 b1 c1 d1 e1         == Section a2 b2 c2 d2 e2         = (a1, b1, c1, d1, e1) == (a2, b2, c2, d2, e2)+  Apply a1 b1 c1 d1 e1 f1        == Apply a2 b2 c2 d2 e2 f2        = (a1, b1, c1, d1, e1, f1) == (a2, b2, c2, d2, e2, f2)   Import a1 b1 c1                == Import a2 b2 c2                = (a1, b1, c1) == (a2, b2, c2)   Pragma a1 b1                   == Pragma a2 b2                   = (a1, b1) == (a2, b2)   Open a1 b1 c1                  == Open a2 b2 c2                  = (a1, b1, c1) == (a2, b2, c2)-  FunDef a1 b1 c1 d1             == FunDef a2 b2 c2 d2             = (a1, b1, c1, d1) == (a2, b2, c2, d2)-  DataSig a1 b1 c1 d1            == DataSig a2 b2 c2 d2            = (a1, b1, c1, d1) == (a2, b2, c2, d2)+  FunDef a1 b1 c1                == FunDef a2 b2 c2                = (a1, b1, c1) == (a2, b2, c2)+  DataSig a1 b1 c1 d1 e1         == DataSig a2 b2 c2 d2 e2         = (a1, b1, c1, d1, e1) == (a2, b2, c2, d2, e2)   DataDef a1 b1 c1 d1 e1         == DataDef a2 b2 c2 d2 e2         = (a1, b1, c1, d1, e1) == (a2, b2, c2, d2, e2)-  RecSig a1 b1 c1 d1             == RecSig a2 b2 c2 d2             = (a1, b1, c1, d1) == (a2, b2, c2, d2)+  RecSig a1 b1 c1 d1 e1          == RecSig a2 b2 c2 d2 e2          = (a1, b1, c1, d1, e1) == (a2, b2, c2, d2, e2)   RecDef a1 b1 c1 d1 e1 f1 g1    == RecDef a2 b2 c2 d2 e2 f2 g2    = (a1, b1, c1, d1, e1, f1, g1) == (a2, b2, c2, d2, e2, f2, g2)   PatternSynDef a1 b1 c1         == PatternSynDef a2 b2 c2         = (a1, b1, c1) == (a2, b2, c2)   UnquoteDecl a1 b1 c1 d1        == UnquoteDecl a2 b2 c2 d2        = (a1, b1, c1, d1) == (a2, b2, c2, d2)   UnquoteDef a1 b1 c1            == UnquoteDef a2 b2 c2            = (a1, b1, c1) == (a2, b2, c2)+  UnfoldingDecl a1 b1            == UnfoldingDecl a2 b2            = (a1,b1) == (a2,b2)    _                              == _                              = False  instance Underscore Expr where   underscore   = Underscore emptyMetaInfo-  isUnderscore = __IMPOSSIBLE__+  isUnderscore = \case+    Underscore _ -> True+    _ -> False  instance LensHiding LamBinding where   getHiding   (DomainFree _ x) = getHiding x@@ -596,13 +642,13 @@   mapHiding f (DomainFull tb)  = DomainFull $ mapHiding f tb  instance LensHiding TypedBinding where-  getHiding (TBind _ _ (x :|_) _) = getHiding x   -- Slightly dubious-  getHiding TLet{}                = mempty-  mapHiding f (TBind r t xs e)    = TBind r t ((fmap . mapHiding) f xs) e-  mapHiding f b@TLet{}            = b+  getHiding (TBind _ _ (x :| _) _) = getHiding x   -- Slightly dubious+  getHiding TLet{}                 = mempty+  mapHiding f (TBind r t xs e)     = TBind r t ((fmap . mapHiding) f xs) e+  mapHiding f b@TLet{}             = b  instance HasRange a => HasRange (Binder' a) where-  getRange (Binder p n) = fuseRange p n+  getRange (Binder p _ n) = fuseRange p n  instance HasRange LamBinding where     getRange (DomainFree _ x) = getRange x@@ -630,9 +676,8 @@     getRange (Generalized _ x)       = getRange x     getRange (Fun i _ _)             = getRange i     getRange (Let i _ _)             = getRange i-    getRange (Rec i _)               = getRange i-    getRange (RecUpdate i _ _)       = getRange i-    getRange (ETel tel)              = getRange tel+    getRange (Rec _ i _)             = getRange i+    getRange (RecUpdate _ i _ _)     = getRange i     getRange (ScopedExpr _ e)        = getRange e     getRange (Quote i)               = getRange i     getRange (QuoteTerm i)           = getRange i@@ -642,28 +687,30 @@     getRange (Macro x)               = getRange x  instance HasRange Declaration where-    getRange (Axiom    _ i _ _ _ _  ) = getRange i-    getRange (Generalize _ i _ _ _)   = getRange i-    getRange (Field      i _ _      ) = getRange i-    getRange (Mutual     i _        ) = getRange i-    getRange (Section    i _ _ _    ) = getRange i-    getRange (Apply      i _ _ _ _)   = getRange i-    getRange (Import     i _ _      ) = getRange i-    getRange (Primitive  i _ _      ) = getRange i-    getRange (Pragma     i _        ) = getRange i-    getRange (Open       i _ _      ) = getRange i-    getRange (ScopedDecl _ d        ) = getRange d-    getRange (FunDef     i _ _ _    ) = getRange i-    getRange (DataSig    i _ _ _    ) = getRange i-    getRange (DataDef    i _ _ _ _  ) = getRange i-    getRange (RecSig     i _ _ _    ) = getRange i-    getRange (RecDef i _ _ _ _ _ _)   = getRange i-    getRange (PatternSynDef x _ _   ) = getRange x-    getRange (UnquoteDecl _ i _ _)    = getRange i-    getRange (UnquoteDef i _ _)       = getRange i+    getRange (Axiom    _ i _ _ _ _  )  = getRange i+    getRange (Generalize _ i _ _ _)    = getRange i+    getRange (Field      i _ _      )  = getRange i+    getRange (Mutual     i _        )  = getRange i+    getRange (Section    i _ _ _ _  )  = getRange i+    getRange (Apply      i _ _ _ _ _)  = getRange i+    getRange (Import     i _ _      )  = getRange i+    getRange (Primitive  i _ _      )  = getRange i+    getRange (Pragma     i _        )  = getRange i+    getRange (Open       i _ _      )  = getRange i+    getRange (ScopedDecl _ d        )  = getRange d+    getRange (FunDef     i _ _      )  = getRange i+    getRange (DataSig    i _ _ _ _  )  = getRange i+    getRange (DataDef    i _ _ _ _  )  = getRange i+    getRange (RecSig     i _ _ _ _  )  = getRange i+    getRange (RecDef i _ _ _ _ _ _)    = getRange i+    getRange (PatternSynDef x _ _   )  = getRange x+    getRange (UnquoteDecl _ i _ _)     = getRange i+    getRange (UnquoteDef i _ _)        = getRange i+    getRange (UnquoteData i _ _ j _ _) = getRange (i, j)+    getRange (UnfoldingDecl r _)       = r  instance HasRange (Pattern' e) where-    getRange (VarP x)           = getRange x+    getRange (VarP x)            = getRange x     getRange (ConP i _ _)        = getRange i     getRange (ProjP i _ _)       = getRange i     getRange (DefP i _ _)        = getRange i@@ -673,10 +720,9 @@     getRange (AbsurdP i)         = getRange i     getRange (LitP i l)          = getRange i     getRange (PatternSynP i _ _) = getRange i-    getRange (RecP i _)          = getRange i+    getRange (RecP _kwr i _)     = getRange i     getRange (EqualP i _)        = getRange i     getRange (WithP i _)         = getRange i-    getRange (AnnP i _ _)        = getRange i  instance HasRange SpineLHS where     getRange (SpineLHS i _ _)  = getRange i@@ -699,14 +745,14 @@     getRange (RewriteRHS xes _ rhs wh) = getRange (xes, rhs, wh)  instance HasRange WhereDeclarations where-  getRange (WhereDecls _ ds) = getRange ds+  getRange (WhereDecls _ _ ds) = getRange ds  instance HasRange LetBinding where-    getRange (LetBind i _ _ _ _     ) = getRange i-    getRange (LetPatBind  i _ _      ) = getRange i-    getRange (LetApply i _ _ _ _     ) = getRange i-    getRange (LetOpen  i _ _         ) = getRange i-    getRange (LetDeclaredVariable x)  = getRange x+  getRange (LetBind i _ _ _ _)     = getRange i+  getRange (LetAxiom i _ _ _)      = getRange i+  getRange (LetPatBind  i _ _)     = getRange i+  getRange (LetApply i _ _ _ _ _)  = getRange i+  getRange (LetOpen  i _ _)        = getRange i  -- setRange for patterns applies the range to the outermost pattern constructor instance SetRange (Pattern' a) where@@ -720,17 +766,17 @@     setRange r (AbsurdP _)          = AbsurdP (PatRange r)     setRange r (LitP _ l)           = LitP (PatRange r) l     setRange r (PatternSynP _ n as) = PatternSynP (PatRange r) n as-    setRange r (RecP i as)          = RecP (PatRange r) as+    setRange r (RecP _ i as)        = RecP empty (setRange r i) as     setRange r (EqualP _ es)        = EqualP (PatRange r) es     setRange r (WithP i p)          = WithP (setRange r i) p-    setRange r (AnnP i a p)         = AnnP (setRange r i) a p + instance KillRange a => KillRange (Binder' a) where-  killRange (Binder a b) = killRange2 Binder a b+  killRange (Binder a o b) = killRangeN Binder a o b  instance KillRange LamBinding where-  killRange (DomainFree t x) = killRange2 DomainFree t x-  killRange (DomainFull b)   = killRange1 DomainFull b+  killRange (DomainFree t x) = killRangeN DomainFree t x+  killRange (DomainFull b)   = killRangeN DomainFull b  instance KillRange GeneralizeTelescope where   killRange (GeneralizeTel s tel) = GeneralizeTel s (killRange tel)@@ -738,121 +784,129 @@ instance KillRange DataDefParams where   killRange (DataDefParams s tel) = DataDefParams s (killRange tel) +instance KillRange TypedBindingInfo where+  killRange (TypedBindingInfo a b) = killRangeN TypedBindingInfo a b+ instance KillRange TypedBinding where-  killRange (TBind r t xs e) = killRange4 TBind r t xs e-  killRange (TLet r lbs)     = killRange2 TLet r lbs+  killRange (TBind r t xs e) = killRangeN TBind r t xs e+  killRange (TLet r lbs)     = killRangeN TLet r lbs  instance KillRange Expr where-  killRange (Var x)                  = killRange1 Var x-  killRange (Def' x v)               = killRange2 Def' x v-  killRange (Proj o x)               = killRange1 (Proj o) x-  killRange (Con x)                  = killRange1 Con x-  killRange (Lit i l)                = killRange2 Lit i l-  killRange (QuestionMark i ii)      = killRange2 QuestionMark i ii-  killRange (Underscore  i)          = killRange1 Underscore i-  killRange (Dot i e)                = killRange2 Dot i e-  killRange (App i e1 e2)            = killRange3 App i e1 e2-  killRange (WithApp i e es)         = killRange3 WithApp i e es-  killRange (Lam i b e)              = killRange3 Lam i b e-  killRange (AbsurdLam i h)          = killRange2 AbsurdLam i h-  killRange (ExtendedLam i n e d ps) = killRange5 ExtendedLam i n e d ps-  killRange (Pi i a b)               = killRange3 Pi i a b-  killRange (Generalized s x)        = killRange1 (Generalized s) x-  killRange (Fun i a b)              = killRange3 Fun i a b-  killRange (Let i ds e)             = killRange3 Let i ds e-  killRange (Rec i fs)               = killRange2 Rec i fs-  killRange (RecUpdate i e fs)       = killRange3 RecUpdate i e fs-  killRange (ETel tel)               = killRange1 ETel tel-  killRange (ScopedExpr s e)         = killRange1 (ScopedExpr s) e-  killRange (Quote i)                = killRange1 Quote i-  killRange (QuoteTerm i)            = killRange1 QuoteTerm i-  killRange (Unquote i)              = killRange1 Unquote i-  killRange (DontCare e)             = killRange1 DontCare e-  killRange (PatternSyn x)           = killRange1 PatternSyn x-  killRange (Macro x)                = killRange1 Macro x+  killRange (Var x)                  = killRangeN Var x+  killRange (Def' x v)               = killRangeN Def' x v+  killRange (Proj o x)               = killRangeN (Proj o) x+  killRange (Con x)                  = killRangeN Con x+  killRange (Lit i l)                = killRangeN Lit i l+  killRange (QuestionMark i ii)      = killRangeN QuestionMark i ii+  killRange (Underscore  i)          = killRangeN Underscore i+  killRange (Dot i e)                = killRangeN Dot i e+  killRange (App i e1 e2)            = killRangeN App i e1 e2+  killRange (WithApp i e es)         = killRangeN WithApp i e es+  killRange (Lam i b e)              = killRangeN Lam i b e+  killRange (AbsurdLam i h)          = killRangeN AbsurdLam i h+  killRange (ExtendedLam i n e d ps) = killRangeN ExtendedLam i n e d ps+  killRange (Pi i a b)               = killRangeN Pi i a b+  killRange (Generalized s x)        = killRangeN (Generalized s) x+  killRange (Fun i a b)              = killRangeN Fun i a b+  killRange (Let i ds e)             = killRangeN Let i ds e+  killRange (Rec kwr i fs)           = killRangeN Rec kwr i fs+  killRange (RecUpdate kwr i e fs)   = killRangeN RecUpdate kwr i e fs+  killRange (ScopedExpr s e)         = killRangeN (ScopedExpr s) e+  killRange (Quote i)                = killRangeN Quote i+  killRange (QuoteTerm i)            = killRangeN QuoteTerm i+  killRange (Unquote i)              = killRangeN Unquote i+  killRange (DontCare e)             = killRangeN DontCare e+  killRange (PatternSyn x)           = killRangeN PatternSyn x+  killRange (Macro x)                = killRangeN Macro x  instance KillRange Suffix where   killRange = id  instance KillRange Declaration where-  killRange (Axiom    p i a b c d     ) = killRange4 (\i a c d -> Axiom p i a b c d) i a c d-  killRange (Generalize s i j x e     ) = killRange4 (Generalize s) i j x e-  killRange (Field      i a b         ) = killRange3 Field      i a b-  killRange (Mutual     i a           ) = killRange2 Mutual     i a-  killRange (Section    i a b c       ) = killRange4 Section    i a b c-  killRange (Apply      i a b c d     ) = killRange5 Apply      i a b c d-  killRange (Import     i a b         ) = killRange3 Import     i a b-  killRange (Primitive  i a b         ) = killRange3 Primitive  i a b+  killRange (Axiom    p i a b c d     ) = killRangeN (\i a c d -> Axiom p i a b c d) i a c d+  killRange (Generalize s i j x e     ) = killRangeN (Generalize s) i j x e+  killRange (Field      i a b         ) = killRangeN Field      i a b+  killRange (Mutual     i a           ) = killRangeN Mutual     i a+  killRange (Section    i a b c d     ) = killRangeN Section    i a b c d+  killRange (Apply      i a b c d e   ) = killRangeN Apply      i a b c d e+  killRange (Import     i a b         ) = killRangeN Import     i a b+  killRange (Primitive  i a b         ) = killRangeN Primitive  i a b   killRange (Pragma     i a           ) = Pragma (killRange i) a-  killRange (Open       i x dir       ) = killRange3 Open       i x dir-  killRange (ScopedDecl a d           ) = killRange1 (ScopedDecl a) d-  killRange (FunDef  i a b c          ) = killRange4 FunDef  i a b c-  killRange (DataSig i a b c          ) = killRange4 DataSig i a b c-  killRange (DataDef i a b c d        ) = killRange5 DataDef i a b c d-  killRange (RecSig  i a b c          ) = killRange4 RecSig  i a b c-  killRange (RecDef  i a b c d e f    ) = killRange7 RecDef  i a b c d e f-  killRange (PatternSynDef x xs p     ) = killRange3 PatternSynDef x xs p-  killRange (UnquoteDecl mi i x e     ) = killRange4 UnquoteDecl mi i x e-  killRange (UnquoteDef i x e         ) = killRange3 UnquoteDef i x e+  killRange (Open       i x dir       ) = killRangeN Open       i x dir+  killRange (ScopedDecl a d           ) = killRangeN (ScopedDecl a) d+  killRange (FunDef  i a b            ) = killRangeN FunDef  i a b+  killRange (DataSig i a b c d        ) = killRangeN DataSig i a b c d+  killRange (DataDef i a b c d        ) = killRangeN DataDef i a b c d+  killRange (RecSig  i a b c d        ) = killRangeN RecSig  i a b c d+  killRange (RecDef  i a b c d e f    ) = killRangeN RecDef  i a b c d e f+  killRange (PatternSynDef x xs p     ) = killRangeN PatternSynDef x xs p+  killRange (UnquoteDecl mi i x e     ) = killRangeN UnquoteDecl mi i x e+  killRange (UnquoteDef i x e         ) = killRangeN UnquoteDef i x e+  killRange (UnquoteData i xs uc j cs e) = killRangeN UnquoteData i xs uc j cs e+  killRange (UnfoldingDecl r xs)         = killRangeN UnfoldingDecl r xs  instance KillRange ModuleApplication where-  killRange (SectionApp a b c  ) = killRange3 SectionApp a b c-  killRange (RecordModuleInstance a) = killRange1 RecordModuleInstance a+  killRange (SectionApp a b c  ) = killRangeN SectionApp a b c+  killRange (RecordModuleInstance a) = killRangeN RecordModuleInstance a  instance KillRange ScopeCopyInfo where-  killRange (ScopeCopyInfo a b) = killRange2 ScopeCopyInfo a b+  killRange (ScopeCopyInfo a b) = killRangeN ScopeCopyInfo a b +instance KillRange RecordConName where+  killRange (NamedRecCon x) = killRangeN NamedRecCon x+  killRange (FreshRecCon x) = killRangeN FreshRecCon x+ instance KillRange e => KillRange (Pattern' e) where-  killRange (VarP x)           = killRange1 VarP x-  killRange (ConP i a b)        = killRange3 ConP i a b-  killRange (ProjP i o a)       = killRange3 ProjP i o a-  killRange (DefP i a b)        = killRange3 DefP i a b-  killRange (WildP i)           = killRange1 WildP i-  killRange (AsP i a b)         = killRange3 AsP i a b-  killRange (DotP i a)          = killRange2 DotP i a-  killRange (AbsurdP i)         = killRange1 AbsurdP i-  killRange (LitP i l)          = killRange2 LitP i l-  killRange (PatternSynP i a p) = killRange3 PatternSynP i a p-  killRange (RecP i as)         = killRange2 RecP i as-  killRange (EqualP i es)       = killRange2 EqualP i es-  killRange (WithP i p)         = killRange2 WithP i p-  killRange (AnnP i a p)        = killRange3 AnnP i a p+  killRange (VarP x)           = killRangeN VarP x+  killRange (ConP i a b)        = killRangeN ConP i a b+  killRange (ProjP i o a)       = killRangeN ProjP i o a+  killRange (DefP i a b)        = killRangeN DefP i a b+  killRange (WildP i)           = killRangeN WildP i+  killRange (AsP i a b)         = killRangeN AsP i a b+  killRange (DotP i a)          = killRangeN DotP i a+  killRange (AbsurdP i)         = killRangeN AbsurdP i+  killRange (LitP i l)          = killRangeN LitP i l+  killRange (PatternSynP i a p) = killRangeN PatternSynP i a p+  killRange (RecP kwr i as)     = killRangeN RecP kwr i as+  killRange (EqualP i es)       = killRangeN EqualP i es+  killRange (WithP i p)         = killRangeN WithP i p  instance KillRange SpineLHS where-  killRange (SpineLHS i a b)  = killRange3 SpineLHS i a b+  killRange (SpineLHS i a b)  = killRangeN SpineLHS i a b  instance KillRange LHS where-  killRange (LHS i a)   = killRange2 LHS i a+  killRange (LHS i a)   = killRangeN LHS i a  instance KillRange e => KillRange (LHSCore' e) where-  killRange (LHSHead a b)   = killRange2 LHSHead a b-  killRange (LHSProj a b c) = killRange3 LHSProj a b c-  killRange (LHSWith a b c) = killRange3 LHSWith a b c+  killRange (LHSHead a b)   = killRangeN LHSHead a b+  killRange (LHSProj a b c) = killRangeN LHSProj a b c+  killRange (LHSWith a b c) = killRangeN LHSWith a b c  instance KillRange a => KillRange (Clause' a) where-  killRange (Clause lhs spats rhs ds catchall) = killRange5 Clause lhs spats rhs ds catchall+  killRange (Clause lhs spats rhs ds catchall) = killRangeN Clause lhs spats rhs ds catchall  instance KillRange ProblemEq where-  killRange (ProblemEq p v a) = killRange3 ProblemEq p v a+  killRange (ProblemEq p v a) = killRangeN ProblemEq p v a  instance KillRange RHS where   killRange AbsurdRHS                = AbsurdRHS-  killRange (RHS e c)                = killRange2 RHS e c-  killRange (WithRHS q e cs)         = killRange3 WithRHS q e cs-  killRange (RewriteRHS xes spats rhs wh) = killRange4 RewriteRHS xes spats rhs wh+  killRange (RHS e c)                = killRangeN RHS e c+  killRange (WithRHS q e cs)         = killRangeN WithRHS q e cs+  killRange (RewriteRHS xes spats rhs wh) = killRangeN RewriteRHS xes spats rhs wh  instance KillRange WhereDeclarations where-  killRange (WhereDecls a b) = killRange2 WhereDecls a b+  killRange (WhereDecls a b c) = killRangeN WhereDecls a b c  instance KillRange LetBinding where-  killRange (LetBind   i info a b c) = killRange5 LetBind i info a b c-  killRange (LetPatBind i a b       ) = killRange3 LetPatBind i a b-  killRange (LetApply   i a b c d   ) = killRange5 LetApply i a b c d-  killRange (LetOpen    i x dir     ) = killRange3 LetOpen  i x dir-  killRange (LetDeclaredVariable x)  = killRange1 LetDeclaredVariable x+  killRange (LetBind i info a b c)  = killRangeN LetBind i info a b c+  killRange (LetAxiom i a b c)      = killRangeN LetAxiom i a b c+  killRange (LetPatBind i a b)      = killRangeN LetPatBind i a b+  killRange (LetApply i a b c d e)  = killRangeN LetApply i a b c d e+  killRange (LetOpen i x dir)       = killRangeN LetOpen  i x dir  instance NFData Expr instance NFData ScopeCopyInfo+instance NFData RecordConName instance NFData Declaration instance NFData ModuleApplication instance NFData Pragma@@ -860,6 +914,7 @@ instance NFData a => NFData (Binder' a) instance NFData LamBinding instance NFData TypedBinding+instance NFData TypedBindingInfo instance NFData GeneralizeTelescope instance NFData DataDefParams instance NFData ProblemEq@@ -900,12 +955,12 @@   anyAbstract (Field i _ _)          = defAbstract i == AbstractDef   anyAbstract (Mutual     _ ds)      = anyAbstract ds   anyAbstract (ScopedDecl _ ds)      = anyAbstract ds-  anyAbstract (Section _ _ _ ds)     = anyAbstract ds-  anyAbstract (FunDef i _ _ _)       = defAbstract i == AbstractDef+  anyAbstract (Section _ _ _ _ ds)   = anyAbstract ds+  anyAbstract (FunDef i _ _)         = defAbstract i == AbstractDef   anyAbstract (DataDef i _ _ _ _)    = defAbstract i == AbstractDef   anyAbstract (RecDef i _ _ _ _ _ _) = defAbstract i == AbstractDef-  anyAbstract (DataSig i _ _ _)      = defAbstract i == AbstractDef-  anyAbstract (RecSig i _ _ _)       = defAbstract i == AbstractDef+  anyAbstract (DataSig i _ _ _ _)    = defAbstract i == AbstractDef+  anyAbstract (RecSig i _ _ _ _)     = defAbstract i == AbstractDef   anyAbstract _                      = __IMPOSSIBLE__  -- | Turn a name into an expression.@@ -962,33 +1017,15 @@ mkLet _ []     e = e mkLet i (d:ds) e = Let i (d :| ds) e -patternToExpr :: Pattern -> Expr-patternToExpr = \case-  VarP x             -> Var (unBind x)-  ConP _ c ps        -> Con c `app` map (fmap (fmap patternToExpr)) ps-  ProjP _ o ds       -> Proj o ds-  DefP _ fs ps       -> Def (headAmbQ fs) `app` map (fmap (fmap patternToExpr)) ps-  WildP _            -> Underscore emptyMetaInfo-  AsP _ _ p          -> patternToExpr p-  DotP _ e           -> e-  AbsurdP _          -> Underscore emptyMetaInfo  -- TODO: could this happen?-  LitP (PatRange r) l-> Lit (ExprRange r) l-  PatternSynP _ c ps -> PatternSyn c `app` (map . fmap . fmap) patternToExpr ps-  RecP _ as          -> Rec exprNoRange $ map (Left . fmap patternToExpr) as-  EqualP{}           -> __IMPOSSIBLE__  -- Andrea TODO: where is this used?-  WithP r p          -> __IMPOSSIBLE__-  AnnP _ _ p         -> patternToExpr p--type PatternSynDefn = ([Arg Name], Pattern' Void)+type PatternSynDefn = ([WithHiding Name], Pattern' Void) type PatternSynDefns = Map QName PatternSynDefn -lambdaLiftExpr :: [Name] -> Expr -> Expr-lambdaLiftExpr ns e-  = foldr-      (\ n -> Lam exprNoRange (mkDomainFree $ defaultNamedArg $ mkBinder_ n))-      e-      ns+lambdaLiftExpr :: [WithHiding Name] -> Expr -> Expr+lambdaLiftExpr ns e = foldr f e ns+  where+  f (WithHiding h n) = Lam exprNoRange $ setHiding h $ mkDomainFree $ defaultNamedArg $ mkBinder_ n + -- NOTE: This is only used on expressions that come from right-hand sides of pattern synonyms, and -- thus does not have to handle all forms of expressions. class SubstExpr a where@@ -1029,7 +1066,7 @@     Lit _ _         -> e     Underscore   _  -> e     App  i e e'     -> App i (substExpr s e) (substExpr s e')-    Rec  i nes      -> Rec i (substExpr s nes)+    Rec kwr i nes   -> Rec kwr i (substExpr s nes)     ScopedExpr si e -> ScopedExpr si (substExpr s e)     -- The below cannot appear in pattern synonym right-hand sides     QuestionMark{}  -> __IMPOSSIBLE__@@ -1042,7 +1079,6 @@     Generalized{}   -> __IMPOSSIBLE__     Fun{}           -> __IMPOSSIBLE__     Let{}           -> __IMPOSSIBLE__-    ETel{}          -> __IMPOSSIBLE__     RecUpdate{}     -> __IMPOSSIBLE__     Quote{}         -> __IMPOSSIBLE__     QuoteTerm{}     -> __IMPOSSIBLE__@@ -1051,28 +1087,140 @@     Macro{}         -> __IMPOSSIBLE__  -- TODO: more informative failure-insertImplicitPatSynArgs-  :: HasRange a-  => (Range -> a)+insertImplicitPatSynArgs :: forall a. HasRange a+  => (Hiding -> Range -> a)+       -- ^ Thing to insert (wildcard).   -> Range-  -> [Arg Name]+       -- ^ Range of the whole pattern synonym expression/pattern.+  -> [WithHiding Name]+       -- ^ The parameters of the pattern synonym (from its definition).   -> [NamedArg a]-  -> Maybe ([(Name, a)], [Arg Name])+       -- ^ The arguments it is used with.+  -> Maybe ([(Name, a)], [WithHiding Name])+       -- ^ Substitution and left-over parameters. insertImplicitPatSynArgs wild r ns as = matchArgs r ns as   where+    matchNextArg :: Range -> WithHiding Name -> [NamedArg a] -> Maybe (a, [NamedArg a])     matchNextArg r n as@(~(a : as'))-      | matchNext n as = return (namedArg a, as')+      | not (null as)+      , matchNext n a  = return (namedArg a, as')       | visible n      = Nothing-      | otherwise      = return (wild r, as)+      | otherwise      = return (wild (getHiding n) r, as) -    matchNext _ [] = False-    matchNext n (a:as) = sameHiding n a && maybe True (x ==) (bareNameOf a)+    matchNext ::+         WithHiding Name  -- Pattern synonym parameter+      -> NamedArg a       -- Argument given to pattern synonym+      -> Bool+    matchNext n a = sameHiding n a && maybe True (x ==) (bareNameOf a)       where-        x = C.nameToRawName $ nameConcrete $ unArg n+        x = C.nameToRawName $ nameConcrete $ whThing n +    matchArgs ::+         Range+      -> [WithHiding Name]+      -> [NamedArg a]+      -> Maybe ([(Name, a)], [WithHiding Name])     matchArgs r [] []     = return ([], [])     matchArgs r [] as     = Nothing     matchArgs r (n:ns) [] | visible n = return ([], n : ns)    -- under-applied     matchArgs r (n:ns) as = do       (p, as) <- matchNextArg r n as-      first ((unArg n, p) :) <$> matchArgs (getRange p) ns as+      first ((whThing n, p) :) <$> matchArgs (getRange p) ns as++------------------------------------------------------------------------+-- Declaration spines+------------------------------------------------------------------------++-- | Declaration spines. Used in debugging to make it easy to see+-- where constructors such as 'ScopedDecl' and 'Mutual' are placed.++data DeclarationSpine+  = AxiomS+  | GeneralizeS+  | FieldS+  | PrimitiveS+  | MutualS [DeclarationSpine]+  | SectionS [DeclarationSpine]+  | ApplyS+  | ImportS+  | PragmaS+  | OpenS+  | FunDefS [ClauseSpine]+  | DataSigS+  | DataDefS+  | RecSigS+  | RecDefS [DeclarationSpine]+  | PatternSynDefS+  | UnquoteDeclS+  | UnquoteDefS+  | UnquoteDataS+  | ScopedDeclS [DeclarationSpine]+  | UnfoldingDeclS+  deriving Show++-- | Clause spines.++data ClauseSpine = ClauseS RHSSpine WhereDeclarationsSpine+  deriving Show++-- | Right-hand side spines.++data RHSSpine+  = RHSS+  | AbsurdRHSS+  | WithRHSS (List1 ClauseSpine)+  | RewriteRHSS RHSSpine WhereDeclarationsSpine+  deriving Show++-- | Spines corresponding to 'WhereDeclarations' values.++data WhereDeclarationsSpine = WhereDeclsS (Maybe DeclarationSpine)+  deriving Show++-- | The declaration spine corresponding to a declaration.++declarationSpine :: Declaration -> DeclarationSpine+declarationSpine = \case+  Axiom _ _ _ _ _ _       -> AxiomS+  Generalize _ _ _ _ _    -> GeneralizeS+  Field _ _ _             -> FieldS+  Primitive _ _ _         -> PrimitiveS+  Mutual _ ds             -> MutualS (map declarationSpine ds)+  Section _ _ _ _ ds      -> SectionS (map declarationSpine ds)+  Apply _ _ _ _ _ _       -> ApplyS+  Import _ _ _            -> ImportS+  Pragma _ _              -> PragmaS+  Open _ _ _              -> OpenS+  FunDef _ _ cs           -> FunDefS (map clauseSpine cs)+  DataSig _ _ _ _ _       -> DataSigS+  DataDef _ _ _ _ _       -> DataDefS+  RecSig _ _ _ _ _        -> RecSigS+  RecDef _ _ _ _ _ _ ds   -> RecDefS (map declarationSpine ds)+  PatternSynDef _ _ _     -> PatternSynDefS+  UnquoteDecl _ _ _ _     -> UnquoteDeclS+  UnquoteDef _ _ _        -> UnquoteDefS+  UnquoteData _ _ _ _ _ _ -> UnquoteDataS+  ScopedDecl _ ds         -> ScopedDeclS (map declarationSpine ds)+  UnfoldingDecl _ _       -> UnquoteDeclS++-- | The clause spine corresponding to a clause.++clauseSpine :: Clause -> ClauseSpine+clauseSpine (Clause _ _ rhs ws _) =+  ClauseS (rhsSpine rhs) (whereDeclarationsSpine ws)++-- | The right-hand side spine corresponding to a right-hand side.++rhsSpine :: RHS -> RHSSpine+rhsSpine = \case+  RHS _ _               -> RHSS+  AbsurdRHS             -> AbsurdRHSS+  WithRHS _ _ cs        -> WithRHSS $ fmap clauseSpine cs+  RewriteRHS _ _ rhs ws ->+    RewriteRHSS (rhsSpine rhs) (whereDeclarationsSpine ws)++-- | The spine corresponding to a 'WhereDeclarations' value.++whereDeclarationsSpine :: WhereDeclarations -> WhereDeclarationsSpine+whereDeclarationsSpine (WhereDecls _ _ md) =+  WhereDeclsS (fmap declarationSpine md)
src/full/Agda/Syntax/Abstract/Name.hs view
@@ -7,13 +7,12 @@   , FreshNameMode(..)   ) where -import Prelude hiding (length)+import Prelude hiding (length, null)  import Control.DeepSeq -import Data.Data (Data) import Data.Foldable (length)-import Data.Function+import Data.Function (on) import Data.Hashable (Hashable(..)) import qualified Data.List as List import Data.Maybe@@ -21,6 +20,7 @@  import Agda.Syntax.Position import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty import Agda.Syntax.Concrete.Name (IsNoName(..), NumHoles(..), NameInScope(..), LensInScope(..), FreshNameMode(..)) import qualified Agda.Syntax.Concrete.Name as C @@ -29,7 +29,7 @@ import qualified Agda.Utils.List as L import Agda.Utils.List1 (List1, pattern (:|), (<|)) import qualified Agda.Utils.List1 as List1-import Agda.Utils.Pretty+import Agda.Utils.Null import Agda.Utils.Size  import Agda.Utils.Impossible@@ -46,7 +46,7 @@   , nameIsRecordName :: Bool       -- ^ Is this the name of the invisible record variable `self`?       --   Should not be printed or displayed in the context, see issue #3584.-  } deriving Data+  }  -- | Useful for debugging scoping problems uglyShowName :: Name -> String@@ -61,7 +61,6 @@ data QName = QName { qnameModule :: ModuleName                    , qnameName   :: Name                    }-    deriving Data  -- | Something preceeded by a qualified name. data QNamed a = QNamed@@ -75,14 +74,14 @@ -- The 'SetRange' instance for module names sets all individual ranges -- to the given one. newtype ModuleName = MName { mnameToList :: [Name] }-  deriving (Eq, Ord, Data)+  deriving (Eq, Ord, NFData, Null)  -- | Ambiguous qualified names. Used for overloaded constructors. -- -- Invariant: All the names in the list must have the same concrete, -- unqualified name.  (This implies that they all have the same 'Range'). newtype AmbiguousQName = AmbQ { unAmbQ :: List1 QName }-  deriving (Eq, Ord, Data, NFData)+  deriving (Eq, Ord, NFData)  -- | A singleton "ambiguous" name. unambiguous :: QName -> AmbiguousQName@@ -105,8 +104,11 @@ data Suffix   = NoSuffix   | Suffix !Integer-  deriving (Data, Show, Eq, Ord)+  deriving (Show, Eq, Ord) +instance Null Suffix where+  empty = NoSuffix+ instance NFData Suffix where   rnf NoSuffix   = ()   rnf (Suffix _) = ()@@ -207,11 +209,10 @@ mnameToQName = qnameFromList . mnameToList1  showQNameId :: QName -> String-showQNameId q = show ns ++ "@" ++ show m+showQNameId q = show (List1.toList ns) ++ "@" ++ show (List1.head ms)   where-    is = map nameId $ mnameToList (qnameModule q) ++ [qnameName q]-    ns = [ n | NameId n _ <- is ]-    m  = head [ m | NameId _ m <- is ]+    (ns, ms) = List1.unzip $ fmap (unNameId . nameId) $ List1.snoc (mnameToList $ qnameModule q) (qnameName q)+    unNameId (NameId n m) = (n, m)  -- | Turn a qualified name into a concrete name. This should only be used as a --   fallback when looking up the right concrete name in the scope fails.@@ -225,16 +226,6 @@   where     cs = fmap nameConcrete (x :| xs) --- | Computes the 'TopLevelModuleName' corresponding to the given--- module name, which is assumed to represent a top-level module name.------ Precondition: The module name must be well-formed.--toTopLevelModuleName :: ModuleName -> C.TopLevelModuleName-toTopLevelModuleName (MName []) = __IMPOSSIBLE__-toTopLevelModuleName (MName ms) = List1.ifNull ms __IMPOSSIBLE__ {-else-} $ \ ms1 ->-  C.TopLevelModuleName (getRange ms1) $ fmap (C.nameToRawName . nameConcrete) ms1- qualifyM :: ModuleName -> ModuleName -> ModuleName qualifyM m1 m2 = mnameFromList $ mnameToList m1 ++ mnameToList m2 @@ -315,6 +306,9 @@ instance IsNoName Name where   isNoName = isNoName . nameConcrete +instance IsNoName ModuleName where+  isNoName (MName xs) = all isNoName xs+ instance NumHoles Name where   numHoles = numHoles . nameConcrete @@ -329,7 +323,7 @@ -- * name lenses ------------------------------------------------------------------------ -lensQNameName :: Lens' Name QName+lensQNameName :: Lens' QName Name lensQNameName f (QName m n) = QName m <$> f n  ------------------------------------------------------------------------@@ -448,7 +442,7 @@  instance KillRange Name where   killRange (Name a b c d e f) =-    (killRange6 Name a b c d e f) { nameBindingSite = d }+    (killRangeN Name a b c d e f) { nameBindingSite = d }     -- Andreas, 2017-07-25, issue #2649     -- Preserve the nameBindingSite for error message.     --@@ -466,7 +460,7 @@   killRange (MName xs) = MName $ killRange xs  instance KillRange QName where-  killRange (QName a b) = killRange2 QName a b+  killRange (QName a b) = killRangeN QName a b   -- killRange q = q { qnameModule = killRange $ qnameModule q   --                 , qnameName   = killRange $ qnameName   q   --                 }@@ -480,9 +474,11 @@  instance Sized QName where   size = size . qnameToList+  natSize = natSize . qnameToList  instance Sized ModuleName where   size = size . mnameToList+  natSize = natSize . mnameToList  ------------------------------------------------------------------------ -- * NFData instances@@ -495,6 +491,3 @@  instance NFData QName where   rnf (QName a b) = rnf a `seq` rnf b--instance NFData ModuleName where-  rnf (MName a) = rnf a
src/full/Agda/Syntax/Abstract/Pattern.hs view
@@ -10,11 +10,12 @@ import Control.Arrow           ( (***), second ) import Control.Monad           ( (>=>) ) import Control.Monad.Identity  ( Identity(..), runIdentity )+import Control.Monad.Reader    ( Reader, runReader, asks, local ) import Control.Applicative     ( liftA2 ) - import Data.Maybe import Data.Monoid+import Data.Void (Void)  import Agda.Syntax.Abstract as A import Agda.Syntax.Common@@ -26,7 +27,10 @@  import Agda.Utils.Functor import Agda.Utils.List+import Agda.Utils.List1 ( List1, pattern (:|) )+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Null+import Agda.Utils.Singleton  import Agda.Utils.Impossible @@ -59,12 +63,11 @@       PatternSynP i x ps -> f $ setNamedArg p $ PatternSynP i x $ mapNamedArgPattern f ps       -- Pattern subpattern(s):       -- RecP: we copy the NamedArg info to the subpatterns but discard it after recursion-      RecP i fs          -> f $ setNamedArg p $ RecP i $ map (fmap namedArg) $ mapNamedArgPattern f $ map (fmap (setNamedArg p)) fs+      RecP kwr i fs      -> f $ setNamedArg p $ RecP kwr i $ map (fmap namedArg) $ mapNamedArgPattern f $ map (fmap (setNamedArg p)) fs       -- AsP: we hand the NamedArg info to the subpattern       AsP i x p0         -> f $ updateNamedArg (AsP i x) $ mapNamedArgPattern f $ setNamedArg p p0       -- WithP: like AsP       WithP i p0         -> f $ updateNamedArg (WithP i) $ mapNamedArgPattern f $ setNamedArg p p0-      AnnP i a p0        -> f $ updateNamedArg (AnnP i a) $ mapNamedArgPattern f $ setNamedArg p p0  instance MapNamedArgPattern a => MapNamedArgPattern [a]                  where instance MapNamedArgPattern a => MapNamedArgPattern (FieldAssignment' a) where@@ -140,7 +143,7 @@       AsP _ _ p          -> foldrAPattern f p       ConP _ _ ps        -> foldrAPattern f ps       DefP _ _ ps        -> foldrAPattern f ps-      RecP _ ps          -> foldrAPattern f ps+      RecP _ _ ps        -> foldrAPattern f ps       PatternSynP _ _ ps -> foldrAPattern f ps       WithP _ p          -> foldrAPattern f p       VarP _             -> mempty@@ -150,7 +153,6 @@       AbsurdP _          -> mempty       LitP _ _           -> mempty       EqualP _ _         -> mempty-      AnnP _ _ p         -> foldrAPattern f p    traverseAPatternM pre post = pre >=> recurse >=> post     where@@ -167,10 +169,9 @@       A.ConP        i ds ps -> A.ConP        i ds <$> traverseAPatternM pre post ps       A.DefP        i q  ps -> A.DefP        i q  <$> traverseAPatternM pre post ps       A.AsP         i x  p  -> A.AsP         i x  <$> traverseAPatternM pre post p-      A.RecP        i    ps -> A.RecP        i    <$> traverseAPatternM pre post ps+      A.RecP    kwr i    ps -> A.RecP    kwr i    <$> traverseAPatternM pre post ps       A.PatternSynP i x  ps -> A.PatternSynP i x  <$> traverseAPatternM pre post ps       A.WithP       i p     -> A.WithP       i    <$> traverseAPatternM pre post p-      A.AnnP        i a  p  -> A.AnnP        i a  <$> traverseAPatternM pre post p  instance APatternLike a => APatternLike (Arg a) where   type ADotT (Arg a) = ADotT a@@ -223,7 +224,6 @@     A.EqualP      {} -> mempty     A.PatternSynP {} -> mempty     A.WithP _ _      -> mempty-    A.AnnP        {} -> mempty  -- | Check if a pattern contains a specific (sub)pattern. @@ -251,9 +251,9 @@ -- | Check if any user-written pattern variables occur more than once, --   and throw the given error if they do. checkPatternLinearity :: (Monad m, APatternLike p)-                      => p -> ([C.Name] -> m ()) -> m ()-checkPatternLinearity ps err =-  unlessNull (duplicates $ map nameConcrete $ patternVars ps) $ \ys -> err ys+  => p -> (List1 C.Name -> m ()) -> m ()+checkPatternLinearity =+  List1.unlessNull . duplicates . map nameConcrete . patternVars   -- * Specific traversals@@ -277,11 +277,10 @@ substPattern' subE s = mapAPattern $ \ p -> case p of   VarP x            -> fromMaybe p $ lookup (A.unBind x) s   DotP i e          -> DotP i $ subE e-  EqualP i es       -> EqualP i $ map (subE *** subE) es-  AnnP i a p        -> AnnP i (subE a) p+  EqualP i es       -> EqualP i $ fmap (subE *** subE) es   -- No action on the other patterns (besides the recursion):   ConP _ _ _        -> p-  RecP _ _          -> p+  RecP _ _ _        -> p   ProjP _ _ _       -> p   WildP _           -> p   AbsurdP _         -> p@@ -291,7 +290,79 @@   PatternSynP _ _ _ -> p   WithP _ _         -> p +-- | Convert a pattern to an expression.+--+-- Does not support all cases of patterns.+-- Result has no 'Range' info, except in identifiers.+--+-- This function is only used in expanding pattern synonyms+-- and in "Agda.Syntax.Translation.InternalToAbstract",+-- so we can cut some corners.+patternToExpr :: Pattern -> Expr+patternToExpr p = patToExpr p `runReader` empty +-- | Converting a pattern to an expression.+--+--   The 'Hiding' context is remembered to create instance metas+--   when translating absurd patterns in instance position.+--+class PatternToExpr p e where+  patToExpr :: p -> Reader Hiding e++  default patToExpr :: (Traversable t, PatternToExpr p' e', p ~ t p', e ~ t e')+    => p -> Reader Hiding e+  patToExpr = traverse patToExpr++instance PatternToExpr p e => PatternToExpr [p] [e]+instance PatternToExpr p e => PatternToExpr (Named n p) (Named n e)+instance PatternToExpr p e => PatternToExpr (FieldAssignment' p) (FieldAssignment' e)++instance PatternToExpr p e => PatternToExpr (Arg p) (Arg e) where+  patToExpr (Arg ai p) = local (const $ getHiding ai) $ Arg ai <$> patToExpr p++instance PatternToExpr Pattern Expr where+  patToExpr = \case+    VarP x             -> return $ Var (unBind x)+    ConP _ c ps        -> app (Con c) <$> patToExpr ps+    ProjP _ o ds       -> return $ Proj o ds+    DefP _ fs ps       -> app (Def $ headAmbQ fs) <$> patToExpr ps+    WildP _            -> return $ Underscore emptyMetaInfo+    AsP _ _ p          -> patToExpr p+    DotP _ e           -> return e+    -- Issue #7176: An absurd pattern in an instance position should turn into an instance meta:+    AbsurdP _          -> asks hidingToMetaKind <&> \ k -> Underscore emptyMetaInfo{ metaKind = k }+    LitP _ l           -> return $ Lit empty l+    PatternSynP _ c ps -> app (PatternSyn c) <$> patToExpr ps+    RecP kwr _ as      -> Rec kwr exprNoRange . map Left <$> patToExpr as+    EqualP{}           -> __IMPOSSIBLE__  -- Andrea TODO: where is this used?+    WithP r p          -> __IMPOSSIBLE__++-- | Make sure that there are no dot or equality patterns (called on pattern synonyms).+--   Also disallows annotated patterns.+--+noDotOrEqPattern :: forall m e. Monad m+  => m (A.Pattern' Void)   -- ^ Exception or replacement for dot (etc.) patterns.+  -> A.Pattern' e          -- ^ In pattern.+  -> m (A.Pattern' Void)   -- ^ Out pattern.+noDotOrEqPattern err = dot+  where+    dot :: A.Pattern' e -> m (A.Pattern' Void)+    dot = \case+      A.VarP x               -> pure $ A.VarP x+      A.ConP i c args        -> A.ConP i c <$> (traverse $ traverse $ traverse dot) args+      A.ProjP i o d          -> pure $ A.ProjP i o d+      A.WildP i              -> pure $ A.WildP i+      A.AsP i x p            -> A.AsP i x <$> dot p+      A.DotP{}               -> err+      A.EqualP{}             -> err   -- Andrea: so we also disallow = patterns, reasonable?+      A.AbsurdP i            -> pure $ A.AbsurdP i+      A.LitP i l             -> pure $ A.LitP i l+      A.DefP i f args        -> A.DefP i f <$> (traverse $ traverse $ traverse dot) args+      A.PatternSynP i c args -> A.PatternSynP i c <$> (traverse $ traverse $ traverse dot) args+      A.RecP kwr i fs        -> A.RecP kwr i <$> (traverse $ traverse dot) fs+      A.WithP i p            -> A.WithP i <$> dot p++ -- * Other pattern utilities ------------------------------------------------------------------------ @@ -313,11 +384,11 @@ -- -- (This view discards 'PatInfo'.) data LHSPatternView e-  = LHSAppP  (NAPs e)+  = LHSAppP  (NAPs1 e)       -- ^ Application patterns (non-empty list).   | LHSProjP ProjOrigin AmbiguousQName (NamedArg (Pattern' e))       -- ^ A projection pattern.  Is also stored unmodified here.-  | LHSWithP [Pattern' e]+  | LHSWithP (List1 (Pattern' e))       -- ^ With patterns (non-empty list).       --   These patterns are not prefixed with 'WithP'.   deriving (Show)@@ -332,11 +403,11 @@   case namedArg p0 of     ProjP _i o d -> Just (LHSProjP o d p0, ps)     -- If the next pattern is a with-pattern, collect more with-patterns-    WithP _i p   -> Just (LHSWithP (p : map namedArg ps1), ps2)+    WithP _i p   -> Just (LHSWithP (p :| map namedArg ps1), ps2)       where       (ps1, ps2) = spanJust isWithP ps     -- If the next pattern is an application pattern, collect more of these-    _ -> Just (LHSAppP (p0 : ps1), ps2)+    _ -> Just (LHSAppP (p0 :| ps1), ps2)       where       (ps1, ps2) = span (\ p -> isNothing (isProjP p) && isNothing (isWithP p)) ps @@ -369,7 +440,7 @@   LHSHead f ps     -> QNamed f ps   LHSProj d h ps   -> lhsCoreToSpine (namedArg h) <&> (++ (p : ps))     where p = updateNamedArg (const $ ProjP empty ProjPrefix d) h-  LHSWith h wps ps -> lhsCoreToSpine h <&> (++ map fromWithPat wps ++ ps)+  LHSWith h wps ps -> lhsCoreToSpine h <&> (++ map fromWithPat (List1.toList wps) ++ ps)     where       fromWithPat :: Arg (Pattern' e) -> NamedArg (Pattern' e)       fromWithPat = fmap (unnamed . mkWithP)@@ -383,16 +454,16 @@ lhsCoreApp core ps = core { lhsPats = lhsPats core ++ ps }  -- | Add with-patterns to the right.-lhsCoreWith :: LHSCore' e -> [Arg (Pattern' e)] -> LHSCore' e-lhsCoreWith (LHSWith core wps []) wps' = LHSWith core (wps ++ wps') []+lhsCoreWith :: LHSCore' e -> List1 (Arg (Pattern' e)) -> LHSCore' e+lhsCoreWith (LHSWith core wps []) wps' = LHSWith core (wps <> wps') [] lhsCoreWith core                  wps' = LHSWith core wps' []  lhsCoreAddChunk :: IsProjP e => LHSCore' e -> LHSPatternView e -> LHSCore' e lhsCoreAddChunk core = \case-  LHSAppP ps               -> lhsCoreApp core ps+  LHSAppP ps               -> lhsCoreApp core $ List1.toList ps   LHSWithP wps             -> lhsCoreWith core (defaultArg <$> wps)   LHSProjP ProjPrefix d np -> LHSProj d (setNamedArg np core) []  -- Prefix projection pattern.-  LHSProjP _          _ np -> lhsCoreApp core [np]       -- Postfix projection pattern.+  LHSProjP _          _ np -> lhsCoreApp core (singleton np)      -- Postfix projection pattern.  -- | Add projection, with, and applicative patterns to the right. lhsCoreAddSpine :: IsProjP e => LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e@@ -426,7 +497,7 @@     LHSProj d lhscore aps -> DefP noInfo d $       fmap (fmap lhsCoreToPattern) lhscore : aps     LHSWith h wps aps     -> case lhsCoreToPattern h of-      DefP r q ps         -> DefP r q $ ps ++ map fromWithPat wps ++ aps+      DefP r q ps         -> DefP r q $ ps ++ map fromWithPat (List1.toList wps) ++ aps         where           fromWithPat :: Arg Pattern -> NamedArg Pattern           fromWithPat = fmap (unnamed . mkWithP)
src/full/Agda/Syntax/Abstract/PatternSynonyms.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Pattern synonym utilities: folding pattern synonym definitions for --   printing and merging pattern synonym definitions to handle overloaded@@ -32,8 +33,8 @@  mergeDef :: PatternSynDefn -> PatternSynDefn -> Maybe PatternSynDefn mergeDef (xs, p) (ys, q) = do-  guard $ map getArgInfo xs == map getArgInfo ys-  let ren = zip (map unArg xs) (map unArg ys)+  guard $ map whHiding xs == map whHiding ys+  let ren = zip (map whThing xs) (map whThing ys)   (xs,) <$> merge ren p q   where     merge ren p@(VarP x) (VarP y)   = p <$ guard ((unBind x, unBind y) `elem` ren)@@ -47,7 +48,7 @@     mergeArg ren p q = setNamedArg p <$> merge ren (namedArg p) (namedArg q)  -- | Match an expression against a pattern synonym.-matchPatternSyn :: PatternSynDefn -> Expr -> Maybe [Arg Expr]+matchPatternSyn :: PatternSynDefn -> Expr -> Maybe [WithHiding Expr] matchPatternSyn = runMatch match   where     match (VarP x) e = unBind x ==> e@@ -60,7 +61,7 @@     match _ _ = empty  -- | Match a pattern against a pattern synonym.-matchPatternSynP :: PatternSynDefn -> Pattern' e -> Maybe [Arg (Pattern' e)]+matchPatternSynP :: PatternSynDefn -> Pattern' e -> Maybe [WithHiding (Pattern' e)] matchPatternSynP = runMatch match   where     match (VarP x) q = unBind x ==> q@@ -77,7 +78,7 @@ (==>) :: Name -> e -> Match e () x ==> e = tell (Map.singleton x e) -runMatch :: (Pattern' Void -> e -> Match e ()) -> PatternSynDefn -> e -> Maybe [Arg e]+runMatch :: (Pattern' Void -> e -> Match e ()) -> PatternSynDefn -> e -> Maybe [WithHiding e] runMatch match (xs, pat) e = do   sub <- execWriterT (match pat e)-  forM xs $ \ x -> (<$ x) <$> Map.lookup (unArg x) sub+  forM xs $ \ x -> (<$ x) <$> Map.lookup (whThing x) sub
src/full/Agda/Syntax/Abstract/Pretty.hs view
@@ -1,9 +1,10 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Syntax.Abstract.Pretty where  import Agda.Syntax.Fixity import Agda.Syntax.Translation.AbstractToConcrete-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty  showA :: (ToConcrete a, Show (ConOfAbs a), MonadAbsToCon m) => a -> m String showA x = show <$> abstractToConcrete_ x@@ -23,3 +24,8 @@  prettyATop :: (ToConcrete a, Pretty (ConOfAbs a),  MonadAbsToCon m) => a -> m Doc prettyATop x = pretty <$> abstractToConcreteCtx TopCtx x++-- | Variant of 'prettyA' which unqualifies out-of-scope names.++prettyAUnqualify :: (ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) => a -> m Doc+prettyAUnqualify x = pretty <$> abstractToConcreteUnqualify x
+ src/full/Agda/Syntax/Abstract/UsedNames.hs view
@@ -0,0 +1,181 @@++module Agda.Syntax.Abstract.UsedNames+  ( allUsedNames+  ) where++import Data.Foldable (foldMap)+import Data.Semigroup (Semigroup, (<>))+import Data.Set (Set)+import qualified Data.Set as Set++import Agda.Syntax.Common+import Agda.Syntax.Abstract+import Agda.Syntax.Concrete (FieldAssignment'(..))+import Agda.Utils.List1 (List1)++import Agda.Utils.Impossible++-- | All names used in an abstract expression. This is used when rendering clauses to figure out+--   which (implicit) pattern variables must be preserved. For example, the for @f : Nat → Nat@, the+--   clause @f {n} = 0@ can be printed as @f = 0@ (dropping the @n@), but @f {n} = n@ must preserve+--   the @n@.+allUsedNames :: Expr -> Set Name+allUsedNames = usedNames . boundAndUsed++data BoundAndUsedNames = BoundAndUsedNames+  { boundNames :: Set Name+  , usedNames  :: Set Name }++-- | Bound names in first argument scope over second argument.+instance Semigroup BoundAndUsedNames where+  BoundAndUsedNames bound1 used1 <> BoundAndUsedNames bound2 used2 =+    BoundAndUsedNames (bound1 <> bound2) (used1 <> Set.difference used2 bound1)++instance Monoid BoundAndUsedNames where+  mempty  = BoundAndUsedNames mempty mempty+  mappend = (<>)++singleUse :: Name -> BoundAndUsedNames+singleUse x = BoundAndUsedNames mempty (Set.singleton x)++singleBind :: Name -> BoundAndUsedNames+singleBind x = BoundAndUsedNames (Set.singleton x) mempty++noBindings :: BoundAndUsedNames -> BoundAndUsedNames+noBindings names = names{ boundNames = mempty }++-- | Bound names in first argument do *not* scope over second argument.+parB :: BoundAndUsedNames -> BoundAndUsedNames -> BoundAndUsedNames+parB (BoundAndUsedNames bound1 used1) (BoundAndUsedNames bound2 used2) =+  BoundAndUsedNames (bound1 <> bound2) (used1 <> used2)++parBindings :: (BoundAndUsed a, BoundAndUsed b) => a -> b -> BoundAndUsedNames+parBindings a b = boundAndUsed a `parB` boundAndUsed b++parBoundAndUsed :: (Foldable f, BoundAndUsed a) => f a -> BoundAndUsedNames+parBoundAndUsed = foldr parBindings mempty++class BoundAndUsed a where+  boundAndUsed :: a -> BoundAndUsedNames++  default boundAndUsed :: (a ~ f b, Foldable f, BoundAndUsed b) => a -> BoundAndUsedNames+  boundAndUsed = foldMap boundAndUsed++instance BoundAndUsed BoundAndUsedNames where+  boundAndUsed = id++instance BoundAndUsed a => BoundAndUsed (Arg a)+instance BoundAndUsed a => BoundAndUsed (Named n a)+instance BoundAndUsed a => BoundAndUsed (List1 a)+instance BoundAndUsed a => BoundAndUsed [a]+instance BoundAndUsed a => BoundAndUsed (Maybe a)++instance (BoundAndUsed a, BoundAndUsed b) => BoundAndUsed (Either a b) where+  boundAndUsed = either boundAndUsed boundAndUsed++instance BoundAndUsed ModuleName where+  boundAndUsed _ = mempty++instance (BoundAndUsed a, BoundAndUsed b) => BoundAndUsed (a, b) where+  boundAndUsed (a, b) = boundAndUsed a <> boundAndUsed b++instance BoundAndUsed Expr where+  boundAndUsed = noBindings . \ case+    Var x                  -> singleUse x+    Def'{}                 -> mempty+    Proj{}                 -> mempty+    Con{}                  -> mempty+    PatternSyn{}           -> mempty+    Macro{}                -> mempty+    Lit{}                  -> mempty+    QuestionMark{}         -> mempty+    Underscore{}           -> mempty+    Dot _ expr             -> boundAndUsed expr+    App _ expr arg         -> boundAndUsed (expr, arg)+    WithApp _ expr exprs   -> boundAndUsed (expr, exprs)+    Lam _ bind expr        -> boundAndUsed (bind, expr)+    AbsurdLam{}            -> mempty+    ExtendedLam _ _ _ _ cs -> boundAndUsed cs+    Pi _ tel expr          -> boundAndUsed (tel, expr)+    Generalized _ expr     -> boundAndUsed expr+    Fun _ arg expr         -> boundAndUsed (arg, expr)+    Let _ binds expr       -> boundAndUsed (binds, expr)+    Rec _ _ as             -> boundAndUsed as+    RecUpdate _ _ expr as  -> boundAndUsed expr <> boundAndUsed as+    ScopedExpr _ expr      -> boundAndUsed expr+    Quote{}                -> mempty+    QuoteTerm{}            -> mempty+    Unquote{}              -> mempty+    DontCare expr          -> boundAndUsed expr++instance BoundAndUsed lhs => BoundAndUsed (Clause' lhs) where+  -- Note: where declarations are ignored. We use this only on expressions coming from+  --       InternalToAbstract where there are no where decls.+  boundAndUsed Clause{ clauseLHS = lhs, clauseRHS = rhs } = boundAndUsed (lhs, rhs)++instance BoundAndUsed RHS where+  boundAndUsed = \ case+    RHS body _              -> boundAndUsed body+    AbsurdRHS               -> mempty+    WithRHS _ es cs         -> boundAndUsed (es, cs)+    RewriteRHS eqns _ rhs _ -> boundAndUsed (eqns, rhs)++instance BoundAndUsed LHS where+  boundAndUsed = boundAndUsed . lhsCore++instance BoundAndUsed e => BoundAndUsed (LHSCore' e) where+  boundAndUsed = \ case+    LHSHead _ ps       -> parBoundAndUsed ps+    LHSProj _ lhs ps   -> lhs `parBindings` parBoundAndUsed ps+    LHSWith lhs wps ps -> lhs `parBindings` parBoundAndUsed wps+                              `parBindings` parBoundAndUsed ps++instance (BoundAndUsed x, BoundAndUsed p, BoundAndUsed e) => BoundAndUsed (RewriteEqn' q x p e) where+  boundAndUsed (Rewrite es)  = boundAndUsed $ snd <$> es+  boundAndUsed (Invert _ bs) = parBoundAndUsed (namedThing <$> bs) <> boundAndUsed (nameOf <$> bs)+  boundAndUsed (LeftLet bs)  = boundAndUsed bs++instance BoundAndUsed LetBinding where+  boundAndUsed = \ case   -- Note: binder last since it's not recursive+    LetBind _ _ x ty e     -> boundAndUsed ((ty, e), x)+    LetAxiom _ _ x ty      -> boundAndUsed (ty, x)+    LetPatBind _ p e       -> boundAndUsed (e, p)+    LetApply _ _ _ app _ _ -> boundAndUsed app+    LetOpen{}              -> mempty++instance BoundAndUsed LamBinding where+  boundAndUsed (DomainFree _ b) = boundAndUsed b+  boundAndUsed (DomainFull b)   = boundAndUsed b++instance BoundAndUsed TypedBinding where+  boundAndUsed (TBind _ _ bs ty) = boundAndUsed (ty, bs)+  boundAndUsed (TLet _ bs)       = boundAndUsed bs++instance BoundAndUsed name => BoundAndUsed (Binder' name) where+  boundAndUsed (Binder p _ x) = parBindings p x++instance BoundAndUsed BindName where+  boundAndUsed x = singleBind (unBind x)++instance BoundAndUsed e => BoundAndUsed (Pattern' e) where+  boundAndUsed = \ case+    VarP x             -> boundAndUsed x+    ConP _ _ ps        -> parBoundAndUsed ps+    ProjP{}            -> mempty+    DefP _ _ ps        -> parBoundAndUsed ps+    WildP{}            -> mempty+    AsP _ x p          -> parBindings x p+    DotP _ e           -> boundAndUsed e+    AbsurdP{}          -> mempty+    LitP{}             -> mempty+    PatternSynP _ _ ps -> parBoundAndUsed ps+    RecP _ _ as        -> parBoundAndUsed as+    EqualP _ eqs       -> parBoundAndUsed eqs+    WithP _ p          -> boundAndUsed p++instance BoundAndUsed e => BoundAndUsed (FieldAssignment' e) where+  boundAndUsed (FieldAssignment _ e) = boundAndUsed e++instance BoundAndUsed ModuleApplication where+  boundAndUsed (SectionApp tel _ es)  = noBindings $ boundAndUsed (tel, es)+  boundAndUsed RecordModuleInstance{} = mempty
src/full/Agda/Syntax/Abstract/Views.hs view
@@ -4,16 +4,16 @@ import Prelude hiding (null)  import Control.Applicative ( Const(Const), getConst )-import Control.Arrow (first) import Control.Monad.Identity  import Data.Foldable (foldMap)+import qualified Data.DList as DL import Data.Semigroup ((<>)) import Data.Void  import Agda.Syntax.Common import Agda.Syntax.Abstract as A-import Agda.Syntax.Concrete (FieldAssignment', exprFieldA)+import Agda.Syntax.Concrete (FieldAssignment', exprFieldA, TacticAttribute') import Agda.Syntax.Info import Agda.Syntax.Scope.Base (KindOfName(..), conKindOfName, WithKind(..)) @@ -37,18 +37,20 @@ appView = fmap snd . appView'  appView' :: Expr -> AppView' (AppInfo, Expr)-appView' e =-  case e of+appView' e = f (DL.toList es)+  where+  (f, es) = appView'' e++  appView'' = \case     App i e1 e2       | Dot _ e2' <- unScope $ namedArg e2       , Just f <- maybeProjTurnPostfix e2'       , getHiding e2 == NotHidden -- Jesper, 2018-12-13: postfix projections shouldn't be hidden-                   -> Application f [defaultNamedArg (i, e1)]-    App i e1 arg-      | Application hd es <- appView' e1-                   -> Application hd $ es ++ [(fmap . fmap) (i,) arg]-    ScopedExpr _ e -> appView' e-    _              -> Application e []+      -> (Application f, singleton (defaultNamedArg (i, e1)))+    App i e1 arg | (f, es) <- appView'' e1 ->+      (f, es `DL.snoc` (fmap . fmap) (i,) arg)+    ScopedExpr _ e -> appView'' e+    e              -> (Application e, mempty)  maybeProjTurnPostfix :: Expr -> Maybe Expr maybeProjTurnPostfix e =@@ -70,12 +72,23 @@ lamView (ScopedExpr _ e) = lamView e lamView e = LamView [] e --- | Gather top-level 'AsP'atterns and 'AnnP'atterns to expose underlying pattern.-asView :: A.Pattern -> ([Name], [A.Expr], A.Pattern)-asView (A.AsP _ x p)  = (\(asb, ann, p) -> (unBind x : asb, ann, p)) $ asView p-asView (A.AnnP _ a p) = (\(asb, ann, p) -> (asb, a : ann, p))        $ asView p-asView p              = ([], [], p)+-- | Collect @A.Pi@s.+data PiView = PiView [(ExprInfo, Telescope1)] Type +piView :: Expr -> PiView+piView = \case+   Pi i tel b -> cons $ piView b+     where cons (PiView tels t) = PiView ((i,tel) : tels) t+   e -> PiView [] e++unPiView :: PiView -> Expr+unPiView (PiView tels t) = foldr (uncurry Pi) t tels++-- | Gather top-level 'AsP'atterns to expose underlying pattern.+asView :: A.Pattern -> ([Name], A.Pattern)+asView (A.AsP _ x p)  = (\(asb, p) -> (unBind x : asb, p)) $ asView p+asView p              = ([], p)+ -- | Remove top 'ScopedExpr' wrappers. unScope :: Expr -> Expr unScope (ScopedExpr scope e) = unScope e@@ -94,12 +107,15 @@ deepUnscopeDecls = concatMap deepUnscopeDecl  deepUnscopeDecl :: A.Declaration -> [A.Declaration]-deepUnscopeDecl (A.ScopedDecl _ ds)              = deepUnscopeDecls ds-deepUnscopeDecl (A.Mutual i ds)                  = [A.Mutual i (deepUnscopeDecls ds)]-deepUnscopeDecl (A.Section i m tel ds)           = [A.Section i m (deepUnscope tel) (deepUnscopeDecls ds)]-deepUnscopeDecl (A.RecDef i x uc dir bs e ds) =-  [ A.RecDef i x uc dir (deepUnscope bs) (deepUnscope e) (deepUnscopeDecls ds) ]-deepUnscopeDecl d                                = [deepUnscope d]+deepUnscopeDecl = \case+  A.ScopedDecl _ ds           -> deepUnscopeDecls ds+  A.Mutual i ds               -> [A.Mutual i (deepUnscopeDecls ds)]+  A.Section i e m tel ds      -> [A.Section i e m (deepUnscope tel)+                                   (deepUnscopeDecls ds)]+  A.RecDef i x uc dir bs e ds -> [ A.RecDef i x uc dir (deepUnscope bs)+                                     (deepUnscope e)+                                     (deepUnscopeDecls ds) ]+  d                           -> [deepUnscope d]  -- * Traversal ---------------------------------------------------------------------------@@ -157,9 +173,8 @@       Generalized  s e           -> Generalized s <$> recurse e       Fun ei arg e               -> Fun ei <$> recurse arg <*> recurse e       Let ei bs e                -> Let ei <$> recurse bs <*> recurse e-      ETel tel                   -> ETel <$> recurse tel-      Rec ei bs                  -> Rec ei <$> recurse bs-      RecUpdate ei e bs          -> RecUpdate ei <$> recurse e <*> recurse bs+      Rec kwr ei bs              -> Rec kwr ei <$> recurse bs+      RecUpdate kwr ei e bs      -> RecUpdate kwr ei <$> recurse e <*> recurse bs       ScopedExpr sc e            -> ScopedExpr sc <$> recurse e       Quote{}                    -> pure e0       QuoteTerm{}                -> pure e0@@ -190,9 +205,8 @@       Generalized _ e        -> m `mappend` fold e       Fun _ e e'             -> m `mappend` fold e `mappend` fold e'       Let _ bs e             -> m `mappend` fold bs `mappend` fold e-      ETel tel               -> m `mappend` fold tel-      Rec _ as               -> m `mappend` fold as-      RecUpdate _ e as       -> m `mappend` fold e `mappend` fold as+      Rec _ _ as             -> m `mappend` fold as+      RecUpdate _ _ e as     -> m `mappend` fold e `mappend` fold as       ScopedExpr _ e         -> m `mappend` fold e       Quote{}                -> m       QuoteTerm{}            -> m@@ -226,9 +240,8 @@       Generalized s e            -> f =<< Generalized s <$> trav e       Fun ei arg e               -> f =<< Fun ei <$> trav arg <*> trav e       Let ei bs e                -> f =<< Let ei <$> trav bs <*> trav e-      ETel tel                   -> f =<< ETel <$> trav tel-      Rec ei bs                  -> f =<< Rec ei <$> trav bs-      RecUpdate ei e bs          -> f =<< RecUpdate ei <$> trav e <*> trav bs+      Rec kwr ei bs              -> f =<< Rec kwr ei <$> trav bs+      RecUpdate kwr ei e bs      -> f =<< RecUpdate kwr ei <$> trav e <*> trav bs       ScopedExpr sc e            -> f =<< ScopedExpr sc <$> trav e       Quote{}                    -> f e       QuoteTerm{}                -> f e@@ -240,8 +253,10 @@ instance ExprLike a => ExprLike (Arg a) instance ExprLike a => ExprLike (Maybe a) instance ExprLike a => ExprLike (Named x a)+instance ExprLike a => ExprLike (Ranged a) instance ExprLike a => ExprLike [a] instance ExprLike a => ExprLike (List1 a)+instance ExprLike a => ExprLike (TacticAttribute' a)  instance (ExprLike a, ExprLike b) => ExprLike (a, b) where   recurseExpr f (x, y) = (,) <$> recurseExpr f x <*> recurseExpr f y@@ -289,6 +304,11 @@   foldExpr     f (DataDefParams s tel) = foldExpr f tel   traverseExpr f (DataDefParams s tel) = DataDefParams s <$> traverseExpr f tel +instance ExprLike TypedBindingInfo where+  recurseExpr f (TypedBindingInfo s t)  = TypedBindingInfo <$> recurseExpr f s <*> pure t+  foldExpr f (TypedBindingInfo s t)     = foldExpr f s+  traverseExpr f (TypedBindingInfo s t) = TypedBindingInfo <$> traverseExpr f s <*> pure t+ instance ExprLike TypedBinding where   recurseExpr f e =     case e of@@ -311,19 +331,19 @@       recurse e = recurseExpr f e     case e of       LetBind li ai x e e'  -> LetBind li ai x <$> recurse e <*> recurse e'+      LetAxiom li ai x e    -> LetAxiom li ai x <$> recurse e       LetPatBind li p e     -> LetPatBind li <$> recurse p <*> recurse e       LetApply{}            -> pure e       LetOpen{}             -> pure e-      LetDeclaredVariable _ -> pure e    foldExpr :: forall m. FoldExprFn m LetBinding   foldExpr f e =     case e of       LetBind _ _ _ e e'    -> fold e `mappend` fold e'+      LetAxiom _ _ _ e      -> fold e       LetPatBind _ p e      -> fold p `mappend` fold e       LetApply{}            -> mempty       LetOpen{}             -> mempty-      LetDeclaredVariable _ -> mempty     where       fold :: FoldExprRecFn m       fold e = foldExpr f e@@ -335,10 +355,10 @@       trav e = traverseExpr f e     case e of       LetBind li ai x e e'  -> LetBind li ai x <$> trav e <*> trav e'+      LetAxiom li ai x e    -> LetAxiom li ai x <$> trav e       LetPatBind li p e     -> LetPatBind li <$> trav p <*> trav e       LetApply{}            -> pure e       LetOpen{}             -> pure e-      LetDeclaredVariable _ -> pure e  instance ExprLike a => ExprLike (Pattern' a) where @@ -365,9 +385,10 @@   recurseExpr f = \case     Rewrite es    -> Rewrite <$> recurseExpr f es     Invert qn pes -> Invert <$> recurseExpr f qn <*> recurseExpr f pes+    LeftLet pes   -> LeftLet <$> recurseExpr f pes  instance ExprLike WhereDeclarations where-  recurseExpr f (WhereDecls a b) = WhereDecls a <$> recurseExpr f b+  recurseExpr f (WhereDecls a b c) = WhereDecls a b <$> recurseExpr f c  instance ExprLike ModuleApplication where   recurseExpr :: forall m. RecurseExprFn m ModuleApplication@@ -390,8 +411,11 @@       CompilePragma{}             -> pure p       StaticPragma{}              -> pure p       InjectivePragma{}           -> pure p+      InjectiveForInferencePragma{} -> pure p       InlinePragma{}              -> pure p       EtaPragma{}                 -> pure p+      NotProjectionLikePragma{}   -> pure p+      OverlapPragma{}             -> pure p       DisplayPragma f xs e        -> DisplayPragma f <$> rec xs <*> rec e     where       rec :: RecurseExprRecFn m@@ -415,20 +439,22 @@       Field i x e               -> Field i x <$> rec e       Primitive i x e           -> Primitive i x <$> rec e       Mutual i ds               -> Mutual i <$> rec ds-      Section i m tel ds        -> Section i m <$> rec tel <*> rec ds-      Apply i m a ci d          -> (\ a -> Apply i m a ci d) <$> rec a+      Section i e m tel ds      -> Section i e m <$> rec tel <*> rec ds+      Apply i e m a ci d        -> (\a -> Apply i e m a ci d) <$> rec a       Import{}                  -> pure d       Pragma i p                -> Pragma i <$> rec p       Open{}                    -> pure d-      FunDef i f d cs           -> FunDef i f d <$> rec cs-      DataSig i d tel e         -> DataSig i d <$> rec tel <*> rec e+      FunDef i f cs             -> FunDef i f <$> rec cs+      DataSig i er d tel e      -> DataSig i er d <$> rec tel <*> rec e       DataDef i d uc bs cs      -> DataDef i d uc <$> rec bs <*> rec cs-      RecSig i r tel e          -> RecSig i r <$> rec tel <*> rec e+      RecSig i er r tel e       -> RecSig i er r <$> rec tel <*> rec e       RecDef i r uc dir bs e ds -> RecDef i r uc dir <$> rec bs <*> rec e <*> rec ds       PatternSynDef f xs p      -> PatternSynDef f xs <$> rec p       UnquoteDecl i is xs e     -> UnquoteDecl i is xs <$> rec e       UnquoteDef i xs e         -> UnquoteDef i xs <$> rec e+      UnquoteData i xs uc j cs e -> UnquoteData i xs uc j cs <$> rec e       ScopedDecl s ds           -> ScopedDecl s <$> rec ds+      UnfoldingDecl r ds        -> UnfoldingDecl r <$> rec ds     where       rec :: RecurseExprRecFn m       rec e = recurseExpr f e@@ -470,7 +496,9 @@  instance DeclaredNames RecordDirectives where   declaredNames (RecordDirectives i _ _ c) = kc where-    kc = maybe mempty (singleton . WithKind k) c+    kc = case c of+      NamedRecCon c -> singleton $ WithKind k c+      FreshRecCon{} -> mempty     k  = maybe ConName (conKindOfName . rangedThing) i  instance DeclaredNames Declaration where@@ -483,20 +511,22 @@       Field _ q _                  -> singleton (WithKind FldName q)       Primitive _ q _              -> singleton (WithKind PrimName q)       Mutual _ decls               -> declaredNames decls-      DataSig _ q _ _              -> singleton (WithKind DataName q)+      DataSig _ _ q _ _            -> singleton (WithKind DataName q)       DataDef _ q _ _ decls        -> singleton (WithKind DataName q) <> foldMap con decls-      RecSig _ q _ _               -> singleton (WithKind RecName q)+      RecSig _ _ q _ _             -> singleton (WithKind RecName q)       RecDef _ q _ dir _ _ decls   -> singleton (WithKind RecName q) <> declaredNames dir <> declaredNames decls       PatternSynDef q _ _          -> singleton (WithKind PatternSynName q)       UnquoteDecl _ _ qs _         -> fromList $ map (WithKind OtherDefName) qs  -- could be Fun or Axiom       UnquoteDef _ qs _            -> fromList $ map (WithKind FunName) qs       -- cannot be Axiom-      FunDef _ q _ cls             -> singleton (WithKind FunName q) <> declaredNames cls+      UnquoteData _ d _ _ cs _     -> singleton (WithKind DataName d) <> fromList (map (WithKind ConName) cs) -- singleton _ <> map (WithKind ConName) cs+      FunDef _ q cls               -> singleton (WithKind FunName q) <> declaredNames cls       ScopedDecl _ decls           -> declaredNames decls-      Section _ _ _ decls          -> declaredNames decls+      Section _ _ _ _ decls        -> declaredNames decls       Pragma _ pragma              -> declaredNames pragma       Apply{}                      -> mempty       Import{}                     -> mempty       Open{}                       -> mempty+      UnfoldingDecl{}              -> mempty     where     con = \case       Axiom _ _ _ _ q _ -> singleton $ WithKind ConName q@@ -505,21 +535,24 @@ instance DeclaredNames Pragma where   declaredNames = \case     BuiltinNoDefPragma _b kind x -> singleton $ WithKind kind x-    BuiltinPragma{}         -> mempty-    CompilePragma{}         -> mempty-    RewritePragma{}         -> mempty-    StaticPragma{}          -> mempty-    EtaPragma{}             -> mempty-    InjectivePragma{}       -> mempty-    InlinePragma{}          -> mempty-    DisplayPragma{}         -> mempty-    OptionsPragma{}         -> mempty+    BuiltinPragma{}           -> mempty+    CompilePragma{}           -> mempty+    RewritePragma{}           -> mempty+    StaticPragma{}            -> mempty+    EtaPragma{}               -> mempty+    InjectivePragma{}         -> mempty+    InjectiveForInferencePragma{} -> mempty+    InlinePragma{}            -> mempty+    NotProjectionLikePragma{} -> mempty+    DisplayPragma{}           -> mempty+    OptionsPragma{}           -> mempty+    OverlapPragma{}           -> mempty  instance DeclaredNames Clause where   declaredNames (Clause _ _ rhs decls _) = declaredNames rhs <> declaredNames decls  instance DeclaredNames WhereDeclarations where-  declaredNames (WhereDecls _ ds) = declaredNames ds+  declaredNames (WhereDecls _ _ ds) = declaredNames ds  instance DeclaredNames RHS where   declaredNames = \case@@ -575,7 +608,6 @@ --     Set{}                 -> mempty --     Prop{}                -> mempty --     Let _ lbs e           -> declaredNames lbs <> declaredNames e---     ETel{}                -> __IMPOSSIBLE__ --     Rec _ fields          -> declaredNames fields --     RecUpdate _ e fs      -> declaredNames e <> declaredNames fs --     ScopedExpr _ e        -> declaredNames e@@ -599,7 +631,6 @@ --   declaredNames (LetPatBind _ _ e)      = declaredNames e --   declaredNames (LetApply _ _ app _ _)  = declaredNames app --   declaredNames LetOpen{}               = mempty---   declaredNames (LetDeclaredVariable _) = mempty  -- instance DeclaredNames ModuleApplication where --   declaredNames (SectionApp bindss _ es) = declaredNames bindss <> declaredNames es
src/full/Agda/Syntax/Builtin.hs view
@@ -1,318 +1,1087 @@--- | This module defines the names of all BUILTINs.-module Agda.Syntax.Builtin where--import Agda.Utils.List--builtinNat, builtinSuc, builtinZero, builtinNatPlus, builtinNatMinus,-  builtinNatTimes, builtinNatDivSucAux, builtinNatModSucAux, builtinNatEquals,-  builtinNatLess, builtinInteger, builtinIntegerPos, builtinIntegerNegSuc,-  builtinWord64,-  builtinFloat, builtinChar, builtinString, builtinUnit, builtinUnitUnit,-  builtinSigma,-  builtinBool, builtinTrue, builtinFalse,-  builtinList, builtinNil, builtinCons, builtinIO,-  builtinMaybe, builtinNothing, builtinJust,-  builtinPath, builtinPathP, builtinInterval, builtinIZero, builtinIOne, builtinPartial, builtinPartialP,-  builtinIMin, builtinIMax, builtinINeg,-  builtinIsOne,  builtinItIsOne, builtinIsOne1, builtinIsOne2, builtinIsOneEmpty,-  builtinComp, builtinPOr,-  builtinTrans, builtinHComp,-  builtinSub, builtinSubIn, builtinSubOut,-  builtinEquiv, builtinEquivFun, builtinEquivProof,-  builtinTranspProof,-  builtinGlue, builtin_glue, builtin_unglue,-  builtin_glueU, builtin_unglueU,-  builtinFaceForall,-  builtinId, builtinConId, builtinIdElim,-  builtinSizeUniv, builtinSize, builtinSizeLt,-  builtinSizeSuc, builtinSizeInf, builtinSizeMax,-  builtinInf, builtinSharp, builtinFlat,-  builtinEquality, builtinRefl, builtinRewrite, builtinLevelMax,-  builtinLevel, builtinLevelZero, builtinLevelSuc,-  builtinSet, builtinProp, builtinSetOmega, builtinStrictSet, builtinSSetOmega,-  builtinLockUniv,-  builtinFromNat, builtinFromNeg, builtinFromString,-  builtinQName, builtinAgdaSort, builtinAgdaSortSet, builtinAgdaSortLit,-  builtinAgdaSortProp, builtinAgdaSortPropLit, builtinAgdaSortInf,-  builtinAgdaSortUnsupported,-  builtinHiding, builtinHidden, builtinInstance, builtinVisible,-  builtinRelevance, builtinRelevant, builtinIrrelevant,-  builtinQuantity, builtinQuantity0, builtinQuantityω,-  builtinModality, builtinModalityConstructor,-  builtinAssoc, builtinAssocLeft, builtinAssocRight, builtinAssocNon,-  builtinPrecedence, builtinPrecRelated, builtinPrecUnrelated,-  builtinFixity, builtinFixityFixity,-  builtinArgInfo, builtinArgArgInfo,-  builtinArg, builtinArgArg,-  builtinAbs, builtinAbsAbs, builtinAgdaTerm,-  builtinAgdaTermVar, builtinAgdaTermLam, builtinAgdaTermExtLam,-  builtinAgdaTermDef, builtinAgdaTermCon, builtinAgdaTermPi,-  builtinAgdaTermSort, builtinAgdaTermLit, builtinAgdaTermUnsupported, builtinAgdaTermMeta,-  builtinAgdaErrorPart, builtinAgdaErrorPartString, builtinAgdaErrorPartTerm, builtinAgdaErrorPartName,-  builtinAgdaLiteral, builtinAgdaLitNat, builtinAgdaLitWord64, builtinAgdaLitFloat,-  builtinAgdaLitChar, builtinAgdaLitString, builtinAgdaLitQName, builtinAgdaLitMeta,-  builtinAgdaClause, builtinAgdaClauseClause, builtinAgdaClauseAbsurd, builtinAgdaPattern,-  builtinAgdaPatVar, builtinAgdaPatCon, builtinAgdaPatDot, builtinAgdaPatLit,-  builtinAgdaPatProj, builtinAgdaPatAbsurd,-  builtinAgdaDefinitionFunDef,-  builtinAgdaDefinitionDataDef, builtinAgdaDefinitionRecordDef,-  builtinAgdaDefinitionDataConstructor, builtinAgdaDefinitionPostulate,-  builtinAgdaDefinitionPrimitive, builtinAgdaDefinition,-  builtinAgdaMeta,-  builtinAgdaTCM, builtinAgdaTCMReturn, builtinAgdaTCMBind, builtinAgdaTCMUnify,-  builtinAgdaTCMTypeError, builtinAgdaTCMInferType,-  builtinAgdaTCMCheckType, builtinAgdaTCMNormalise, builtinAgdaTCMReduce,-  builtinAgdaTCMCatchError,-  builtinAgdaTCMGetContext, builtinAgdaTCMExtendContext, builtinAgdaTCMInContext,-  builtinAgdaTCMFreshName, builtinAgdaTCMDeclareDef, builtinAgdaTCMDeclarePostulate, builtinAgdaTCMDefineFun,-  builtinAgdaTCMGetType, builtinAgdaTCMGetDefinition,-  builtinAgdaTCMQuoteTerm, builtinAgdaTCMUnquoteTerm, builtinAgdaTCMQuoteOmegaTerm,-  builtinAgdaTCMBlockOnMeta, builtinAgdaTCMCommit, builtinAgdaTCMIsMacro,-  builtinAgdaTCMWithNormalisation, builtinAgdaTCMWithReconsParams, builtinAgdaTCMDebugPrint,-  builtinAgdaTCMOnlyReduceDefs, builtinAgdaTCMDontReduceDefs,-  builtinAgdaTCMNoConstraints,-  builtinAgdaTCMRunSpeculative,-  builtinAgdaTCMExec-  :: String--builtinNat                               = "NATURAL"-builtinSuc                               = "SUC"-builtinZero                              = "ZERO"-builtinNatPlus                           = "NATPLUS"-builtinNatMinus                          = "NATMINUS"-builtinNatTimes                          = "NATTIMES"-builtinNatDivSucAux                      = "NATDIVSUCAUX"-builtinNatModSucAux                      = "NATMODSUCAUX"-builtinNatEquals                         = "NATEQUALS"-builtinNatLess                           = "NATLESS"-builtinWord64                            = "WORD64"-builtinInteger                           = "INTEGER"-builtinIntegerPos                        = "INTEGERPOS"-builtinIntegerNegSuc                     = "INTEGERNEGSUC"-builtinFloat                             = "FLOAT"-builtinChar                              = "CHAR"-builtinString                            = "STRING"-builtinUnit                              = "UNIT"-builtinUnitUnit                          = "UNITUNIT"-builtinSigma                             = "SIGMA"-builtinBool                              = "BOOL"-builtinTrue                              = "TRUE"-builtinFalse                             = "FALSE"-builtinList                              = "LIST"-builtinNil                               = "NIL"-builtinCons                              = "CONS"-builtinMaybe                             = "MAYBE"-builtinNothing                           = "NOTHING"-builtinJust                              = "JUST"-builtinIO                                = "IO"-builtinId                                = "ID"-builtinConId                             = "CONID"-builtinIdElim                            = "primIdElim"-builtinPath                              = "PATH"-builtinPathP                             = "PATHP"-builtinInterval                          = "INTERVAL"-builtinIMin                              = "primIMin"-builtinIMax                              = "primIMax"-builtinINeg                              = "primINeg"-builtinIZero                             = "IZERO"-builtinIOne                              = "IONE"-builtinPartial                           = "PARTIAL"-builtinPartialP                          = "PARTIALP"-builtinIsOne                             = "ISONE"-builtinItIsOne                           = "ITISONE"-builtinEquiv                             = "EQUIV"-builtinEquivFun                          = "EQUIVFUN"-builtinEquivProof                        = "EQUIVPROOF"-builtinTranspProof                       = "TRANSPPROOF"-builtinGlue                              = "primGlue"-builtin_glue                             = "prim^glue"-builtin_unglue                           = "prim^unglue"-builtin_glueU                            = "prim^glueU"-builtin_unglueU                          = "prim^unglueU"-builtinFaceForall                        = "primFaceForall"-builtinIsOne1                            = "ISONE1"-builtinIsOne2                            = "ISONE2"-builtinIsOneEmpty                        = "ISONEEMPTY"-builtinComp                              = "primComp"-builtinPOr                               = "primPOr"-builtinTrans                             = "primTransp"-builtinHComp                             = "primHComp"-builtinSub                               = "SUB"-builtinSubIn                             = "SUBIN"-builtinSubOut                            = "primSubOut"-builtinSizeUniv                          = "SIZEUNIV"-builtinSize                              = "SIZE"-builtinSizeLt                            = "SIZELT"-builtinSizeSuc                           = "SIZESUC"-builtinSizeInf                           = "SIZEINF"-builtinSizeMax                           = "SIZEMAX"-builtinInf                               = "INFINITY"-builtinSharp                             = "SHARP"-builtinFlat                              = "FLAT"-builtinEquality                          = "EQUALITY"-builtinRefl                              = "REFL"-builtinRewrite                           = "REWRITE"-builtinLevelMax                          = "LEVELMAX"-builtinLevel                             = "LEVEL"-builtinLevelZero                         = "LEVELZERO"-builtinLevelSuc                          = "LEVELSUC"-builtinSet                               = "TYPE"-builtinProp                              = "PROP"-builtinSetOmega                          = "SETOMEGA"-builtinLockUniv                          = "primLockUniv"-builtinSSetOmega                         = "STRICTSETOMEGA"-builtinStrictSet                         = "STRICTSET"-builtinFromNat                           = "FROMNAT"-builtinFromNeg                           = "FROMNEG"-builtinFromString                        = "FROMSTRING"-builtinQName                             = "QNAME"-builtinAgdaSort                          = "AGDASORT"-builtinAgdaSortSet                       = "AGDASORTSET"-builtinAgdaSortLit                       = "AGDASORTLIT"-builtinAgdaSortProp                      = "AGDASORTPROP"-builtinAgdaSortPropLit                   = "AGDASORTPROPLIT"-builtinAgdaSortInf                       = "AGDASORTINF"-builtinAgdaSortUnsupported               = "AGDASORTUNSUPPORTED"-builtinHiding                            = "HIDING"-builtinHidden                            = "HIDDEN"-builtinInstance                          = "INSTANCE"-builtinVisible                           = "VISIBLE"-builtinRelevance                         = "RELEVANCE"-builtinRelevant                          = "RELEVANT"-builtinIrrelevant                        = "IRRELEVANT"-builtinQuantity                          = "QUANTITY"-builtinQuantity0                         = "QUANTITY-0"-builtinQuantityω                         = "QUANTITY-ω"-builtinModality                          = "MODALITY"-builtinModalityConstructor               = "MODALITY-CONSTRUCTOR"-builtinAssoc                             = "ASSOC"-builtinAssocLeft                         = "ASSOCLEFT"-builtinAssocRight                        = "ASSOCRIGHT"-builtinAssocNon                          = "ASSOCNON"-builtinPrecedence                        = "PRECEDENCE"-builtinPrecRelated                       = "PRECRELATED"-builtinPrecUnrelated                     = "PRECUNRELATED"-builtinFixity                            = "FIXITY"-builtinFixityFixity                      = "FIXITYFIXITY"-builtinArg                               = "ARG"-builtinArgInfo                           = "ARGINFO"-builtinArgArgInfo                        = "ARGARGINFO"-builtinArgArg                            = "ARGARG"-builtinAbs                               = "ABS"-builtinAbsAbs                            = "ABSABS"-builtinAgdaTerm                          = "AGDATERM"-builtinAgdaTermVar                       = "AGDATERMVAR"-builtinAgdaTermLam                       = "AGDATERMLAM"-builtinAgdaTermExtLam                    = "AGDATERMEXTLAM"-builtinAgdaTermDef                       = "AGDATERMDEF"-builtinAgdaTermCon                       = "AGDATERMCON"-builtinAgdaTermPi                        = "AGDATERMPI"-builtinAgdaTermSort                      = "AGDATERMSORT"-builtinAgdaTermLit                       = "AGDATERMLIT"-builtinAgdaTermUnsupported               = "AGDATERMUNSUPPORTED"-builtinAgdaTermMeta                      = "AGDATERMMETA"-builtinAgdaErrorPart                     = "AGDAERRORPART"-builtinAgdaErrorPartString               = "AGDAERRORPARTSTRING"-builtinAgdaErrorPartTerm                 = "AGDAERRORPARTTERM"-builtinAgdaErrorPartName                 = "AGDAERRORPARTNAME"-builtinAgdaLiteral                       = "AGDALITERAL"-builtinAgdaLitNat                        = "AGDALITNAT"-builtinAgdaLitWord64                     = "AGDALITWORD64"-builtinAgdaLitFloat                      = "AGDALITFLOAT"-builtinAgdaLitChar                       = "AGDALITCHAR"-builtinAgdaLitString                     = "AGDALITSTRING"-builtinAgdaLitQName                      = "AGDALITQNAME"-builtinAgdaLitMeta                       = "AGDALITMETA"-builtinAgdaClause                        = "AGDACLAUSE"-builtinAgdaClauseClause                  = "AGDACLAUSECLAUSE"-builtinAgdaClauseAbsurd                  = "AGDACLAUSEABSURD"-builtinAgdaPattern                       = "AGDAPATTERN"-builtinAgdaPatVar                        = "AGDAPATVAR"-builtinAgdaPatCon                        = "AGDAPATCON"-builtinAgdaPatDot                        = "AGDAPATDOT"-builtinAgdaPatLit                        = "AGDAPATLIT"-builtinAgdaPatProj                       = "AGDAPATPROJ"-builtinAgdaPatAbsurd                     = "AGDAPATABSURD"-builtinAgdaDefinitionFunDef              = "AGDADEFINITIONFUNDEF"-builtinAgdaDefinitionDataDef             = "AGDADEFINITIONDATADEF"-builtinAgdaDefinitionRecordDef           = "AGDADEFINITIONRECORDDEF"-builtinAgdaDefinitionDataConstructor     = "AGDADEFINITIONDATACONSTRUCTOR"-builtinAgdaDefinitionPostulate           = "AGDADEFINITIONPOSTULATE"-builtinAgdaDefinitionPrimitive           = "AGDADEFINITIONPRIMITIVE"-builtinAgdaDefinition                    = "AGDADEFINITION"-builtinAgdaMeta                          = "AGDAMETA"-builtinAgdaTCM                           = "AGDATCM"-builtinAgdaTCMReturn                     = "AGDATCMRETURN"-builtinAgdaTCMBind                       = "AGDATCMBIND"-builtinAgdaTCMUnify                      = "AGDATCMUNIFY"-builtinAgdaTCMTypeError                  = "AGDATCMTYPEERROR"-builtinAgdaTCMInferType                  = "AGDATCMINFERTYPE"-builtinAgdaTCMCheckType                  = "AGDATCMCHECKTYPE"-builtinAgdaTCMNormalise                  = "AGDATCMNORMALISE"-builtinAgdaTCMReduce                     = "AGDATCMREDUCE"-builtinAgdaTCMCatchError                 = "AGDATCMCATCHERROR"-builtinAgdaTCMGetContext                 = "AGDATCMGETCONTEXT"-builtinAgdaTCMExtendContext              = "AGDATCMEXTENDCONTEXT"-builtinAgdaTCMInContext                  = "AGDATCMINCONTEXT"-builtinAgdaTCMFreshName                  = "AGDATCMFRESHNAME"-builtinAgdaTCMDeclareDef                 = "AGDATCMDECLAREDEF"-builtinAgdaTCMDeclarePostulate           = "AGDATCMDECLAREPOSTULATE"-builtinAgdaTCMDefineFun                  = "AGDATCMDEFINEFUN"-builtinAgdaTCMGetType                    = "AGDATCMGETTYPE"-builtinAgdaTCMGetDefinition              = "AGDATCMGETDEFINITION"-builtinAgdaTCMBlockOnMeta                = "AGDATCMBLOCKONMETA"-builtinAgdaTCMCommit                     = "AGDATCMCOMMIT"-builtinAgdaTCMQuoteTerm                  = "AGDATCMQUOTETERM"-builtinAgdaTCMUnquoteTerm                = "AGDATCMUNQUOTETERM"-builtinAgdaTCMQuoteOmegaTerm             = "AGDATCMQUOTEOMEGATERM"-builtinAgdaTCMIsMacro                    = "AGDATCMISMACRO"-builtinAgdaTCMWithNormalisation          = "AGDATCMWITHNORMALISATION"-builtinAgdaTCMWithReconsParams           = "AGDATCMWITHRECONSPARAMS"-builtinAgdaTCMDebugPrint                 = "AGDATCMDEBUGPRINT"-builtinAgdaTCMOnlyReduceDefs             = "AGDATCMONLYREDUCEDEFS"-builtinAgdaTCMDontReduceDefs             = "AGDATCMDONTREDUCEDEFS"-builtinAgdaTCMNoConstraints              = "AGDATCMNOCONSTRAINTS"-builtinAgdaTCMRunSpeculative             = "AGDATCMRUNSPECULATIVE"-builtinAgdaTCMExec                       = "AGDATCMEXEC"---- | Builtins that come without a definition in Agda syntax.---   These are giving names to Agda internal concepts which---   cannot be assigned an Agda type.------   An example would be a user-defined name for @Set@.------     {-# BUILTIN TYPE Type #-}------   The type of @Type@ would be @Type : Level → Setω@---   which is not valid Agda.--isBuiltinNoDef :: String -> Bool-isBuiltinNoDef = hasElem builtinsNoDef--builtinsNoDef :: [String]-builtinsNoDef =-  sizeBuiltins ++-  [ builtinConId-  , builtinInterval-  , builtinPartial-  , builtinPartialP-  , builtinIsOne-  , builtinSub-  , builtinIZero-  , builtinIOne-  , builtinSet-  , builtinProp-  , builtinSetOmega-  , builtinStrictSet-  , builtinSSetOmega-  ]--sizeBuiltins :: [String]-sizeBuiltins =-  [ builtinSizeUniv-  , builtinSize-  , builtinSizeLt-  , builtinSizeSuc-  , builtinSizeInf-  , builtinSizeMax-  ]+{-# OPTIONS_GHC -Wunused-imports #-}++-- | This module defines the names of all builtin and primitives used in Agda.+--+-- See "Agda.TypeChecking.Monad.Builtin"+module Agda.Syntax.Builtin where++import GHC.Generics (Generic)++import Control.DeepSeq (NFData)++import qualified Data.Map as M+import Data.Hashable++import Agda.Syntax.Common.Pretty+import Agda.Syntax.Position++import Agda.Utils.List++-- | Either a 'BuiltinId' or 'PrimitiveId', used for some lookups.+data SomeBuiltin+  = BuiltinName !BuiltinId+  | PrimitiveName !PrimitiveId+  deriving (Show, Eq, Ord, Generic)++instance Hashable SomeBuiltin+instance NFData SomeBuiltin++-- | The class of types which can be converted to 'SomeBuiltin'.+class IsBuiltin a where+  -- | Convert this value to a builtin.+  someBuiltin :: a -> SomeBuiltin++  -- | Get the identifier for this builtin, generally used for error messages.+  getBuiltinId :: a -> String++instance IsBuiltin SomeBuiltin where+  someBuiltin = id++  getBuiltinId (BuiltinName x) = getBuiltinId x+  getBuiltinId (PrimitiveName x) = getBuiltinId x++-- * Builtins++-- | A builtin name, defined by the @BUILTIN@ pragma.+data BuiltinId+  = BuiltinNat+  | BuiltinSuc+  | BuiltinZero+  | BuiltinNatPlus+  | BuiltinNatMinus+  | BuiltinNatTimes+  | BuiltinNatDivSucAux+  | BuiltinNatModSucAux+  | BuiltinNatEquals+  | BuiltinNatLess+  | BuiltinWord64+  | BuiltinInteger+  | BuiltinIntegerPos+  | BuiltinIntegerNegSuc+  | BuiltinFloat+  | BuiltinChar+  | BuiltinString+  | BuiltinUnit+  | BuiltinUnitUnit+  | BuiltinSigma+  | BuiltinSigmaCon+  | BuiltinBool+  | BuiltinTrue+  | BuiltinFalse+  | BuiltinList+  | BuiltinNil+  | BuiltinCons+  | BuiltinMaybe+  | BuiltinNothing+  | BuiltinJust+  | BuiltinIO+  | BuiltinPath+  | BuiltinPathP+  | BuiltinIntervalUniv+  | BuiltinInterval+  | BuiltinIZero+  | BuiltinIOne+  | BuiltinPartial+  | BuiltinPartialP+  | BuiltinIsOne+  | BuiltinItIsOne+  | BuiltinEquiv+  | BuiltinEquivFun+  | BuiltinEquivProof+  | BuiltinTranspProof+  | BuiltinIsOne1+  | BuiltinIsOne2+  | BuiltinIsOneEmpty+  | BuiltinSub+  | BuiltinSubIn+  | BuiltinSizeUniv+  | BuiltinSize+  | BuiltinSizeLt+  | BuiltinSizeSuc+  | BuiltinSizeInf+  | BuiltinSizeMax+  | BuiltinInf+  | BuiltinSharp+  | BuiltinFlat+  | BuiltinEquality+  | BuiltinRefl+  | BuiltinRewrite+  | BuiltinLevelMax+  | BuiltinLevel+  | BuiltinLevelZero+  | BuiltinLevelSuc+  | BuiltinProp+  | BuiltinSet+  | BuiltinStrictSet+  | BuiltinPropOmega+  | BuiltinSetOmega+  | BuiltinSSetOmega+  | BuiltinLevelUniv+  | BuiltinFromNat+  | BuiltinFromNeg+  | BuiltinFromString+  | BuiltinQName+  | BuiltinAgdaSort+  | BuiltinAgdaSortSet+  | BuiltinAgdaSortLit+  | BuiltinAgdaSortProp+  | BuiltinAgdaSortPropLit+  | BuiltinAgdaSortInf+  | BuiltinAgdaSortUnsupported+  | BuiltinHiding+  | BuiltinHidden+  | BuiltinInstance+  | BuiltinVisible+  | BuiltinRelevance+  | BuiltinRelevant+  | BuiltinIrrelevant+  | BuiltinQuantity+  | BuiltinQuantity0+  | BuiltinQuantityω+  | BuiltinModality+  | BuiltinModalityConstructor+  | BuiltinAssoc+  | BuiltinAssocLeft+  | BuiltinAssocRight+  | BuiltinAssocNon+  | BuiltinPrecedence+  | BuiltinPrecRelated+  | BuiltinPrecUnrelated+  | BuiltinFixity+  | BuiltinFixityFixity+  | BuiltinArg+  | BuiltinArgInfo+  | BuiltinArgArgInfo+  | BuiltinArgArg+  | BuiltinAbs+  | BuiltinAbsAbs+  | BuiltinAgdaTerm+  | BuiltinAgdaTermVar+  | BuiltinAgdaTermLam+  | BuiltinAgdaTermExtLam+  | BuiltinAgdaTermDef+  | BuiltinAgdaTermCon+  | BuiltinAgdaTermPi+  | BuiltinAgdaTermSort+  | BuiltinAgdaTermLit+  | BuiltinAgdaTermUnsupported+  | BuiltinAgdaTermMeta+  | BuiltinAgdaErrorPart+  | BuiltinAgdaErrorPartString+  | BuiltinAgdaErrorPartTerm+  | BuiltinAgdaErrorPartPatt+  | BuiltinAgdaErrorPartName+  | BuiltinAgdaLiteral+  | BuiltinAgdaLitNat+  | BuiltinAgdaLitWord64+  | BuiltinAgdaLitFloat+  | BuiltinAgdaLitChar+  | BuiltinAgdaLitString+  | BuiltinAgdaLitQName+  | BuiltinAgdaLitMeta+  | BuiltinAgdaClause+  | BuiltinAgdaClauseClause+  | BuiltinAgdaClauseAbsurd+  | BuiltinAgdaPattern+  | BuiltinAgdaPatVar+  | BuiltinAgdaPatCon+  | BuiltinAgdaPatDot+  | BuiltinAgdaPatLit+  | BuiltinAgdaPatProj+  | BuiltinAgdaPatAbsurd+  | BuiltinAgdaDefinitionFunDef+  | BuiltinAgdaDefinitionDataDef+  | BuiltinAgdaDefinitionRecordDef+  | BuiltinAgdaDefinitionDataConstructor+  | BuiltinAgdaDefinitionPostulate+  | BuiltinAgdaDefinitionPrimitive+  | BuiltinAgdaDefinition+  | BuiltinAgdaMeta+  | BuiltinAgdaTCM+  | BuiltinAgdaTCMReturn+  | BuiltinAgdaTCMBind+  | BuiltinAgdaTCMUnify+  | BuiltinAgdaTCMTypeError+  | BuiltinAgdaTCMInferType+  | BuiltinAgdaTCMCheckType+  | BuiltinAgdaTCMNormalise+  | BuiltinAgdaTCMReduce+  | BuiltinAgdaTCMCatchError+  | BuiltinAgdaTCMGetContext+  | BuiltinAgdaTCMExtendContext+  | BuiltinAgdaTCMInContext+  | BuiltinAgdaTCMFreshName+  | BuiltinAgdaTCMDeclareDef+  | BuiltinAgdaTCMDeclarePostulate+  | BuiltinAgdaTCMDeclareData+  | BuiltinAgdaTCMDefineData+  | BuiltinAgdaTCMDefineFun+  | BuiltinAgdaTCMGetType+  | BuiltinAgdaTCMGetDefinition+  | BuiltinAgdaTCMBlock+  | BuiltinAgdaTCMCommit+  | BuiltinAgdaTCMQuoteTerm+  | BuiltinAgdaTCMUnquoteTerm+  | BuiltinAgdaTCMQuoteOmegaTerm+  | BuiltinAgdaTCMIsMacro+  | BuiltinAgdaTCMWithNormalisation+  | BuiltinAgdaTCMWithReconstructed+  | BuiltinAgdaTCMWithExpandLast+  | BuiltinAgdaTCMWithReduceDefs+  | BuiltinAgdaTCMAskNormalisation+  | BuiltinAgdaTCMAskReconstructed+  | BuiltinAgdaTCMAskExpandLast+  | BuiltinAgdaTCMAskReduceDefs+  | BuiltinAgdaTCMFormatErrorParts+  | BuiltinAgdaTCMDebugPrint+  | BuiltinAgdaTCMNoConstraints+  | BuiltinAgdaTCMWorkOnTypes+  | BuiltinAgdaTCMRunSpeculative+  | BuiltinAgdaTCMExec+  | BuiltinAgdaTCMCheckFromString+  | BuiltinAgdaTCMGetInstances+  | BuiltinAgdaTCMSolveInstances+  | BuiltinAgdaTCMPragmaForeign+  | BuiltinAgdaTCMPragmaCompile+  | BuiltinAgdaBlocker+  | BuiltinAgdaBlockerAny+  | BuiltinAgdaBlockerAll+  | BuiltinAgdaBlockerMeta+  deriving (Show, Eq, Ord, Bounded, Enum, Generic)++instance NFData BuiltinId++instance Hashable BuiltinId where+  s `hashWithSalt` b = s `hashWithSalt` fromEnum b++instance KillRange BuiltinId where+  killRange = id++instance Pretty BuiltinId where+  pretty = text . getBuiltinId++instance IsBuiltin BuiltinId where+  someBuiltin = BuiltinName++  getBuiltinId = \case+    BuiltinNat                               -> "NATURAL"+    BuiltinSuc                               -> "SUC"+    BuiltinZero                              -> "ZERO"+    BuiltinNatPlus                           -> "NATPLUS"+    BuiltinNatMinus                          -> "NATMINUS"+    BuiltinNatTimes                          -> "NATTIMES"+    BuiltinNatDivSucAux                      -> "NATDIVSUCAUX"+    BuiltinNatModSucAux                      -> "NATMODSUCAUX"+    BuiltinNatEquals                         -> "NATEQUALS"+    BuiltinNatLess                           -> "NATLESS"+    BuiltinWord64                            -> "WORD64"+    BuiltinInteger                           -> "INTEGER"+    BuiltinIntegerPos                        -> "INTEGERPOS"+    BuiltinIntegerNegSuc                     -> "INTEGERNEGSUC"+    BuiltinFloat                             -> "FLOAT"+    BuiltinChar                              -> "CHAR"+    BuiltinString                            -> "STRING"+    BuiltinUnit                              -> "UNIT"+    BuiltinUnitUnit                          -> "UNITUNIT"+    BuiltinSigma                             -> "SIGMA"+    BuiltinSigmaCon                          -> "SIGMACON"+    BuiltinBool                              -> "BOOL"+    BuiltinTrue                              -> "TRUE"+    BuiltinFalse                             -> "FALSE"+    BuiltinList                              -> "LIST"+    BuiltinNil                               -> "NIL"+    BuiltinCons                              -> "CONS"+    BuiltinMaybe                             -> "MAYBE"+    BuiltinNothing                           -> "NOTHING"+    BuiltinJust                              -> "JUST"+    BuiltinIO                                -> "IO"+    BuiltinPath                              -> "PATH"+    BuiltinPathP                             -> "PATHP"+    BuiltinIntervalUniv                      -> "CUBEINTERVALUNIV"+    BuiltinInterval                          -> "INTERVAL"+    BuiltinIZero                             -> "IZERO"+    BuiltinIOne                              -> "IONE"+    BuiltinPartial                           -> "PARTIAL"+    BuiltinPartialP                          -> "PARTIALP"+    BuiltinIsOne                             -> "ISONE"+    BuiltinItIsOne                           -> "ITISONE"+    BuiltinEquiv                             -> "EQUIV"+    BuiltinEquivFun                          -> "EQUIVFUN"+    BuiltinEquivProof                        -> "EQUIVPROOF"+    BuiltinTranspProof                       -> "TRANSPPROOF"+    BuiltinIsOne1                            -> "ISONE1"+    BuiltinIsOne2                            -> "ISONE2"+    BuiltinIsOneEmpty                        -> "ISONEEMPTY"+    BuiltinSub                               -> "SUB"+    BuiltinSubIn                             -> "SUBIN"+    BuiltinSizeUniv                          -> "SIZEUNIV"+    BuiltinSize                              -> "SIZE"+    BuiltinSizeLt                            -> "SIZELT"+    BuiltinSizeSuc                           -> "SIZESUC"+    BuiltinSizeInf                           -> "SIZEINF"+    BuiltinSizeMax                           -> "SIZEMAX"+    BuiltinInf                               -> "INFINITY"+    BuiltinSharp                             -> "SHARP"+    BuiltinFlat                              -> "FLAT"+    BuiltinEquality                          -> "EQUALITY"+    BuiltinRefl                              -> "REFL"+    BuiltinRewrite                           -> "REWRITE"+    BuiltinLevelMax                          -> "LEVELMAX"+    BuiltinLevel                             -> "LEVEL"+    BuiltinLevelZero                         -> "LEVELZERO"+    BuiltinLevelSuc                          -> "LEVELSUC"+    BuiltinProp                              -> "PROP"+    BuiltinSet                               -> "TYPE"+    BuiltinStrictSet                         -> "STRICTSET"+    BuiltinPropOmega                         -> "PROPOMEGA"+    BuiltinSetOmega                          -> "SETOMEGA"+    BuiltinSSetOmega                         -> "STRICTSETOMEGA"+    BuiltinLevelUniv                         -> "LEVELUNIV"+    BuiltinFromNat                           -> "FROMNAT"+    BuiltinFromNeg                           -> "FROMNEG"+    BuiltinFromString                        -> "FROMSTRING"+    BuiltinQName                             -> "QNAME"+    BuiltinAgdaSort                          -> "AGDASORT"+    BuiltinAgdaSortSet                       -> "AGDASORTSET"+    BuiltinAgdaSortLit                       -> "AGDASORTLIT"+    BuiltinAgdaSortProp                      -> "AGDASORTPROP"+    BuiltinAgdaSortPropLit                   -> "AGDASORTPROPLIT"+    BuiltinAgdaSortInf                       -> "AGDASORTINF"+    BuiltinAgdaSortUnsupported               -> "AGDASORTUNSUPPORTED"+    BuiltinHiding                            -> "HIDING"+    BuiltinHidden                            -> "HIDDEN"+    BuiltinInstance                          -> "INSTANCE"+    BuiltinVisible                           -> "VISIBLE"+    BuiltinRelevance                         -> "RELEVANCE"+    BuiltinRelevant                          -> "RELEVANT"+    BuiltinIrrelevant                        -> "IRRELEVANT"+    BuiltinQuantity                          -> "QUANTITY"+    BuiltinQuantity0                         -> "QUANTITY-0"+    BuiltinQuantityω                         -> "QUANTITY-ω"+    BuiltinModality                          -> "MODALITY"+    BuiltinModalityConstructor               -> "MODALITY-CONSTRUCTOR"+    BuiltinAssoc                             -> "ASSOC"+    BuiltinAssocLeft                         -> "ASSOCLEFT"+    BuiltinAssocRight                        -> "ASSOCRIGHT"+    BuiltinAssocNon                          -> "ASSOCNON"+    BuiltinPrecedence                        -> "PRECEDENCE"+    BuiltinPrecRelated                       -> "PRECRELATED"+    BuiltinPrecUnrelated                     -> "PRECUNRELATED"+    BuiltinFixity                            -> "FIXITY"+    BuiltinFixityFixity                      -> "FIXITYFIXITY"+    BuiltinArg                               -> "ARG"+    BuiltinArgInfo                           -> "ARGINFO"+    BuiltinArgArgInfo                        -> "ARGARGINFO"+    BuiltinArgArg                            -> "ARGARG"+    BuiltinAbs                               -> "ABS"+    BuiltinAbsAbs                            -> "ABSABS"+    BuiltinAgdaTerm                          -> "AGDATERM"+    BuiltinAgdaTermVar                       -> "AGDATERMVAR"+    BuiltinAgdaTermLam                       -> "AGDATERMLAM"+    BuiltinAgdaTermExtLam                    -> "AGDATERMEXTLAM"+    BuiltinAgdaTermDef                       -> "AGDATERMDEF"+    BuiltinAgdaTermCon                       -> "AGDATERMCON"+    BuiltinAgdaTermPi                        -> "AGDATERMPI"+    BuiltinAgdaTermSort                      -> "AGDATERMSORT"+    BuiltinAgdaTermLit                       -> "AGDATERMLIT"+    BuiltinAgdaTermUnsupported               -> "AGDATERMUNSUPPORTED"+    BuiltinAgdaTermMeta                      -> "AGDATERMMETA"+    BuiltinAgdaErrorPart                     -> "AGDAERRORPART"+    BuiltinAgdaErrorPartString               -> "AGDAERRORPARTSTRING"+    BuiltinAgdaErrorPartTerm                 -> "AGDAERRORPARTTERM"+    BuiltinAgdaErrorPartPatt                 -> "AGDAERRORPARTPATT"+    BuiltinAgdaErrorPartName                 -> "AGDAERRORPARTNAME"+    BuiltinAgdaLiteral                       -> "AGDALITERAL"+    BuiltinAgdaLitNat                        -> "AGDALITNAT"+    BuiltinAgdaLitWord64                     -> "AGDALITWORD64"+    BuiltinAgdaLitFloat                      -> "AGDALITFLOAT"+    BuiltinAgdaLitChar                       -> "AGDALITCHAR"+    BuiltinAgdaLitString                     -> "AGDALITSTRING"+    BuiltinAgdaLitQName                      -> "AGDALITQNAME"+    BuiltinAgdaLitMeta                       -> "AGDALITMETA"+    BuiltinAgdaClause                        -> "AGDACLAUSE"+    BuiltinAgdaClauseClause                  -> "AGDACLAUSECLAUSE"+    BuiltinAgdaClauseAbsurd                  -> "AGDACLAUSEABSURD"+    BuiltinAgdaPattern                       -> "AGDAPATTERN"+    BuiltinAgdaPatVar                        -> "AGDAPATVAR"+    BuiltinAgdaPatCon                        -> "AGDAPATCON"+    BuiltinAgdaPatDot                        -> "AGDAPATDOT"+    BuiltinAgdaPatLit                        -> "AGDAPATLIT"+    BuiltinAgdaPatProj                       -> "AGDAPATPROJ"+    BuiltinAgdaPatAbsurd                     -> "AGDAPATABSURD"+    BuiltinAgdaDefinitionFunDef              -> "AGDADEFINITIONFUNDEF"+    BuiltinAgdaDefinitionDataDef             -> "AGDADEFINITIONDATADEF"+    BuiltinAgdaDefinitionRecordDef           -> "AGDADEFINITIONRECORDDEF"+    BuiltinAgdaDefinitionDataConstructor     -> "AGDADEFINITIONDATACONSTRUCTOR"+    BuiltinAgdaDefinitionPostulate           -> "AGDADEFINITIONPOSTULATE"+    BuiltinAgdaDefinitionPrimitive           -> "AGDADEFINITIONPRIMITIVE"+    BuiltinAgdaDefinition                    -> "AGDADEFINITION"+    BuiltinAgdaMeta                          -> "AGDAMETA"+    BuiltinAgdaTCM                           -> "AGDATCM"+    BuiltinAgdaTCMReturn                     -> "AGDATCMRETURN"+    BuiltinAgdaTCMBind                       -> "AGDATCMBIND"+    BuiltinAgdaTCMUnify                      -> "AGDATCMUNIFY"+    BuiltinAgdaTCMTypeError                  -> "AGDATCMTYPEERROR"+    BuiltinAgdaTCMInferType                  -> "AGDATCMINFERTYPE"+    BuiltinAgdaTCMCheckType                  -> "AGDATCMCHECKTYPE"+    BuiltinAgdaTCMNormalise                  -> "AGDATCMNORMALISE"+    BuiltinAgdaTCMReduce                     -> "AGDATCMREDUCE"+    BuiltinAgdaTCMCatchError                 -> "AGDATCMCATCHERROR"+    BuiltinAgdaTCMGetContext                 -> "AGDATCMGETCONTEXT"+    BuiltinAgdaTCMExtendContext              -> "AGDATCMEXTENDCONTEXT"+    BuiltinAgdaTCMInContext                  -> "AGDATCMINCONTEXT"+    BuiltinAgdaTCMFreshName                  -> "AGDATCMFRESHNAME"+    BuiltinAgdaTCMDeclareDef                 -> "AGDATCMDECLAREDEF"+    BuiltinAgdaTCMDeclarePostulate           -> "AGDATCMDECLAREPOSTULATE"+    BuiltinAgdaTCMDeclareData                -> "AGDATCMDECLAREDATA"+    BuiltinAgdaTCMDefineData                 -> "AGDATCMDEFINEDATA"+    BuiltinAgdaTCMDefineFun                  -> "AGDATCMDEFINEFUN"+    BuiltinAgdaTCMGetType                    -> "AGDATCMGETTYPE"+    BuiltinAgdaTCMGetDefinition              -> "AGDATCMGETDEFINITION"+    BuiltinAgdaTCMBlock                      -> "AGDATCMBLOCK"+    BuiltinAgdaTCMCommit                     -> "AGDATCMCOMMIT"+    BuiltinAgdaTCMQuoteTerm                  -> "AGDATCMQUOTETERM"+    BuiltinAgdaTCMUnquoteTerm                -> "AGDATCMUNQUOTETERM"+    BuiltinAgdaTCMQuoteOmegaTerm             -> "AGDATCMQUOTEOMEGATERM"+    BuiltinAgdaTCMIsMacro                    -> "AGDATCMISMACRO"+    BuiltinAgdaTCMWithNormalisation          -> "AGDATCMWITHNORMALISATION"+    BuiltinAgdaTCMWithReconstructed          -> "AGDATCMWITHRECONSTRUCTED"+    BuiltinAgdaTCMWithExpandLast             -> "AGDATCMWITHEXPANDLAST"+    BuiltinAgdaTCMWithReduceDefs             -> "AGDATCMWITHREDUCEDEFS"+    BuiltinAgdaTCMAskNormalisation           -> "AGDATCMASKNORMALISATION"+    BuiltinAgdaTCMAskReconstructed           -> "AGDATCMASKRECONSTRUCTED"+    BuiltinAgdaTCMAskExpandLast              -> "AGDATCMASKEXPANDLAST"+    BuiltinAgdaTCMAskReduceDefs              -> "AGDATCMASKREDUCEDEFS"+    BuiltinAgdaTCMFormatErrorParts           -> "AGDATCMFORMATERRORPARTS"+    BuiltinAgdaTCMDebugPrint                 -> "AGDATCMDEBUGPRINT"+    BuiltinAgdaTCMNoConstraints              -> "AGDATCMNOCONSTRAINTS"+    BuiltinAgdaTCMWorkOnTypes                -> "AGDATCMWORKONTYPES"+    BuiltinAgdaTCMRunSpeculative             -> "AGDATCMRUNSPECULATIVE"+    BuiltinAgdaTCMExec                       -> "AGDATCMEXEC"+    BuiltinAgdaTCMCheckFromString            -> "AGDATCMCHECKFROMSTRING"+    BuiltinAgdaTCMGetInstances               -> "AGDATCMGETINSTANCES"+    BuiltinAgdaTCMSolveInstances             -> "AGDATCMSOLVEINSTANCES"+    BuiltinAgdaTCMPragmaForeign              -> "AGDATCMPRAGMAFOREIGN"+    BuiltinAgdaTCMPragmaCompile              -> "AGDATCMPRAGMACOMPILE"+    BuiltinAgdaBlocker                       -> "AGDABLOCKER"+    BuiltinAgdaBlockerAny                    -> "AGDABLOCKERANY"+    BuiltinAgdaBlockerAll                    -> "AGDABLOCKERALL"+    BuiltinAgdaBlockerMeta                   -> "AGDABLOCKERMETA"++-- | Builtins that come without a definition in Agda syntax.+--   These are giving names to Agda internal concepts which+--   cannot be assigned an Agda type.+--+--   An example would be a user-defined name for @Set@.+--+--     {-# BUILTIN TYPE Type #-}+--+--   The type of @Type@ would be @Type : Level → Setω@+--   which is not valid Agda.+isBuiltinNoDef :: BuiltinId -> Bool+isBuiltinNoDef = hasElem builtinsNoDef++builtinsNoDef :: [BuiltinId]+builtinsNoDef =+  sizeBuiltins +++   -- builtinConId,+  [ builtinIntervalUniv+  , builtinInterval+  , builtinPartial+  , builtinPartialP+  , builtinIsOne+  , builtinSub+  , builtinIZero+  , builtinIOne+  , builtinProp+  , builtinSet+  , builtinStrictSet+  , builtinPropOmega+  , builtinSetOmega+  , builtinSSetOmega+  , builtinLevelUniv+  ]++sizeBuiltins :: [BuiltinId]+sizeBuiltins =+  [ builtinSizeUniv+  , builtinSize+  , builtinSizeLt+  , builtinSizeSuc+  , builtinSizeInf+  , builtinSizeMax+  ]++builtinNat, builtinSuc, builtinZero, builtinNatPlus, builtinNatMinus,+  builtinNatTimes, builtinNatDivSucAux, builtinNatModSucAux, builtinNatEquals,+  builtinNatLess, builtinInteger, builtinIntegerPos, builtinIntegerNegSuc,+  builtinWord64,+  builtinFloat, builtinChar, builtinString, builtinUnit, builtinUnitUnit,+  builtinSigma,+  builtinBool, builtinTrue, builtinFalse,+  builtinList, builtinNil, builtinCons, builtinIO,+  builtinMaybe, builtinNothing, builtinJust,+  builtinPath, builtinPathP, builtinInterval, builtinIZero, builtinIOne, builtinPartial, builtinPartialP,+  builtinIsOne,  builtinItIsOne, builtinIsOne1, builtinIsOne2, builtinIsOneEmpty,+  builtinSub, builtinSubIn,+  builtinEquiv, builtinEquivFun, builtinEquivProof,+  builtinTranspProof,+  builtinSizeUniv, builtinSize, builtinSizeLt,+  builtinSizeSuc, builtinSizeInf, builtinSizeMax,+  builtinInf, builtinSharp, builtinFlat,+  builtinEquality, builtinRefl, builtinRewrite, builtinLevelMax,+  builtinLevel, builtinLevelZero, builtinLevelSuc,+  builtinProp, builtinSet, builtinStrictSet,+  builtinPropOmega, builtinSetOmega, builtinSSetOmega,+  builtinLevelUniv,+  builtinIntervalUniv,+  builtinFromNat, builtinFromNeg, builtinFromString,+  builtinQName, builtinAgdaSort, builtinAgdaSortSet, builtinAgdaSortLit,+  builtinAgdaSortProp, builtinAgdaSortPropLit, builtinAgdaSortInf,+  builtinAgdaSortUnsupported,+  builtinHiding, builtinHidden, builtinInstance, builtinVisible,+  builtinRelevance, builtinRelevant, builtinIrrelevant,+  builtinQuantity, builtinQuantity0, builtinQuantityω,+  builtinModality, builtinModalityConstructor,+  builtinAssoc, builtinAssocLeft, builtinAssocRight, builtinAssocNon,+  builtinPrecedence, builtinPrecRelated, builtinPrecUnrelated,+  builtinFixity, builtinFixityFixity,+  builtinArgInfo, builtinArgArgInfo,+  builtinArg, builtinArgArg,+  builtinAbs, builtinAbsAbs, builtinAgdaTerm,+  builtinAgdaTermVar, builtinAgdaTermLam, builtinAgdaTermExtLam,+  builtinAgdaTermDef, builtinAgdaTermCon, builtinAgdaTermPi,+  builtinAgdaTermSort, builtinAgdaTermLit, builtinAgdaTermUnsupported, builtinAgdaTermMeta,+  builtinAgdaErrorPart, builtinAgdaErrorPartString, builtinAgdaErrorPartTerm, builtinAgdaErrorPartPatt, builtinAgdaErrorPartName,+  builtinAgdaLiteral, builtinAgdaLitNat, builtinAgdaLitWord64, builtinAgdaLitFloat,+  builtinAgdaLitChar, builtinAgdaLitString, builtinAgdaLitQName, builtinAgdaLitMeta,+  builtinAgdaClause, builtinAgdaClauseClause, builtinAgdaClauseAbsurd, builtinAgdaPattern,+  builtinAgdaPatVar, builtinAgdaPatCon, builtinAgdaPatDot, builtinAgdaPatLit,+  builtinAgdaPatProj, builtinAgdaPatAbsurd,+  builtinAgdaDefinitionFunDef,+  builtinAgdaDefinitionDataDef, builtinAgdaDefinitionRecordDef,+  builtinAgdaDefinitionDataConstructor, builtinAgdaDefinitionPostulate,+  builtinAgdaDefinitionPrimitive, builtinAgdaDefinition,+  builtinAgdaMeta,+  builtinAgdaTCM, builtinAgdaTCMReturn, builtinAgdaTCMBind, builtinAgdaTCMUnify,+  builtinAgdaTCMTypeError, builtinAgdaTCMInferType,+  builtinAgdaTCMCheckType, builtinAgdaTCMNormalise, builtinAgdaTCMReduce,+  builtinAgdaTCMCatchError,+  builtinAgdaTCMGetContext, builtinAgdaTCMExtendContext, builtinAgdaTCMInContext,+  builtinAgdaTCMFreshName, builtinAgdaTCMDeclareDef, builtinAgdaTCMDeclarePostulate, builtinAgdaTCMDeclareData, builtinAgdaTCMDefineData, builtinAgdaTCMDefineFun,+  builtinAgdaTCMGetType, builtinAgdaTCMGetDefinition,+  builtinAgdaTCMQuoteTerm, builtinAgdaTCMUnquoteTerm, builtinAgdaTCMQuoteOmegaTerm,+  builtinAgdaTCMCommit, builtinAgdaTCMIsMacro, builtinAgdaTCMBlock,+  builtinAgdaBlocker, builtinAgdaBlockerAll, builtinAgdaBlockerAny, builtinAgdaBlockerMeta,+  builtinAgdaTCMFormatErrorParts, builtinAgdaTCMDebugPrint,+  builtinAgdaTCMWithNormalisation, builtinAgdaTCMWithReconstructed,+  builtinAgdaTCMWithExpandLast, builtinAgdaTCMWithReduceDefs,+  builtinAgdaTCMAskNormalisation, builtinAgdaTCMAskReconstructed,+  builtinAgdaTCMAskExpandLast, builtinAgdaTCMAskReduceDefs,+  builtinAgdaTCMNoConstraints,+  builtinAgdaTCMWorkOnTypes,+  builtinAgdaTCMRunSpeculative,+  builtinAgdaTCMExec,+  builtinAgdaTCMCheckFromString,+  builtinAgdaTCMGetInstances,+  builtinAgdaTCMSolveInstances,+  builtinAgdaTCMPragmaForeign,+  builtinAgdaTCMPragmaCompile+  :: BuiltinId++builtinNat                               = BuiltinNat+builtinSuc                               = BuiltinSuc+builtinZero                              = BuiltinZero+builtinNatPlus                           = BuiltinNatPlus+builtinNatMinus                          = BuiltinNatMinus+builtinNatTimes                          = BuiltinNatTimes+builtinNatDivSucAux                      = BuiltinNatDivSucAux+builtinNatModSucAux                      = BuiltinNatModSucAux+builtinNatEquals                         = BuiltinNatEquals+builtinNatLess                           = BuiltinNatLess+builtinWord64                            = BuiltinWord64+builtinInteger                           = BuiltinInteger+builtinIntegerPos                        = BuiltinIntegerPos+builtinIntegerNegSuc                     = BuiltinIntegerNegSuc+builtinFloat                             = BuiltinFloat+builtinChar                              = BuiltinChar+builtinString                            = BuiltinString+builtinUnit                              = BuiltinUnit+builtinUnitUnit                          = BuiltinUnitUnit+builtinSigma                             = BuiltinSigma+builtinBool                              = BuiltinBool+builtinTrue                              = BuiltinTrue+builtinFalse                             = BuiltinFalse+builtinList                              = BuiltinList+builtinNil                               = BuiltinNil+builtinCons                              = BuiltinCons+builtinMaybe                             = BuiltinMaybe+builtinNothing                           = BuiltinNothing+builtinJust                              = BuiltinJust+builtinIO                                = BuiltinIO+builtinPath                              = BuiltinPath+builtinPathP                             = BuiltinPathP+builtinIntervalUniv                      = BuiltinIntervalUniv+builtinInterval                          = BuiltinInterval+builtinIZero                             = BuiltinIZero+builtinIOne                              = BuiltinIOne+builtinPartial                           = BuiltinPartial+builtinPartialP                          = BuiltinPartialP+builtinIsOne                             = BuiltinIsOne+builtinItIsOne                           = BuiltinItIsOne+builtinEquiv                             = BuiltinEquiv+builtinEquivFun                          = BuiltinEquivFun+builtinEquivProof                        = BuiltinEquivProof+builtinTranspProof                       = BuiltinTranspProof+builtinIsOne1                            = BuiltinIsOne1+builtinIsOne2                            = BuiltinIsOne2+builtinIsOneEmpty                        = BuiltinIsOneEmpty+builtinSub                               = BuiltinSub+builtinSubIn                             = BuiltinSubIn+builtinSizeUniv                          = BuiltinSizeUniv+builtinSize                              = BuiltinSize+builtinSizeLt                            = BuiltinSizeLt+builtinSizeSuc                           = BuiltinSizeSuc+builtinSizeInf                           = BuiltinSizeInf+builtinSizeMax                           = BuiltinSizeMax+builtinInf                               = BuiltinInf+builtinSharp                             = BuiltinSharp+builtinFlat                              = BuiltinFlat+builtinEquality                          = BuiltinEquality+builtinRefl                              = BuiltinRefl+builtinRewrite                           = BuiltinRewrite+builtinLevelMax                          = BuiltinLevelMax+builtinLevel                             = BuiltinLevel+builtinLevelZero                         = BuiltinLevelZero+builtinLevelSuc                          = BuiltinLevelSuc+builtinProp                              = BuiltinProp+builtinSet                               = BuiltinSet+builtinStrictSet                         = BuiltinStrictSet+builtinPropOmega                         = BuiltinPropOmega+builtinSetOmega                          = BuiltinSetOmega+builtinSSetOmega                         = BuiltinSSetOmega+builtinLevelUniv                         = BuiltinLevelUniv+builtinFromNat                           = BuiltinFromNat+builtinFromNeg                           = BuiltinFromNeg+builtinFromString                        = BuiltinFromString+builtinQName                             = BuiltinQName+builtinAgdaSort                          = BuiltinAgdaSort+builtinAgdaSortSet                       = BuiltinAgdaSortSet+builtinAgdaSortLit                       = BuiltinAgdaSortLit+builtinAgdaSortProp                      = BuiltinAgdaSortProp+builtinAgdaSortPropLit                   = BuiltinAgdaSortPropLit+builtinAgdaSortInf                       = BuiltinAgdaSortInf+builtinAgdaSortUnsupported               = BuiltinAgdaSortUnsupported+builtinHiding                            = BuiltinHiding+builtinHidden                            = BuiltinHidden+builtinInstance                          = BuiltinInstance+builtinVisible                           = BuiltinVisible+builtinRelevance                         = BuiltinRelevance+builtinRelevant                          = BuiltinRelevant+builtinIrrelevant                        = BuiltinIrrelevant+builtinQuantity                          = BuiltinQuantity+builtinQuantity0                         = BuiltinQuantity0+builtinQuantityω                         = BuiltinQuantityω+builtinModality                          = BuiltinModality+builtinModalityConstructor               = BuiltinModalityConstructor+builtinAssoc                             = BuiltinAssoc+builtinAssocLeft                         = BuiltinAssocLeft+builtinAssocRight                        = BuiltinAssocRight+builtinAssocNon                          = BuiltinAssocNon+builtinPrecedence                        = BuiltinPrecedence+builtinPrecRelated                       = BuiltinPrecRelated+builtinPrecUnrelated                     = BuiltinPrecUnrelated+builtinFixity                            = BuiltinFixity+builtinFixityFixity                      = BuiltinFixityFixity+builtinArg                               = BuiltinArg+builtinArgInfo                           = BuiltinArgInfo+builtinArgArgInfo                        = BuiltinArgArgInfo+builtinArgArg                            = BuiltinArgArg+builtinAbs                               = BuiltinAbs+builtinAbsAbs                            = BuiltinAbsAbs+builtinAgdaTerm                          = BuiltinAgdaTerm+builtinAgdaTermVar                       = BuiltinAgdaTermVar+builtinAgdaTermLam                       = BuiltinAgdaTermLam+builtinAgdaTermExtLam                    = BuiltinAgdaTermExtLam+builtinAgdaTermDef                       = BuiltinAgdaTermDef+builtinAgdaTermCon                       = BuiltinAgdaTermCon+builtinAgdaTermPi                        = BuiltinAgdaTermPi+builtinAgdaTermSort                      = BuiltinAgdaTermSort+builtinAgdaTermLit                       = BuiltinAgdaTermLit+builtinAgdaTermUnsupported               = BuiltinAgdaTermUnsupported+builtinAgdaTermMeta                      = BuiltinAgdaTermMeta+builtinAgdaErrorPart                     = BuiltinAgdaErrorPart+builtinAgdaErrorPartString               = BuiltinAgdaErrorPartString+builtinAgdaErrorPartTerm                 = BuiltinAgdaErrorPartTerm+builtinAgdaErrorPartPatt                 = BuiltinAgdaErrorPartPatt+builtinAgdaErrorPartName                 = BuiltinAgdaErrorPartName+builtinAgdaLiteral                       = BuiltinAgdaLiteral+builtinAgdaLitNat                        = BuiltinAgdaLitNat+builtinAgdaLitWord64                     = BuiltinAgdaLitWord64+builtinAgdaLitFloat                      = BuiltinAgdaLitFloat+builtinAgdaLitChar                       = BuiltinAgdaLitChar+builtinAgdaLitString                     = BuiltinAgdaLitString+builtinAgdaLitQName                      = BuiltinAgdaLitQName+builtinAgdaLitMeta                       = BuiltinAgdaLitMeta+builtinAgdaClause                        = BuiltinAgdaClause+builtinAgdaClauseClause                  = BuiltinAgdaClauseClause+builtinAgdaClauseAbsurd                  = BuiltinAgdaClauseAbsurd+builtinAgdaPattern                       = BuiltinAgdaPattern+builtinAgdaPatVar                        = BuiltinAgdaPatVar+builtinAgdaPatCon                        = BuiltinAgdaPatCon+builtinAgdaPatDot                        = BuiltinAgdaPatDot+builtinAgdaPatLit                        = BuiltinAgdaPatLit+builtinAgdaPatProj                       = BuiltinAgdaPatProj+builtinAgdaPatAbsurd                     = BuiltinAgdaPatAbsurd+builtinAgdaDefinitionFunDef              = BuiltinAgdaDefinitionFunDef+builtinAgdaDefinitionDataDef             = BuiltinAgdaDefinitionDataDef+builtinAgdaDefinitionRecordDef           = BuiltinAgdaDefinitionRecordDef+builtinAgdaDefinitionDataConstructor     = BuiltinAgdaDefinitionDataConstructor+builtinAgdaDefinitionPostulate           = BuiltinAgdaDefinitionPostulate+builtinAgdaDefinitionPrimitive           = BuiltinAgdaDefinitionPrimitive+builtinAgdaDefinition                    = BuiltinAgdaDefinition+builtinAgdaMeta                          = BuiltinAgdaMeta+builtinAgdaTCM                           = BuiltinAgdaTCM+builtinAgdaTCMReturn                     = BuiltinAgdaTCMReturn+builtinAgdaTCMBind                       = BuiltinAgdaTCMBind+builtinAgdaTCMUnify                      = BuiltinAgdaTCMUnify+builtinAgdaTCMTypeError                  = BuiltinAgdaTCMTypeError+builtinAgdaTCMInferType                  = BuiltinAgdaTCMInferType+builtinAgdaTCMCheckType                  = BuiltinAgdaTCMCheckType+builtinAgdaTCMNormalise                  = BuiltinAgdaTCMNormalise+builtinAgdaTCMReduce                     = BuiltinAgdaTCMReduce+builtinAgdaTCMCatchError                 = BuiltinAgdaTCMCatchError+builtinAgdaTCMGetContext                 = BuiltinAgdaTCMGetContext+builtinAgdaTCMExtendContext              = BuiltinAgdaTCMExtendContext+builtinAgdaTCMInContext                  = BuiltinAgdaTCMInContext+builtinAgdaTCMFreshName                  = BuiltinAgdaTCMFreshName+builtinAgdaTCMDeclareDef                 = BuiltinAgdaTCMDeclareDef+builtinAgdaTCMDeclarePostulate           = BuiltinAgdaTCMDeclarePostulate+builtinAgdaTCMDeclareData                = BuiltinAgdaTCMDeclareData+builtinAgdaTCMDefineData                 = BuiltinAgdaTCMDefineData+builtinAgdaTCMDefineFun                  = BuiltinAgdaTCMDefineFun+builtinAgdaTCMGetType                    = BuiltinAgdaTCMGetType+builtinAgdaTCMGetDefinition              = BuiltinAgdaTCMGetDefinition+builtinAgdaTCMBlock                      = BuiltinAgdaTCMBlock+builtinAgdaTCMCommit                     = BuiltinAgdaTCMCommit+builtinAgdaTCMQuoteTerm                  = BuiltinAgdaTCMQuoteTerm+builtinAgdaTCMUnquoteTerm                = BuiltinAgdaTCMUnquoteTerm+builtinAgdaTCMQuoteOmegaTerm             = BuiltinAgdaTCMQuoteOmegaTerm+builtinAgdaTCMIsMacro                    = BuiltinAgdaTCMIsMacro+builtinAgdaTCMWithNormalisation          = BuiltinAgdaTCMWithNormalisation+builtinAgdaTCMWithReconstructed          = BuiltinAgdaTCMWithReconstructed+builtinAgdaTCMWithExpandLast             = BuiltinAgdaTCMWithExpandLast+builtinAgdaTCMWithReduceDefs             = BuiltinAgdaTCMWithReduceDefs+builtinAgdaTCMAskNormalisation           = BuiltinAgdaTCMAskNormalisation+builtinAgdaTCMAskReconstructed           = BuiltinAgdaTCMAskReconstructed+builtinAgdaTCMAskExpandLast              = BuiltinAgdaTCMAskExpandLast+builtinAgdaTCMAskReduceDefs              = BuiltinAgdaTCMAskReduceDefs+builtinAgdaTCMFormatErrorParts           = BuiltinAgdaTCMFormatErrorParts+builtinAgdaTCMDebugPrint                 = BuiltinAgdaTCMDebugPrint+builtinAgdaTCMNoConstraints              = BuiltinAgdaTCMNoConstraints+builtinAgdaTCMWorkOnTypes                = BuiltinAgdaTCMWorkOnTypes+builtinAgdaTCMRunSpeculative             = BuiltinAgdaTCMRunSpeculative+builtinAgdaTCMExec                       = BuiltinAgdaTCMExec+builtinAgdaTCMCheckFromString            = BuiltinAgdaTCMCheckFromString+builtinAgdaTCMGetInstances               = BuiltinAgdaTCMGetInstances+builtinAgdaTCMSolveInstances             = BuiltinAgdaTCMSolveInstances+builtinAgdaTCMPragmaForeign              = BuiltinAgdaTCMPragmaForeign+builtinAgdaTCMPragmaCompile              = BuiltinAgdaTCMPragmaCompile+builtinAgdaBlocker                       = BuiltinAgdaBlocker+builtinAgdaBlockerAny                    = BuiltinAgdaBlockerAny+builtinAgdaBlockerAll                    = BuiltinAgdaBlockerAll+builtinAgdaBlockerMeta                   = BuiltinAgdaBlockerMeta++-- | Lookup a builtin by the string used in the @BUILTIN@ pragma.+builtinById :: String -> Maybe BuiltinId+builtinById = flip M.lookup m where+  m = M.fromList [(getBuiltinId x, x) | x <- [(minBound :: BuiltinId)..]]++-- * Primitives++-- | A primitive name, defined by the @primitive@ block.+data PrimitiveId+  -- Cubical+  = PrimIMin+  | PrimIMax+  | PrimINeg+  | PrimPartial+  | PrimPartialP+  | PrimSubOut+  | PrimGlue+  | Prim_glue+  | Prim_unglue+  | Prim_glueU+  | Prim_unglueU+  | PrimFaceForall+  | PrimComp+  | PrimPOr+  | PrimTrans+  | PrimHComp+  --  Integer+  | PrimShowInteger+  -- Natural+  | PrimNatPlus+  | PrimNatMinus+  | PrimNatTimes+  | PrimNatDivSucAux+  | PrimNatModSucAux+  | PrimNatEquality+  | PrimNatLess+  | PrimShowNat+  -- Word64+  | PrimWord64FromNat+  | PrimWord64ToNat+  | PrimWord64ToNatInjective+  -- Level+  | PrimLevelZero+  | PrimLevelSuc+  | PrimLevelMax+  -- Float+  | PrimFloatEquality+  | PrimFloatInequality+  | PrimFloatLess+  | PrimFloatIsInfinite+  | PrimFloatIsNaN+  | PrimFloatIsNegativeZero+  | PrimFloatIsSafeInteger+  | PrimFloatToWord64+  | PrimFloatToWord64Injective+  | PrimNatToFloat+  | PrimIntToFloat+  | PrimFloatRound+  | PrimFloatFloor+  | PrimFloatCeiling+  | PrimFloatToRatio+  | PrimRatioToFloat+  | PrimFloatDecode+  | PrimFloatEncode+  | PrimShowFloat+  | PrimFloatPlus+  | PrimFloatMinus+  | PrimFloatTimes+  | PrimFloatNegate+  | PrimFloatDiv+  | PrimFloatPow+  | PrimFloatSqrt+  | PrimFloatExp+  | PrimFloatLog+  | PrimFloatSin+  | PrimFloatCos+  | PrimFloatTan+  | PrimFloatASin+  | PrimFloatACos+  | PrimFloatATan+  | PrimFloatATan2+  | PrimFloatSinh+  | PrimFloatCosh+  | PrimFloatTanh+  | PrimFloatASinh+  | PrimFloatACosh+  | PrimFloatATanh+  -- Character+  | PrimCharEquality+  | PrimIsLower+  | PrimIsDigit+  | PrimIsAlpha+  | PrimIsSpace+  | PrimIsAscii+  | PrimIsLatin1+  | PrimIsPrint+  | PrimIsHexDigit+  | PrimToUpper+  | PrimToLower+  | PrimCharToNat+  | PrimCharToNatInjective+  | PrimNatToChar+  | PrimShowChar+  -- String+  | PrimStringToList+  | PrimStringToListInjective+  | PrimStringFromList+  | PrimStringFromListInjective+  | PrimStringAppend+  | PrimStringEquality+  | PrimShowString+  | PrimStringUncons+  -- "Other stuff"+  | PrimErase+  | PrimEraseEquality+  | PrimForce+  | PrimForceLemma+  | PrimQNameEquality+  | PrimQNameLess+  | PrimShowQName+  | PrimQNameFixity+  | PrimQNameToWord64s+  | PrimQNameToWord64sInjective+  | PrimMetaEquality+  | PrimMetaLess+  | PrimShowMeta+  | PrimMetaToNat+  | PrimMetaToNatInjective+  | PrimLockUniv+  deriving (Show, Eq, Ord, Bounded, Enum, Generic)++instance NFData PrimitiveId++instance Hashable PrimitiveId where+  s `hashWithSalt` b = s `hashWithSalt` fromEnum b++instance KillRange PrimitiveId where+  killRange = id++instance Pretty PrimitiveId where+  pretty = text . getBuiltinId++instance IsBuiltin PrimitiveId where+  someBuiltin = PrimitiveName++  getBuiltinId = \case+    -- Cubical+    PrimIMin                              -> "primIMin"+    PrimIMax                              -> "primIMax"+    PrimINeg                              -> "primINeg"+    PrimPartial                           -> "primPartial"+    PrimPartialP                          -> "primPartialP"+    PrimSubOut                            -> "primSubOut"+    PrimGlue                              -> "primGlue"+    Prim_glue                             -> "prim^glue"+    Prim_unglue                           -> "prim^unglue"+    Prim_glueU                            -> "prim^glueU"+    Prim_unglueU                          -> "prim^unglueU"+    PrimFaceForall                        -> "primFaceForall"+    PrimComp                              -> "primComp"+    PrimPOr                               -> "primPOr"+    PrimTrans                             -> "primTransp"+    PrimHComp                             -> "primHComp"+    --  Integer+    PrimShowInteger                       -> "primShowInteger"+    -- Natural+    PrimNatPlus                           -> "primNatPlus"+    PrimNatMinus                          -> "primNatMinus"+    PrimNatTimes                          -> "primNatTimes"+    PrimNatDivSucAux                      -> "primNatDivSucAux"+    PrimNatModSucAux                      -> "primNatModSucAux"+    PrimNatEquality                       -> "primNatEquality"+    PrimNatLess                           -> "primNatLess"+    PrimShowNat                           -> "primShowNat"+    -- Word64+    PrimWord64FromNat                     -> "primWord64FromNat"+    PrimWord64ToNat                       -> "primWord64ToNat"+    PrimWord64ToNatInjective              -> "primWord64ToNatInjective"+    -- Level+    PrimLevelZero                         -> "primLevelZero"+    PrimLevelSuc                          -> "primLevelSuc"+    PrimLevelMax                          -> "primLevelMax"+    -- Float+    PrimFloatEquality                     -> "primFloatEquality"+    PrimFloatInequality                   -> "primFloatInequality"+    PrimFloatLess                         -> "primFloatLess"+    PrimFloatIsInfinite                   -> "primFloatIsInfinite"+    PrimFloatIsNaN                        -> "primFloatIsNaN"+    PrimFloatIsNegativeZero               -> "primFloatIsNegativeZero"+    PrimFloatIsSafeInteger                -> "primFloatIsSafeInteger"+    PrimFloatToWord64                     -> "primFloatToWord64"+    PrimFloatToWord64Injective            -> "primFloatToWord64Injective"+    PrimNatToFloat                        -> "primNatToFloat"+    PrimIntToFloat                        -> "primIntToFloat"+    PrimFloatRound                        -> "primFloatRound"+    PrimFloatFloor                        -> "primFloatFloor"+    PrimFloatCeiling                      -> "primFloatCeiling"+    PrimFloatToRatio                      -> "primFloatToRatio"+    PrimRatioToFloat                      -> "primRatioToFloat"+    PrimFloatDecode                       -> "primFloatDecode"+    PrimFloatEncode                       -> "primFloatEncode"+    PrimShowFloat                         -> "primShowFloat"+    PrimFloatPlus                         -> "primFloatPlus"+    PrimFloatMinus                        -> "primFloatMinus"+    PrimFloatTimes                        -> "primFloatTimes"+    PrimFloatNegate                       -> "primFloatNegate"+    PrimFloatDiv                          -> "primFloatDiv"+    PrimFloatPow                          -> "primFloatPow"+    PrimFloatSqrt                         -> "primFloatSqrt"+    PrimFloatExp                          -> "primFloatExp"+    PrimFloatLog                          -> "primFloatLog"+    PrimFloatSin                          -> "primFloatSin"+    PrimFloatCos                          -> "primFloatCos"+    PrimFloatTan                          -> "primFloatTan"+    PrimFloatASin                         -> "primFloatASin"+    PrimFloatACos                         -> "primFloatACos"+    PrimFloatATan                         -> "primFloatATan"+    PrimFloatATan2                        -> "primFloatATan2"+    PrimFloatSinh                         -> "primFloatSinh"+    PrimFloatCosh                         -> "primFloatCosh"+    PrimFloatTanh                         -> "primFloatTanh"+    PrimFloatASinh                        -> "primFloatASinh"+    PrimFloatACosh                        -> "primFloatACosh"+    PrimFloatATanh                        -> "primFloatATanh"+    -- Character+    PrimCharEquality                      -> "primCharEquality"+    PrimIsLower                           -> "primIsLower"+    PrimIsDigit                           -> "primIsDigit"+    PrimIsAlpha                           -> "primIsAlpha"+    PrimIsSpace                           -> "primIsSpace"+    PrimIsAscii                           -> "primIsAscii"+    PrimIsLatin1                          -> "primIsLatin1"+    PrimIsPrint                           -> "primIsPrint"+    PrimIsHexDigit                        -> "primIsHexDigit"+    PrimToUpper                           -> "primToUpper"+    PrimToLower                           -> "primToLower"+    PrimCharToNat                         -> "primCharToNat"+    PrimCharToNatInjective                -> "primCharToNatInjective"+    PrimNatToChar                         -> "primNatToChar"+    PrimShowChar                          -> "primShowChar"+    -- String+    PrimStringToList                      -> "primStringToList"+    PrimStringToListInjective             -> "primStringToListInjective"+    PrimStringFromList                    -> "primStringFromList"+    PrimStringFromListInjective           -> "primStringFromListInjective"+    PrimStringAppend                      -> "primStringAppend"+    PrimStringEquality                    -> "primStringEquality"+    PrimShowString                        -> "primShowString"+    PrimStringUncons                      -> "primStringUncons"+    -- "Other stuff"+    PrimErase                             -> "primErase"+    PrimEraseEquality                     -> "primEraseEquality"+    PrimForce                             -> "primForce"+    PrimForceLemma                        -> "primForceLemma"+    PrimQNameEquality                     -> "primQNameEquality"+    PrimQNameLess                         -> "primQNameLess"+    PrimShowQName                         -> "primShowQName"+    PrimQNameFixity                       -> "primQNameFixity"+    PrimQNameToWord64s                    -> "primQNameToWord64s"+    PrimQNameToWord64sInjective           -> "primQNameToWord64sInjective"+    PrimMetaEquality                      -> "primMetaEquality"+    PrimMetaLess                          -> "primMetaLess"+    PrimShowMeta                          -> "primShowMeta"+    PrimMetaToNat                         -> "primMetaToNat"+    PrimMetaToNatInjective                -> "primMetaToNatInjective"+    PrimLockUniv                          -> "primLockUniv"++builtinSubOut,+  builtinIMin, builtinIMax, builtinINeg,+  builtinGlue, builtin_glue, builtin_unglue, builtin_glueU, builtin_unglueU,+  builtinFaceForall, builtinComp, builtinPOr,+  builtinTrans,  builtinHComp, builtinLockUniv+  :: PrimitiveId+builtinIMin                              = PrimIMin+builtinIMax                              = PrimIMax+builtinINeg                              = PrimINeg+builtinSubOut                            = PrimSubOut+builtinGlue                              = PrimGlue+builtin_glue                             = Prim_glue+builtin_unglue                           = Prim_unglue+builtin_glueU                            = Prim_glueU+builtin_unglueU                          = Prim_unglueU+builtinFaceForall                        = PrimFaceForall+builtinComp                              = PrimComp+builtinPOr                               = PrimPOr+builtinTrans                             = PrimTrans+builtinHComp                             = PrimHComp+builtinLockUniv                          = PrimLockUniv++-- | Lookup a primitive by its identifier.+primitiveById :: String -> Maybe PrimitiveId+primitiveById = flip M.lookup m where+  m = M.fromList [(getBuiltinId x, x) | x <- [(minBound :: PrimitiveId)..]]
src/full/Agda/Syntax/Common.hs view
@@ -1,2976 +1,4022 @@-{-# LANGUAGE CPP #-}--{-| Some common syntactic entities are defined in this module.--}-module Agda.Syntax.Common where--import Prelude hiding (null)--import Control.DeepSeq-import Control.Arrow ((&&&))-import Control.Applicative ((<|>), liftA2)--#if __GLASGOW_HASKELL__ < 804-import Data.Semigroup hiding (Arg)-#endif-import Data.Bifunctor-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as ByteString-import qualified Data.Foldable as Fold-import Data.Function-import Data.Hashable (Hashable(..))-import qualified Data.Strict.Maybe as Strict-import Data.Data (Data)-import Data.Word-import Data.IntSet (IntSet)-import qualified Data.IntSet as IntSet--import GHC.Generics (Generic)--import Agda.Syntax.Position--import Agda.Utils.Functor-import Agda.Utils.Lens-import Agda.Utils.List1  ( List1, pattern (:|), (<|) )-import qualified Agda.Utils.List1 as List1-import Agda.Utils.Maybe-import Agda.Utils.Null-import Agda.Utils.PartialOrd-import Agda.Utils.POMonoid-import Agda.Utils.Pretty--import Agda.Utils.Impossible--type Nat    = Int-type Arity  = Nat-------------------------------------------------------------------------------- * Delayed-------------------------------------------------------------------------------- | Used to specify whether something should be delayed.-data Delayed = Delayed | NotDelayed-  deriving (Data, Show, Eq, Ord, Generic)--instance KillRange Delayed where-  killRange = id--instance NFData Delayed-------------------------------------------------------------------------------- * File------------------------------------------------------------------------------data FileType = AgdaFileType | MdFileType | RstFileType | TexFileType | OrgFileType-  deriving (Data, Eq, Ord, Show, Generic)--instance Pretty FileType where-  pretty = \case-    AgdaFileType -> "Agda"-    MdFileType   -> "Markdown"-    RstFileType  -> "ReStructedText"-    TexFileType  -> "LaTeX"-    OrgFileType  -> "org-mode"--instance NFData FileType-------------------------------------------------------------------------------- * Agda variants-------------------------------------------------------------------------------- | Variants of Cubical Agda.--data Cubical = CErased | CFull-    deriving (Eq, Show, Generic)--instance NFData Cubical---- | Agda variants.------ Only some variants are tracked.--data Language-  = WithoutK-  | WithK-  | Cubical Cubical-    deriving (Eq, Show, Generic)--instance KillRange Language where-  killRange = id--instance NFData Language-------------------------------------------------------------------------------- * Record Directives------------------------------------------------------------------------------data RecordDirectives' a = RecordDirectives-  { recInductive   :: Maybe (Ranged Induction)-  , recHasEta      :: Maybe HasEta0-  , recPattern     :: Maybe Range-  , recConstructor :: Maybe a-  } deriving (Functor, Data, Show, Eq)--emptyRecordDirectives :: RecordDirectives' a-emptyRecordDirectives = RecordDirectives empty empty empty empty--instance HasRange a => HasRange (RecordDirectives' a) where-  getRange (RecordDirectives a b c d) = getRange (a,b,c,d)--instance KillRange a => KillRange (RecordDirectives' a) where-  killRange (RecordDirectives a b c d) = killRange4 RecordDirectives a b c d--instance NFData a => NFData (RecordDirectives' a) where-  rnf (RecordDirectives a b c d) = c `seq` rnf (a, b, d)-------------------------------------------------------------------------------- * Eta-equality-------------------------------------------------------------------------------- | Does a record come with eta-equality?-data HasEta' a-  = YesEta-  | NoEta a-  deriving (Data, Show, Eq, Ord, Functor, Foldable, Traversable)--instance HasRange a => HasRange (HasEta' a) where-  getRange = foldMap getRange--instance KillRange a => KillRange (HasEta' a) where-  killRange = fmap killRange--instance NFData a => NFData (HasEta' a) where-  rnf YesEta    = ()-  rnf (NoEta p) = rnf p---- | Pattern and copattern matching is allowed in the presence of eta.------   In the absence of eta, we have to choose whether we want to allow---   matching on the constructor or copattern matching with the projections.---   Having both leads to breakage of subject reduction (issue #4560).--type HasEta  = HasEta' PatternOrCopattern-type HasEta0 = HasEta' ()---- | For a record without eta, which type of matching do we allow?-data PatternOrCopattern-  = PatternMatching-      -- ^ Can match on the record constructor.-  | CopatternMatching-      -- ^ Can copattern match using the projections. (Default.)-  deriving (Data, Show, Eq, Ord, Enum, Bounded)--instance NFData PatternOrCopattern where-  rnf PatternMatching   = ()-  rnf CopatternMatching = ()--instance HasRange PatternOrCopattern where-  getRange _ = noRange--instance KillRange PatternOrCopattern where-  killRange = id---- | Can we pattern match on the record constructor?-class PatternMatchingAllowed a where-  patternMatchingAllowed :: a -> Bool--instance PatternMatchingAllowed PatternOrCopattern where-  patternMatchingAllowed = (== PatternMatching)--instance PatternMatchingAllowed HasEta where-  patternMatchingAllowed = \case-    YesEta -> True-    NoEta p -> patternMatchingAllowed p----- | Can we construct a record by copattern matching?-class CopatternMatchingAllowed a where-  copatternMatchingAllowed :: a -> Bool--instance CopatternMatchingAllowed PatternOrCopattern where-  copatternMatchingAllowed = (== CopatternMatching)--instance CopatternMatchingAllowed HasEta where-  copatternMatchingAllowed = \case-    YesEta -> True-    NoEta p -> copatternMatchingAllowed p-------------------------------------------------------------------------------- * Induction-------------------------------------------------------------------------------- | @Inductive < Coinductive@-data Induction = Inductive | CoInductive  -- Keep in this order!-  deriving (Data, Eq, Ord, Show)--instance Pretty Induction where-  pretty Inductive   = "inductive"-  pretty CoInductive = "coinductive"--instance HasRange Induction where-  getRange _ = noRange--instance KillRange Induction where-  killRange = id--instance NFData Induction where-  rnf Inductive   = ()-  rnf CoInductive = ()--instance PatternMatchingAllowed Induction where-  patternMatchingAllowed = (== Inductive)-------------------------------------------------------------------------------- * Hiding------------------------------------------------------------------------------data Overlappable = YesOverlap | NoOverlap-  deriving (Data, Show, Eq, Ord)--data Hiding  = Hidden | Instance Overlappable | NotHidden-  deriving (Data, Show, Eq, Ord)--instance Pretty Hiding where-  pretty = \case-    Hidden     -> "hidden"-    NotHidden  -> "visible"-    Instance{} -> "instance"---- | Just for the 'Hiding' instance. Should never combine different---   overlapping.-instance Semigroup Overlappable where-  NoOverlap  <> NoOverlap  = NoOverlap-  YesOverlap <> YesOverlap = YesOverlap-  _          <> _          = __IMPOSSIBLE__---- | 'Hiding' is an idempotent partial monoid, with unit 'NotHidden'.---   'Instance' and 'NotHidden' are incompatible.-instance Semigroup Hiding where-  NotHidden  <> h           = h-  h          <> NotHidden   = h-  Hidden     <> Hidden      = Hidden-  Instance o <> Instance o' = Instance (o <> o')-  _          <> _           = __IMPOSSIBLE__--instance Monoid Overlappable where-  mempty  = NoOverlap-  mappend = (<>)--instance Monoid Hiding where-  mempty = NotHidden-  mappend = (<>)--instance HasRange Hiding where-  getRange _ = noRange--instance KillRange Hiding where-  killRange = id--instance NFData Overlappable where-  rnf NoOverlap  = ()-  rnf YesOverlap = ()--instance NFData Hiding where-  rnf Hidden       = ()-  rnf (Instance o) = rnf o-  rnf NotHidden    = ()---- | Decorating something with 'Hiding' information.-data WithHiding a = WithHiding-  { whHiding :: !Hiding-  , whThing  :: a-  }-  deriving (Data, Eq, Ord, Show, Functor, Foldable, Traversable)--instance Decoration WithHiding where-  traverseF f (WithHiding h a) = WithHiding h <$> f a--instance Applicative WithHiding where-  pure = WithHiding mempty-  WithHiding h f <*> WithHiding h' a = WithHiding (mappend h h') (f a)--instance HasRange a => HasRange (WithHiding a) where-  getRange = getRange . dget--instance SetRange a => SetRange (WithHiding a) where-  setRange = fmap . setRange--instance KillRange a => KillRange (WithHiding a) where-  killRange = fmap killRange--instance NFData a => NFData (WithHiding a) where-  rnf (WithHiding _ a) = rnf a---- | A lens to access the 'Hiding' attribute in data structures.---   Minimal implementation: @getHiding@ and @mapHiding@ or @LensArgInfo@.-class LensHiding a where--  getHiding :: a -> Hiding--  setHiding :: Hiding -> a -> a-  setHiding h = mapHiding (const h)--  mapHiding :: (Hiding -> Hiding) -> a -> a--  default getHiding :: LensArgInfo a => a -> Hiding-  getHiding = argInfoHiding . getArgInfo--  default mapHiding :: LensArgInfo a => (Hiding -> Hiding) -> a -> a-  mapHiding f = mapArgInfo $ \ ai -> ai { argInfoHiding = f $ argInfoHiding ai }--instance LensHiding Hiding where-  getHiding = id-  setHiding = const-  mapHiding = id--instance LensHiding (WithHiding a) where-  getHiding   (WithHiding h _) = h-  setHiding h (WithHiding _ a) = WithHiding h a-  mapHiding f (WithHiding h a) = WithHiding (f h) a--instance LensHiding a => LensHiding (Named nm a) where-  getHiding = getHiding . namedThing-  setHiding = fmap . setHiding-  mapHiding = fmap . mapHiding---- | Monoidal composition of 'Hiding' information in some data.-mergeHiding :: LensHiding a => WithHiding a -> a-mergeHiding (WithHiding h a) = mapHiding (mappend h) a---- | 'NotHidden' arguments are @visible@.-visible :: LensHiding a => a -> Bool-visible a = getHiding a == NotHidden---- | 'Instance' and 'Hidden' arguments are @notVisible@.-notVisible :: LensHiding a => a -> Bool-notVisible a = getHiding a /= NotHidden---- | 'Hidden' arguments are @hidden@.-hidden :: LensHiding a => a -> Bool-hidden a = getHiding a == Hidden--hide :: LensHiding a => a -> a-hide = setHiding Hidden--hideOrKeepInstance :: LensHiding a => a -> a-hideOrKeepInstance x =-  case getHiding x of-    Hidden     -> x-    Instance{} -> x-    NotHidden  -> setHiding Hidden x--makeInstance :: LensHiding a => a -> a-makeInstance = makeInstance' NoOverlap--makeInstance' :: LensHiding a => Overlappable -> a -> a-makeInstance' o = setHiding (Instance o)--isOverlappable :: LensHiding a => a -> Bool-isOverlappable x =-  case getHiding x of-    Instance YesOverlap -> True-    _ -> False--isInstance :: LensHiding a => a -> Bool-isInstance x =-  case getHiding x of-    Instance{} -> True-    _          -> False---- | Ignores 'Overlappable'.-sameHiding :: (LensHiding a, LensHiding b) => a -> b -> Bool-sameHiding x y =-  case (getHiding x, getHiding y) of-    (Instance{}, Instance{}) -> True-    (hx, hy)                 -> hx == hy-------------------------------------------------------------------------------- * Modalities-------------------------------------------------------------------------------- | Type wrapper to indicate additive monoid/semigroup context.-newtype UnderAddition t = UnderAddition t deriving (Show, Functor, Eq, Ord, PartialOrd)--instance Applicative UnderAddition where-  pure = UnderAddition-  (<*>) (UnderAddition f) (UnderAddition a) = pure (f a)---- | Type wrapper to indicate composition or multiplicative monoid/semigroup context.-newtype UnderComposition t = UnderComposition t deriving (Show, Functor, Eq, Ord, PartialOrd)--instance Applicative UnderComposition where-  pure = UnderComposition-  (<*>) (UnderComposition f) (UnderComposition a) = pure (f a)---- | We have a tuple of modalities, which might not be fully orthogonal.---   For instance, irrelevant stuff is also run-time irrelevant.-data Modality = Modality-  { modRelevance :: Relevance-      -- ^ Legacy irrelevance.-      --   See Pfenning, LiCS 2001; Abel/Vezzosi/Winterhalter, ICFP 2017.-  , modQuantity  :: Quantity-      -- ^ Cardinality / runtime erasure.-      --   See Conor McBride, I got plenty o' nutting, Wadlerfest 2016.-      --   See Bob Atkey, Syntax and Semantics of Quantitative Type Theory, LiCS 2018.-  , modCohesion :: Cohesion-      -- ^ Cohesion/what was in Agda-flat.-      --   see "Brouwer's fixed-point theorem in real-cohesive homotopy type theory" (arXiv:1509.07584)-      --   Currently only the comonad is implemented.-  } deriving (Data, Eq, Ord, Show, Generic)---- | Dominance ordering.-instance PartialOrd Modality where-  comparable (Modality r q c) (Modality r' q' c') = comparable (r, (q, c)) (r', (q', c'))---- | Pointwise composition.-instance Semigroup (UnderComposition Modality) where-  (<>) = liftA2 composeModality---- | Pointwise composition unit.-instance Monoid (UnderComposition Modality) where-  mempty  = pure unitModality-  mappend = (<>)--instance POSemigroup (UnderComposition Modality) where-instance POMonoid (UnderComposition Modality) where--instance LeftClosedPOMonoid (UnderComposition Modality) where-  inverseCompose = liftA2 inverseComposeModality---- | Pointwise addition.-instance Semigroup (UnderAddition Modality) where-  (<>) = liftA2 addModality---- | Pointwise additive unit.-instance Monoid (UnderAddition Modality) where-  mempty  = pure zeroModality-  mappend = (<>)--instance POSemigroup (UnderAddition Modality) where-instance POMonoid (UnderAddition Modality) where---- | @m `moreUsableModality` m'@ means that an @m@ can be used---   where ever an @m'@ is required.--moreUsableModality :: Modality -> Modality -> Bool-moreUsableModality m m' = related m POLE m'--usableModality :: LensModality a => a -> Bool-usableModality a = usableRelevance m && usableQuantity m-  where m = getModality a---- | Multiplicative monoid (standard monoid).-composeModality :: Modality -> Modality -> Modality-composeModality (Modality r q c) (Modality r' q' c') =-    Modality (r `composeRelevance` r')-             (q `composeQuantity` q')-             (c `composeCohesion` c')---- | Compose with modality flag from the left.---   This function is e.g. used to update the modality information---   on pattern variables @a@ after a match against something of modality @q@.-applyModality :: LensModality a => Modality -> a -> a-applyModality m = mapModality (m `composeModality`)---- | @inverseComposeModality r x@ returns the least modality @y@---   such that forall @x@, @y@ we have---   @x \`moreUsableModality\` (r \`composeModality\` y)@---   iff---   @(r \`inverseComposeModality\` x) \`moreUsableModality\` y@ (Galois connection).-inverseComposeModality :: Modality -> Modality -> Modality-inverseComposeModality (Modality r q c) (Modality r' q' c') =-  Modality (r `inverseComposeRelevance` r')-           (q `inverseComposeQuantity`  q')-           (c `inverseComposeCohesion`  c')---- | Left division by a 'Modality'.---   Used e.g. to modify context when going into a @m@ argument.------ Note that this function does not change quantities.-inverseApplyModalityButNotQuantity :: LensModality a => Modality -> a -> a-inverseApplyModalityButNotQuantity m =-  mapModality (m' `inverseComposeModality`)-  where-  m' = setQuantity (Quantity1 Q1Inferred) m---- | 'Modality' forms a pointwise additive monoid.-addModality :: Modality -> Modality -> Modality-addModality (Modality r q c) (Modality r' q' c') = Modality (addRelevance r r') (addQuantity q q') (addCohesion c c')---- | Identity under addition-zeroModality :: Modality-zeroModality = Modality zeroRelevance zeroQuantity zeroCohesion---- | Identity under composition-unitModality :: Modality-unitModality = Modality unitRelevance unitQuantity unitCohesion---- | Absorptive element under addition.-topModality :: Modality-topModality = Modality topRelevance topQuantity topCohesion---- | The default Modality---   Beware that this is neither the additive unit nor the unit under---   composition, because the default quantity is ω.-defaultModality :: Modality-defaultModality = Modality defaultRelevance defaultQuantity defaultCohesion---- | Equality ignoring origin.--sameModality :: (LensModality a, LensModality b) => a -> b -> Bool-sameModality x y = case (getModality x , getModality y) of-  (Modality r q c , Modality r' q' c') -> sameRelevance r r' && sameQuantity q q' && sameCohesion c c'---- boilerplate instances--instance HasRange Modality where-  getRange (Modality r q c) = getRange (r, q, c)--instance KillRange Modality where-  killRange (Modality r q c) = killRange3 Modality r q c--instance NFData Modality where---- Lens stuff--lModRelevance :: Lens' Relevance Modality-lModRelevance f m = f (modRelevance m) <&> \ r -> m { modRelevance = r }--lModQuantity :: Lens' Quantity Modality-lModQuantity f m = f (modQuantity m) <&> \ q -> m { modQuantity = q }--lModCohesion :: Lens' Cohesion Modality-lModCohesion f m = f (modCohesion m) <&> \ q -> m { modCohesion = q }--class LensModality a where--  getModality :: a -> Modality--  setModality :: Modality -> a -> a-  setModality = mapModality . const--  mapModality :: (Modality -> Modality) -> a -> a--  default getModality :: LensArgInfo a => a -> Modality-  getModality = argInfoModality . getArgInfo--  default mapModality :: LensArgInfo a => (Modality -> Modality) -> a -> a-  mapModality f = mapArgInfo $ \ ai -> ai { argInfoModality = f $ argInfoModality ai }--instance LensModality Modality where-  getModality = id-  setModality = const-  mapModality = id--instance LensRelevance Modality where-  getRelevance = modRelevance-  setRelevance h m = m { modRelevance = h }-  mapRelevance f m = m { modRelevance = f (modRelevance m) }--instance LensQuantity Modality where-  getQuantity = modQuantity-  setQuantity h m = m { modQuantity = h }-  mapQuantity f m = m { modQuantity = f (modQuantity m) }--instance LensCohesion Modality where-  getCohesion = modCohesion-  setCohesion h m = m { modCohesion = h }-  mapCohesion f m = m { modCohesion = f (modCohesion m) }---- default accessors for Relevance--getRelevanceMod :: LensModality a => LensGet Relevance a-getRelevanceMod = getRelevance . getModality--setRelevanceMod :: LensModality a => LensSet Relevance a-setRelevanceMod = mapModality . setRelevance--mapRelevanceMod :: LensModality a => LensMap Relevance a-mapRelevanceMod = mapModality . mapRelevance---- default accessors for Quantity--getQuantityMod :: LensModality a => LensGet Quantity a-getQuantityMod = getQuantity . getModality--setQuantityMod :: LensModality a => LensSet Quantity a-setQuantityMod = mapModality . setQuantity--mapQuantityMod :: LensModality a => LensMap Quantity a-mapQuantityMod = mapModality . mapQuantity---- default accessors for Cohesion--getCohesionMod :: LensModality a => LensGet Cohesion a-getCohesionMod = getCohesion . getModality--setCohesionMod :: LensModality a => LensSet Cohesion a-setCohesionMod = mapModality . setCohesion--mapCohesionMod :: LensModality a => LensMap Cohesion a-mapCohesionMod = mapModality . mapCohesion-------------------------------------------------------------------------------- * Quantities-------------------------------------------------------------------------------- ** Quantity origin.---- | Origin of 'Quantity0'.-data Q0Origin-  = Q0Inferred       -- ^ User wrote nothing.-  | Q0       Range   -- ^ User wrote "@0".-  | Q0Erased Range   -- ^ User wrote "@erased".-  deriving (Data, Show, Generic, Eq, Ord)---- | Origin of 'Quantity1'.-data Q1Origin-  = Q1Inferred       -- ^ User wrote nothing.-  | Q1       Range   -- ^ User wrote "@1".-  | Q1Linear Range   -- ^ User wrote "@linear".-  deriving (Data, Show, Generic, Eq, Ord)---- | Origin of 'Quantityω'.-data QωOrigin-  = QωInferred       -- ^ User wrote nothing.-  | Qω       Range   -- ^ User wrote "@ω".-  | QωPlenty Range   -- ^ User wrote "@plenty".-  deriving (Data, Show, Generic, Eq, Ord)---- *** Instances for 'Q0Origin'.---- | Right-biased composition, because the left quantity---   acts as context, and the right one as occurrence.-instance Semigroup Q0Origin where-  (<>) = curry $ \case-    (Q0Inferred, o) -> o-    (o, Q0Inferred) -> o-    (o, Q0       r) -> Q0 $ fuseRange o r-    (o, Q0Erased r) -> Q0 $ fuseRange o r--instance Monoid Q0Origin where-  mempty = Q0Inferred-  mappend = (<>)--instance Null Q0Origin where-  empty = mempty--instance HasRange Q0Origin where-  getRange = \case-    Q0Inferred -> noRange-    Q0       r -> r-    Q0Erased r -> r--instance SetRange Q0Origin where-  setRange r = \case-    Q0Inferred -> Q0Inferred-    Q0       _ -> Q0       r-    Q0Erased _ -> Q0Erased r--instance KillRange Q0Origin where-  killRange = \case-    Q0Inferred -> Q0Inferred-    Q0       _ -> Q0       noRange-    Q0Erased _ -> Q0Erased noRange--instance NFData Q0Origin where-  rnf = \case-    Q0Inferred -> ()-    Q0       _ -> ()-    Q0Erased _ -> ()---- *** Instances for 'Q1Origin'.---- | Right-biased composition, because the left quantity---   acts as context, and the right one as occurrence.-instance Semigroup Q1Origin where-  (<>) = curry $ \case-    (Q1Inferred, o) -> o-    (o, Q1Inferred) -> o-    (o, Q1       r) -> Q1 $ fuseRange o r-    (o, Q1Linear r) -> Q1 $ fuseRange o r--instance Monoid Q1Origin where-  mempty = Q1Inferred-  mappend = (<>)--instance Null Q1Origin where-  empty = mempty--instance HasRange Q1Origin where-  getRange = \case-    Q1Inferred -> noRange-    Q1       r -> r-    Q1Linear r -> r--instance SetRange Q1Origin where-  setRange r = \case-    Q1Inferred -> Q1Inferred-    Q1       _ -> Q1       r-    Q1Linear _ -> Q1Linear r--instance KillRange Q1Origin where-  killRange = \case-    Q1Inferred -> Q1Inferred-    Q1       _ -> Q1       noRange-    Q1Linear _ -> Q1Linear noRange--instance NFData Q1Origin where-  rnf = \case-    Q1Inferred -> ()-    Q1       _ -> ()-    Q1Linear _ -> ()---- *** Instances for 'QωOrigin'.---- | Right-biased composition, because the left quantity---   acts as context, and the right one as occurrence.-instance Semigroup QωOrigin where-  (<>) = curry $ \case-    (QωInferred, o) -> o-    (o, QωInferred) -> o-    (o, Qω       r) -> Qω $ fuseRange o r-    (o, QωPlenty r) -> Qω $ fuseRange o r--instance Monoid QωOrigin where-  mempty = QωInferred-  mappend = (<>)--instance Null QωOrigin where-  empty = mempty--instance HasRange QωOrigin where-  getRange = \case-    QωInferred -> noRange-    Qω       r -> r-    QωPlenty r -> r--instance SetRange QωOrigin where-  setRange r = \case-    QωInferred -> QωInferred-    Qω       _ -> Qω       r-    QωPlenty _ -> QωPlenty r--instance KillRange QωOrigin where-  killRange = \case-    QωInferred -> QωInferred-    Qω       _ -> Qω       noRange-    QωPlenty _ -> QωPlenty noRange--instance NFData QωOrigin where-  rnf = \case-    QωInferred -> ()-    Qω       _ -> ()-    QωPlenty _ -> ()---- ** Quantity.---- | Quantity for linearity.------   A quantity is a set of natural numbers, indicating possible semantic---   uses of a variable.  A singleton set @{n}@ requires that the---   corresponding variable is used exactly @n@ times.----data Quantity-  = Quantity0 Q0Origin -- ^ Zero uses @{0}@, erased at runtime.-  | Quantity1 Q1Origin -- ^ Linear use @{1}@ (could be updated destructively).-    -- Mostly TODO (needs postponable constraints between quantities to compute uses).-  | Quantityω QωOrigin -- ^ Unrestricted use @ℕ@.-  deriving (Data, Show, Generic, Eq, Ord)-    -- @Ord@ instance in case @Quantity@ is used in keys for maps etc.---- | Equality ignoring origin.--sameQuantity :: Quantity -> Quantity -> Bool-sameQuantity = curry $ \case-  (Quantity0{}, Quantity0{}) -> True-  (Quantity1{}, Quantity1{}) -> True-  (Quantityω{}, Quantityω{}) -> True-  _ -> False---- | Composition of quantities (multiplication).------ 'Quantity0' is dominant.--- 'Quantity1' is neutral.------ Right-biased for origin.----instance Semigroup (UnderComposition Quantity) where-  (<>) = liftA2 composeQuantity---- | In the absense of finite quantities besides 0, ω is the unit.---   Otherwise, 1 is the unit.-instance Monoid (UnderComposition Quantity) where-  mempty  = pure unitQuantity-  mappend = (<>)--instance POSemigroup (UnderComposition Quantity) where-instance POMonoid (UnderComposition Quantity) where--instance LeftClosedPOMonoid (UnderComposition Quantity) where-  inverseCompose = liftA2 inverseComposeQuantity--instance Semigroup (UnderAddition Quantity) where-  (<>) = liftA2 addQuantity--instance Monoid (UnderAddition Quantity) where-  mempty  = pure zeroQuantity-  mappend = (<>)--instance POSemigroup (UnderAddition Quantity) where-instance POMonoid (UnderAddition Quantity) where---- | Note that the order is @ω ≤ 0,1@, more options is smaller.-instance PartialOrd Quantity where-  comparable = curry $ \case-    (q, q') | sameQuantity q q' -> POEQ-    -- ω is least-    (Quantityω{}, _)  -> POLT-    (_, Quantityω{})  -> POGT-    -- others are uncomparable-    _ -> POAny---- | 'Quantity' forms an additive monoid with zero Quantity0.-addQuantity :: Quantity -> Quantity -> Quantity-addQuantity = curry $ \case-  -- ω is absorptive-  (q@Quantityω{}, _) -> q-  (_, q@Quantityω{}) -> q-  -- 0 is neutral-  (Quantity0{}, q) -> q-  (q, Quantity0{}) -> q-  -- 1 + 1 = ω-  (Quantity1 _, Quantity1 _) -> topQuantity---- | Identity element under addition-zeroQuantity :: Quantity-zeroQuantity = Quantity0 mempty---- | Absorptive element!---   This differs from Relevance and Cohesion whose default---   is the multiplicative unit.-defaultQuantity :: Quantity-defaultQuantity = topQuantity---- | Identity element under composition-unitQuantity :: Quantity-unitQuantity = Quantityω mempty---- | Absorptive element is ω.-topQuantity :: Quantity-topQuantity = Quantityω mempty---- | @m `moreUsableQuantity` m'@ means that an @m@ can be used---   where ever an @m'@ is required.--moreQuantity :: Quantity -> Quantity -> Bool-moreQuantity m m' = related m POLE m'---- | Composition of quantities (multiplication).------ 'Quantity0' is dominant.--- 'Quantity1' is neutral.------ Right-biased for origin.----composeQuantity :: Quantity -> Quantity -> Quantity-composeQuantity = curry $ \case-  (Quantity1 o, Quantity1 o') -> Quantity1 (o <> o')-  (Quantity1{}, q           ) -> q-  (q          , Quantity1{} ) -> q-  (Quantity0 o, Quantity0 o') -> Quantity0 (o <> o')-  (_          , Quantity0 o ) -> Quantity0 o-  (Quantity0 o, _           ) -> Quantity0 o-  (Quantityω o, Quantityω o') -> Quantityω (o <> o')---- | Compose with quantity flag from the left.---   This function is e.g. used to update the quantity information---   on pattern variables @a@ after a match against something of quantity @q@.--applyQuantity :: LensQuantity a => Quantity -> a -> a-applyQuantity q = mapQuantity (q `composeQuantity`)---- | @inverseComposeQuantity r x@ returns the least quantity @y@---   such that forall @x@, @y@ we have---   @x \`moreQuantity\` (r \`composeQuantity\` y)@---   iff---   @(r \`inverseComposeQuantity\` x) \`moreQuantity\` y@ (Galois connection).--inverseComposeQuantity :: Quantity -> Quantity -> Quantity-inverseComposeQuantity = curry $ \case-    (Quantity1{} , x)              -> x             -- going to linear arg: nothing changes-    (Quantity0{} , x)              -> topQuantity   -- going to erased arg: every thing usable-    (Quantityω{} , x@Quantityω{})  -> x-    (Quantityω{} , _)              -> zeroQuantity  -- linear resources are unusable as arguments to unrestricted functions---- | Left division by a 'Quantity'.---   Used e.g. to modify context when going into a @q@ argument.--inverseApplyQuantity :: LensQuantity a => Quantity -> a -> a-inverseApplyQuantity q = mapQuantity (q `inverseComposeQuantity`)---- | Check for 'Quantity0'.--hasQuantity0 :: LensQuantity a => a -> Bool-hasQuantity0 a-  | Quantity0{} <- getQuantity a = True-  | otherwise = False---- | Check for 'Quantity1'.--hasQuantity1 :: LensQuantity a => a -> Bool-hasQuantity1 a-  | Quantity1{} <- getQuantity a = True-  | otherwise = False---- | Check for 'Quantityω'.--hasQuantityω :: LensQuantity a => a -> Bool-hasQuantityω a-  | Quantityω{} <- getQuantity a = True-  | otherwise = False---- | Did the user supply a quantity annotation?--noUserQuantity :: LensQuantity a => a -> Bool-noUserQuantity a = case getQuantity a of-  Quantity0 o -> null o-  Quantity1 o -> null o-  Quantityω o -> null o---- | A thing of quantity 0 is unusable, all others are usable.--usableQuantity :: LensQuantity a => a -> Bool-usableQuantity = not . hasQuantity0---- boilerplate instances--class LensQuantity a where--  getQuantity :: a -> Quantity--  setQuantity :: Quantity -> a -> a-  setQuantity = mapQuantity . const--  mapQuantity :: (Quantity -> Quantity) -> a -> a--  default getQuantity :: LensModality a => a -> Quantity-  getQuantity = modQuantity . getModality--  default mapQuantity :: LensModality a => (Quantity -> Quantity) -> a -> a-  mapQuantity f = mapModality $ \ ai -> ai { modQuantity = f $ modQuantity ai }--instance LensQuantity Quantity where-  getQuantity = id-  setQuantity = const-  mapQuantity = id--instance HasRange Quantity where-  getRange = \case-    Quantity0 o -> getRange o-    Quantity1 o -> getRange o-    Quantityω o -> getRange o--instance SetRange Quantity where-  setRange r = \case-    Quantity0 o -> Quantity0 $ setRange r o-    Quantity1 o -> Quantity1 $ setRange r o-    Quantityω o -> Quantityω $ setRange r o--instance KillRange Quantity where-  killRange = \case-    Quantity0 o -> Quantity0 $ killRange o-    Quantity1 o -> Quantity1 $ killRange o-    Quantityω o -> Quantityω $ killRange o--instance NFData Quantity where-  rnf (Quantity0 o) = rnf o-  rnf (Quantity1 o) = rnf o-  rnf (Quantityω o) = rnf o---- ** Erased.---- | A special case of 'Quantity': erased or not.--data Erased-  = Erased Q0Origin-  | NotErased QωOrigin-  deriving (Data, Show, Eq, Generic)---- | The default value of type 'Erased': not erased.--defaultErased :: Erased-defaultErased = NotErased QωInferred---- | 'Erased' can be embedded into 'Quantity'.--asQuantity :: Erased -> Quantity-asQuantity (Erased    o) = Quantity0 o-asQuantity (NotErased o) = Quantityω o---- | 'Quantity' can be projected onto 'Erased'.--erasedFromQuantity :: Quantity -> Maybe Erased-erasedFromQuantity = \case-  Quantity1{} -> Nothing-  Quantity0 o -> Just $ Erased    o-  Quantityω o -> Just $ NotErased o---- | Equality ignoring origin.--sameErased :: Erased -> Erased -> Bool-sameErased = sameQuantity `on` asQuantity---- | Is the value \"erased\"?--isErased :: Erased -> Bool-isErased = hasQuantity0 . asQuantity--instance NFData Erased--instance HasRange Erased where-  getRange = getRange . asQuantity--instance KillRange Erased where-  killRange = \case-    Erased o    -> Erased $ killRange o-    NotErased o -> NotErased $ killRange o---- | Composition of values of type 'Erased'.------ 'Erased' is dominant.--- 'NotErased' is neutral.------ Right-biased for the origin.--composeErased :: Erased -> Erased -> Erased-composeErased = curry $ \case-  (Erased o,    Erased o')    -> Erased (o <> o')-  (NotErased _, Erased o)     -> Erased o-  (Erased o,    NotErased _)  -> Erased o-  (NotErased o, NotErased o') -> NotErased (o <> o')--instance Semigroup (UnderComposition Erased) where-  (<>) = liftA2 composeErased-------------------------------------------------------------------------------- * Relevance-------------------------------------------------------------------------------- | A function argument can be relevant or irrelevant.---   See "Agda.TypeChecking.Irrelevance".-data Relevance-  = Relevant    -- ^ The argument is (possibly) relevant at compile-time.-  | NonStrict   -- ^ The argument may never flow into evaluation position.-                --   Therefore, it is irrelevant at run-time.-                --   It is treated relevantly during equality checking.-  | Irrelevant  -- ^ The argument is irrelevant at compile- and runtime.-    deriving (Data, Show, Eq, Enum, Bounded, Generic)--allRelevances :: [Relevance]-allRelevances = [minBound..maxBound]--instance HasRange Relevance where-  getRange _ = noRange--instance SetRange Relevance where-  setRange _ = id--instance KillRange Relevance where-  killRange rel = rel -- no range to kill--instance NFData Relevance where-  rnf Relevant   = ()-  rnf NonStrict  = ()-  rnf Irrelevant = ()---- | A lens to access the 'Relevance' attribute in data structures.---   Minimal implementation: @getRelevance@ and @mapRelevance@ or @LensModality@.-class LensRelevance a where--  getRelevance :: a -> Relevance--  setRelevance :: Relevance -> a -> a-  setRelevance h = mapRelevance (const h)--  mapRelevance :: (Relevance -> Relevance) -> a -> a--  default getRelevance :: LensModality a => a -> Relevance-  getRelevance = modRelevance . getModality--  default mapRelevance :: LensModality a => (Relevance -> Relevance) -> a -> a-  mapRelevance f = mapModality $ \ ai -> ai { modRelevance = f $ modRelevance ai }--instance LensRelevance Relevance where-  getRelevance = id-  setRelevance = const-  mapRelevance = id--isRelevant :: LensRelevance a => a -> Bool-isRelevant a = getRelevance a == Relevant--isIrrelevant :: LensRelevance a => a -> Bool-isIrrelevant a = getRelevance a == Irrelevant--isNonStrict :: LensRelevance a => a -> Bool-isNonStrict a = getRelevance a == NonStrict---- | Information ordering.--- @Relevant  \`moreRelevant\`---  NonStrict \`moreRelevant\`---  Irrelevant@-moreRelevant :: Relevance -> Relevance -> Bool-moreRelevant = (<=)---- | Equality ignoring origin.-sameRelevance :: Relevance -> Relevance -> Bool-sameRelevance = (==)---- | More relevant is smaller.-instance Ord Relevance where-  compare = curry $ \case-    (r, r') | r == r' -> EQ-    -- top-    (_, Irrelevant) -> LT-    (Irrelevant, _) -> GT-    -- bottom-    (Relevant, _) -> LT-    (_, Relevant) -> GT-    -- redundant case-    (NonStrict,NonStrict) -> EQ---- | More relevant is smaller.-instance PartialOrd Relevance where-  comparable = comparableOrd---- | @usableRelevance rel == False@ iff we cannot use a variable of @rel@.-usableRelevance :: LensRelevance a => a -> Bool-usableRelevance = isRelevant---- | 'Relevance' composition.---   'Irrelevant' is dominant, 'Relevant' is neutral.---   Composition coincides with 'max'.-composeRelevance :: Relevance -> Relevance -> Relevance-composeRelevance r r' =-  case (r, r') of-    (Irrelevant, _) -> Irrelevant-    (_, Irrelevant) -> Irrelevant-    (NonStrict, _)  -> NonStrict-    (_, NonStrict)  -> NonStrict-    (Relevant, Relevant) -> Relevant---- | Compose with relevance flag from the left.---   This function is e.g. used to update the relevance information---   on pattern variables @a@ after a match against something @rel@.-applyRelevance :: LensRelevance a => Relevance -> a -> a-applyRelevance rel = mapRelevance (rel `composeRelevance`)---- | @inverseComposeRelevance r x@ returns the most irrelevant @y@---   such that forall @x@, @y@ we have---   @x \`moreRelevant\` (r \`composeRelevance\` y)@---   iff---   @(r \`inverseComposeRelevance\` x) \`moreRelevant\` y@ (Galois connection).-inverseComposeRelevance :: Relevance -> Relevance -> Relevance-inverseComposeRelevance r x =-  case (r, x) of-    (Relevant  , x)          -> x          -- going to relevant arg.: nothing changes-                                           -- because Relevant is comp.-neutral-    (Irrelevant, x)          -> Relevant   -- going irrelevant: every thing usable-    (NonStrict , Irrelevant) -> Irrelevant -- otherwise: irrelevant things remain unusable-    (NonStrict , _)          -> Relevant   -- but @NonStrict@s become usable---- | Left division by a 'Relevance'.---   Used e.g. to modify context when going into a @rel@ argument.-inverseApplyRelevance :: LensRelevance a => Relevance -> a -> a-inverseApplyRelevance rel = mapRelevance (rel `inverseComposeRelevance`)---- | 'Relevance' forms a semigroup under composition.-instance Semigroup (UnderComposition Relevance) where-  (<>) = liftA2 composeRelevance---- | 'Relevant' is the unit under composition.-instance Monoid (UnderComposition Relevance) where-  mempty  = pure unitRelevance-  mappend = (<>)--instance POSemigroup (UnderComposition Relevance) where-instance POMonoid (UnderComposition Relevance) where--instance LeftClosedPOMonoid (UnderComposition Relevance) where-  inverseCompose = liftA2 inverseComposeRelevance--instance Semigroup (UnderAddition Relevance) where-  (<>) = liftA2 addRelevance--instance Monoid (UnderAddition Relevance) where-  mempty  = pure zeroRelevance-  mappend = (<>)--instance POSemigroup (UnderAddition Relevance) where-instance POMonoid (UnderAddition Relevance) where---- | Combine inferred 'Relevance'.---   The unit is 'Irrelevant'.-addRelevance :: Relevance -> Relevance -> Relevance-addRelevance = min---- | 'Relevance' forms a monoid under addition, and even a semiring.-zeroRelevance :: Relevance-zeroRelevance = Irrelevant---- | Identity element under composition-unitRelevance :: Relevance-unitRelevance = Relevant---- | Absorptive element under addition.-topRelevance :: Relevance-topRelevance = Relevant---- | Default Relevance is the identity element under composition-defaultRelevance :: Relevance-defaultRelevance = unitRelevance---- | Irrelevant function arguments may appear non-strictly in the codomain type.-irrToNonStrict :: Relevance -> Relevance-irrToNonStrict Irrelevant = NonStrict-irrToNonStrict rel        = rel---- | Applied when working on types (unless --experimental-irrelevance).-nonStrictToRel :: Relevance -> Relevance-nonStrictToRel NonStrict = Relevant-nonStrictToRel rel       = rel--nonStrictToIrr :: Relevance -> Relevance-nonStrictToIrr NonStrict = Irrelevant-nonStrictToIrr rel       = rel--------------------------------------------------------------------------------- * Annotations-------------------------------------------------------------------------------- | We have a tuple of annotations, which might not be fully orthogonal.-data Annotation = Annotation-  { annLock :: Lock-    -- ^ Fitch-style dependent right adjoints.-    --   See Modal Dependent Type Theory and Dependent Right Adjoints, arXiv:1804.05236.-  } deriving (Data, Eq, Ord, Show, Generic)--instance HasRange Annotation where-  getRange _ = noRange--instance KillRange Annotation where-  killRange = id--defaultAnnotation :: Annotation-defaultAnnotation = Annotation defaultLock--instance NFData Annotation where-  rnf (Annotation l) = rnf l--class LensAnnotation a where--  getAnnotation :: a -> Annotation--  setAnnotation :: Annotation -> a -> a--  mapAnnotation :: (Annotation -> Annotation) -> a -> a-  mapAnnotation f a = setAnnotation (f $ getAnnotation a) a--  default getAnnotation :: LensArgInfo a => a -> Annotation-  getAnnotation = argInfoAnnotation . getArgInfo--  default setAnnotation :: LensArgInfo a => Annotation -> a -> a-  setAnnotation a = mapArgInfo $ \ ai -> ai { argInfoAnnotation = a }--instance LensAnnotation Annotation where-  getAnnotation = id-  setAnnotation = const-  mapAnnotation = id--instance LensAnnotation (Arg t) where-  getAnnotation = getAnnotation . getArgInfo-  setAnnotation = mapArgInfo . setAnnotation--------------------------------------------------------------------------------- * Locks------------------------------------------------------------------------------data Lock = IsNotLock-          | IsLock -- ^ In the future there might be different kinds of them.-                   --   For now we assume lock weakening.-  deriving (Data, Show, Generic, Eq, Enum, Bounded, Ord)--defaultLock :: Lock-defaultLock = IsNotLock--instance NFData Lock where-  rnf IsNotLock = ()-  rnf IsLock    = ()--class LensLock a where--  getLock :: a -> Lock--  setLock :: Lock -> a -> a-  setLock = mapLock . const--  mapLock :: (Lock -> Lock) -> a -> a-  mapLock f a = setLock (f $ getLock a) a--instance LensLock Lock where-  getLock = id-  setLock = const-  mapLock = id--instance LensLock ArgInfo where-  getLock = annLock . argInfoAnnotation-  setLock l info = info { argInfoAnnotation = Annotation l }--instance LensLock (Arg t) where-  getLock = getLock . getArgInfo-  setLock = mapArgInfo . setLock-------------------------------------------------------------------------------- * Cohesion-------------------------------------------------------------------------------- | Cohesion modalities---   see "Brouwer's fixed-point theorem in real-cohesive homotopy type theory" (arXiv:1509.07584)---   types are now given an additional topological layer which the modalities interact with.-data Cohesion-  = Flat        -- ^ same points, discrete topology, idempotent comonad, box-like.-  | Continuous  -- ^ identity modality.-  -- | Sharp    -- ^ same points, codiscrete topology, idempotent monad, diamond-like.-  | Squash      -- ^ single point space, artificially added for Flat left-composition.-    deriving (Data, Show, Eq, Enum, Bounded, Generic)--allCohesions :: [Cohesion]-allCohesions = [minBound..maxBound]--instance HasRange Cohesion where-  getRange _ = noRange--instance SetRange Cohesion where-  setRange _ = id--instance KillRange Cohesion where-  killRange rel = rel -- no range to kill--instance NFData Cohesion where-  rnf Flat       = ()-  rnf Continuous = ()-  rnf Squash     = ()---- | A lens to access the 'Cohesion' attribute in data structures.---   Minimal implementation: @getCohesion@ and @mapCohesion@ or @LensModality@.-class LensCohesion a where--  getCohesion :: a -> Cohesion--  setCohesion :: Cohesion -> a -> a-  setCohesion h = mapCohesion (const h)--  mapCohesion :: (Cohesion -> Cohesion) -> a -> a--  default getCohesion :: LensModality a => a -> Cohesion-  getCohesion = modCohesion . getModality--  default mapCohesion :: LensModality a => (Cohesion -> Cohesion) -> a -> a-  mapCohesion f = mapModality $ \ ai -> ai { modCohesion = f $ modCohesion ai }--instance LensCohesion Cohesion where-  getCohesion = id-  setCohesion = const-  mapCohesion = id---- | Information ordering.--- @Flat  \`moreCohesion\`---  Continuous \`moreCohesion\`---  Sharp \`moreCohesion\`---  Squash@-moreCohesion :: Cohesion -> Cohesion -> Bool-moreCohesion = (<=)---- | Equality ignoring origin.-sameCohesion :: Cohesion -> Cohesion -> Bool-sameCohesion = (==)---- | Order is given by implication: flatter is smaller.-instance Ord Cohesion where-  compare = curry $ \case-    (r, r') | r == r' -> EQ-    -- top-    (_, Squash) -> LT-    (Squash, _) -> GT-    -- bottom-    (Flat, _) -> LT-    (_, Flat) -> GT-    -- redundant case-    (Continuous,Continuous) -> EQ---- | Flatter is smaller.-instance PartialOrd Cohesion where-  comparable = comparableOrd---- | @usableCohesion rel == False@ iff we cannot use a variable of @rel@.-usableCohesion :: LensCohesion a => a -> Bool-usableCohesion a = getCohesion a `moreCohesion` Continuous---- | 'Cohesion' composition.---   'Squash' is dominant, 'Continuous' is neutral.-composeCohesion :: Cohesion -> Cohesion -> Cohesion-composeCohesion r r' =-  case (r, r') of-    (Squash, _) -> Squash-    (_, Squash) -> Squash-    (Flat, _)  -> Flat-    (_, Flat)  -> Flat-    (Continuous, Continuous) -> Continuous---- | Compose with cohesion flag from the left.---   This function is e.g. used to update the cohesion information---   on pattern variables @a@ after a match against something of cohesion @rel@.-applyCohesion :: LensCohesion a => Cohesion -> a -> a-applyCohesion rel = mapCohesion (rel `composeCohesion`)---- | @inverseComposeCohesion r x@ returns the least @y@---   such that forall @x@, @y@ we have---   @x \`moreCohesion\` (r \`composeCohesion\` y)@---   iff---   @(r \`inverseComposeCohesion\` x) \`moreCohesion\` y@ (Galois connection).---   The above law fails for @r = Squash@.-inverseComposeCohesion :: Cohesion -> Cohesion -> Cohesion-inverseComposeCohesion r x =-  case (r, x) of-    (Continuous  , x) -> x          -- going to continous arg.: nothing changes-                                    -- because Continuous is comp.-neutral-    (Squash, x)       -> Squash     -- artificial case, should not be needed.-    (Flat , Flat)     -> Flat       -- otherwise: Flat things remain Flat-    (Flat , _)        -> Squash     -- but everything else becomes unusable.---- | Left division by a 'Cohesion'.---   Used e.g. to modify context when going into a @rel@ argument.-inverseApplyCohesion :: LensCohesion a => Cohesion -> a -> a-inverseApplyCohesion rel = mapCohesion (rel `inverseComposeCohesion`)---- | 'Cohesion' forms a semigroup under composition.-instance Semigroup (UnderComposition Cohesion) where-  (<>) = liftA2 composeCohesion---- | 'Continous' is the multiplicative unit.-instance Monoid (UnderComposition Cohesion) where-  mempty  = pure unitCohesion-  mappend = (<>)--instance POSemigroup (UnderComposition Cohesion) where-instance POMonoid (UnderComposition Cohesion) where--instance LeftClosedPOMonoid (UnderComposition Cohesion) where-  inverseCompose = liftA2 inverseComposeCohesion---- | 'Cohesion' forms a semigroup under addition.-instance Semigroup (UnderAddition Cohesion) where-  (<>) = liftA2 addCohesion---- | 'Squash' is the additive unit.-instance Monoid (UnderAddition Cohesion) where-  mempty  = pure zeroCohesion-  mappend = (<>)--instance POSemigroup (UnderAddition Cohesion) where-instance POMonoid (UnderAddition Cohesion) where---- | Combine inferred 'Cohesion'.---   The unit is 'Squash'.-addCohesion :: Cohesion -> Cohesion -> Cohesion-addCohesion = min---- | 'Cohesion' forms a monoid under addition, and even a semiring.-zeroCohesion :: Cohesion-zeroCohesion = Squash---- | Identity under composition-unitCohesion :: Cohesion-unitCohesion = Continuous---- | Absorptive element under addition.-topCohesion :: Cohesion-topCohesion = Flat---- | Default Cohesion is the identity element under composition-defaultCohesion :: Cohesion-defaultCohesion = unitCohesion-------------------------------------------------------------------------------- * Origin of arguments (user-written, inserted or reflected)-------------------------------------------------------------------------------- | Origin of arguments.-data Origin-  = UserWritten  -- ^ From the source file / user input.  (Preserve!)-  | Inserted     -- ^ E.g. inserted hidden arguments.-  | Reflected    -- ^ Produced by the reflection machinery.-  | CaseSplit    -- ^ Produced by an interactive case split.-  | Substitution -- ^ Named application produced to represent a substitution. E.g. "?0 (x = n)" instead of "?0 n"-  deriving (Data, Show, Eq, Ord)--instance HasRange Origin where-  getRange _ = noRange--instance KillRange Origin where-  killRange = id--instance NFData Origin where-  rnf UserWritten = ()-  rnf Inserted = ()-  rnf Reflected = ()-  rnf CaseSplit = ()-  rnf Substitution = ()---- | Decorating something with 'Origin' information.-data WithOrigin a = WithOrigin-  { woOrigin :: !Origin-  , woThing  :: a-  }-  deriving (Data, Eq, Ord, Show, Functor, Foldable, Traversable)--instance Decoration WithOrigin where-  traverseF f (WithOrigin h a) = WithOrigin h <$> f a--instance Pretty a => Pretty (WithOrigin a) where-  prettyPrec p = prettyPrec p . woThing--instance HasRange a => HasRange (WithOrigin a) where-  getRange = getRange . dget--instance SetRange a => SetRange (WithOrigin a) where-  setRange = fmap . setRange--instance KillRange a => KillRange (WithOrigin a) where-  killRange = fmap killRange--instance NFData a => NFData (WithOrigin a) where-  rnf (WithOrigin _ a) = rnf a---- | A lens to access the 'Origin' attribute in data structures.---   Minimal implementation: @getOrigin@ and @mapOrigin@ or @LensArgInfo@.--class LensOrigin a where--  getOrigin :: a -> Origin--  setOrigin :: Origin -> a -> a-  setOrigin o = mapOrigin (const o)--  mapOrigin :: (Origin -> Origin) -> a -> a--  default getOrigin :: LensArgInfo a => a -> Origin-  getOrigin = argInfoOrigin . getArgInfo--  default mapOrigin :: LensArgInfo a => (Origin -> Origin) -> a -> a-  mapOrigin f = mapArgInfo $ \ ai -> ai { argInfoOrigin = f $ argInfoOrigin ai }--instance LensOrigin Origin where-  getOrigin = id-  setOrigin = const-  mapOrigin = id--instance LensOrigin (WithOrigin a) where-  getOrigin   (WithOrigin h _) = h-  setOrigin h (WithOrigin _ a) = WithOrigin h a-  mapOrigin f (WithOrigin h a) = WithOrigin (f h) a---------------------------------------------------------------------------------- * Free variable annotations--------------------------------------------------------------------------------data FreeVariables = UnknownFVs | KnownFVs IntSet-  deriving (Data, Eq, Ord, Show)--instance Semigroup FreeVariables where-  UnknownFVs   <> _            = UnknownFVs-  _            <> UnknownFVs   = UnknownFVs-  KnownFVs vs1 <> KnownFVs vs2 = KnownFVs (IntSet.union vs1 vs2)--instance Monoid FreeVariables where-  mempty  = KnownFVs IntSet.empty-  mappend = (<>)--instance KillRange FreeVariables where-  killRange = id--instance NFData FreeVariables where-  rnf UnknownFVs    = ()-  rnf (KnownFVs fv) = rnf fv--unknownFreeVariables :: FreeVariables-unknownFreeVariables = UnknownFVs--noFreeVariables :: FreeVariables-noFreeVariables = mempty--oneFreeVariable :: Int -> FreeVariables-oneFreeVariable = KnownFVs . IntSet.singleton--freeVariablesFromList :: [Int] -> FreeVariables-freeVariablesFromList = mconcat . map oneFreeVariable---- | A lens to access the 'FreeVariables' attribute in data structures.---   Minimal implementation: @getFreeVariables@ and @mapFreeVariables@ or @LensArgInfo@.-class LensFreeVariables a where--  getFreeVariables :: a -> FreeVariables--  setFreeVariables :: FreeVariables -> a -> a-  setFreeVariables o = mapFreeVariables (const o)--  mapFreeVariables :: (FreeVariables -> FreeVariables) -> a -> a--  default getFreeVariables :: LensArgInfo a => a -> FreeVariables-  getFreeVariables = argInfoFreeVariables . getArgInfo--  default mapFreeVariables :: LensArgInfo a => (FreeVariables -> FreeVariables) -> a -> a-  mapFreeVariables f = mapArgInfo $ \ ai -> ai { argInfoFreeVariables = f $ argInfoFreeVariables ai }--instance LensFreeVariables FreeVariables where-  getFreeVariables = id-  setFreeVariables = const-  mapFreeVariables = id--hasNoFreeVariables :: LensFreeVariables a => a -> Bool-hasNoFreeVariables x =-  case getFreeVariables x of-    UnknownFVs  -> False-    KnownFVs fv -> IntSet.null fv-------------------------------------------------------------------------------- * Argument decoration-------------------------------------------------------------------------------- | A function argument can be hidden and/or irrelevant.--data ArgInfo = ArgInfo-  { argInfoHiding        :: Hiding-  , argInfoModality      :: Modality-  , argInfoOrigin        :: Origin-  , argInfoFreeVariables :: FreeVariables-  , argInfoAnnotation    :: Annotation-    -- ^ Sometimes we want a different kind of binder/pi-type, without it-    --   supporting any of the @Modality@ interface.-  } deriving (Data, Eq, Ord, Show)--instance HasRange ArgInfo where-  getRange (ArgInfo h m o _fv a) = getRange (h, m, o, a)--instance KillRange ArgInfo where-  killRange (ArgInfo h m o fv a) = killRange5 ArgInfo h m o fv a--class LensArgInfo a where-  getArgInfo :: a -> ArgInfo-  setArgInfo :: ArgInfo -> a -> a-  setArgInfo ai = mapArgInfo (const ai)-  mapArgInfo :: (ArgInfo -> ArgInfo) -> a -> a-  mapArgInfo f a = setArgInfo (f $ getArgInfo a) a--instance LensArgInfo ArgInfo where-  getArgInfo = id-  setArgInfo = const-  mapArgInfo = id--instance NFData ArgInfo where-  rnf (ArgInfo a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e--instance LensHiding ArgInfo where-  getHiding = argInfoHiding-  setHiding h ai = ai { argInfoHiding = h }-  mapHiding f ai = ai { argInfoHiding = f (argInfoHiding ai) }--instance LensModality ArgInfo where-  getModality = argInfoModality-  setModality m ai = ai { argInfoModality = m }-  mapModality f ai = ai { argInfoModality = f (argInfoModality ai) }--instance LensOrigin ArgInfo where-  getOrigin = argInfoOrigin-  setOrigin o ai = ai { argInfoOrigin = o }-  mapOrigin f ai = ai { argInfoOrigin = f (argInfoOrigin ai) }--instance LensFreeVariables ArgInfo where-  getFreeVariables = argInfoFreeVariables-  setFreeVariables o ai = ai { argInfoFreeVariables = o }-  mapFreeVariables f ai = ai { argInfoFreeVariables = f (argInfoFreeVariables ai) }--instance LensAnnotation ArgInfo where-  getAnnotation = argInfoAnnotation-  setAnnotation m ai = ai { argInfoAnnotation = m }-  mapAnnotation f ai = ai { argInfoAnnotation = f (argInfoAnnotation ai) }---- inherited instances--instance LensRelevance ArgInfo where-  getRelevance = getRelevanceMod-  setRelevance = setRelevanceMod-  mapRelevance = mapRelevanceMod--instance LensQuantity ArgInfo where-  getQuantity = getQuantityMod-  setQuantity = setQuantityMod-  mapQuantity = mapQuantityMod--instance LensCohesion ArgInfo where-  getCohesion = getCohesionMod-  setCohesion = setCohesionMod-  mapCohesion = mapCohesionMod--defaultArgInfo :: ArgInfo-defaultArgInfo =  ArgInfo-  { argInfoHiding        = NotHidden-  , argInfoModality      = defaultModality-  , argInfoOrigin        = UserWritten-  , argInfoFreeVariables = UnknownFVs-  , argInfoAnnotation    = defaultAnnotation-  }---- Accessing through ArgInfo---- default accessors for Hiding--getHidingArgInfo :: LensArgInfo a => LensGet Hiding a-getHidingArgInfo = getHiding . getArgInfo--setHidingArgInfo :: LensArgInfo a => LensSet Hiding a-setHidingArgInfo = mapArgInfo . setHiding--mapHidingArgInfo :: LensArgInfo a => LensMap Hiding a-mapHidingArgInfo = mapArgInfo . mapHiding---- default accessors for Modality--getModalityArgInfo :: LensArgInfo a => LensGet Modality a-getModalityArgInfo = getModality . getArgInfo--setModalityArgInfo :: LensArgInfo a => LensSet Modality a-setModalityArgInfo = mapArgInfo . setModality--mapModalityArgInfo :: LensArgInfo a => LensMap Modality a-mapModalityArgInfo = mapArgInfo . mapModality---- default accessors for Origin--getOriginArgInfo :: LensArgInfo a => LensGet Origin a-getOriginArgInfo = getOrigin . getArgInfo--setOriginArgInfo :: LensArgInfo a => LensSet Origin a-setOriginArgInfo = mapArgInfo . setOrigin--mapOriginArgInfo :: LensArgInfo a => LensMap Origin a-mapOriginArgInfo = mapArgInfo . mapOrigin---- default accessors for FreeVariables--getFreeVariablesArgInfo :: LensArgInfo a => LensGet FreeVariables a-getFreeVariablesArgInfo = getFreeVariables . getArgInfo--setFreeVariablesArgInfo :: LensArgInfo a => LensSet FreeVariables a-setFreeVariablesArgInfo = mapArgInfo . setFreeVariables--mapFreeVariablesArgInfo :: LensArgInfo a => LensMap FreeVariables a-mapFreeVariablesArgInfo = mapArgInfo . mapFreeVariables---- inserted hidden arguments--isInsertedHidden :: (LensHiding a, LensOrigin a) => a -> Bool-isInsertedHidden a = getHiding a == Hidden && getOrigin a == Inserted-------------------------------------------------------------------------------- * Arguments------------------------------------------------------------------------------data Arg e  = Arg-  { argInfo :: ArgInfo-  , unArg :: e-  } deriving (Data, Eq, Ord, Show, Functor, Foldable, Traversable)--instance Decoration Arg where-  traverseF f (Arg ai a) = Arg ai <$> f a--instance HasRange a => HasRange (Arg a) where-    getRange = getRange . unArg--instance SetRange a => SetRange (Arg a) where-  setRange r = fmap $ setRange r--instance KillRange a => KillRange (Arg a) where-  killRange (Arg info a) = killRange2 Arg info a---- Andreas, 2019-07-05, issue #3889--- A dedicated equality for with-abstraction now exists,--- thus, we can use intensional equality for Arg.------ -- | Ignores 'Quantity', 'Relevance', 'Origin', and 'FreeVariables'.--- --   Ignores content of argument if 'Irrelevant'.--- ----- instance Eq a => Eq (Arg a) where---   Arg (ArgInfo h1 m1 _ _) x1 == Arg (ArgInfo h2 m2 _ _) x2 =---     h1 == h2 && (isIrrelevant m1 || isIrrelevant m2 || x1 == x2)---     -- Andreas, 2017-10-04, issue #2775, ignore irrelevant arguments during with-abstraction.---     -- This is a hack, we should not use '(==)' in with-abstraction---     -- and more generally not use it on Syntax.---     -- Andrea: except for caching.---- instance Show a => Show (Arg a) where---     show (Arg (ArgInfo h (Modality r q) o fv) a) = showFVs fv $ showQ q $ showR r $ showO o $ showH h $ show a---       where---         showH Hidden       s = "{" ++ s ++ "}"---         showH NotHidden    s = "(" ++ s ++ ")"---         showH (Instance o) s = showOv o ++ "{{" ++ s ++ "}}"---           where showOv YesOverlap = "overlap "---                 showOv NoOverlap  = ""---         showR r s = case r of---           Irrelevant   -> "." ++ s---           NonStrict    -> "?" ++ s---           Relevant     -> "r" ++ s -- Andreas: I want to see it explicitly---         showQ q s = case q of---           Quantity0   -> "0" ++ s---           Quantity1   -> "1" ++ s---           Quantityω   -> "ω" ++ s---         showO o s = case o of---           UserWritten -> "u" ++ s---           Inserted    -> "i" ++ s---           Reflected   -> "g" ++ s -- generated by reflection---           CaseSplit   -> "c" ++ s -- generated by case split---           Substitution -> "s" ++ s---         showFVs UnknownFVs    s = s---         showFVs (KnownFVs fv) s = "fv" ++ show (IntSet.toList fv) ++ s---- -- defined in Concrete.Pretty--- instance Pretty a => Pretty (Arg a) where---     pretty (Arg (ArgInfo h (Modality r q) o fv) a) = prettyFVs fv $ prettyQ q $ prettyR r $ prettyO o $ prettyH h $ pretty a---       where---         prettyH Hidden       s = "{" <> s <> "}"---         prettyH NotHidden    s = "(" <> s <> ")"---         prettyH (Instance o) s = prettyOv o <> "{{" <> s <> "}}"---           where prettyOv YesOverlap = "overlap "---                 prettyOv NoOverlap  = ""---         prettyR r s = case r of---           Irrelevant   -> "." <> s---           NonStrict    -> "?" <> s---           Relevant     -> "r" <> s -- Andreas: I want to see it explicitly---         prettyQ q s = case q of---           Quantity0   -> "0" <> s---           Quantity1   -> "1" <> s---           Quantityω   -> "ω" <> s---         prettyO o s = case o of---           UserWritten -> "u" <> s---           Inserted    -> "i" <> s---           Reflected   -> "g" <> s -- generated by reflection---           CaseSplit   -> "c" <> s -- generated by case split---           Substitution -> "s" <> s---         prettyFVs UnknownFVs    s = s---         prettyFVs (KnownFVs fv) s = "fv" <> pretty (IntSet.toList fv) <> s--instance NFData e => NFData (Arg e) where-  rnf (Arg a b) = rnf a `seq` rnf b--instance LensArgInfo (Arg a) where-  getArgInfo        = argInfo-  setArgInfo ai arg = arg { argInfo = ai }-  mapArgInfo f arg  = arg { argInfo = f $ argInfo arg }---- The other lenses are defined through LensArgInfo--instance LensHiding (Arg e) where-  getHiding = getHidingArgInfo-  setHiding = setHidingArgInfo-  mapHiding = mapHidingArgInfo--instance LensModality (Arg e) where-  getModality = getModalityArgInfo-  setModality = setModalityArgInfo-  mapModality = mapModalityArgInfo--instance LensOrigin (Arg e) where-  getOrigin = getOriginArgInfo-  setOrigin = setOriginArgInfo-  mapOrigin = mapOriginArgInfo--instance LensFreeVariables (Arg e) where-  getFreeVariables = getFreeVariablesArgInfo-  setFreeVariables = setFreeVariablesArgInfo-  mapFreeVariables = mapFreeVariablesArgInfo---- Since we have LensModality, we get relevance and quantity by default--instance LensRelevance (Arg e) where-  getRelevance = getRelevanceMod-  setRelevance = setRelevanceMod-  mapRelevance = mapRelevanceMod--instance LensQuantity (Arg e) where-  getQuantity = getQuantityMod-  setQuantity = setQuantityMod-  mapQuantity = mapQuantityMod--instance LensCohesion (Arg e) where-  getCohesion = getCohesionMod-  setCohesion = setCohesionMod-  mapCohesion = mapCohesionMod--defaultArg :: a -> Arg a-defaultArg = Arg defaultArgInfo---- | @xs \`withArgsFrom\` args@ translates @xs@ into a list of 'Arg's,--- using the elements in @args@ to fill in the non-'unArg' fields.------ Precondition: The two lists should have equal length.--withArgsFrom :: [a] -> [Arg b] -> [Arg a]-xs `withArgsFrom` args =-  zipWith (\x arg -> fmap (const x) arg) xs args--withNamedArgsFrom :: [a] -> [NamedArg b] -> [NamedArg a]-xs `withNamedArgsFrom` args =-  zipWith (\x -> fmap (x <$)) xs args-------------------------------------------------------------------------------- * Names------------------------------------------------------------------------------class Eq a => Underscore a where-  underscore   :: a-  isUnderscore :: a -> Bool-  isUnderscore = (== underscore)--instance Underscore String where-  underscore = "_"--instance Underscore ByteString where-  underscore = ByteString.pack underscore--instance Underscore Doc where-  underscore = text underscore-------------------------------------------------------------------------------- * Named arguments-------------------------------------------------------------------------------- | Something potentially carrying a name.-data Named name a =-    Named { nameOf     :: Maybe name-          , namedThing :: a-          }-    deriving (Eq, Ord, Show, Data, Functor, Foldable, Traversable)---- | Standard naming.-type Named_ = Named NamedName---- | Standard argument names.-type NamedName = WithOrigin (Ranged ArgName)---- | Equality of argument names of things modulo 'Range' and 'Origin'.-sameName :: NamedName -> NamedName -> Bool-sameName = (==) `on` (rangedThing . woThing)--unnamed :: a -> Named name a-unnamed = Named Nothing--isUnnamed :: Named name a -> Maybe a-isUnnamed = \case-  Named Nothing a -> Just a-  Named Just{}  a -> Nothing--named :: name -> a -> Named name a-named = Named . Just--userNamed :: Ranged ArgName -> a -> Named_ a-userNamed = Named . Just . WithOrigin UserWritten---- | Accessor/editor for the 'nameOf' component.-class LensNamed a where-  -- | The type of the name-  type NameOf a-  lensNamed :: Lens' (Maybe (NameOf a)) a--  -- Lenses lift through decorations:-  default lensNamed :: (Decoration f, LensNamed b, NameOf b ~ NameOf a, f b ~ a) => Lens' (Maybe (NameOf a)) a-  lensNamed = traverseF . lensNamed--instance LensNamed a => LensNamed (Arg a) where-  type NameOf (Arg a) = NameOf a--instance LensNamed (Maybe a) where-  type NameOf (Maybe a) = a-  lensNamed = id--instance LensNamed (Named name a) where-  type NameOf (Named name a) = name--  lensNamed f (Named mn a) = f mn <&> \ mn' -> Named mn' a--getNameOf :: LensNamed a => a -> Maybe (NameOf a)-getNameOf a = a ^. lensNamed--setNameOf :: LensNamed a => Maybe (NameOf a) -> a -> a-setNameOf = set lensNamed--mapNameOf :: LensNamed a => (Maybe (NameOf a) -> Maybe (NameOf a)) -> a -> a-mapNameOf = over lensNamed-bareNameOf :: (LensNamed a, NameOf a ~ NamedName) => a -> Maybe ArgName-bareNameOf a = rangedThing . woThing <$> getNameOf a--bareNameWithDefault :: (LensNamed a, NameOf a ~ NamedName) => ArgName -> a -> ArgName-bareNameWithDefault x a = maybe x (rangedThing . woThing) $ getNameOf a---- | Equality of argument names of things modulo 'Range' and 'Origin'.-namedSame :: (LensNamed a, LensNamed b, NameOf a ~ NamedName, NameOf b ~ NamedName) => a -> b -> Bool-namedSame a b = case (getNameOf a, getNameOf b) of-  (Nothing, Nothing) -> True-  (Just x , Just y ) -> sameName x y-  _ -> False---- | Does an argument @arg@ fit the shape @dom@ of the next expected argument?------   The hiding has to match, and if the argument has a name, it should match---   the name of the domain.------   'Nothing' should be '__IMPOSSIBLE__', so use as---   @@---     fromMaybe __IMPOSSIBLE__ $ fittingNamedArg arg dom---   @@----fittingNamedArg-  :: ( LensNamed arg, NameOf arg ~ NamedName, LensHiding arg-     , LensNamed dom, NameOf dom ~ NamedName, LensHiding dom )-  => arg -> dom -> Maybe Bool-fittingNamedArg arg dom-    | not $ sameHiding arg dom = no-    | visible arg              = yes-    | otherwise =-        caseMaybe (bareNameOf arg) yes        $ \ x ->-        caseMaybe (bareNameOf dom) impossible $ \ y ->-        return $ x == y-  where-    yes = return True-    no  = return False-    impossible = Nothing---- Standard instances for 'Named':--instance Decoration (Named name) where-  traverseF f (Named n a) = Named n <$> f a--instance HasRange a => HasRange (Named name a) where-    getRange = getRange . namedThing--instance SetRange a => SetRange (Named name a) where-  setRange r = fmap $ setRange r--instance (KillRange name, KillRange a) => KillRange (Named name a) where-  killRange (Named n a) = Named (killRange n) (killRange a)---- instance Show a => Show (Named_ a) where---     show (Named Nothing a)  = show a---     show (Named (Just n) a) = rawNameToString (rangedThing n) ++ " = " ++ show a---- -- Defined in Concrete.Pretty--- instance Pretty a => Pretty (Named_ a) where---     pretty (Named Nothing a)  = pretty a---     pretty (Named (Just n) a) = text (rawNameToString (rangedThing n)) <+> "=" <+> pretty a--instance (NFData name, NFData a) => NFData (Named name a) where-  rnf (Named a b) = rnf a `seq` rnf b---- | Only 'Hidden' arguments can have names.-type NamedArg a = Arg (Named_ a)---- | Get the content of a 'NamedArg'.-namedArg :: NamedArg a -> a-namedArg = namedThing . unArg--defaultNamedArg :: a -> NamedArg a-defaultNamedArg = unnamedArg defaultArgInfo--unnamedArg :: ArgInfo -> a -> NamedArg a-unnamedArg info = Arg info . unnamed---- | The functor instance for 'NamedArg' would be ambiguous,---   so we give it another name here.-updateNamedArg :: (a -> b) -> NamedArg a -> NamedArg b-updateNamedArg = fmap . fmap--updateNamedArgA :: Applicative f => (a -> f b) -> NamedArg a -> f (NamedArg b)-updateNamedArgA = traverse . traverse---- | @setNamedArg a b = updateNamedArg (const b) a@-setNamedArg :: NamedArg a -> b -> NamedArg b-setNamedArg a b = (b <$) <$> a---- ** ArgName---- | Names in binders and arguments.-type ArgName = String--argNameToString :: ArgName -> String-argNameToString = id--stringToArgName :: String -> ArgName-stringToArgName = id--appendArgNames :: ArgName -> ArgName -> ArgName-appendArgNames = (++)-------------------------------------------------------------------------------- * Range decoration.-------------------------------------------------------------------------------- | Thing with range info.-data Ranged a = Ranged-  { rangeOf     :: Range-  , rangedThing :: a-  }-  deriving (Data, Show, Functor, Foldable, Traversable)---- | Thing with no range info.-unranged :: a -> Ranged a-unranged = Ranged noRange---- | Ignores range.-instance Pretty a => Pretty (Ranged a) where-  pretty = pretty . rangedThing---- | Ignores range.-instance Eq a => Eq (Ranged a) where-  (==) = (==) `on` rangedThing---- | Ignores range.-instance Ord a => Ord (Ranged a) where-  compare = compare `on` rangedThing--instance HasRange (Ranged a) where-  getRange = rangeOf--instance KillRange (Ranged a) where-  killRange (Ranged _ x) = Ranged noRange x--instance Decoration Ranged where-  traverseF f (Ranged r x) = Ranged r <$> f x---- | Ranges are not forced.--instance NFData a => NFData (Ranged a) where-  rnf (Ranged _ a) = rnf a-------------------------------------------------------------------------------- * Raw names (before parsing into name parts).-------------------------------------------------------------------------------- | A @RawName@ is some sort of string.-type RawName = String--rawNameToString :: RawName -> String-rawNameToString = id--stringToRawName :: String -> RawName-stringToRawName = id---- | String with range info.-type RString = Ranged RawName-------------------------------------------------------------------------------- * Further constructor and projection info-------------------------------------------------------------------------------- | Where does the 'ConP' or 'Con' come from?-data ConOrigin-  = ConOSystem  -- ^ Inserted by system or expanded from an implicit pattern.-  | ConOCon     -- ^ User wrote a constructor (pattern).-  | ConORec     -- ^ User wrote a record (pattern).-  | ConOSplit   -- ^ Generated by interactive case splitting.-  deriving (Data, Show, Eq, Ord, Enum, Bounded, Generic)--instance NFData ConOrigin--instance KillRange ConOrigin where-  killRange = id---- | Prefer user-written over system-inserted.-bestConInfo :: ConOrigin -> ConOrigin -> ConOrigin-bestConInfo ConOSystem o = o-bestConInfo o _ = o---- | Where does a projection come from?-data ProjOrigin-  = ProjPrefix    -- ^ User wrote a prefix projection.-  | ProjPostfix   -- ^ User wrote a postfix projection.-  | ProjSystem    -- ^ Projection was generated by the system.-  deriving (Data, Show, Eq, Ord, Enum, Bounded, Generic)--instance NFData ProjOrigin--instance KillRange ProjOrigin where-  killRange = id-------------------------------------------------------------------------------- * Infixity, access, abstract, etc.-------------------------------------------------------------------------------- | Functions can be defined in both infix and prefix style. See---   'Agda.Syntax.Concrete.LHS'.-data IsInfix = InfixDef | PrefixDef-    deriving (Data, Show, Eq, Ord)---- ** private blocks, public imports---- | Access modifier.-data Access-  = PrivateAccess Origin-      -- ^ Store the 'Origin' of the private block that lead to this qualifier.-      --   This is needed for more faithful printing of declarations.-  | PublicAccess-    deriving (Data, Show, Eq, Ord)--instance Pretty Access where-  pretty = text . \case-    PrivateAccess _ -> "private"-    PublicAccess    -> "public"--instance NFData Access where-  rnf _ = ()--instance HasRange Access where-  getRange _ = noRange--instance KillRange Access where-  killRange = id---- ** abstract blocks---- | Abstract or concrete.-data IsAbstract = AbstractDef | ConcreteDef-    deriving (Data, Show, Eq, Ord, Generic)---- | Semigroup computes if any of several is an 'AbstractDef'.-instance Semigroup IsAbstract where-  AbstractDef <> _ = AbstractDef-  ConcreteDef <> a = a---- | Default is 'ConcreteDef'.-instance Monoid IsAbstract where-  mempty  = ConcreteDef-  mappend = (<>)--instance KillRange IsAbstract where-  killRange = id--instance NFData IsAbstract--class LensIsAbstract a where-  lensIsAbstract :: Lens' IsAbstract a--instance LensIsAbstract IsAbstract where-  lensIsAbstract = id---- | Is any element of a collection an 'AbstractDef'.-class AnyIsAbstract a where-  anyIsAbstract :: a -> IsAbstract--  default anyIsAbstract :: (Foldable t, AnyIsAbstract b, t b ~ a) => a -> IsAbstract-  anyIsAbstract = Fold.foldMap anyIsAbstract--instance AnyIsAbstract IsAbstract where-  anyIsAbstract = id--instance AnyIsAbstract a => AnyIsAbstract [a] where-instance AnyIsAbstract a => AnyIsAbstract (Maybe a) where---- ** instance blocks---- | Is this definition eligible for instance search?-data IsInstance-  = InstanceDef Range  -- ^ Range of the @instance@ keyword.-  | NotInstanceDef-    deriving (Data, Show, Eq, Ord)--instance KillRange IsInstance where-  killRange = \case-    InstanceDef _    -> InstanceDef noRange-    i@NotInstanceDef -> i--instance HasRange IsInstance where-  getRange = \case-    InstanceDef r  -> r-    NotInstanceDef -> noRange--instance NFData IsInstance where-  rnf (InstanceDef _) = ()-  rnf NotInstanceDef  = ()---- ** macro blocks---- | Is this a macro definition?-data IsMacro = MacroDef | NotMacroDef-  deriving (Data, Show, Eq, Ord, Generic)--instance KillRange IsMacro where killRange = id-instance HasRange  IsMacro where getRange _ = noRange--instance NFData IsMacro-------------------------------------------------------------------------------- * NameId------------------------------------------------------------------------------newtype ModuleNameHash = ModuleNameHash Word64-  deriving (Eq, Ord, Show, Data)--noModuleNameHash :: ModuleNameHash-noModuleNameHash = ModuleNameHash 0---- | The unique identifier of a name. Second argument is the top-level module---   identifier.-data NameId = NameId {-# UNPACK #-} !Word64 {-# UNPACK #-} !ModuleNameHash-    deriving (Eq, Ord, Data, Generic, Show)--instance KillRange NameId where-  killRange = id--instance Pretty NameId where-  pretty (NameId n m) = text $ show n ++ "@" ++ show m--instance Enum NameId where-  succ (NameId n m)     = NameId (n + 1) m-  pred (NameId n m)     = NameId (n - 1) m-  toEnum n              = __IMPOSSIBLE__  -- should not be used-  fromEnum (NameId n _) = fromIntegral n--instance NFData NameId where-  rnf (NameId _ _) = ()--instance NFData ModuleNameHash where-  rnf _ = ()--instance Hashable NameId where-  {-# INLINE hashWithSalt #-}-  hashWithSalt salt (NameId n (ModuleNameHash m)) = hashWithSalt salt (n, m)-------------------------------------------------------------------------------- * Meta variables-------------------------------------------------------------------------------- | A meta variable identifier is just a natural number.----newtype MetaId = MetaId { metaId :: Nat }-    deriving (Eq, Ord, Num, Real, Enum, Integral, Data, Generic)--instance Pretty MetaId where-  pretty (MetaId n) = text $ "_" ++ show n---- | Show non-record version of this newtype.-instance Show MetaId where-  showsPrec p (MetaId n) = showParen (p > 0) $-    showString "MetaId " . shows n--instance NFData MetaId where-  rnf (MetaId x) = rnf x--instance Hashable MetaId--newtype Constr a = Constr a---------------------------------------------------------------------------------- * Problems---------------------------------------------------------------------------------- | A "problem" consists of a set of constraints and the same constraint can be part of multiple---   problems.-newtype ProblemId = ProblemId Nat-  deriving (Data, Eq, Ord, Enum, Real, Integral, Num, NFData)---- This particular Show instance is ok because of the Num instance.-instance Show   ProblemId where show   (ProblemId n) = show n-instance Pretty ProblemId where pretty (ProblemId n) = pretty n----------------------------------------------------------------------------- * Placeholders (used to parse sections)----------------------------------------------------------------------------- | The position of a name part or underscore in a name.--data PositionInName-  = Beginning-    -- ^ The following underscore is at the beginning of the name:-    -- @_foo@.-  | Middle-    -- ^ The following underscore is in the middle of the name:-    -- @foo_bar@.-  | End-    -- ^ The following underscore is at the end of the name: @foo_@.-  deriving (Show, Eq, Ord, Data)---- | Placeholders are used to represent the underscores in a section.--data MaybePlaceholder e-  = Placeholder !PositionInName-  | NoPlaceholder !(Strict.Maybe PositionInName) e-    -- ^ The second argument is used only (but not always) for name-    -- parts other than underscores.-  deriving (Data, Eq, Ord, Functor, Foldable, Traversable, Show)---- | An abbreviation: @noPlaceholder = 'NoPlaceholder'--- 'Strict.Nothing'@.--noPlaceholder :: e -> MaybePlaceholder e-noPlaceholder = NoPlaceholder Strict.Nothing--instance HasRange a => HasRange (MaybePlaceholder a) where-  getRange Placeholder{}       = noRange-  getRange (NoPlaceholder _ e) = getRange e--instance KillRange a => KillRange (MaybePlaceholder a) where-  killRange p@Placeholder{}     = p-  killRange (NoPlaceholder p e) = killRange1 (NoPlaceholder p) e--instance NFData a => NFData (MaybePlaceholder a) where-  rnf (Placeholder _)     = ()-  rnf (NoPlaceholder _ a) = rnf a-------------------------------------------------------------------------------- * Interaction meta variables------------------------------------------------------------------------------newtype InteractionId = InteractionId { interactionId :: Nat }-    deriving ( Eq-             , Ord-             , Show-             , Num-             , Integral-             , Real-             , Enum-             , Data-             , NFData-             )--instance Pretty InteractionId where-    pretty (InteractionId i) = text $ "?" ++ show i--instance KillRange InteractionId where killRange = id-------------------------------------------------------------------------------- * Fixity-------------------------------------------------------------------------------- | Precedence levels for operators.--type PrecedenceLevel = Double--data FixityLevel-  = Unrelated-    -- ^ No fixity declared.-  | Related !PrecedenceLevel-    -- ^ Fixity level declared as the number.-  deriving (Eq, Ord, Show, Data)--instance Null FixityLevel where-  null Unrelated = True-  null Related{} = False-  empty = Unrelated--instance NFData FixityLevel where-  rnf Unrelated   = ()-  rnf (Related _) = ()---- | Associativity.--data Associativity = NonAssoc | LeftAssoc | RightAssoc-   deriving (Eq, Ord, Show, Data)---- | Fixity of operators.--data Fixity = Fixity-  { fixityRange :: Range-    -- ^ Range of the whole fixity declaration.-  , fixityLevel :: !FixityLevel-  , fixityAssoc :: !Associativity-  }-  deriving (Data, Show)--noFixity :: Fixity-noFixity = Fixity noRange Unrelated NonAssoc--defaultFixity :: Fixity-defaultFixity = Fixity noRange (Related 20) NonAssoc---- For @instance Pretty Fixity@, see Agda.Syntax.Concrete.Pretty--instance Eq Fixity where-  f1 == f2 = compare f1 f2 == EQ--instance Ord Fixity where-  compare = compare `on` (fixityLevel &&& fixityAssoc)--instance Null Fixity where-  null  = null . fixityLevel-  empty = noFixity--instance HasRange Fixity where-  getRange = fixityRange--instance KillRange Fixity where-  killRange f = f { fixityRange = noRange }--instance NFData Fixity where-  rnf (Fixity _ _ _) = ()     -- Ranges are not forced, the other fields are strict.---- * Notation coupled with 'Fixity'---- | The notation is handled as the fixity in the renamer.---   Hence, they are grouped together in this type.-data Fixity' = Fixity'-    { theFixity   :: !Fixity-    , theNotation :: Notation-    , theNameRange :: Range-      -- ^ Range of the name in the fixity declaration-      --   (used for correct highlighting, see issue #2140).-    }-  deriving (Data, Show)--noFixity' :: Fixity'-noFixity' = Fixity' noFixity noNotation noRange--instance Eq Fixity' where-  Fixity' f n _ == Fixity' f' n' _ = f == f' && n == n'--instance Null Fixity' where-  null (Fixity' f n _) = null f && null n-  empty = noFixity'--instance NFData Fixity' where-  rnf (Fixity' _ a _) = rnf a--instance KillRange Fixity' where-  killRange (Fixity' f n r) = killRange3 Fixity' f n r---- lenses--_fixityAssoc :: Lens' Associativity Fixity-_fixityAssoc f r = f (fixityAssoc r) <&> \x -> r { fixityAssoc = x }--_fixityLevel :: Lens' FixityLevel Fixity-_fixityLevel f r = f (fixityLevel r) <&> \x -> r { fixityLevel = x }---- Lens focusing on Fixity--class LensFixity a where-  lensFixity :: Lens' Fixity a--instance LensFixity Fixity where-  lensFixity = id--instance LensFixity Fixity' where-  lensFixity f fix' = f (theFixity fix') <&> \ fx -> fix' { theFixity = fx }---- Lens focusing on Fixity'--class LensFixity' a where-  lensFixity' :: Lens' Fixity' a--instance LensFixity' Fixity' where-  lensFixity' = id------------------------------------------------------------------------------- * Import directive-------------------------------------------------------------------------------- | The things you are allowed to say when you shuffle names between name---   spaces (i.e. in @import@, @namespace@, or @open@ declarations).-data ImportDirective' n m = ImportDirective-  { importDirRange :: Range-  , using          :: Using' n m-  , hiding         :: HidingDirective' n m-  , impRenaming    :: RenamingDirective' n m-  , publicOpen     :: Maybe Range -- ^ Only for @open@. Exports the opened names from the current module.-  }-  deriving (Data, Eq)--type HidingDirective'   n m = [ImportedName' n m]-type RenamingDirective' n m = [Renaming' n m]---- | @null@ for import directives holds when everything is imported unchanged---   (no names are hidden or renamed).-instance Null (ImportDirective' n m) where-  null = \case-    ImportDirective _ UseEverything [] [] _ -> True-    _ -> False-  empty = defaultImportDir--instance (HasRange n, HasRange m) => Semigroup (ImportDirective' n m) where-  i1 <> i2 = ImportDirective-    { importDirRange = fuseRange i1 i2-    , using          = using i1 <> using i2-    , hiding         = hiding i1 ++ hiding i2-    , impRenaming    = impRenaming i1 ++ impRenaming i2-    , publicOpen     = publicOpen i1 <|> publicOpen i2-    }--instance (HasRange n, HasRange m) => Monoid (ImportDirective' n m) where-  mempty  = empty-  mappend = (<>)---- | Default is directive is @private@ (use everything, but do not export).-defaultImportDir :: ImportDirective' n m-defaultImportDir = ImportDirective noRange UseEverything [] [] Nothing---- | @isDefaultImportDir@ implies @null@, but not the other way round.-isDefaultImportDir :: ImportDirective' n m -> Bool-isDefaultImportDir dir = null dir && null (publicOpen dir)---- | The @using@ clause of import directive.-data Using' n m-  = UseEverything              -- ^ No @using@ clause given.-  | Using [ImportedName' n m]  -- ^ @using@ the specified names.-  deriving (Data, Eq)--instance Semigroup (Using' n m) where-  UseEverything <> u             = u-  u             <> UseEverything = u-  Using xs      <> Using ys      = Using (xs ++ ys)--instance Monoid (Using' n m) where-  mempty  = UseEverything-  mappend = (<>)--instance Null (Using' n m) where-  null UseEverything = True-  null Using{}       = False-  empty = mempty--mapUsing :: ([ImportedName' n1 m1] -> [ImportedName' n2 m2]) -> Using' n1 m1 -> Using' n2 m2-mapUsing f = \case-  UseEverything -> UseEverything-  Using xs      -> Using $ f xs---- | An imported name can be a module or a defined name.-data ImportedName' n m-  = ImportedModule  m  -- ^ Imported module name of type @m@.-  | ImportedName    n  -- ^ Imported name of type @n@.-  deriving (Data, Eq, Ord, Show)--fromImportedName :: ImportedName' a a -> a-fromImportedName = \case-  ImportedModule x -> x-  ImportedName   x -> x--setImportedName :: ImportedName' a a -> a -> ImportedName' a a-setImportedName (ImportedName   x) y = ImportedName   y-setImportedName (ImportedModule x) y = ImportedModule y---- | Like 'partitionEithers'.-partitionImportedNames :: [ImportedName' n m] -> ([n], [m])-partitionImportedNames = flip foldr ([], []) $ \case-  ImportedName   n -> first  (n:)-  ImportedModule m -> second (m:)---- -- Defined in Concrete.Pretty--- instance (Pretty n, Pretty m) => Pretty (ImportedName' n m) where---   pretty (ImportedModule x) = "module" <+> pretty x---   pretty (ImportedName   x) = pretty x---- instance (Show n, Show m) => Show (ImportedName' n m) where---   show (ImportedModule x) = "module " ++ show x---   show (ImportedName   x) = show x--data Renaming' n m = Renaming-  { renFrom    :: ImportedName' n m-    -- ^ Rename from this name.-  , renTo      :: ImportedName' n m-    -- ^ To this one.  Must be same kind as 'renFrom'.-  , renFixity  :: Maybe Fixity-    -- ^ New fixity of 'renTo' (optional).-  , renToRange :: Range-    -- ^ The range of the \"to\" keyword.  Retained for highlighting purposes.-  }-  deriving (Data, Eq)---- ** HasRange instances--instance (HasRange a, HasRange b) => HasRange (ImportDirective' a b) where-  getRange = importDirRange--instance (HasRange a, HasRange b) => HasRange (Using' a b) where-  getRange (Using  xs) = getRange xs-  getRange UseEverything = noRange--instance (HasRange a, HasRange b) => HasRange (Renaming' a b) where-  getRange r = getRange (renFrom r, renTo r)--instance (HasRange a, HasRange b) => HasRange (ImportedName' a b) where-  getRange (ImportedName   x) = getRange x-  getRange (ImportedModule x) = getRange x---- ** KillRange instances--instance (KillRange a, KillRange b) => KillRange (ImportDirective' a b) where-  killRange (ImportDirective _ u h r p) =-    killRange3 (\u h r -> ImportDirective noRange u h r p) u h r--instance (KillRange a, KillRange b) => KillRange (Using' a b) where-  killRange (Using  i) = killRange1 Using  i-  killRange UseEverything = UseEverything--instance (KillRange a, KillRange b) => KillRange (Renaming' a b) where-  killRange (Renaming i n mf _to) = killRange3 (\ i n mf -> Renaming i n mf noRange) i n mf--instance (KillRange a, KillRange b) => KillRange (ImportedName' a b) where-  killRange (ImportedModule n) = killRange1 ImportedModule n-  killRange (ImportedName   n) = killRange1 ImportedName   n---- ** NFData instances---- | Ranges are not forced.--instance (NFData a, NFData b) => NFData (ImportDirective' a b) where-  rnf (ImportDirective _ a b c _) = rnf a `seq` rnf b `seq` rnf c--instance (NFData a, NFData b) => NFData (Using' a b) where-  rnf UseEverything = ()-  rnf (Using a)     = rnf a---- | Ranges are not forced.--instance (NFData a, NFData b) => NFData (Renaming' a b) where-  rnf (Renaming a b c _) = rnf a `seq` rnf b `seq` rnf c--instance (NFData a, NFData b) => NFData (ImportedName' a b) where-  rnf (ImportedModule a) = rnf a-  rnf (ImportedName a)   = rnf a---------------------------------------------------------------------------------- * Termination---------------------------------------------------------------------------------- | Termination check? (Default = TerminationCheck).-data TerminationCheck m-  = TerminationCheck-    -- ^ Run the termination checker.-  | NoTerminationCheck-    -- ^ Skip termination checking (unsafe).-  | NonTerminating-    -- ^ Treat as non-terminating.-  | Terminating-    -- ^ Treat as terminating (unsafe).  Same effect as 'NoTerminationCheck'.-  | TerminationMeasure Range m-    -- ^ Skip termination checking but use measure instead.-    deriving (Data, Show, Eq, Functor)--instance KillRange m => KillRange (TerminationCheck m) where-  killRange (TerminationMeasure _ m) = TerminationMeasure noRange (killRange m)-  killRange t                        = t--instance NFData a => NFData (TerminationCheck a) where-  rnf TerminationCheck         = ()-  rnf NoTerminationCheck       = ()-  rnf NonTerminating           = ()-  rnf Terminating              = ()-  rnf (TerminationMeasure _ a) = rnf a---------------------------------------------------------------------------------- * Positivity---------------------------------------------------------------------------------- | Positivity check? (Default = True).-data PositivityCheck = YesPositivityCheck | NoPositivityCheck-  deriving (Eq, Ord, Show, Bounded, Enum, Data, Generic)--instance KillRange PositivityCheck where-  killRange = id---- Semigroup and Monoid via conjunction-instance Semigroup PositivityCheck where-  NoPositivityCheck <> _ = NoPositivityCheck-  _ <> NoPositivityCheck = NoPositivityCheck-  _ <> _ = YesPositivityCheck--instance Monoid PositivityCheck where-  mempty  = YesPositivityCheck-  mappend = (<>)--instance NFData PositivityCheck---------------------------------------------------------------------------------- * Universe checking---------------------------------------------------------------------------------- | Universe check? (Default is yes).-data UniverseCheck = YesUniverseCheck | NoUniverseCheck-  deriving (Eq, Ord, Show, Bounded, Enum, Data, Generic)--instance KillRange UniverseCheck where-  killRange = id--instance NFData UniverseCheck---------------------------------------------------------------------------------- * Universe checking---------------------------------------------------------------------------------- | Coverage check? (Default is yes).-data CoverageCheck = YesCoverageCheck | NoCoverageCheck-  deriving (Eq, Ord, Show, Bounded, Enum, Data, Generic)--instance KillRange CoverageCheck where-  killRange = id---- Semigroup and Monoid via conjunction-instance Semigroup CoverageCheck where-  NoCoverageCheck <> _ = NoCoverageCheck-  _ <> NoCoverageCheck = NoCoverageCheck-  _ <> _ = YesCoverageCheck--instance Monoid CoverageCheck where-  mempty  = YesCoverageCheck-  mappend = (<>)--instance NFData CoverageCheck---------------------------------------------------------------------------------- * Rewrite Directives on the LHS---------------------------------------------------------------------------------- | @RewriteEqn' qn p e@ represents the @rewrite@ and irrefutable @with@---   clauses of the LHS.---   @qn@ stands for the QName of the auxiliary function generated to implement the feature---   @nm@ is the type of names for pattern variables---   @p@  is the type of patterns---   @e@  is the type of expressions--data RewriteEqn' qn nm p e-  = Rewrite (List1 (qn, e))             -- ^ @rewrite e@-  | Invert qn (List1 (Named nm (p, e))) -- ^ @with p <- e in eq@-  deriving (Data, Eq, Show, Functor, Foldable, Traversable)--instance (NFData qn, NFData nm, NFData p, NFData e) => NFData (RewriteEqn' qn nm p e) where-  rnf = \case-    Rewrite es    -> rnf es-    Invert qn pes -> rnf (qn, pes)--instance (Pretty nm, Pretty p, Pretty e) => Pretty (RewriteEqn' qn nm p e) where-  pretty = \case-    Rewrite es   -> prefixedThings (text "rewrite") $ List1.toList (pretty . snd <$> es)-    Invert _ pes -> prefixedThings (text "invert") $ List1.toList (namedWith <$> pes) where--      namedWith (Named nm (p, e)) =-        let patexp = pretty p <+> "<-" <+> pretty e in-        case nm of-          Nothing -> patexp-          Just nm -> pretty nm <+> ":" <+> patexp--instance (HasRange qn, HasRange nm, HasRange p, HasRange e) => HasRange (RewriteEqn' qn nm p e) where-  getRange = \case-    Rewrite es    -> getRange es-    Invert qn pes -> getRange (qn, pes)--instance (KillRange qn, KillRange nm, KillRange e, KillRange p) => KillRange (RewriteEqn' qn nm p e) where-  killRange = \case-    Rewrite es    -> killRange1 Rewrite es-    Invert qn pes -> killRange2 Invert qn pes---------------------------------------------------------------------------------- * Information on expanded ellipsis (@...@)---------------------------------------------------------------------------------- ^ When the ellipsis in a clause is expanded, we remember that we---   did so. We also store the number of with-arguments that are---   included in the expanded ellipsis.-data ExpandedEllipsis-  = ExpandedEllipsis-  { ellipsisRange :: Range-  , ellipsisWithArgs :: Int-  }-  | NoEllipsis-  deriving (Data, Show, Eq)--instance Null ExpandedEllipsis where-  null  = (== NoEllipsis)-  empty = NoEllipsis--instance Semigroup ExpandedEllipsis where-  NoEllipsis <> e          = e-  e          <> NoEllipsis = e-  (ExpandedEllipsis r1 k1) <> (ExpandedEllipsis r2 k2) = ExpandedEllipsis (r1 <> r2) (k1 + k2)--instance Monoid ExpandedEllipsis where-  mempty  = NoEllipsis-  mappend = (<>)--instance KillRange ExpandedEllipsis where-  killRange (ExpandedEllipsis _ k) = ExpandedEllipsis noRange k-  killRange NoEllipsis             = NoEllipsis--instance NFData ExpandedEllipsis where-  rnf (ExpandedEllipsis _ a) = rnf a-  rnf NoEllipsis             = ()---- | Notation as provided by the @syntax@ declaration.-type Notation = [GenPart]--noNotation :: Notation-noNotation = []---- | Part of a Notation-data GenPart-  = BindHole Range (Ranged Int)-    -- ^ Argument is the position of the hole (with binding) where the binding should occur.-    --   First range is the rhs range and second is the binder.-  | NormalHole Range (NamedArg (Ranged Int))-    -- ^ Argument is where the expression should go.-  | WildHole (Ranged Int)-    -- ^ An underscore in binding position.-  | IdPart RString-  deriving (Data, Show)--instance Eq GenPart where-  BindHole _ i   == BindHole _ j   = i == j-  NormalHole _ x == NormalHole _ y = x == y-  WildHole i     == WildHole j     = i == j-  IdPart x       == IdPart y       = x == y-  _              == _              = False--instance Ord GenPart where-  BindHole _ i   `compare` BindHole _ j   = i `compare` j-  NormalHole _ x `compare` NormalHole _ y = x `compare` y-  WildHole i     `compare` WildHole j     = i `compare` j-  IdPart x       `compare` IdPart y       = x `compare` y-  BindHole{}     `compare` _              = LT-  _              `compare` BindHole{}     = GT-  NormalHole{}   `compare` _              = LT-  _              `compare` NormalHole{}   = GT-  WildHole{}     `compare` _              = LT-  _              `compare` WildHole{}     = GT--instance HasRange GenPart where-  getRange = \case-    IdPart x       -> getRange x-    BindHole r _   -> r-    WildHole i     -> getRange i-    NormalHole r _ -> r--instance SetRange GenPart where-  setRange r = \case-    IdPart x       -> IdPart x-    BindHole _ i   -> BindHole r i-    WildHole i     -> WildHole i-    NormalHole _ i -> NormalHole r i--instance KillRange GenPart where-  killRange = \case-    IdPart x       -> IdPart $ killRange x-    BindHole _ i   -> BindHole noRange $ killRange i-    WildHole i     -> WildHole $ killRange i-    NormalHole _ x -> NormalHole noRange $ killRange x--instance NFData GenPart where-  rnf (BindHole _ a)   = rnf a-  rnf (NormalHole _ a) = rnf a-  rnf (WildHole a)     = rnf a-  rnf (IdPart a)       = rnf a+{-| Some common syntactic entities are defined in this module.+-}+module Agda.Syntax.Common+  ( module Agda.Syntax.Common+  , module Agda.Syntax.Common.KeywordRange+  , module Agda.Syntax.TopLevelModuleName.Boot+  , Induction(..)+  )+  where++import Agda.Syntax.TopLevelModuleName.Boot++import Prelude hiding (null)++import Control.DeepSeq+import Control.Arrow ((&&&))+import Control.Applicative ((<|>), liftA2)++import Data.Bifunctor+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as ByteString+import qualified Data.Foldable as Fold+import Data.Function (on)+import Data.Hashable (Hashable(..))+import qualified Data.Strict.Maybe as Strict+import Data.Word+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import Data.Text (Text)++import GHC.Generics (Generic)++import Agda.Syntax.Common.Aspect (Induction(..))+import Agda.Syntax.Common.KeywordRange+import Agda.Syntax.Common.Pretty+import Agda.Syntax.Concrete.Glyph+import Agda.Syntax.Position++import Agda.Utils.BiMap (HasTag(..))+import Agda.Utils.Boolean (Boolean(fromBool), IsBool(toBool))+import Agda.Utils.Float (toStringWithoutDotZero)+import Agda.Utils.Functor+import Agda.Utils.Lens+import Agda.Utils.List  ( lastMaybe )+import Agda.Utils.List1  ( List1, pattern (:|), (<|) )+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Maybe+import Agda.Utils.Null+import Agda.Utils.PartialOrd+import Agda.Utils.POMonoid++import Agda.Utils.Impossible++-- | Number @>= 0@.+type Nat    = Int+type Arity  = Nat++-- | Number @>= 1@.+type Nat1   = Nat++---------------------------------------------------------------------------+-- * IsMain+---------------------------------------------------------------------------++data IsMain = IsMain | NotMain+  deriving (Eq, Show)++-- | Conjunctive semigroup ('NotMain' is absorbing).+instance Semigroup IsMain where+  NotMain <> _ = NotMain+  _       <> NotMain = NotMain+  IsMain  <> IsMain = IsMain++instance Monoid IsMain where+  mempty = IsMain+  mappend = (<>)++---------------------------------------------------------------------------+-- * File+---------------------------------------------------------------------------++data FileType = AgdaFileType | MdFileType | RstFileType | TexFileType | OrgFileType | TypstFileType | TreeFileType+  deriving (Eq, Ord, Show, Generic)++instance Pretty FileType where+  pretty = \case+    AgdaFileType -> "Agda"+    MdFileType   -> "Markdown"+    RstFileType  -> "ReStructedText"+    TexFileType  -> "LaTeX"+    OrgFileType  -> "org-mode"+    TypstFileType -> "Typst"+    TreeFileType -> "Forester"++instance NFData FileType++---------------------------------------------------------------------------+-- * Agda variants+---------------------------------------------------------------------------++-- | Variants of Cubical Agda.++data Cubical = CErased | CFull+    deriving (Eq, Show, Generic)++instance NFData Cubical++cubicalOptionString :: Cubical -> String+cubicalOptionString = \case+  CErased -> "--erased-cubical"+  CFull   -> "--cubical"++-- | Agda variants.+--+-- Only some variants are tracked.++data Language+  = WithoutK+  | WithK+  | Cubical Cubical+    deriving (Eq, Show, Generic)++instance KillRange Language where+  killRange = id++instance NFData Language++---------------------------------------------------------------------------+-- * Backends+---------------------------------------------------------------------------++type BackendName = Text++---------------------------------------------------------------------------+-- * Some enums+---------------------------------------------------------------------------++-- | Distinguish constructors from pattern synonyms.++data ConstructorOrPatternSynonym = IsConstructor | IsPatternSynonym+  deriving (Show, Generic, Enum, Bounded)++instance Pretty ConstructorOrPatternSynonym where+  pretty = \case+    IsConstructor    -> "constructor"+    IsPatternSynonym -> "pattern synonym"++instance NFData ConstructorOrPatternSynonym++-- | Distinguish parsing a DISPLAY pragma from an ordinary left hand side.++data DisplayLHS = YesDisplayLHS | NoDisplayLHS+  deriving (Eq, Show, Generic, Enum, Bounded)++instance Boolean DisplayLHS where+  fromBool = \case+    True -> YesDisplayLHS+    False -> NoDisplayLHS++instance IsBool DisplayLHS where+  toBool = \case+    YesDisplayLHS -> True+    NoDisplayLHS -> False++-- | Expression kinds: Expressions or patterns.++data ExprKind = IsExpr | IsPattern+  deriving (Eq, Show)++---------------------------------------------------------------------------+-- * Record Directives+---------------------------------------------------------------------------++data RecordDirectives' a = RecordDirectives+  { recInductive   :: Maybe (Ranged Induction)+  , recHasEta      :: Maybe (Ranged HasEta0)+  , recPattern     :: Maybe Range+  , recConstructor :: a+  } deriving (Functor, Show, Eq, Foldable, Traversable)++instance Null a => Null (RecordDirectives' a) where+  empty = emptyRecordDirectives+  null (RecordDirectives a b c d) = and [null a, null b, null c, null d]++emptyRecordDirectives :: Null a => RecordDirectives' a+emptyRecordDirectives = RecordDirectives empty empty empty empty++instance HasRange a => HasRange (RecordDirectives' a) where+  getRange (RecordDirectives a b c d) = getRange (a,b,c,d)++instance KillRange a => KillRange (RecordDirectives' a) where+  killRange (RecordDirectives a b c d) = killRangeN RecordDirectives a b c d++instance NFData a => NFData (RecordDirectives' a) where+  rnf (RecordDirectives a b c d) = c `seq` rnf (a, b, d)++---------------------------------------------------------------------------+-- * Eta-equality+---------------------------------------------------------------------------++-- | Does a record come with eta-equality?+data HasEta' a+  = YesEta+  | NoEta a+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)++instance HasRange a => HasRange (HasEta' a) where+  getRange = foldMap getRange++instance KillRange a => KillRange (HasEta' a) where+  killRange = fmap killRange++instance NFData a => NFData (HasEta' a) where+  rnf YesEta    = ()+  rnf (NoEta p) = rnf p++-- | Pattern and copattern matching is allowed in the presence of eta.+--+--   In the absence of eta, we have to choose whether we want to allow+--   matching on the constructor or copattern matching with the projections.+--   Having both leads to breakage of subject reduction (issue #4560).++type HasEta  = HasEta' PatternOrCopattern+type HasEta0 = HasEta' ()++-- | For a record without eta, which type of matching do we allow?+data PatternOrCopattern+  = PatternMatching+      -- ^ Can match on the record constructor.+  | CopatternMatching+      -- ^ Can copattern match using the projections. (Default.)+  deriving (Show, Eq, Ord, Enum, Bounded)++instance NFData PatternOrCopattern where+  rnf PatternMatching   = ()+  rnf CopatternMatching = ()++instance HasRange PatternOrCopattern where+  getRange _ = noRange++instance KillRange PatternOrCopattern where+  killRange = id++-- | Can we pattern match on the record constructor?+class PatternMatchingAllowed a where+  patternMatchingAllowed :: a -> Bool++instance PatternMatchingAllowed PatternOrCopattern where+  patternMatchingAllowed = (== PatternMatching)++instance PatternMatchingAllowed HasEta where+  patternMatchingAllowed = \case+    YesEta -> True+    NoEta p -> patternMatchingAllowed p+++-- | Can we construct a record by copattern matching?+class CopatternMatchingAllowed a where+  copatternMatchingAllowed :: a -> Bool++instance CopatternMatchingAllowed PatternOrCopattern where+  copatternMatchingAllowed = (== CopatternMatching)++instance CopatternMatchingAllowed HasEta where+  copatternMatchingAllowed = \case+    YesEta -> True+    NoEta p -> copatternMatchingAllowed p++---------------------------------------------------------------------------+-- * Induction+---------------------------------------------------------------------------++instance Pretty Induction where+  pretty Inductive   = "inductive"+  pretty CoInductive = "coinductive"++instance HasRange Induction where+  getRange _ = noRange++instance KillRange Induction where+  killRange = id++instance PatternMatchingAllowed Induction where+  patternMatchingAllowed = (== Inductive)++---------------------------------------------------------------------------+-- * Overlapping instances+---------------------------------------------------------------------------++data Overlappable = YesOverlap | NoOverlap+  deriving (Show, Eq, Ord)++-- | Just for the 'Hiding' instance. Should never combine different+--   overlapping.+instance Semigroup Overlappable where+  NoOverlap  <> NoOverlap  = NoOverlap+  YesOverlap <> YesOverlap = YesOverlap+  _          <> _          = __IMPOSSIBLE__++instance Monoid Overlappable where+  mempty  = NoOverlap+  mappend = (<>)++instance NFData Overlappable where+  rnf NoOverlap  = ()+  rnf YesOverlap = ()++-- | The possible overlap modes for an instance, also used for instance candidates.+data OverlapMode+  = Overlappable+  -- ^ User-written OVERLAPPABLE pragma: this candidate can *be removed*+  -- by a more specific candidate.++  | Overlapping+  -- ^ User-written OVERLAPPING pragma: this candidate can *remove* a+  -- less specific candidate.++  | Overlaps+  -- ^ User-written OVERLAPS pragma: both overlappable and overlapping.++  | DefaultOverlap+  -- ^ No user-written overlap pragma. This instance can be overlapped+  -- by an OVERLAPPING instance, and it can overlap OVERLAPPABLE+  -- instances.++  | Incoherent+  -- ^ User-written INCOHERENT pragma: both overlappable and+  -- overlapping; and, if there are multiple candidates after all+  -- overlap has been handled, make an arbitrary choice.++  | FieldOverlap+  -- ^ Overlapping instances in record fields.+  deriving (Show, Eq, Ord, Enum, Bounded)++instance Pretty OverlapMode where+  pretty = \case+    Overlappable   -> "OVERLAPPABLE"+    Overlapping    -> "OVERLAPPING"+    Incoherent     -> "INCOHERENT"+    Overlaps       -> "OVERLAPS"+    FieldOverlap   -> "overlap"+    DefaultOverlap -> empty++instance KillRange OverlapMode where+  killRange = id++instance NFData OverlapMode where+  rnf = \case+    Overlappable   -> ()+    Overlapping    -> ()+    Overlaps       -> ()+    DefaultOverlap -> ()+    FieldOverlap   -> ()+    Incoherent     -> ()++class HasOverlapMode a where+  lensOverlapMode :: Lens' a OverlapMode++instance HasOverlapMode OverlapMode where+  lensOverlapMode = id++isIncoherent, isOverlappable, isOverlapping :: HasOverlapMode a => a -> Bool+isIncoherent x = case x ^. lensOverlapMode of+  Incoherent -> True+  _          -> False++isOverlappable x = case x ^. lensOverlapMode of+  Overlappable -> True+  Incoherent   -> True+  Overlaps     -> True+  _            -> False++isOverlapping x = case x ^. lensOverlapMode of+  Overlapping -> True+  Incoherent  -> True+  Overlaps    -> True+  _           -> False++---------------------------------------------------------------------------+-- * Hiding+---------------------------------------------------------------------------++data Hiding  = Hidden | Instance Overlappable | NotHidden+  deriving (Show, Eq, Ord)++instance Pretty Hiding where+  pretty = text . hidingToString++hidingToString :: Hiding -> String+hidingToString = \case+  Hidden     -> "hidden"+  NotHidden  -> "visible"+  Instance{} -> "instance"++instance Null Hiding where+  empty = NotHidden++-- | 'Hiding' is an idempotent partial monoid, with unit 'NotHidden'.+--   'Instance' and 'NotHidden' are incompatible.+instance Semigroup Hiding where+  NotHidden  <> h           = h+  h          <> NotHidden   = h+  Hidden     <> Hidden      = Hidden+  Instance o <> Instance o' = Instance (o <> o')+  _          <> _           = __IMPOSSIBLE__++instance Monoid Hiding where+  mempty = empty+  mappend = (<>)++instance HasRange Hiding where+  getRange _ = noRange++instance KillRange Hiding where+  killRange = id++instance NFData Hiding where+  rnf Hidden       = ()+  rnf (Instance o) = rnf o+  rnf NotHidden    = ()++-- | Decorating something with 'Hiding' information.+data WithHiding a = WithHiding+  { whHiding :: !Hiding+  , whThing  :: a+  }+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++instance Decoration WithHiding where+  traverseF f (WithHiding h a) = WithHiding h <$> f a++instance Applicative WithHiding where+  pure = WithHiding mempty+  WithHiding h f <*> WithHiding h' a = WithHiding (mappend h h') (f a)++instance HasRange a => HasRange (WithHiding a) where+  getRange = getRange . dget++instance SetRange a => SetRange (WithHiding a) where+  setRange = fmap . setRange++instance KillRange a => KillRange (WithHiding a) where+  killRange = fmap killRange++instance NFData a => NFData (WithHiding a) where+  rnf (WithHiding _ a) = rnf a++-- | A lens to access the 'Hiding' attribute in data structures.+--   Minimal implementation: @getHiding@ and @mapHiding@ or @LensArgInfo@.+class LensHiding a where++  getHiding :: a -> Hiding++  setHiding :: Hiding -> a -> a+  setHiding h = mapHiding (const h)++  mapHiding :: (Hiding -> Hiding) -> a -> a++  default getHiding :: LensArgInfo a => a -> Hiding+  getHiding = argInfoHiding . getArgInfo++  default mapHiding :: LensArgInfo a => (Hiding -> Hiding) -> a -> a+  mapHiding f = mapArgInfo $ \ ai -> ai { argInfoHiding = f $ argInfoHiding ai }++instance LensHiding Hiding where+  getHiding = id+  setHiding = const+  mapHiding = id++instance LensHiding (WithHiding a) where+  getHiding   (WithHiding h _) = h+  setHiding h (WithHiding _ a) = WithHiding h a+  mapHiding f (WithHiding h a) = WithHiding (f h) a++instance LensHiding a => LensHiding (Named nm a) where+  getHiding = getHiding . namedThing+  setHiding = fmap . setHiding+  mapHiding = fmap . mapHiding++-- | Monoidal composition of 'Hiding' information in some data.+mergeHiding :: LensHiding a => WithHiding a -> a+mergeHiding (WithHiding h a) = mapHiding (mappend h) a++-- | 'NotHidden' arguments are @visible@.+visible :: LensHiding a => a -> Bool+visible a = getHiding a == NotHidden++-- | 'Instance' and 'Hidden' arguments are @notVisible@.+notVisible :: LensHiding a => a -> Bool+notVisible a = getHiding a /= NotHidden++-- | 'Hidden' arguments are @hidden@.+hidden :: LensHiding a => a -> Bool+hidden a = getHiding a == Hidden++hide :: LensHiding a => a -> a+hide = setHiding Hidden++hideOrKeepInstance :: LensHiding a => a -> a+hideOrKeepInstance x =+  case getHiding x of+    Hidden     -> x+    Instance{} -> x+    NotHidden  -> setHiding Hidden x++makeInstance :: LensHiding a => a -> a+makeInstance = makeInstance' NoOverlap++makeInstance' :: LensHiding a => Overlappable -> a -> a+makeInstance' o = setHiding (Instance o)++isYesOverlap :: LensHiding a => a -> Bool+isYesOverlap x =+  case getHiding x of+    Instance YesOverlap -> True+    _ -> False++isInstance :: LensHiding a => a -> Bool+isInstance x =+  case getHiding x of+    Instance{} -> True+    _          -> False++-- | Ignores 'Overlappable'.+sameHiding :: (LensHiding a, LensHiding b) => a -> b -> Bool+sameHiding x y =+  case (getHiding x, getHiding y) of+    (Instance{}, Instance{}) -> True+    (hx, hy)                 -> hx == hy++-- | @prettyHiding info visible doc@ puts the correct braces+--   around @doc@ according to info @info@ and returns+--   @visible doc@ if the we deal with a visible thing.+prettyHiding :: LensHiding a => a -> (Doc -> Doc) -> Doc -> Doc+prettyHiding a parens =+  case getHiding a of+    Hidden     -> braces'+    Instance{} -> dbraces+    NotHidden  -> parens++instance Pretty a => Pretty (WithHiding a) where+  pretty w = prettyHiding w id $ pretty $ dget w++---------------------------------------------------------------------------+-- * Modalities+---------------------------------------------------------------------------++-- | Type wrapper to indicate additive monoid/semigroup context.+newtype UnderAddition t = UnderAddition t deriving (Show, Functor, Eq, Ord, PartialOrd)++instance Applicative UnderAddition where+  pure = UnderAddition+  (<*>) (UnderAddition f) (UnderAddition a) = pure (f a)++-- | Type wrapper to indicate composition or multiplicative monoid/semigroup context.+newtype UnderComposition t = UnderComposition t deriving (Show, Functor, Eq, Ord, PartialOrd)++instance Applicative UnderComposition where+  pure = UnderComposition+  (<*>) (UnderComposition f) (UnderComposition a) = pure (f a)++-- | We have a tuple of modalities, which might not be fully orthogonal.+--   For example, irrelevant stuff is also run-time irrelevant.+data Modality = Modality+  { modRelevance :: Relevance+      -- ^ Legacy irrelevance.+      --   See Pfenning, LiCS 2001; Abel, Vezzosi and Winterhalter, ICFP 2017.+  , modQuantity  :: Quantity+      -- ^ Cardinality / runtime erasure.+      --   See Conor McBride, I got plenty o' nutting, Wadlerfest 2016.+      --   See Bob Atkey, Syntax and Semantics of Quantitative Type Theory, LiCS 2018.+  , modCohesion :: Cohesion+      -- ^ Cohesion/what was in Agda-flat.+      --   see "Brouwer's fixed-point theorem in real-cohesive homotopy type theory" (arXiv:1509.07584)+      --   Currently only the comonad is implemented.+  , modPolarity :: PolarityModality+      -- ^ Polarity annotations (strictly positive, ...)+  } deriving (Eq, Ord, Show, Generic)++-- | Dominance ordering.+instance PartialOrd Modality where+  comparable (Modality r q c p) (Modality r' q' c' p') = comparable (r, (q, (c, p))) (r', (q', (c', p')))++-- | Pointwise composition.+instance Semigroup (UnderComposition Modality) where+  (<>) = liftA2 composeModality++-- | Pointwise composition unit.+instance Monoid (UnderComposition Modality) where+  mempty  = pure unitModality+  mappend = (<>)++instance POSemigroup (UnderComposition Modality) where+instance POMonoid (UnderComposition Modality) where++instance LeftClosedPOMonoid (UnderComposition Modality) where+  inverseCompose = liftA2 inverseComposeModality++-- | Pointwise addition.+instance Semigroup (UnderAddition Modality) where+  (<>) = liftA2 addModality++-- | Pointwise additive unit.+instance Monoid (UnderAddition Modality) where+  mempty  = pure zeroModality+  mappend = (<>)++instance POSemigroup (UnderAddition Modality) where+instance POMonoid (UnderAddition Modality) where++instance Pretty Modality where+  pretty (Modality r q c p) = hsep+    [ pretty r+    , pretty q+    , pretty c+    , pretty p+    ]++-- | @m `moreUsableModality` m'@ means that an @m@ can be used+--   where ever an @m'@ is required.++moreUsableModality :: Modality -> Modality -> Bool+moreUsableModality m m' = related m POLE m'++usableModality :: LensModality a => a -> Bool+usableModality a = usableRelevance m && usableQuantity m && usableCohesion m && usablePolarity m+  where m = getModality a++-- | Multiplicative monoid (standard monoid).+composeModality :: Modality -> Modality -> Modality+composeModality (Modality r q c p) (Modality r' q' c' p') =+    Modality (r `composeRelevance` r')+             (q `composeQuantity` q')+             (c `composeCohesion` c')+             (p `composePolarity` p')++-- | Compose with modality flag from the left.+--   This function is e.g. used to update the modality information+--   on pattern variables @a@ after a match against something of modality @q@.+applyModality :: LensModality a => Modality -> a -> a+applyModality m = mapModality (m `composeModality`)++-- | @inverseComposeModality r x@ returns the least modality @y@+--   such that forall @x@, @y@ we have+--   @x \`moreUsableModality\` (r \`composeModality\` y)@+--   iff+--   @(r \`inverseComposeModality\` x) \`moreUsableModality\` y@ (Galois connection).+inverseComposeModality :: Modality -> Modality -> Modality+inverseComposeModality (Modality r q c p) (Modality r' q' c' p') =+  Modality (r `inverseComposeRelevance` r')+           (q `inverseComposeQuantity`  q')+           (c `inverseComposeCohesion`  c')+           (p `inverseComposePolarity`  p')++-- | Left division by a 'Modality'.+--   Used e.g. to modify context when going into a @m@ argument.+--+-- Note that this function does not change quantities.+inverseApplyModalityButNotQuantity :: LensModality a => Modality -> a -> a+inverseApplyModalityButNotQuantity m =+  mapModality (m' `inverseComposeModality`)+  where+  m' = setQuantity (Quantity1 Q1Inferred) m++-- | 'Modality' forms a pointwise additive monoid.+addModality :: Modality -> Modality -> Modality+addModality (Modality r q c p) (Modality r' q' c' p') =+  Modality (addRelevance r r')+           (addQuantity  q q')+           (addCohesion  c c')+           (addPolarity  p p')++-- | Identity under addition+zeroModality :: Modality+zeroModality = Modality zeroRelevance zeroQuantity zeroCohesion zeroPolarity++-- | Identity under composition+unitModality :: Modality+unitModality = Modality unitRelevance unitQuantity unitCohesion unitPolarity++-- | Absorptive element under addition.+topModality :: Modality+topModality = Modality topRelevance topQuantity topCohesion topPolarity++-- | The default Modality+--   Beware that this is neither the additive unit nor the unit under+--   composition, because the default quantity is ω.+defaultModality :: Modality+defaultModality = Modality defaultRelevance defaultQuantity defaultCohesion defaultPolarity++-- | The default Modality terms are checked against.+defaultCheckModality :: Modality+defaultCheckModality = defaultModality { modPolarity = withStandardLock StrictlyPositive }++-- | Extract the positional modality component for checks regarding only them.+positionalModalityComponent :: Modality -> Modality+positionalModalityComponent m =+  defaultModality {modCohesion = modCohesion m}++-- | Equality ignoring origin.++sameModality :: (LensModality a, LensModality b) => a -> b -> Bool+sameModality x y = case (getModality x , getModality y) of+  (Modality r q c p , Modality r' q' c' p') -> sameRelevance r r' && sameQuantity q q' && sameCohesion c c' && samePolarity p p'++instance Null Modality where+  empty = defaultModality+  null (Modality r q c p) = and [ null r, null q, null c, null p ]++-- boilerplate instances++instance HasRange Modality where+  getRange (Modality r q c p) = getRange (r, q, c, p)++instance KillRange Modality where+  killRange (Modality r q c p) = killRangeN Modality r q c p++instance NFData Modality where++-- Lens stuff++lModRelevance :: Lens' Modality Relevance+lModRelevance f m = f (modRelevance m) <&> \ r -> m { modRelevance = r }++lModQuantity :: Lens' Modality Quantity+lModQuantity f m = f (modQuantity m) <&> \ q -> m { modQuantity = q }++lModCohesion :: Lens' Modality Cohesion+lModCohesion f m = f (modCohesion m) <&> \ q -> m { modCohesion = q }++lModPolarity :: Lens' Modality PolarityModality+lModPolarity f m = f (modPolarity m) <&> \ p -> m { modPolarity = p }++class LensModality a where++  getModality :: a -> Modality++  setModality :: Modality -> a -> a+  setModality = mapModality . const++  mapModality :: (Modality -> Modality) -> a -> a++  default getModality :: LensArgInfo a => a -> Modality+  getModality = argInfoModality . getArgInfo++  default mapModality :: LensArgInfo a => (Modality -> Modality) -> a -> a+  mapModality f = mapArgInfo $ \ ai -> ai { argInfoModality = f $ argInfoModality ai }++instance LensModality Modality where+  getModality = id+  setModality = const+  mapModality = id++instance LensRelevance Modality where+  getRelevance = modRelevance+  setRelevance h m = m { modRelevance = h }+  mapRelevance f m = m { modRelevance = f (modRelevance m) }++instance LensQuantity Modality where+  getQuantity = modQuantity+  setQuantity h m = m { modQuantity = h }+  mapQuantity f m = m { modQuantity = f (modQuantity m) }++instance LensCohesion Modality where+  getCohesion = modCohesion+  setCohesion h m = m { modCohesion = h }+  mapCohesion f m = m { modCohesion = f (modCohesion m) }++instance LensModalPolarity Modality where+  getModalPolarity = modPolarity+  setModalPolarity h m = m { modPolarity = h }+  mapModalPolarity f m = m { modPolarity = f (modPolarity m) }++-- default accessors for Relevance++getRelevanceMod :: LensModality a => LensGet a Relevance+getRelevanceMod = getRelevance . getModality++setRelevanceMod :: LensModality a => LensSet a Relevance+setRelevanceMod = mapModality . setRelevance++mapRelevanceMod :: LensModality a => LensMap a Relevance+mapRelevanceMod = mapModality . mapRelevance++-- default accessors for Quantity++getQuantityMod :: LensModality a => LensGet a Quantity+getQuantityMod = getQuantity . getModality++setQuantityMod :: LensModality a => LensSet a Quantity+setQuantityMod = mapModality . setQuantity++mapQuantityMod :: LensModality a => LensMap a Quantity+mapQuantityMod = mapModality . mapQuantity++-- default accessors for Cohesion++getCohesionMod :: LensModality a => LensGet a Cohesion+getCohesionMod = getCohesion . getModality++setCohesionMod :: LensModality a => LensSet a Cohesion+setCohesionMod = mapModality . setCohesion++mapCohesionMod :: LensModality a => LensMap a Cohesion+mapCohesionMod = mapModality . mapCohesion++-- default accessors for Polarity++getPolarityMod :: LensModality a => LensGet a PolarityModality+getPolarityMod = getModalPolarity . getModality++setPolarityMod :: LensModality a => LensSet a PolarityModality+setPolarityMod = mapModality . setModalPolarity++mapPolarityMod :: LensModality a => LensMap a PolarityModality+mapPolarityMod = mapModality . mapModalPolarity++---------------------------------------------------------------------------+-- * Quantities+---------------------------------------------------------------------------++-- ** Quantity origin.++-- | Origin of 'Quantity0'.+data Q0Origin+  = Q0Inferred       -- ^ User wrote nothing.+  | Q0       Range   -- ^ User wrote "@0".+  | Q0Erased Range   -- ^ User wrote "@erased".+  deriving (Show, Generic, Eq, Ord)++-- | Origin of 'Quantity1'.+data Q1Origin+  = Q1Inferred       -- ^ User wrote nothing.+  | Q1       Range   -- ^ User wrote "@1".+  | Q1Linear Range   -- ^ User wrote "@linear".+  deriving (Show, Generic, Eq, Ord)++-- | Origin of 'Quantityω'.+data QωOrigin+  = QωInferred       -- ^ User wrote nothing.+  | Qω       Range   -- ^ User wrote "@ω".+  | QωPlenty Range   -- ^ User wrote "@plenty".+  deriving (Show, Generic, Eq, Ord)++-- *** Instances for 'Q0Origin'.++-- | Right-biased composition, because the left quantity+--   acts as context, and the right one as occurrence.+instance Semigroup Q0Origin where+  (<>) = curry $ \case+    (Q0Inferred, o) -> o+    (o, Q0Inferred) -> o+    (o, Q0       r) -> Q0 $ fuseRange o r+    (o, Q0Erased r) -> Q0 $ fuseRange o r++instance Monoid Q0Origin where+  mempty = Q0Inferred+  mappend = (<>)++instance Null Q0Origin where+  empty = mempty++instance HasRange Q0Origin where+  getRange = \case+    Q0Inferred -> noRange+    Q0       r -> r+    Q0Erased r -> r++instance SetRange Q0Origin where+  setRange r = \case+    Q0Inferred -> Q0Inferred+    Q0       _ -> Q0       r+    Q0Erased _ -> Q0Erased r++instance KillRange Q0Origin where+  killRange = \case+    Q0Inferred -> Q0Inferred+    Q0       _ -> Q0       noRange+    Q0Erased _ -> Q0Erased noRange++instance NFData Q0Origin where+  rnf = \case+    Q0Inferred -> ()+    Q0       _ -> ()+    Q0Erased _ -> ()++instance Pretty Q0Origin where+  pretty = \case+    Q0Inferred -> empty+    Q0{}       -> "@0"+    Q0Erased{} -> "@erased"+-- *** Instances for 'Q1Origin'.++-- | Right-biased composition, because the left quantity+--   acts as context, and the right one as occurrence.+instance Semigroup Q1Origin where+  (<>) = curry $ \case+    (Q1Inferred, o) -> o+    (o, Q1Inferred) -> o+    (o, Q1       r) -> Q1 $ fuseRange o r+    (o, Q1Linear r) -> Q1 $ fuseRange o r++instance Monoid Q1Origin where+  mempty = Q1Inferred+  mappend = (<>)++instance Null Q1Origin where+  empty = mempty++instance HasRange Q1Origin where+  getRange = \case+    Q1Inferred -> noRange+    Q1       r -> r+    Q1Linear r -> r++instance SetRange Q1Origin where+  setRange r = \case+    Q1Inferred -> Q1Inferred+    Q1       _ -> Q1       r+    Q1Linear _ -> Q1Linear r++instance KillRange Q1Origin where+  killRange = \case+    Q1Inferred -> Q1Inferred+    Q1       _ -> Q1       noRange+    Q1Linear _ -> Q1Linear noRange++instance NFData Q1Origin where+  rnf = \case+    Q1Inferred -> ()+    Q1       _ -> ()+    Q1Linear _ -> ()++instance Pretty Q1Origin where+  pretty = \case+    Q1Inferred -> empty+    Q1{}       -> "@1"+    Q1Linear{} -> "@linear"++-- *** Instances for 'QωOrigin'.++-- | Right-biased composition, because the left quantity+--   acts as context, and the right one as occurrence.+instance Semigroup QωOrigin where+  (<>) = curry $ \case+    (QωInferred, o) -> o+    (o, QωInferred) -> o+    (o, Qω       r) -> Qω $ fuseRange o r+    (o, QωPlenty r) -> Qω $ fuseRange o r++instance Monoid QωOrigin where+  mempty = QωInferred+  mappend = (<>)++instance Null QωOrigin where+  empty = mempty++instance HasRange QωOrigin where+  getRange = \case+    QωInferred -> noRange+    Qω       r -> r+    QωPlenty r -> r++instance SetRange QωOrigin where+  setRange r = \case+    QωInferred -> QωInferred+    Qω       _ -> Qω       r+    QωPlenty _ -> QωPlenty r++instance KillRange QωOrigin where+  killRange = \case+    QωInferred -> QωInferred+    Qω       _ -> Qω       noRange+    QωPlenty _ -> QωPlenty noRange++instance NFData QωOrigin where+  rnf = \case+    QωInferred -> ()+    Qω       _ -> ()+    QωPlenty _ -> ()++instance Pretty QωOrigin where+  pretty = \case+    QωInferred -> empty+    Qω{}       -> "@ω"+    QωPlenty{} -> "@plenty"++-- ** Quantity.++-- | Quantity for linearity.+--+--   A quantity is a set of natural numbers, indicating possible semantic+--   uses of a variable.  A singleton set @{n}@ requires that the+--   corresponding variable is used exactly @n@ times.+--+data Quantity+  = Quantity0 Q0Origin -- ^ Zero uses @{0}@, erased at runtime.+  | Quantity1 Q1Origin -- ^ Linear use @{1}@ (could be updated destructively).+    -- Mostly TODO (needs postponable constraints between quantities to compute uses).+  | Quantityω QωOrigin -- ^ Unrestricted use @ℕ@.+  deriving (Show, Generic, Eq, Ord)+    -- @Ord@ instance in case @Quantity@ is used in keys for maps etc.++-- | Equality ignoring origin.++sameQuantity :: Quantity -> Quantity -> Bool+sameQuantity = curry $ \case+  (Quantity0{}, Quantity0{}) -> True+  (Quantity1{}, Quantity1{}) -> True+  (Quantityω{}, Quantityω{}) -> True+  _ -> False++-- | Composition of quantities (multiplication).+--+-- 'Quantity0' is dominant.+-- 'Quantity1' is neutral.+--+-- Right-biased for origin.+--+instance Semigroup (UnderComposition Quantity) where+  (<>) = liftA2 composeQuantity++-- | In the absense of finite quantities besides 0, ω is the unit.+--   Otherwise, 1 is the unit.+instance Monoid (UnderComposition Quantity) where+  mempty  = pure unitQuantity+  mappend = (<>)++instance POSemigroup (UnderComposition Quantity) where+instance POMonoid (UnderComposition Quantity) where++instance LeftClosedPOMonoid (UnderComposition Quantity) where+  inverseCompose = liftA2 inverseComposeQuantity++instance Semigroup (UnderAddition Quantity) where+  (<>) = liftA2 addQuantity++instance Monoid (UnderAddition Quantity) where+  mempty  = pure zeroQuantity+  mappend = (<>)++instance POSemigroup (UnderAddition Quantity) where+instance POMonoid (UnderAddition Quantity) where++-- | Note that the order is @ω ≤ 0,1@, more options is smaller.+instance PartialOrd Quantity where+  comparable = curry $ \case+    (q, q') | sameQuantity q q' -> POEQ+    -- ω is least+    (Quantityω{}, _)  -> POLT+    (_, Quantityω{})  -> POGT+    -- others are uncomparable+    _ -> POAny++instance Pretty Quantity where+  pretty = \case+    Quantity0 o -> ifNull (pretty o) "@0" id+    Quantity1 o -> ifNull (pretty o) "@1" id+    Quantityω o -> pretty o++-- | 'Quantity' forms an additive monoid with zero Quantity0.+addQuantity :: Quantity -> Quantity -> Quantity+addQuantity = curry $ \case+  -- ω is absorptive+  (q@Quantityω{}, _) -> q+  (_, q@Quantityω{}) -> q+  -- 0 is neutral+  (Quantity0{}, q) -> q+  (q, Quantity0{}) -> q+  -- 1 + 1 = ω+  (Quantity1 _, Quantity1 _) -> topQuantity++-- | Identity element under addition+zeroQuantity :: Quantity+zeroQuantity = Quantity0 mempty++-- | Absorptive element!+--   This differs from Relevance and Cohesion whose default+--   is the multiplicative unit.+defaultQuantity :: Quantity+defaultQuantity = topQuantity++-- | Identity element under composition+unitQuantity :: Quantity+unitQuantity = Quantityω mempty++-- | Absorptive element is ω.+topQuantity :: Quantity+topQuantity = Quantityω mempty++-- | 'null' means no information, not even origin or range.+instance Null Quantity where+  empty = defaultQuantity+  null = \case+    Quantityω o -> null o+    _ -> False++-- | @m `moreUsableQuantity` m'@ means that an @m@ can be used+--   where ever an @m'@ is required.++moreQuantity :: Quantity -> Quantity -> Bool+moreQuantity m m' = related m POLE m'++-- | Composition of quantities (multiplication).+--+-- 'Quantity0' is dominant.+-- 'Quantity1' is neutral.+--+-- Right-biased for origin.+--+composeQuantity :: Quantity -> Quantity -> Quantity+composeQuantity = curry $ \case+  (Quantity1 o, Quantity1 o') -> Quantity1 (o <> o')+  (Quantity1{}, q           ) -> q+  (q          , Quantity1{} ) -> q+  (Quantity0 o, Quantity0 o') -> Quantity0 (o <> o')+  (_          , Quantity0 o ) -> Quantity0 o+  (Quantity0 o, _           ) -> Quantity0 o+  (Quantityω o, Quantityω o') -> Quantityω (o <> o')++-- | Compose with quantity flag from the left.+--   This function is e.g. used to update the quantity information+--   on pattern variables @a@ after a match against something of quantity @q@.++applyQuantity :: LensQuantity a => Quantity -> a -> a+applyQuantity q = mapQuantity (q `composeQuantity`)++-- | @inverseComposeQuantity r x@ returns the least quantity @y@+--   such that forall @x@, @y@ we have+--   @x \`moreQuantity\` (r \`composeQuantity\` y)@+--   iff+--   @(r \`inverseComposeQuantity\` x) \`moreQuantity\` y@ (Galois connection).++inverseComposeQuantity :: Quantity -> Quantity -> Quantity+inverseComposeQuantity = curry $ \case+    (Quantity1{} , x)              -> x             -- going to linear arg: nothing changes+    (Quantity0{} , x)              -> topQuantity   -- going to erased arg: every thing usable+    (Quantityω{} , x@Quantityω{})  -> x+    (Quantityω{} , _)              -> zeroQuantity  -- linear resources are unusable as arguments to unrestricted functions++-- | Left division by a 'Quantity'.+--   Used e.g. to modify context when going into a @q@ argument.++inverseApplyQuantity :: LensQuantity a => Quantity -> a -> a+inverseApplyQuantity q = mapQuantity (q `inverseComposeQuantity`)++-- | Check for 'Quantity0'.++hasQuantity0 :: LensQuantity a => a -> Bool+hasQuantity0 a+  | Quantity0{} <- getQuantity a = True+  | otherwise = False++-- | Check for 'Quantity1'.++hasQuantity1 :: LensQuantity a => a -> Bool+hasQuantity1 a+  | Quantity1{} <- getQuantity a = True+  | otherwise = False++-- | Check for 'Quantityω'.++hasQuantityω :: LensQuantity a => a -> Bool+hasQuantityω a+  | Quantityω{} <- getQuantity a = True+  | otherwise = False++-- | Did the user supply a quantity annotation?++noUserQuantity :: LensQuantity a => a -> Bool+noUserQuantity a = case getQuantity a of+  Quantity0 o -> null o+  Quantity1 o -> null o+  Quantityω o -> null o++-- | A thing of quantity 0 is unusable, all others are usable.++usableQuantity :: LensQuantity a => a -> Bool+usableQuantity = not . hasQuantity0++-- boilerplate instances++class LensQuantity a where++  getQuantity :: a -> Quantity++  setQuantity :: Quantity -> a -> a+  setQuantity = mapQuantity . const++  mapQuantity :: (Quantity -> Quantity) -> a -> a++  default getQuantity :: LensModality a => a -> Quantity+  getQuantity = modQuantity . getModality++  default mapQuantity :: LensModality a => (Quantity -> Quantity) -> a -> a+  mapQuantity f = mapModality $ \ ai -> ai { modQuantity = f $ modQuantity ai }++instance LensQuantity Quantity where+  getQuantity = id+  setQuantity = const+  mapQuantity = id++instance HasRange Quantity where+  getRange = \case+    Quantity0 o -> getRange o+    Quantity1 o -> getRange o+    Quantityω o -> getRange o++instance SetRange Quantity where+  setRange r = \case+    Quantity0 o -> Quantity0 $ setRange r o+    Quantity1 o -> Quantity1 $ setRange r o+    Quantityω o -> Quantityω $ setRange r o++instance KillRange Quantity where+  killRange = \case+    Quantity0 o -> Quantity0 $ killRange o+    Quantity1 o -> Quantity1 $ killRange o+    Quantityω o -> Quantityω $ killRange o++instance NFData Quantity where+  rnf (Quantity0 o) = rnf o+  rnf (Quantity1 o) = rnf o+  rnf (Quantityω o) = rnf o++isQuantity0 :: LensQuantity a => a -> Bool+isQuantity0 a = case getQuantity a of+  Quantity0{} -> True+  _ -> False++isQuantityω :: LensQuantity a => a -> Bool+isQuantityω a = case getQuantity a of+  Quantityω{} -> True+  _ -> False++prettyQuantity :: LensQuantity a => a -> Doc -> Doc+prettyQuantity a = (pretty (getQuantity a) <+>)++-- ** Erased.++-- | A special case of 'Quantity': erased or not.+--+-- Note that the 'Ord' instance does *not* ignore the origin+-- arguments.++data Erased+  = Erased Q0Origin+  | NotErased QωOrigin+  deriving (Show, Eq, Ord, Generic)++-- | The default value of type 'Erased': not erased.++defaultErased :: Erased+defaultErased = NotErased QωInferred++-- | 'Erased' can be embedded into 'Quantity'.++asQuantity :: Erased -> Quantity+asQuantity (Erased    o) = Quantity0 o+asQuantity (NotErased o) = Quantityω o++-- | 'Quantity' can be projected onto 'Erased'.++erasedFromQuantity :: Quantity -> Maybe Erased+erasedFromQuantity = \case+  Quantity1{} -> Nothing+  Quantity0 o -> Just $ Erased    o+  Quantityω o -> Just $ NotErased o++-- | Equality ignoring origin.++sameErased :: Erased -> Erased -> Bool+sameErased = sameQuantity `on` asQuantity++-- | Is the value \"erased\"?++isErased :: Erased -> Bool+isErased = hasQuantity0 . asQuantity++instance NFData Erased++instance HasRange Erased where+  getRange = getRange . asQuantity++instance KillRange Erased where+  killRange = \case+    Erased o    -> Erased $ killRange o+    NotErased o -> NotErased $ killRange o++instance Pretty Erased where+  pretty = pretty . asQuantity++-- | Composition of values of type 'Erased'.+--+-- 'Erased' is dominant.+-- 'NotErased' is neutral.+--+-- Right-biased for the origin.++composeErased :: Erased -> Erased -> Erased+composeErased = curry $ \case+  (Erased o,    Erased o')    -> Erased (o <> o')+  (NotErased _, Erased o)     -> Erased o+  (Erased o,    NotErased _)  -> Erased o+  (NotErased o, NotErased o') -> NotErased (o <> o')++instance Semigroup (UnderComposition Erased) where+  (<>) = liftA2 composeErased++prettyErased :: Erased -> Doc -> Doc+prettyErased = prettyQuantity . asQuantity++---------------------------------------------------------------------------+-- * Relevance+---------------------------------------------------------------------------++-- ** Relevance origin++-- | Origin of 'Relevant'.++data OriginRelevant+  = ORelInferred        -- ^ User wrote nothing.+  | ORelRelevant Range  -- ^ User wrote "@relevant".+  deriving (Show, Generic)++-- | Origin of 'Irrelevant'.++data OriginIrrelevant+  = OIrrInferred          -- ^ User wrote nothing.+  | OIrrDot        Range  -- ^ User wrote ".".+  | OIrrIrr        Range  -- ^ User wrote "@irr".+  | OIrrIrrelevant Range  -- ^ User wrote "@irrelevant".+  deriving (Show, Generic)++-- | Origin of 'ShapeIrrelevant'.++data OriginShapeIrrelevant+  = OShIrrInferred               -- ^ User wrote nothing.+  | OShIrrDotDot          Range  -- ^ User wrote "..".+  | OShIrrShIrr           Range  -- ^ User wrote "@shirr".+  | OShIrrShapeIrrelevant Range  -- ^ User wrote "@shape-irrelevant".+  deriving (Show, Generic)++-- *** Instances for 'OriginRelevant'++instance Null OriginRelevant where+  empty = ORelInferred+  null = \case+    ORelInferred -> True+    _ -> False++instance Semigroup OriginRelevant where+  (<>) = curry \case+    (ORelInferred, o  ) -> o+    (o, ORelInferred  ) -> o+    (o, ORelRelevant r) -> ORelRelevant $ fuseRange o r++instance Monoid OriginRelevant where+  mempty = empty++instance HasRange OriginRelevant where+  getRange = \case+    ORelInferred   -> noRange+    ORelRelevant r -> r++instance SetRange OriginRelevant where+  setRange r = \case+    ORelInferred   -> ORelInferred+    ORelRelevant _ -> ORelRelevant r++instance KillRange OriginRelevant where+  killRange = setRange noRange++instance NFData OriginRelevant where+  rnf = \case+    ORelInferred   -> ()+    ORelRelevant _ -> ()++-- *** Instances for 'OriginIrrelevant'++instance Null OriginIrrelevant where+  empty = OIrrInferred+  null = \case+    OIrrInferred -> True+    _ -> False++-- | Right-biased composition, because the left relevance+--   acts as context, and the right one as occurrence.++instance Semigroup OriginIrrelevant where+  (<>) = curry \case+    (OIrrInferred, o    ) -> o+    (o, OIrrInferred    ) -> o+    (o, OIrrDot        r) -> OIrrDot        $ fuseRange o r+    (o, OIrrIrr        r) -> OIrrIrr        $ fuseRange o r+    (o, OIrrIrrelevant r) -> OIrrIrrelevant $ fuseRange o r++instance Monoid OriginIrrelevant where+  mempty = empty++instance HasRange OriginIrrelevant where+  getRange = \case+    OIrrInferred     -> noRange+    OIrrDot        r -> r+    OIrrIrr        r -> r+    OIrrIrrelevant r -> r++instance SetRange OriginIrrelevant where+  setRange r = \case+    OIrrInferred     -> OIrrInferred+    OIrrDot _        -> OIrrDot r+    OIrrIrr _        -> OIrrIrr r+    OIrrIrrelevant _ -> OIrrIrrelevant r++instance KillRange OriginIrrelevant where+  killRange = setRange noRange++instance NFData OriginIrrelevant where+  rnf = \case+    OIrrInferred     -> ()+    OIrrDot _        -> ()+    OIrrIrr _        -> ()+    OIrrIrrelevant _ -> ()++-- *** Instances for 'OriginShapeIrrelevant'++instance Null OriginShapeIrrelevant where+  empty = OShIrrInferred+  null = \case+    OShIrrInferred -> True+    _ -> False++-- | Right-biased composition, because the left relevance+--   acts as context, and the right one as occurrence.++instance Semigroup OriginShapeIrrelevant where+  (<>) = curry \case+    (OShIrrInferred, o         ) -> o+    (o, OShIrrInferred         ) -> o+    (o, OShIrrDotDot          r) -> OShIrrDotDot          $ fuseRange o r+    (o, OShIrrShIrr           r) -> OShIrrShIrr           $ fuseRange o r+    (o, OShIrrShapeIrrelevant r) -> OShIrrShapeIrrelevant $ fuseRange o r++instance Monoid OriginShapeIrrelevant where+  mempty = empty++instance HasRange OriginShapeIrrelevant where+  getRange = \case+    OShIrrInferred          -> noRange+    OShIrrDotDot          r -> r+    OShIrrShIrr           r -> r+    OShIrrShapeIrrelevant r -> r++instance SetRange OriginShapeIrrelevant where+  setRange r = \case+    OShIrrInferred          -> OShIrrInferred+    OShIrrDotDot _          -> OShIrrDotDot r+    OShIrrShIrr _           -> OShIrrShIrr r+    OShIrrShapeIrrelevant _ -> OShIrrShapeIrrelevant r++instance KillRange OriginShapeIrrelevant where+  killRange = setRange noRange++instance NFData OriginShapeIrrelevant where+  rnf = \case+    OShIrrInferred          -> ()+    OShIrrDotDot _          -> ()+    OShIrrShIrr _           -> ()+    OShIrrShapeIrrelevant _ -> ()++instance Pretty OriginRelevant where+  pretty = \case+    ORelInferred {} -> empty+    ORelRelevant {} -> "@relevant"++instance Pretty OriginIrrelevant where+  pretty = \case+    OIrrInferred   {} -> empty+    OIrrDot        {} -> "."+    OIrrIrr        {} -> "@irr"+    OIrrIrrelevant {} -> "@irrelevant"++instance Pretty OriginShapeIrrelevant where+  pretty = \case+    OShIrrInferred        {} -> empty+    OShIrrDotDot          {} -> ".."+    OShIrrShIrr           {} -> "@shirr"+    OShIrrShapeIrrelevant {} -> "@shape-irrelevant"++-- ** Relevance levels++-- | A function argument can be relevant or irrelevant.+--   See "Agda.TypeChecking.Irrelevance".+data Relevance+  = Relevant OriginRelevant+      -- ^ The argument is (possibly) relevant at compile-time.+  | ShapeIrrelevant OriginShapeIrrelevant+      -- ^ Like 'Quantity0', the argument may never flow into evaluation position.+      --   So it is irrelevant at run-time,+      --   yet treated relevantly during equality checking.+      --+      --   Unlike 'Quantity0', it is used to type 'Irrelevant' arguments in functions:+      --   If you enable @--experimental-irrelevance@,+      --   then the type of an irrelevant function is forced to be shape-irrelevant.+      --   See:+      --   - <https://doi.org/10.2168/LMCS-8(1:29)2012> example 2.8+      --     (Not enforcing shape-irrelevant codomains can break subject reduction!)+      --   - <https://dl.acm.org/doi/10.1145/3110277>+      --   - <https://doi.org/10.1145/3209108.3209119>+  | Irrelevant OriginIrrelevant+      -- ^ The argument is irrelevant at compile- and runtime.+    deriving (Show, Generic)++instance Eq Relevance where+  (==) = sameRelevance++instance HasRange Relevance where+  getRange = \case+    Relevant        o -> getRange o+    ShapeIrrelevant o -> getRange o+    Irrelevant      o -> getRange o++instance SetRange Relevance where+  setRange r = \case+    Relevant        o -> Relevant        $ setRange r o+    ShapeIrrelevant o -> ShapeIrrelevant $ setRange r o+    Irrelevant      o -> Irrelevant      $ setRange r o++instance KillRange Relevance where+  killRange = setRange noRange++instance NFData Relevance where+  rnf = \case+    Relevant        o -> rnf o+    ShapeIrrelevant o -> rnf o+    Irrelevant      o -> rnf o++-- | A lens to access the 'Relevance' attribute in data structures.+--   Minimal implementation: @getRelevance@ and @mapRelevance@ or @LensModality@.+class LensRelevance a where++  getRelevance :: a -> Relevance++  setRelevance :: Relevance -> a -> a+  setRelevance h = mapRelevance (const h)++  mapRelevance :: (Relevance -> Relevance) -> a -> a++  default getRelevance :: LensModality a => a -> Relevance+  getRelevance = modRelevance . getModality++  default mapRelevance :: LensModality a => (Relevance -> Relevance) -> a -> a+  mapRelevance f = mapModality $ \ ai -> ai { modRelevance = f $ modRelevance ai }++instance LensRelevance Relevance where+  getRelevance = id+  setRelevance = const+  mapRelevance = id++relevant :: Relevance+relevant = Relevant empty++irrelevant :: Relevance+irrelevant = Irrelevant empty++shapeIrrelevant :: Relevance+shapeIrrelevant = ShapeIrrelevant empty++isRelevant :: LensRelevance a => a -> Bool+isRelevant a = case getRelevance a of+  Relevant{} -> True+  _ -> False++isIrrelevant :: LensRelevance a => a -> Bool+isIrrelevant a = case getRelevance a of+  Irrelevant{} -> True+  _ -> False++isShapeIrrelevant :: LensRelevance a => a -> Bool+isShapeIrrelevant a = case getRelevance a of+  ShapeIrrelevant{} -> True+  _ -> False++-- | Information ordering.+-- @Relevant  \`moreRelevant\`+--  ShapeIrrelevant \`moreRelevant\`+--  Irrelevant@+moreRelevant :: Relevance -> Relevance -> Bool+moreRelevant = (<=)++-- | Equality ignoring origin.+sameRelevance :: Relevance -> Relevance -> Bool+sameRelevance = curry $ \case+  (Relevant        {}, Relevant        {}) -> True+  (Irrelevant      {}, Irrelevant      {}) -> True+  (ShapeIrrelevant {}, ShapeIrrelevant {}) -> True+  _ -> False++-- | More relevant is smaller.+instance Ord Relevance where+  compare = curry \case+    (r, r') | sameRelevance r r' -> EQ+    -- top+    (_, Irrelevant{}) -> LT+    (Irrelevant{}, _) -> GT+    -- bottom+    (Relevant{}, _) -> LT+    (_, Relevant{}) -> GT+    -- redundant case+    (ShapeIrrelevant{}, ShapeIrrelevant{}) -> EQ++-- | More relevant is smaller.+instance PartialOrd Relevance where+  comparable = comparableOrd++-- | @usableRelevance rel == False@ iff we cannot use a variable of @rel@.+usableRelevance :: LensRelevance a => a -> Bool+usableRelevance = isRelevant++-- | 'Relevance' composition.+--   'Irrelevant' is dominant, 'Relevant' is neutral.+--   Composition coincides with 'max'.+composeRelevance :: Relevance -> Relevance -> Relevance+composeRelevance = curry \case+  (Relevant o        , Relevant o'       ) -> Relevant (o <> o')+  (Relevant{}        , r                 ) -> r+  (r                 , Relevant{}        ) -> r+  (Irrelevant o      , Irrelevant o'     ) -> Irrelevant (o <> o')+  (_                 , Irrelevant o      ) -> Irrelevant o+  (Irrelevant o      , _                 ) -> Irrelevant o+  (ShapeIrrelevant o , ShapeIrrelevant o') -> ShapeIrrelevant (o <> o')++-- | Compose with relevance flag from the left.+--   This function is e.g. used to update the relevance information+--   on pattern variables @a@ after a match against something @rel@.+applyRelevance :: LensRelevance a => Relevance -> a -> a+applyRelevance rel = mapRelevance (rel `composeRelevance`)++-- | @inverseComposeRelevance r x@ returns the most irrelevant @y@+--   such that forall @x@, @y@ we have+--   @x \`moreRelevant\` (r \`composeRelevance\` y)@+--   iff+--   @(r \`inverseComposeRelevance\` x) \`moreRelevant\` y@ (Galois connection).+inverseComposeRelevance :: Relevance -> Relevance -> Relevance+inverseComposeRelevance = curry \case+  (_                 , Relevant o       ) -> Relevant o   -- can't get more relevant+  (Relevant{}        , x                ) -> x            -- going to relevant arg.: nothing changes+                                                          -- because Relevant is comp.-neutral+  (Irrelevant{}      , x                ) -> relevant     -- going irrelevant: every thing usable+  (ShapeIrrelevant{} , Irrelevant o     ) -> Irrelevant o -- otherwise: irrelevant things remain unusable+  (ShapeIrrelevant{} , ShapeIrrelevant{}) -> relevant     -- but @ShapeIrrelevant@s become usable++-- | Left division by a 'Relevance'.+--   Used e.g. to modify context when going into a @rel@ argument.+inverseApplyRelevance :: LensRelevance a => Relevance -> a -> a+inverseApplyRelevance rel = mapRelevance (rel `inverseComposeRelevance`)++-- | 'Relevance' forms a semigroup under composition.+instance Semigroup (UnderComposition Relevance) where+  (<>) = liftA2 composeRelevance++-- | 'Relevant' is the unit under composition.+instance Monoid (UnderComposition Relevance) where+  mempty  = pure unitRelevance+  mappend = (<>)++instance POSemigroup (UnderComposition Relevance) where+instance POMonoid (UnderComposition Relevance) where++instance LeftClosedPOMonoid (UnderComposition Relevance) where+  inverseCompose = liftA2 inverseComposeRelevance++instance Semigroup (UnderAddition Relevance) where+  (<>) = liftA2 addRelevance++instance Monoid (UnderAddition Relevance) where+  mempty  = pure zeroRelevance+  mappend = (<>)++instance POSemigroup (UnderAddition Relevance) where+instance POMonoid (UnderAddition Relevance) where++-- | Combine inferred 'Relevance'.+--   The unit is 'Irrelevant'.+addRelevance :: Relevance -> Relevance -> Relevance+addRelevance = min++-- | 'Relevance' forms a monoid under addition, and even a semiring.+zeroRelevance :: Relevance+zeroRelevance = irrelevant++-- | Identity element under composition+unitRelevance :: Relevance+unitRelevance = relevant++-- | Absorptive element under addition.+topRelevance :: Relevance+topRelevance = relevant++-- | Default Relevance is the identity element under composition+defaultRelevance :: Relevance+defaultRelevance = unitRelevance++-- | 'null' means no information, not even origin or range.+instance Null Relevance where+  empty = defaultRelevance+  null = \case+    Relevant o -> null o+    _ -> False++-- | Irrelevant function arguments may appear non-strictly in the codomain type.+irrelevantToShapeIrrelevant :: Relevance -> Relevance+irrelevantToShapeIrrelevant Irrelevant{} = shapeIrrelevant+irrelevantToShapeIrrelevant rel = rel++-- | Applied when working on types (unless --experimental-irrelevance).+shapeIrrelevantToRelevant :: Relevance -> Relevance+shapeIrrelevantToRelevant ShapeIrrelevant{} = relevant+shapeIrrelevantToRelevant rel = rel++shapeIrrelevantToIrrelevant :: Relevance -> Relevance+shapeIrrelevantToIrrelevant ShapeIrrelevant{} = irrelevant+shapeIrrelevantToIrrelevant rel = rel++prettyRelevance :: LensRelevance a => a -> Doc -> Doc+prettyRelevance a = if lastMaybe (render d) == Just '.' then (d <>) else (d <+>)+  where+    d = pretty $ getRelevance a++instance Pretty Relevance where+  pretty = \case+    Relevant        o -> pretty o+    Irrelevant      o -> ifNull (pretty o) "." id+    ShapeIrrelevant o -> ifNull (pretty o) ".." id+++---------------------------------------------------------------------------+-- * Annotations+---------------------------------------------------------------------------++-- | We have a tuple of annotations, which might not be fully orthogonal.+data Annotation = Annotation+  { annLock :: Lock+    -- ^ Fitch-style dependent right adjoints.+    --   See Modal Dependent Type Theory and Dependent Right Adjoints, arXiv:1804.05236.+  } deriving (Eq, Ord, Show, Generic)++instance HasRange Annotation where+  getRange _ = noRange++instance KillRange Annotation where+  killRange = id++defaultAnnotation :: Annotation+defaultAnnotation = Annotation defaultLock++instance Null Annotation where+  empty = defaultAnnotation+  null (Annotation lock) = null lock++instance NFData Annotation where+  rnf (Annotation l) = rnf l++class LensAnnotation a where++  getAnnotation :: a -> Annotation++  setAnnotation :: Annotation -> a -> a++  mapAnnotation :: (Annotation -> Annotation) -> a -> a+  mapAnnotation f a = setAnnotation (f $ getAnnotation a) a++  default getAnnotation :: LensArgInfo a => a -> Annotation+  getAnnotation = argInfoAnnotation . getArgInfo++  default setAnnotation :: LensArgInfo a => Annotation -> a -> a+  setAnnotation a = mapArgInfo $ \ ai -> ai { argInfoAnnotation = a }++instance LensAnnotation Annotation where+  getAnnotation = id+  setAnnotation = const+  mapAnnotation = id++instance LensAnnotation (Arg t) where+  getAnnotation = getAnnotation . getArgInfo+  setAnnotation = mapArgInfo . setAnnotation+++---------------------------------------------------------------------------+-- * Locks+---------------------------------------------------------------------------++data LockOrigin+  = LockOLock -- ^ The user wrote @lock.+  | LockOTick -- ^ The user wrote @tick.+  deriving (Show, Generic, Eq, Enum, Bounded, Ord)++data Lock+  = IsNotLock+  | IsLock LockOrigin+  -- ^ In the future there might be different kinds of them.+  --   For now we assume lock weakening.+  deriving (Show, Generic, Eq, Ord)++defaultLock :: Lock+defaultLock = IsNotLock++instance Null Lock where+  empty = defaultLock++instance NFData Lock where+  rnf IsNotLock          = ()+  rnf (IsLock LockOLock) = ()+  rnf (IsLock LockOTick) = ()++class LensLock a where++  getLock :: a -> Lock++  setLock :: Lock -> a -> a+  setLock = mapLock . const++  mapLock :: (Lock -> Lock) -> a -> a+  mapLock f a = setLock (f $ getLock a) a++instance LensLock Lock where+  getLock = id+  setLock = const+  mapLock = id++instance LensLock ArgInfo where+  getLock = annLock . argInfoAnnotation+  setLock l info = info { argInfoAnnotation = (argInfoAnnotation info){ annLock = l } }++instance LensLock (Arg t) where+  getLock = getLock . getArgInfo+  setLock = mapArgInfo . setLock++instance Pretty Lock where+  pretty = \case+    IsLock LockOLock -> "@lock"+    IsLock LockOTick -> "@tick"+    IsNotLock -> empty++prettyLock :: LensLock a => a -> Doc -> Doc+prettyLock a = (pretty (getLock a) <+>)++---------------------------------------------------------------------------+-- * Cohesion+---------------------------------------------------------------------------++-- | Cohesion modalities+--   see "Brouwer's fixed-point theorem in real-cohesive homotopy type theory" (arXiv:1509.07584)+--   types are now given an additional topological layer which the modalities interact with.+data Cohesion+  = Flat        -- ^ same points, discrete topology, idempotent comonad, box-like.+  | Continuous  -- ^ identity modality.+  -- | Sharp    -- ^ same points, codiscrete topology, idempotent monad, diamond-like.+  | Squash      -- ^ single point space, artificially added for Flat left-composition.+    deriving (Show, Eq, Enum, Bounded, Generic)++allCohesions :: [Cohesion]+allCohesions = [minBound..maxBound]++instance HasRange Cohesion where+  getRange _ = noRange++instance SetRange Cohesion where+  setRange _ = id++instance KillRange Cohesion where+  killRange rel = rel -- no range to kill++instance NFData Cohesion where+  rnf Flat       = ()+  rnf Continuous = ()+  rnf Squash     = ()++instance Pretty Cohesion where+  pretty Flat   = "@♭"+  pretty Continuous = mempty+  pretty Squash  = "@⊤"++-- | A lens to access the 'Cohesion' attribute in data structures.+--   Minimal implementation: @getCohesion@ and @mapCohesion@ or @LensModality@.+class LensCohesion a where++  getCohesion :: a -> Cohesion++  setCohesion :: Cohesion -> a -> a+  setCohesion h = mapCohesion (const h)++  mapCohesion :: (Cohesion -> Cohesion) -> a -> a++  default getCohesion :: LensModality a => a -> Cohesion+  getCohesion = modCohesion . getModality++  default mapCohesion :: LensModality a => (Cohesion -> Cohesion) -> a -> a+  mapCohesion f = mapModality $ \ ai -> ai { modCohesion = f $ modCohesion ai }++instance LensCohesion Cohesion where+  getCohesion = id+  setCohesion = const+  mapCohesion = id++isContinuous :: LensCohesion a => a -> Bool+isContinuous = (Continuous ==) . getCohesion++-- | Information ordering.+-- @Flat  \`moreCohesion\`+--  Continuous \`moreCohesion\`+--  Sharp \`moreCohesion\`+--  Squash@+moreCohesion :: Cohesion -> Cohesion -> Bool+moreCohesion = (<=)++-- | Equality ignoring origin.+sameCohesion :: Cohesion -> Cohesion -> Bool+sameCohesion = (==)++-- | Order is given by implication: flatter is smaller.+instance Ord Cohesion where+  compare = curry $ \case+    (r, r') | r == r' -> EQ+    -- top+    (_, Squash) -> LT+    (Squash, _) -> GT+    -- bottom+    (Flat, _) -> LT+    (_, Flat) -> GT+    -- redundant case+    (Continuous,Continuous) -> EQ++-- | Flatter is smaller.+instance PartialOrd Cohesion where+  comparable = comparableOrd++-- | @usableCohesion rel == False@ iff we cannot use a variable of @rel@.+usableCohesion :: LensCohesion a => a -> Bool+usableCohesion a = getCohesion a `moreCohesion` Continuous++-- | 'Cohesion' composition.+--   'Squash' is dominant, 'Continuous' is neutral.+composeCohesion :: Cohesion -> Cohesion -> Cohesion+composeCohesion r r' =+  case (r, r') of+    (Squash, _) -> Squash+    (_, Squash) -> Squash+    (Flat, _)  -> Flat+    (_, Flat)  -> Flat+    (Continuous, Continuous) -> Continuous++-- | Compose with cohesion flag from the left.+--   This function is e.g. used to update the cohesion information+--   on pattern variables @a@ after a match against something of cohesion @rel@.+applyCohesion :: LensCohesion a => Cohesion -> a -> a+applyCohesion rel = mapCohesion (rel `composeCohesion`)++-- | @inverseComposeCohesion r x@ returns the least @y@+--   such that forall @x@, @y@ we have+--   @x \`moreCohesion\` (r \`composeCohesion\` y)@+--   iff+--   @(r \`inverseComposeCohesion\` x) \`moreCohesion\` y@ (Galois connection).+--   The above law fails for @r = Squash@.+inverseComposeCohesion :: Cohesion -> Cohesion -> Cohesion+inverseComposeCohesion r x =+  case (r, x) of+    (Continuous  , x) -> x          -- going to continous arg.: nothing changes+                                    -- because Continuous is comp.-neutral+    (Squash, x)       -> Flat       -- in squash position everything is usable+    (Flat , Flat)     -> Flat       -- otherwise: Flat things remain Flat+    (Flat , _)        -> Squash     -- but everything else becomes unusable.++-- | Left division by a 'Cohesion'.+--   Used e.g. to modify context when going into a @rel@ argument.+inverseApplyCohesion :: LensCohesion a => Cohesion -> a -> a+inverseApplyCohesion rel = mapCohesion (rel `inverseComposeCohesion`)++-- | 'Cohesion' forms a semigroup under composition.+instance Semigroup (UnderComposition Cohesion) where+  (<>) = liftA2 composeCohesion++-- | 'Continous' is the multiplicative unit.+instance Monoid (UnderComposition Cohesion) where+  mempty  = pure unitCohesion+  mappend = (<>)++instance POSemigroup (UnderComposition Cohesion) where+instance POMonoid (UnderComposition Cohesion) where++instance LeftClosedPOMonoid (UnderComposition Cohesion) where+  inverseCompose = liftA2 inverseComposeCohesion++-- | 'Cohesion' forms a semigroup under addition.+instance Semigroup (UnderAddition Cohesion) where+  (<>) = liftA2 addCohesion++-- | 'Squash' is the additive unit.+instance Monoid (UnderAddition Cohesion) where+  mempty  = pure zeroCohesion+  mappend = (<>)++instance POSemigroup (UnderAddition Cohesion) where+instance POMonoid (UnderAddition Cohesion) where++-- | Combine inferred 'Cohesion'.+--   The unit is 'Squash'.+addCohesion :: Cohesion -> Cohesion -> Cohesion+addCohesion = min++-- | 'Cohesion' forms a monoid under addition, and even a semiring.+zeroCohesion :: Cohesion+zeroCohesion = Squash++-- | Identity under composition+unitCohesion :: Cohesion+unitCohesion = Continuous++-- | Absorptive element under addition.+topCohesion :: Cohesion+topCohesion = Flat++-- | Default Cohesion is the identity element under composition+defaultCohesion :: Cohesion+defaultCohesion = unitCohesion++-- | 'null' shall mean no information, not even origin or range.+instance Null Cohesion where+  empty = defaultCohesion+  null = \case+    Continuous -> True+    _ -> False++prettyCohesion :: LensCohesion a => a -> Doc -> Doc+prettyCohesion a = (pretty (getCohesion a) <+>)++---------------------------------------------------------------------------+-- * Polarity+---------------------------------------------------------------------------++-- | The different polarity options+data ModalPolarity+  = UnusedPolarity    -- ^ argument will not be used.+  | StrictlyPositive  -- ^ argument will only be used in strictly positive position.+  | Positive          -- ^ argument will only be used in positive position.+  | Negative          -- ^ argument will only be used in negative position.+  | MixedPolarity     -- ^ we don't know anything, argument can be used anywhere.+    deriving (Show, Ord, Enum, Eq, Bounded, Generic)++allModalPolarities :: [ModalPolarity]+allModalPolarities = [minBound..maxBound]++-- | The derived Ord instance for ModalPolarity is just used for+--   serialisation and has no particular meaning. The actual order on+--   modalities is a partial order.+instance PartialOrd ModalPolarity where+  comparable x y | x == y = POEQ+  comparable _ UnusedPolarity = POLT+  comparable UnusedPolarity _ = POGT+  comparable _ MixedPolarity = POGT+  comparable MixedPolarity _ = POLT+  comparable _ Negative = POAny+  comparable Negative _ = POAny+  comparable Positive StrictlyPositive = POLT+  comparable StrictlyPositive Positive = POGT+  comparable _ _ = __IMPOSSIBLE__++instance Pretty ModalPolarity where+  pretty p = case p of+    UnusedPolarity -> "@unused"+    StrictlyPositive -> "@++"+    Positive -> "@+"+    Negative -> "@-"+    MixedPolarity -> mempty++-- | @morePolarity' x y@ is True whenever a variable of polarity x can be+--   used anywhere where a variable of polarity y is expected.+--   Note that @morePolarity' x y@ actually means x <= y.+morePolarity' :: ModalPolarity -> ModalPolarity -> Bool+morePolarity' x y = case comparable x y of+  POLT -> True+  POLE -> True+  POEQ -> True+  _    -> False++-- | @splittablePolarity pol == False@ iff we cannot split on a variable of @pol@.+splittablePolarity :: LensModalPolarity a => a -> Bool+splittablePolarity a = modPolarityAnn (getModalPolarity a) `morePolarity'` MixedPolarity++-- | 'ModalPolarity' composition.+--   'UnusedPolarity' is dominant, 'StrictlyPositive' is neutral.+composePolarity' :: ModalPolarity -> ModalPolarity -> ModalPolarity+composePolarity' p p' =+  case (p, p') of+    (UnusedPolarity, _)  -> UnusedPolarity+    (_, UnusedPolarity)  -> UnusedPolarity+    (MixedPolarity, _)   -> MixedPolarity+    (_, MixedPolarity)   -> MixedPolarity+    (Negative, Negative) -> Positive+    (Negative, _) -> Negative+    (_, Negative) -> Negative+    (StrictlyPositive, StrictlyPositive) -> StrictlyPositive+    (_, _) -> Positive++-- | @inverseComposePolarity r x@ returns the least @y@+--   such that forall @x@, @y@ we have+--   @x \`morePolarity'\` (r \`composePolarity\` y)@+--   iff+--   @(r \`inverseComposePolarity\` x) \`morePolarity'\` y@ (Galois connection).+inverseComposePolarity' :: ModalPolarity -> ModalPolarity -> ModalPolarity+inverseComposePolarity' p x =+  case (p, x) of+    (MixedPolarity, MixedPolarity) -> MixedPolarity+    (MixedPolarity, _) -> UnusedPolarity+    (StrictlyPositive , x) -> x+    (UnusedPolarity, _) -> MixedPolarity+    (Positive, StrictlyPositive) -> UnusedPolarity+    (Positive, x) -> x+    (Negative, Positive) -> Negative+    (Negative, Negative) -> Positive+    (Negative, MixedPolarity) -> MixedPolarity+    (Negative, _) -> UnusedPolarity++-- | Combine inferred 'ModalPolarity'.+--   The unit is 'UnusedPolarity'.+addPolarity' :: ModalPolarity -> ModalPolarity -> ModalPolarity+addPolarity' p p' = case (p, p') of+  (MixedPolarity, _) -> MixedPolarity+  (_, MixedPolarity) -> MixedPolarity+  (UnusedPolarity, x) -> x+  (x, UnusedPolarity) -> x+  (Negative, Negative) -> Negative+  (Negative, _) -> MixedPolarity+  (_, Negative) -> MixedPolarity+  (Positive, _) -> Positive+  (_, Positive) -> Positive+  (StrictlyPositive, StrictlyPositive) -> StrictlyPositive+++data PolarityModality = PolarityModality+  { modPolarityAnn :: ModalPolarity    -- ^ The actual polarity of the variable+  , modPolarityOrigin :: ModalPolarity -- ^ The original polarity annotation by the user+  , modPolarityLock :: ModalPolarity   -- ^ The locks of the variable (= composition of all denominators the variable has been left divided by)+  } deriving (Show, Ord, Bounded, Generic)++instance Eq PolarityModality where+  (PolarityModality p o l) == (PolarityModality p' o' l') = p == p'++withStandardLock :: ModalPolarity -> PolarityModality+withStandardLock p = PolarityModality p p StrictlyPositive++instance HasRange PolarityModality where+  getRange _ = noRange++instance SetRange PolarityModality where+  setRange _ = id++instance KillRange PolarityModality where+  killRange rel = rel -- no range to kill++instance NFData PolarityModality where+  rnf (PolarityModality p o l) = ()++instance Pretty PolarityModality where+  pretty (PolarityModality p _ _) = pretty p++instance PartialOrd PolarityModality where+  comparable (PolarityModality p _ _) (PolarityModality p' _ _) = comparable p p'++-- | A lens to access the 'PolarityModality' attribute in data structures.+--   Minimal implementation: @getModalPolarity@ and @mapModalPolarity@ or @LensModality@.+class LensModalPolarity a where++  getModalPolarity :: a -> PolarityModality++  setModalPolarity :: PolarityModality -> a -> a+  setModalPolarity h = mapModalPolarity (const h)++  mapModalPolarity :: (PolarityModality -> PolarityModality) -> a -> a++  default getModalPolarity :: LensModality a => a -> PolarityModality+  getModalPolarity = modPolarity . getModality++  default mapModalPolarity :: LensModality a => (PolarityModality -> PolarityModality) -> a -> a+  mapModalPolarity f = mapModality $ \ ai -> ai { modPolarity = f $ modPolarity ai }++instance LensModalPolarity PolarityModality where+  getModalPolarity = id+  setModalPolarity = const+  mapModalPolarity = id++-- | Equality for polarities.+samePolarity :: PolarityModality -> PolarityModality -> Bool+samePolarity (PolarityModality p _ _) (PolarityModality p' _ _) = p == p'++morePolarity :: PolarityModality -> PolarityModality -> Bool+morePolarity (PolarityModality p _ _) (PolarityModality p' _ _) = morePolarity' p p'++-- | @usablePolarity pol == False@ iff we cannot use a variable of @pol@.+usablePolarity :: LensModalPolarity a => a -> Bool+usablePolarity a = modPolarityAnn pol `morePolarity'` StrictlyPositive+  where+    pol = getModalPolarity a++-- | 'PolarityModality' composition.+--+composePolarity :: PolarityModality -> PolarityModality -> PolarityModality+composePolarity (PolarityModality p o l) (PolarityModality p' o' l') =+  PolarityModality (composePolarity' p p') o' l'++-- | Compose with polarity flag from the left.+--   This function is e.g. used to update the polarity information+--   on pattern variables @a@ after a match against something of polarity @pol@.+applyPolarity :: LensModalPolarity a => PolarityModality -> a -> a+applyPolarity pol = mapModalPolarity (pol `composePolarity`)++-- | @inverseComposePolarity r x@ returns the least @y@+--   such that forall @x@, @y@ we have+--   @x \`morePolarity'\` (r \`composePolarity\` y)@+--   iff+--   @(r \`inverseComposePolarity\` x) \`morePolarity'\` y@ (Galois connection).+inverseComposePolarity :: PolarityModality -> PolarityModality -> PolarityModality+inverseComposePolarity (PolarityModality p o l) (PolarityModality p' o' l') =+  PolarityModality (inverseComposePolarity' p p') o' (composePolarity' l' p)++-- | Left division by a 'PolarityModality'.+--   Used e.g. to modify context when going into a @pol@ argument.+inverseApplyPolarity :: LensModalPolarity a => PolarityModality -> a -> a+inverseApplyPolarity pol = mapModalPolarity (pol `inverseComposePolarity`)++-- | 'ModalPolarity' forms a semigroup under composition.+instance Semigroup (UnderComposition PolarityModality) where+  (<>) = liftA2 composePolarity++-- | 'Continous' is the multiplicative unit.+instance Monoid (UnderComposition PolarityModality) where+  mempty  = pure unitPolarity+  mappend = (<>)++instance POSemigroup (UnderComposition PolarityModality) where+instance POMonoid (UnderComposition PolarityModality) where++instance LeftClosedPOMonoid (UnderComposition PolarityModality) where+  inverseCompose = liftA2 inverseComposePolarity++-- | 'ModalPolarity' forms a semigroup under addition.+instance Semigroup (UnderAddition PolarityModality) where+  (<>) = liftA2 addPolarity++-- | '' is the additive unit.+instance Monoid (UnderAddition PolarityModality) where+  mempty  = pure zeroPolarity+  mappend = (<>)++instance POSemigroup (UnderAddition PolarityModality) where+instance POMonoid (UnderAddition PolarityModality) where++-- | Combine inferred 'PolarityModality'.+--+addPolarity :: PolarityModality -> PolarityModality -> PolarityModality+addPolarity (PolarityModality p o l) (PolarityModality p' o' l') =+  PolarityModality (addPolarity' p p') o' l'++-- | 'ModalPolarity' forms a monoid under addition, and even a semiring.+zeroPolarity :: PolarityModality+zeroPolarity = withStandardLock UnusedPolarity++-- | Identity under composition.+unitPolarity :: PolarityModality+unitPolarity = withStandardLock StrictlyPositive++-- | Alias for 'Negative' polarity.+negativePolarity :: PolarityModality+negativePolarity = withStandardLock Negative++-- | Alias for 'Mixed' polarity.+mixedPolarity :: PolarityModality+mixedPolarity = withStandardLock MixedPolarity++-- | Absorptive element under addition.+topPolarity :: PolarityModality+topPolarity = mixedPolarity++-- | Default used when not caring about polarity+defaultPolarity :: PolarityModality+defaultPolarity = mixedPolarity++instance Null PolarityModality where+  empty = defaultPolarity++prettyPolarity :: LensModalPolarity a => a -> Doc -> Doc+prettyPolarity a = (pretty (getModalPolarity a) <+>)++---------------------------------------------------------------------------+-- * Origin of arguments (user-written, inserted or reflected)+---------------------------------------------------------------------------++-- | Origin of arguments.+data Origin+  = UserWritten     -- ^ From the source file / user input.  (Preserve!)+  | Inserted        -- ^ E.g. inserted hidden arguments.+  | Reflected       -- ^ Produced by the reflection machinery.+  | CaseSplit       -- ^ Produced by an interactive case split.+  | Substitution    -- ^ Named application produced to represent a substitution. E.g. "?0 (x = n)" instead of "?0 n"+  | ExpandedPun     -- ^ An expanded hidden argument pun.+  | Generalization  -- ^ Inserted by the generalization process+  deriving (Show, Eq, Ord)++instance HasRange Origin where+  getRange _ = noRange++instance KillRange Origin where+  killRange = id++instance NFData Origin where+  rnf UserWritten = ()+  rnf Inserted = ()+  rnf Reflected = ()+  rnf CaseSplit = ()+  rnf Substitution = ()+  rnf ExpandedPun = ()+  rnf Generalization = ()++-- | Decorating something with 'Origin' information.+data WithOrigin a = WithOrigin+  { woOrigin :: !Origin+  , woThing  :: a+  }+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++instance Decoration WithOrigin where+  traverseF f (WithOrigin h a) = WithOrigin h <$> f a++instance Pretty a => Pretty (WithOrigin a) where+  prettyPrec p = prettyPrec p . woThing++instance HasRange a => HasRange (WithOrigin a) where+  getRange = getRange . dget++instance SetRange a => SetRange (WithOrigin a) where+  setRange = fmap . setRange++instance KillRange a => KillRange (WithOrigin a) where+  killRange = fmap killRange++instance NFData a => NFData (WithOrigin a) where+  rnf (WithOrigin _ a) = rnf a++-- | A lens to access the 'Origin' attribute in data structures.+--   Minimal implementation: @getOrigin@ and @mapOrigin@ or @LensArgInfo@.++class LensOrigin a where++  getOrigin :: a -> Origin++  setOrigin :: Origin -> a -> a+  setOrigin o = mapOrigin (const o)++  mapOrigin :: (Origin -> Origin) -> a -> a++  default getOrigin :: LensArgInfo a => a -> Origin+  getOrigin = argInfoOrigin . getArgInfo++  default mapOrigin :: LensArgInfo a => (Origin -> Origin) -> a -> a+  mapOrigin f = mapArgInfo $ \ ai -> ai { argInfoOrigin = f $ argInfoOrigin ai }++instance LensOrigin Origin where+  getOrigin = id+  setOrigin = const+  mapOrigin = id++instance LensOrigin (WithOrigin a) where+  getOrigin   (WithOrigin h _) = h+  setOrigin h (WithOrigin _ a) = WithOrigin h a+  mapOrigin f (WithOrigin h a) = WithOrigin (f h) a++------------------------------------------------------------------------+-- Origin of binder names+------------------------------------------------------------------------++data BinderNameOrigin+  = UserBinderName+  | InsertedBinderName+  deriving (Show, Eq, Generic)++instance KillRange BinderNameOrigin where+  killRange = \case+    InsertedBinderName -> InsertedBinderName+    UserBinderName     -> UserBinderName++instance NFData BinderNameOrigin++-----------------------------------------------------------------------------+-- * Free variable annotations+-----------------------------------------------------------------------------++data FreeVariables = UnknownFVs | KnownFVs IntSet+  deriving (Eq, Ord, Show)++instance Semigroup FreeVariables where+  UnknownFVs   <> _            = UnknownFVs+  _            <> UnknownFVs   = UnknownFVs+  KnownFVs vs1 <> KnownFVs vs2 = KnownFVs (IntSet.union vs1 vs2)++instance Monoid FreeVariables where+  mempty  = KnownFVs IntSet.empty+  mappend = (<>)++instance KillRange FreeVariables where+  killRange = id++instance NFData FreeVariables where+  rnf UnknownFVs    = ()+  rnf (KnownFVs fv) = rnf fv++unknownFreeVariables :: FreeVariables+unknownFreeVariables = UnknownFVs++noFreeVariables :: FreeVariables+noFreeVariables = mempty++oneFreeVariable :: Int -> FreeVariables+oneFreeVariable = KnownFVs . IntSet.singleton++freeVariablesFromList :: [Int] -> FreeVariables+freeVariablesFromList = mconcat . map oneFreeVariable++-- | A lens to access the 'FreeVariables' attribute in data structures.+--   Minimal implementation: @getFreeVariables@ and @mapFreeVariables@ or @LensArgInfo@.+class LensFreeVariables a where++  getFreeVariables :: a -> FreeVariables++  setFreeVariables :: FreeVariables -> a -> a+  setFreeVariables o = mapFreeVariables (const o)++  mapFreeVariables :: (FreeVariables -> FreeVariables) -> a -> a++  default getFreeVariables :: LensArgInfo a => a -> FreeVariables+  getFreeVariables = argInfoFreeVariables . getArgInfo++  default mapFreeVariables :: LensArgInfo a => (FreeVariables -> FreeVariables) -> a -> a+  mapFreeVariables f = mapArgInfo $ \ ai -> ai { argInfoFreeVariables = f $ argInfoFreeVariables ai }++instance LensFreeVariables FreeVariables where+  getFreeVariables = id+  setFreeVariables = const+  mapFreeVariables = id++hasNoFreeVariables :: LensFreeVariables a => a -> Bool+hasNoFreeVariables x =+  case getFreeVariables x of+    UnknownFVs  -> False+    KnownFVs fv -> IntSet.null fv++---------------------------------------------------------------------------+-- * Argument decoration+---------------------------------------------------------------------------++-- | A function argument can be hidden and/or irrelevant.++data ArgInfo = ArgInfo+  { argInfoHiding        :: Hiding+  , argInfoModality      :: Modality+  , argInfoOrigin        :: Origin+  , argInfoFreeVariables :: FreeVariables+  , argInfoAnnotation    :: Annotation+    -- ^ Sometimes we want a different kind of binder/pi-type, without it+    --   supporting any of the @Modality@ interface.+  } deriving (Eq, Ord, Show)++instance HasRange ArgInfo where+  getRange (ArgInfo h m o _fv a) = getRange (h, m, o, a)++instance KillRange ArgInfo where+  killRange (ArgInfo h m o fv a) = killRangeN ArgInfo h m o fv a++class LensArgInfo a where+  getArgInfo :: a -> ArgInfo+  setArgInfo :: ArgInfo -> a -> a+  setArgInfo ai = mapArgInfo (const ai)+  mapArgInfo :: (ArgInfo -> ArgInfo) -> a -> a+  mapArgInfo f a = setArgInfo (f $ getArgInfo a) a+  {-# MINIMAL getArgInfo , (setArgInfo | mapArgInfo) #-}++instance LensArgInfo ArgInfo where+  getArgInfo = id+  setArgInfo = const+  mapArgInfo = id++instance NFData ArgInfo where+  rnf (ArgInfo a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e++instance LensHiding ArgInfo where+  getHiding = argInfoHiding+  setHiding h ai = ai { argInfoHiding = h }+  mapHiding f ai = ai { argInfoHiding = f (argInfoHiding ai) }++instance LensModality ArgInfo where+  getModality = argInfoModality+  setModality m ai = ai { argInfoModality = m }+  mapModality f ai = ai { argInfoModality = f (argInfoModality ai) }++instance LensOrigin ArgInfo where+  getOrigin = argInfoOrigin+  setOrigin o ai = ai { argInfoOrigin = o }+  mapOrigin f ai = ai { argInfoOrigin = f (argInfoOrigin ai) }++instance LensFreeVariables ArgInfo where+  getFreeVariables = argInfoFreeVariables+  setFreeVariables o ai = ai { argInfoFreeVariables = o }+  mapFreeVariables f ai = ai { argInfoFreeVariables = f (argInfoFreeVariables ai) }++instance LensAnnotation ArgInfo where+  getAnnotation = argInfoAnnotation+  setAnnotation m ai = ai { argInfoAnnotation = m }+  mapAnnotation f ai = ai { argInfoAnnotation = f (argInfoAnnotation ai) }++-- inherited instances++instance LensRelevance ArgInfo where+  getRelevance = getRelevanceMod+  setRelevance = setRelevanceMod+  mapRelevance = mapRelevanceMod++instance LensQuantity ArgInfo where+  getQuantity = getQuantityMod+  setQuantity = setQuantityMod+  mapQuantity = mapQuantityMod++instance LensCohesion ArgInfo where+  getCohesion = getCohesionMod+  setCohesion = setCohesionMod+  mapCohesion = mapCohesionMod++instance LensModalPolarity ArgInfo where+  getModalPolarity = getPolarityMod+  setModalPolarity = setPolarityMod+  mapModalPolarity = mapPolarityMod++instance Null ArgInfo where+  empty = defaultArgInfo+  null (ArgInfo h m _o _fv ann) = and [ null h, null m, null ann ]++defaultArgInfo :: ArgInfo+defaultArgInfo =  ArgInfo+  { argInfoHiding        = NotHidden+  , argInfoModality      = defaultModality+  , argInfoOrigin        = UserWritten+  , argInfoFreeVariables = UnknownFVs+  , argInfoAnnotation    = defaultAnnotation+  }++defaultIrrelevantArgInfo :: ArgInfo+defaultIrrelevantArgInfo = setRelevance irrelevant defaultArgInfo+++-- Accessing through ArgInfo++-- default accessors for Hiding++getHidingArgInfo :: LensArgInfo a => LensGet a Hiding+getHidingArgInfo = getHiding . getArgInfo++setHidingArgInfo :: LensArgInfo a => LensSet a Hiding+setHidingArgInfo = mapArgInfo . setHiding++mapHidingArgInfo :: LensArgInfo a => LensMap a Hiding+mapHidingArgInfo = mapArgInfo . mapHiding++-- default accessors for Modality++getModalityArgInfo :: LensArgInfo a => LensGet a Modality+getModalityArgInfo = getModality . getArgInfo++setModalityArgInfo :: LensArgInfo a => LensSet a Modality+setModalityArgInfo = mapArgInfo . setModality++mapModalityArgInfo :: LensArgInfo a => LensMap a Modality+mapModalityArgInfo = mapArgInfo . mapModality++-- default accessors for Origin++getOriginArgInfo :: LensArgInfo a => LensGet a Origin+getOriginArgInfo = getOrigin . getArgInfo++setOriginArgInfo :: LensArgInfo a => LensSet a Origin+setOriginArgInfo = mapArgInfo . setOrigin++mapOriginArgInfo :: LensArgInfo a => LensMap a Origin+mapOriginArgInfo = mapArgInfo . mapOrigin++-- default accessors for FreeVariables++getFreeVariablesArgInfo :: LensArgInfo a => LensGet a FreeVariables+getFreeVariablesArgInfo = getFreeVariables . getArgInfo++setFreeVariablesArgInfo :: LensArgInfo a => LensSet a FreeVariables+setFreeVariablesArgInfo = mapArgInfo . setFreeVariables++mapFreeVariablesArgInfo :: LensArgInfo a => LensMap a FreeVariables+mapFreeVariablesArgInfo = mapArgInfo . mapFreeVariables++-- inserted hidden arguments++isInsertedHidden :: (LensHiding a, LensOrigin a) => a -> Bool+isInsertedHidden a = getHiding a == Hidden && getOrigin a == Inserted++---------------------------------------------------------------------------+-- * Arguments+---------------------------------------------------------------------------++data Arg e  = Arg+  { argInfo :: ArgInfo+  , unArg :: e+  } deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++instance Decoration Arg where+  traverseF f (Arg ai a) = Arg ai <$> f a++instance HasRange a => HasRange (Arg a) where+    getRange = getRange . unArg++instance SetRange a => SetRange (Arg a) where+  setRange r = fmap $ setRange r++instance KillRange a => KillRange (Arg a) where+  killRange (Arg info a) = killRangeN Arg info a++-- Andreas, 2019-07-05, issue #3889+-- A dedicated equality for with-abstraction now exists,+-- thus, we can use intensional equality for Arg.+--+-- -- | Ignores 'Quantity', 'Relevance', 'Origin', and 'FreeVariables'.+-- --   Ignores content of argument if 'Irrelevant'.+-- --+-- instance Eq a => Eq (Arg a) where+--   Arg (ArgInfo h1 m1 _ _) x1 == Arg (ArgInfo h2 m2 _ _) x2 =+--     h1 == h2 && (isIrrelevant m1 || isIrrelevant m2 || x1 == x2)+--     -- Andreas, 2017-10-04, issue #2775, ignore irrelevant arguments during with-abstraction.+--     -- This is a hack, we should not use '(==)' in with-abstraction+--     -- and more generally not use it on Syntax.+--     -- Andrea: except for caching.++-- instance Show a => Show (Arg a) where+--     show (Arg (ArgInfo h (Modality r q) o fv) a) = showFVs fv $ showQ q $ showR r $ showO o $ showH h $ show a+--       where+--         showH Hidden       s = "{" ++ s ++ "}"+--         showH NotHidden    s = "(" ++ s ++ ")"+--         showH (Instance o) s = showOv o ++ "{{" ++ s ++ "}}"+--           where showOv YesOverlap = "overlap "+--                 showOv NoOverlap  = ""+--         showR r s = case r of+--           Irrelevant      -> "." ++ s+--           ShapeIrrelevant -> "?" ++ s+--           Relevant        -> "r" ++ s -- Andreas: I want to see it explicitly+--         showQ q s = case q of+--           Quantity0   -> "0" ++ s+--           Quantity1   -> "1" ++ s+--           Quantityω   -> "ω" ++ s+--         showO o s = case o of+--           UserWritten -> "u" ++ s+--           Inserted    -> "i" ++ s+--           Reflected   -> "g" ++ s -- generated by reflection+--           CaseSplit   -> "c" ++ s -- generated by case split+--           Substitution -> "s" ++ s+--         showFVs UnknownFVs    s = s+--         showFVs (KnownFVs fv) s = "fv" ++ show (IntSet.toList fv) ++ s++-- Andreas 2010-09-21: do not print relevance in general, only in function types!+-- Andreas 2010-09-24: and in record fields+instance Pretty a => Pretty (Arg a) where+  prettyPrec p (Arg ai e) = prettyHiding ai localParens $ prettyPrec p' e+      where p' | visible ai = p+               | otherwise  = 0+            localParens | getOrigin ai == Substitution = parens+                        | otherwise = id++instance NFData e => NFData (Arg e) where+  rnf (Arg a b) = rnf a `seq` rnf b++instance LensArgInfo (Arg a) where+  getArgInfo        = argInfo+  setArgInfo ai arg = arg { argInfo = ai }+  mapArgInfo f arg  = arg { argInfo = f $ argInfo arg }++-- The other lenses are defined through LensArgInfo++instance LensHiding (Arg e) where+  getHiding = getHidingArgInfo+  setHiding = setHidingArgInfo+  mapHiding = mapHidingArgInfo++instance LensModality (Arg e) where+  getModality = getModalityArgInfo+  setModality = setModalityArgInfo+  mapModality = mapModalityArgInfo++instance LensOrigin (Arg e) where+  getOrigin = getOriginArgInfo+  setOrigin = setOriginArgInfo+  mapOrigin = mapOriginArgInfo++instance LensFreeVariables (Arg e) where+  getFreeVariables = getFreeVariablesArgInfo+  setFreeVariables = setFreeVariablesArgInfo+  mapFreeVariables = mapFreeVariablesArgInfo++-- Since we have LensModality, we get relevance and quantity by default++instance LensRelevance (Arg e) where+  getRelevance = getRelevanceMod+  setRelevance = setRelevanceMod+  mapRelevance = mapRelevanceMod++instance LensQuantity (Arg e) where+  getQuantity = getQuantityMod+  setQuantity = setQuantityMod+  mapQuantity = mapQuantityMod++instance LensCohesion (Arg e) where+  getCohesion = getCohesionMod+  setCohesion = setCohesionMod+  mapCohesion = mapCohesionMod++instance LensModalPolarity (Arg e) where+  getModalPolarity = getPolarityMod+  setModalPolarity = setPolarityMod+  mapModalPolarity = mapPolarityMod++defaultArg :: a -> Arg a+defaultArg = Arg defaultArgInfo++-- | @xs \`withArgsFrom\` args@ translates @xs@ into a list of 'Arg's,+-- using the elements in @args@ to fill in the non-'unArg' fields.+--+-- Precondition: The two lists should have equal length.++withArgsFrom :: [a] -> [Arg b] -> [Arg a]+xs `withArgsFrom` args =+  zipWith (\x arg -> fmap (const x) arg) xs args++withNamedArgsFrom :: [a] -> [NamedArg b] -> [NamedArg a]+xs `withNamedArgsFrom` args =+  zipWith (\x -> fmap (x <$)) xs args++---------------------------------------------------------------------------+-- * Names+---------------------------------------------------------------------------++class Eq a => Underscore a where+  underscore   :: a+  isUnderscore :: a -> Bool+  isUnderscore = (== underscore)++instance Underscore String where+  underscore = "_"++instance Underscore ByteString where+  underscore = ByteString.pack underscore++instance Underscore Doc where+  underscore = text underscore++---------------------------------------------------------------------------+-- * Named arguments+---------------------------------------------------------------------------++-- | Something potentially carrying a name.+data Named name a =+    Named { nameOf     :: Maybe name+          , namedThing :: a+          }+    deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++-- | Standard naming.+type Named_ = Named NamedName++-- | Standard argument names.+type NamedName = WithOrigin (Ranged ArgName)++-- | Equality of argument names of things modulo 'Range' and 'Origin'.+sameName :: NamedName -> NamedName -> Bool+sameName = (==) `on` (rangedThing . woThing)++unnamed :: a -> Named name a+unnamed = Named Nothing++isUnnamed :: Named name a -> Maybe a+isUnnamed = \case+  Named Nothing a -> Just a+  Named Just{}  a -> Nothing++named :: name -> a -> Named name a+named = Named . Just++userNamed :: Ranged ArgName -> a -> Named_ a+userNamed = Named . Just . WithOrigin UserWritten++-- | Accessor/editor for the 'nameOf' component.+class LensNamed a where+  -- | The type of the name+  type NameOf a+  lensNamed :: Lens' a (Maybe (NameOf a))++  -- Lenses lift through decorations:+  default lensNamed :: (Decoration f, LensNamed b, NameOf b ~ NameOf a, f b ~ a) => Lens' a (Maybe (NameOf a))+  lensNamed = traverseF . lensNamed++instance LensNamed a => LensNamed (Arg a) where+  type NameOf (Arg a) = NameOf a++instance LensNamed (Maybe a) where+  type NameOf (Maybe a) = a+  lensNamed = id++instance LensNamed (Named name a) where+  type NameOf (Named name a) = name++  lensNamed f (Named mn a) = f mn <&> \ mn' -> Named mn' a++getNameOf :: LensNamed a => a -> Maybe (NameOf a)+getNameOf a = a ^. lensNamed++setNameOf :: LensNamed a => Maybe (NameOf a) -> a -> a+setNameOf = set lensNamed++mapNameOf :: LensNamed a => (Maybe (NameOf a) -> Maybe (NameOf a)) -> a -> a+mapNameOf = over lensNamed++bareNameOf :: (LensNamed a, NameOf a ~ NamedName) => a -> Maybe ArgName+bareNameOf a = rangedThing . woThing <$> getNameOf a++bareNameWithDefault :: (LensNamed a, NameOf a ~ NamedName) => ArgName -> a -> ArgName+bareNameWithDefault x a = maybe x (rangedThing . woThing) $ getNameOf a++-- | Equality of argument names of things modulo 'Range' and 'Origin'.+namedSame :: (LensNamed a, LensNamed b, NameOf a ~ NamedName, NameOf b ~ NamedName) => a -> b -> Bool+namedSame a b = case (getNameOf a, getNameOf b) of+  (Nothing, Nothing) -> True+  (Just x , Just y ) -> sameName x y+  _ -> False++-- | Does an argument @arg@ fit the shape @dom@ of the next expected argument?+--+--   The hiding has to match, and if the argument has a name, it should match+--   the name of the domain.+--+--   'Nothing' should be '__IMPOSSIBLE__', so use as+--   @@+--     fromMaybe __IMPOSSIBLE__ $ fittingNamedArg arg dom+--   @@+--+fittingNamedArg+  :: ( LensNamed arg, NameOf arg ~ NamedName, LensHiding arg+     , LensNamed dom, NameOf dom ~ NamedName, LensHiding dom )+  => arg -> dom -> Maybe Bool+fittingNamedArg arg dom+    | not $ sameHiding arg dom = no+    | visible arg              = yes+    | otherwise =+        caseMaybe (bareNameOf arg) yes        $ \ x ->+        caseMaybe (bareNameOf dom) impossible $ \ y ->+        return $ x == y+  where+    yes = return True+    no  = return False+    impossible = Nothing++-- Standard instances for 'Named':++instance Decoration (Named name) where+  traverseF f (Named n a) = Named n <$> f a++instance HasRange a => HasRange (Named name a) where+    getRange = getRange . namedThing++instance SetRange a => SetRange (Named name a) where+  setRange r = fmap $ setRange r++instance (KillRange name, KillRange a) => KillRange (Named name a) where+  killRange (Named n a) = Named (killRange n) (killRange a)++-- instance Show a => Show (Named_ a) where+--     show (Named Nothing a)  = show a+--     show (Named (Just n) a) = rawNameToString (rangedThing n) ++ " = " ++ show a++-- -- Defined in Concrete.Pretty+-- instance Pretty a => Pretty (Named_ a) where+--     pretty (Named Nothing a)  = pretty a+--     pretty (Named (Just n) a) = text (rawNameToString (rangedThing n)) <+> "=" <+> pretty a++instance (NFData name, NFData a) => NFData (Named name a) where+  rnf (Named a b) = rnf a `seq` rnf b++instance Pretty e => Pretty (Named_ e) where+  prettyPrec p (Named nm e)+    | Just s <- bareNameOf nm = mparens (p > 0) $ sep [ text s <+> "=", pretty e ]+    | otherwise               = prettyPrec p e++-- | Only 'Hidden' arguments can have names.+type NamedArg a = Arg (Named_ a)++-- | Get the content of a 'NamedArg'.+namedArg :: NamedArg a -> a+namedArg = namedThing . unArg++defaultNamedArg :: a -> NamedArg a+defaultNamedArg = unnamedArg defaultArgInfo++unnamedArg :: ArgInfo -> a -> NamedArg a+unnamedArg info = Arg info . unnamed++-- | The functor instance for 'NamedArg' would be ambiguous,+--   so we give it another name here.+updateNamedArg :: (a -> b) -> NamedArg a -> NamedArg b+updateNamedArg = fmap . fmap++updateNamedArgA :: Applicative f => (a -> f b) -> NamedArg a -> f (NamedArg b)+updateNamedArgA = traverse . traverse++-- | @setNamedArg a b = updateNamedArg (const b) a@+setNamedArg :: NamedArg a -> b -> NamedArg b+setNamedArg a b = (b <$) <$> a++-- ** ArgName++-- | Names in binders and arguments.+type ArgName = String++argNameToString :: ArgName -> String+argNameToString = id++stringToArgName :: String -> ArgName+stringToArgName = id++appendArgNames :: ArgName -> ArgName -> ArgName+appendArgNames = (++)++---------------------------------------------------------------------------+-- * Range decoration.+---------------------------------------------------------------------------++-- | Thing with range info.+data Ranged a = Ranged+  { rangeOf     :: Range+  , rangedThing :: a+  }+  deriving (Show, Functor, Foldable, Traversable)++-- | Thing with no range info.+unranged :: a -> Ranged a+unranged = Ranged noRange++-- | Ignores range.+instance Pretty a => Pretty (Ranged a) where+  pretty = pretty . rangedThing++-- | Ignores range.+instance Eq a => Eq (Ranged a) where+  (==) = (==) `on` rangedThing++-- | Ignores range.+instance Ord a => Ord (Ranged a) where+  compare = compare `on` rangedThing++instance HasRange (Ranged a) where+  getRange = rangeOf++instance KillRange (Ranged a) where+  killRange (Ranged _ x) = Ranged noRange x++instance Decoration Ranged where+  traverseF f (Ranged r x) = Ranged r <$> f x++-- | Ranges are not forced.++instance NFData a => NFData (Ranged a) where+  rnf (Ranged _ a) = rnf a++---------------------------------------------------------------------------+-- * Raw names (before parsing into name parts).+---------------------------------------------------------------------------++-- | A @RawName@ is some sort of string.+type RawName = String++rawNameToString :: RawName -> String+rawNameToString = id++stringToRawName :: String -> RawName+stringToRawName = id++-- | String with range info.+type RString = Ranged RawName++---------------------------------------------------------------------------+-- * Further constructor and projection info+---------------------------------------------------------------------------++-- | Where does the 'ConP' or 'Con' come from?+data ConOrigin+  = ConOSystem  -- ^ Inserted by system or expanded from an implicit pattern.+  | ConOCon     -- ^ User wrote a constructor (pattern).+  | ConORec     -- ^ User wrote a record (pattern).+  | ConOSplit   -- ^ Generated by interactive case splitting.+  deriving (Show, Eq, Ord, Enum, Bounded, Generic)++instance NFData ConOrigin++instance KillRange ConOrigin where+  killRange = id++-- | Prefer user-written over system-inserted.+bestConInfo :: ConOrigin -> ConOrigin -> ConOrigin+bestConInfo ConOSystem o = o+bestConInfo o _ = o++-- | Where does a projection come from?+data ProjOrigin+  = ProjPrefix    -- ^ User wrote a prefix projection.+  | ProjPostfix   -- ^ User wrote a postfix projection.+  | ProjSystem    -- ^ Projection was generated by the system.+  deriving (Show, Eq, Ord, Enum, Bounded, Generic)++instance NFData ProjOrigin++instance KillRange ProjOrigin where+  killRange = id++---------------------------------------------------------------------------+-- * Infixity, access, abstract, etc.+---------------------------------------------------------------------------++-- | Functions can be defined in both infix and prefix style. See+--   'Agda.Syntax.Concrete.LHS'.+data IsInfix = InfixDef | PrefixDef+    deriving (Show, Eq, Ord)++-- ** private blocks, public imports++-- | Access modifier.+data Access+  = PrivateAccess KwRange Origin+      -- ^ Store the 'Origin' of the private block that lead to this qualifier.+      --   This is needed for more faithful printing of declarations.+      --   'KwRange' is the range of the @private@ keyword.+  | PublicAccess+    deriving (Show, Eq, Ord)++instance Pretty Access where+  pretty = text . \case+    PrivateAccess _ _ -> "private"+    PublicAccess      -> "public"++instance NFData Access where+  rnf _ = ()++instance HasRange Access where+  getRange _ = noRange++instance KillRange Access where+  killRange = id++privateAccessInserted :: Access+privateAccessInserted = PrivateAccess empty Inserted++-- ** abstract blocks++-- | Abstract or concrete.+data IsAbstract = AbstractDef | ConcreteDef+    deriving (Show, Eq, Ord, Generic)++-- | Semigroup computes if any of several is an 'AbstractDef'.+instance Semigroup IsAbstract where+  AbstractDef <> _ = AbstractDef+  ConcreteDef <> a = a++-- | Default is 'ConcreteDef'.+instance Monoid IsAbstract where+  mempty  = ConcreteDef+  mappend = (<>)++instance Boolean IsAbstract where+  fromBool True  = AbstractDef+  fromBool False = ConcreteDef++instance IsBool IsAbstract where+  toBool AbstractDef = True+  toBool ConcreteDef = False++instance KillRange IsAbstract where+  killRange = id++instance NFData IsAbstract++class LensIsAbstract a where+  lensIsAbstract :: Lens' a IsAbstract++instance LensIsAbstract IsAbstract where+  lensIsAbstract = id++-- | Is any element of a collection an 'AbstractDef'.+class AnyIsAbstract a where+  anyIsAbstract :: a -> IsAbstract++  default anyIsAbstract :: (Foldable t, AnyIsAbstract b, t b ~ a) => a -> IsAbstract+  anyIsAbstract = Fold.foldMap anyIsAbstract++instance AnyIsAbstract IsAbstract where+  anyIsAbstract = id++instance AnyIsAbstract a => AnyIsAbstract [a] where+instance AnyIsAbstract a => AnyIsAbstract (Maybe a) where++-- ** instance blocks++-- | Is this definition eligible for instance search?+data IsInstance+  = InstanceDef KwRange  -- ^ Range of the @instance@ keyword.+  | NotInstanceDef+    deriving (Show, Eq, Ord)++instance KillRange IsInstance where+  killRange = \case+    InstanceDef _    -> InstanceDef empty+    i@NotInstanceDef -> i++instance HasRange IsInstance where+  getRange = \case+    InstanceDef r  -> getRange r+    NotInstanceDef -> noRange++instance NFData IsInstance where+  rnf (InstanceDef _) = ()+  rnf NotInstanceDef  = ()++-- ** macro blocks++-- | Is this a macro definition?+data IsMacro = MacroDef | NotMacroDef+  deriving (Show, Eq, Ord, Generic)++instance KillRange IsMacro where killRange = id+instance HasRange  IsMacro where getRange _ = noRange++instance NFData IsMacro++-- ** opaque blocks++-- | Opaque or transparent.+data IsOpaque+  = OpaqueDef {-# UNPACK #-} !OpaqueId+    -- ^ This definition is opaque, and it is guarded by the given+    -- opaque block.+  | TransparentDef+  deriving (Show, Eq, Ord, Generic)++instance KillRange IsOpaque where+  killRange = id++instance NFData IsOpaque++class LensIsOpaque a where+  lensIsOpaque :: Lens' a IsOpaque++instance LensIsOpaque IsOpaque where+  lensIsOpaque = id++-- | Monoid representing the combined opaque blocks of a 'Foldable'+-- containing possibly-opaque declarations.+data JointOpacity+  = UniqueOpaque    {-# UNPACK #-} !OpaqueId+  -- ^ Every definition agrees on what opaque block they belong to.+  | DifferentOpaque !(HashSet OpaqueId)+  -- ^ More than one opaque block was found.+  | NoOpaque+  -- ^ Nothing here is opaque.++instance Semigroup JointOpacity where+  UniqueOpaque i <> UniqueOpaque j+    | i == j    = UniqueOpaque i+    | otherwise = DifferentOpaque (HashSet.fromList [i, j])++  DifferentOpaque is <> UniqueOpaque j     = DifferentOpaque (HashSet.insert j is)+  UniqueOpaque i     <> DifferentOpaque js = DifferentOpaque (HashSet.insert i js)+  DifferentOpaque is <> DifferentOpaque js = DifferentOpaque (HashSet.union is js)++  NoOpaque <> x = x+  x <> NoOpaque = x++instance Monoid JointOpacity where+  mappend = (<>)+  mempty = NoOpaque++class AllAreOpaque a where+  jointOpacity :: a -> JointOpacity++  default jointOpacity :: (Foldable t, AllAreOpaque b, t b ~ a) => a -> JointOpacity+  jointOpacity = Fold.foldMap jointOpacity++instance AllAreOpaque IsOpaque where+  jointOpacity = \case+    TransparentDef -> NoOpaque+    OpaqueDef i    -> UniqueOpaque i++instance AllAreOpaque a => AllAreOpaque [a] where+instance AllAreOpaque a => AllAreOpaque (Maybe a) where++---------------------------------------------------------------------------+-- * NameId+---------------------------------------------------------------------------++-- | The unique identifier of a name. Second argument is the top-level module+--   identifier.+data NameId = NameId {-# UNPACK #-} !Word64 {-# UNPACK #-} !ModuleNameHash+    deriving (Eq, Ord, Generic, Show)++instance KillRange NameId where+  killRange = id++instance Pretty NameId where+  pretty (NameId n m) = text $ show n ++ "@" ++ show m++instance Enum NameId where+  succ (NameId n m)     = NameId (n + 1) m+  pred (NameId n m)     = NameId (n - 1) m+  toEnum n              = __IMPOSSIBLE__  -- should not be used+  fromEnum (NameId n _) = fromIntegral n++instance NFData NameId where+  rnf (NameId _ _) = ()++instance Hashable NameId where+  {-# INLINE hashWithSalt #-}+  hashWithSalt salt (NameId n (ModuleNameHash m)) = hashWithSalt salt (n, m)++---------------------------------------------------------------------------+-- * Meta variables+---------------------------------------------------------------------------++-- | Meta-variable identifiers use the same structure as 'NameId's.++data MetaId = MetaId+  { metaId     :: {-# UNPACK #-} !Word64+  , metaModule :: {-# UNPACK #-} !ModuleNameHash+  }+  deriving (Eq, Ord, Generic)++instance Pretty MetaId where+  pretty (MetaId n m) =+    text $ "_" ++ show n ++ "@" ++ show (moduleNameHash m)++instance Enum MetaId where+  succ MetaId{..} = MetaId { metaId = succ metaId, .. }+  pred MetaId{..} = MetaId { metaId = pred metaId, .. }++  -- The following functions should not be used.+  toEnum   = __IMPOSSIBLE__+  fromEnum = __IMPOSSIBLE__++-- | The record selectors are not included in the resulting strings.++instance Show MetaId where+  showsPrec p (MetaId n m) = showParen (p > 0) $+    showString "MetaId " .+    showsPrec 11 n .+    showString " " .+    showsPrec 11 m++instance NFData MetaId where+  rnf (MetaId x y) = rnf x `seq` rnf y++instance Hashable MetaId where+  {-# INLINE hashWithSalt #-}+  hashWithSalt salt (MetaId n m) = hashWithSalt salt (n, m)++newtype Constr a = Constr a++-----------------------------------------------------------------------------+-- * Problems+-----------------------------------------------------------------------------++-- | A "problem" consists of a set of constraints and the same constraint can be part of multiple+--   problems.+newtype ProblemId = ProblemId Nat+  deriving (Eq, Ord, Enum, Real, Integral, Num, NFData)++-- This particular Show instance is ok because of the Num instance.+instance Show   ProblemId where show   (ProblemId n) = show n+instance Pretty ProblemId where pretty (ProblemId n) = pretty n++-- | The unique identifier of an opaque block. Second argument is the+-- top-level module identifier.+data OpaqueId = OpaqueId {-# UNPACK #-} !Word64 {-# UNPACK #-} !ModuleNameHash+    deriving (Eq, Ord, Generic, Show)++instance KillRange OpaqueId where+  killRange = id++instance Pretty OpaqueId where+  pretty (OpaqueId n m) = text $ show n ++ "@" ++ show m++instance Enum OpaqueId where+  succ (OpaqueId n m)     = OpaqueId (n + 1) m+  pred (OpaqueId n m)     = OpaqueId (n - 1) m+  toEnum n                = __IMPOSSIBLE__  -- should not be used+  fromEnum (OpaqueId n _) = fromIntegral n++instance NFData OpaqueId where+  rnf (OpaqueId _ _) = ()++instance Hashable OpaqueId where+  {-# INLINE hashWithSalt #-}+  hashWithSalt salt (OpaqueId n (ModuleNameHash m)) = hashWithSalt salt (n, m)++------------------------------------------------------------------------+-- * Placeholders (used to parse sections)+------------------------------------------------------------------------++-- | The position of a name part or underscore in a name.++data PositionInName+  = Beginning+    -- ^ The following underscore is at the beginning of the name:+    -- @_foo@.+  | Middle+    -- ^ The following underscore is in the middle of the name:+    -- @foo_bar@.+  | End+    -- ^ The following underscore is at the end of the name: @foo_@.+  deriving (Show, Eq, Ord)++-- | Placeholders are used to represent the underscores in a section.++data MaybePlaceholder e+  = Placeholder !PositionInName+  | NoPlaceholder !(Strict.Maybe PositionInName) e+    -- ^ The second argument is used only (but not always) for name+    -- parts other than underscores.+  deriving (Eq, Ord, Functor, Foldable, Traversable, Show)++-- | An abbreviation: @noPlaceholder = 'NoPlaceholder'+-- 'Strict.Nothing'@.++noPlaceholder :: e -> MaybePlaceholder e+noPlaceholder = NoPlaceholder Strict.Nothing++instance HasRange a => HasRange (MaybePlaceholder a) where+  getRange Placeholder{}       = noRange+  getRange (NoPlaceholder _ e) = getRange e++instance KillRange a => KillRange (MaybePlaceholder a) where+  killRange p@Placeholder{}     = p+  killRange (NoPlaceholder p e) = killRangeN (NoPlaceholder p) e++instance NFData a => NFData (MaybePlaceholder a) where+  rnf (Placeholder _)     = ()+  rnf (NoPlaceholder _ a) = rnf a++---------------------------------------------------------------------------+-- * Interaction meta variables+---------------------------------------------------------------------------++newtype InteractionId = InteractionId { interactionId :: Nat }+    deriving ( Eq+             , Ord+             , Show+             , Num+             , Integral+             , Real+             , Enum+             , NFData+             )++instance Pretty InteractionId where+    pretty (InteractionId i) = text $ "?" ++ show i++instance KillRange InteractionId where killRange = id++---------------------------------------------------------------------------+-- * Fixity+---------------------------------------------------------------------------++-- | Precedence levels for operators.++type PrecedenceLevel = Double++data FixityLevel+  = Unrelated+    -- ^ No fixity declared.+  | Related !PrecedenceLevel+    -- ^ Fixity level declared as the number.+  deriving (Eq, Ord, Show)++instance Null FixityLevel where+  null Unrelated = True+  null Related{} = False+  empty = Unrelated++instance NFData FixityLevel where+  rnf Unrelated   = ()+  rnf (Related _) = ()++instance Pretty FixityLevel where+  pretty = \case+    Unrelated  -> empty+    Related d  -> text $ toStringWithoutDotZero d++-- | Associativity.++data Associativity = NonAssoc | LeftAssoc | RightAssoc+   deriving (Eq, Ord, Show)++instance Pretty Associativity where+  pretty = \case+    LeftAssoc  -> "infixl"+    RightAssoc -> "infixr"+    NonAssoc   -> "infix"++-- | Fixity of operators.++data Fixity = Fixity+  { fixityRange :: Range+    -- ^ Range of the whole fixity declaration.+  , fixityLevel :: !FixityLevel+  , fixityAssoc :: !Associativity+  }+  deriving Show++noFixity :: Fixity+noFixity = Fixity noRange Unrelated NonAssoc++defaultFixity :: Fixity+defaultFixity = Fixity noRange (Related 20) NonAssoc++-- For @instance Pretty Fixity@, see Agda.Syntax.Concrete.Pretty++instance Eq Fixity where+  f1 == f2 = compare f1 f2 == EQ++instance Ord Fixity where+  compare = compare `on` (fixityLevel &&& fixityAssoc)++instance Null Fixity where+  null  = null . fixityLevel+  empty = noFixity++instance HasRange Fixity where+  getRange = fixityRange++instance KillRange Fixity where+  killRange f = f { fixityRange = noRange }++instance NFData Fixity where+  rnf (Fixity _ _ _) = ()     -- Ranges are not forced, the other fields are strict.++instance Pretty Fixity where+  pretty (Fixity _ level ass) = case level of+    Unrelated  -> empty+    Related{}  -> pretty ass <+> pretty level++-- ** Notation coupled with 'Fixity'++-- | The notation is handled as the fixity in the renamer.+--   Hence, they are grouped together in this type.+data Fixity' = Fixity'+    { theFixity   :: !Fixity+    , theNotation :: Notation+    , theNameRange :: Range+      -- ^ Range of the name in the fixity declaration+      --   (used for correct highlighting, see issue #2140).+    }+  deriving Show++noFixity' :: Fixity'+noFixity' = Fixity' noFixity noNotation noRange++instance Eq Fixity' where+  Fixity' f n _ == Fixity' f' n' _ = f == f' && n == n'++instance Null Fixity' where+  null (Fixity' f n _) = null f && null n+  empty = noFixity'++instance NFData Fixity' where+  rnf (Fixity' _ a _) = rnf a++instance KillRange Fixity' where+  killRange (Fixity' f n r) = killRangeN Fixity' f n r++-- lenses++_fixityAssoc :: Lens' Fixity Associativity+_fixityAssoc f r = f (fixityAssoc r) <&> \x -> r { fixityAssoc = x }++_fixityLevel :: Lens' Fixity FixityLevel+_fixityLevel f r = f (fixityLevel r) <&> \x -> r { fixityLevel = x }++-- Lens focusing on Fixity++class LensFixity a where+  lensFixity :: Lens' a Fixity++instance LensFixity Fixity where+  lensFixity = id++instance LensFixity Fixity' where+  lensFixity f fix' = f (theFixity fix') <&> \ fx -> fix' { theFixity = fx }++-- Lens focusing on Fixity'++class LensFixity' a where+  lensFixity' :: Lens' a Fixity'++instance LensFixity' Fixity' where+  lensFixity' = id++---------------------------------------------------------------------------+-- * Import directive+---------------------------------------------------------------------------++-- | The things you are allowed to say when you shuffle names between name+--   spaces (i.e. in @import@, @namespace@, or @open@ declarations).+data ImportDirective' n m = ImportDirective+  { importDirRange :: Range+  , using          :: Using' n m+  , hiding         :: HidingDirective' n m+  , impRenaming    :: RenamingDirective' n m+  , publicOpen     :: Maybe KwRange+      -- ^ Only for @open@. Exports the opened names from the current module.+      --   Range of the @public@ keyword.+  }+  deriving (Eq, Show)++type HidingDirective'   n m = [ImportedName' n m]+type RenamingDirective' n m = [Renaming' n m]++-- | @null@ for import directives holds when everything is imported unchanged+--   (no names are hidden or renamed).+instance Null (ImportDirective' n m) where+  null = \case+    ImportDirective _ UseEverything [] [] _ -> True+    _ -> False+  empty = defaultImportDir++instance (HasRange n, HasRange m) => Semigroup (ImportDirective' n m) where+  i1 <> i2 = ImportDirective+    { importDirRange = fuseRange i1 i2+    , using          = using i1 <> using i2+    , hiding         = hiding i1 ++ hiding i2+    , impRenaming    = impRenaming i1 ++ impRenaming i2+    , publicOpen     = publicOpen i1 <|> publicOpen i2+    }++instance (HasRange n, HasRange m) => Monoid (ImportDirective' n m) where+  mempty  = empty+  mappend = (<>)++-- | Default is directive is @private@ (use everything, but do not export).+defaultImportDir :: ImportDirective' n m+defaultImportDir = ImportDirective noRange UseEverything [] [] Nothing++-- | @isDefaultImportDir@ implies @null@, but not the other way round.+isDefaultImportDir :: ImportDirective' n m -> Bool+isDefaultImportDir dir = null dir && null (publicOpen dir)++-- | The @using@ clause of import directive.+data Using' n m+  = UseEverything              -- ^ No @using@ clause given.+  | Using [ImportedName' n m]  -- ^ @using@ the specified names.+  deriving (Eq, Show)++instance Semigroup (Using' n m) where+  UseEverything <> u             = u+  u             <> UseEverything = u+  Using xs      <> Using ys      = Using (xs ++ ys)++instance Monoid (Using' n m) where+  mempty  = UseEverything+  mappend = (<>)++instance Null (Using' n m) where+  null UseEverything = True+  null Using{}       = False+  empty = mempty++mapUsing :: ([ImportedName' n1 m1] -> [ImportedName' n2 m2]) -> Using' n1 m1 -> Using' n2 m2+mapUsing f = \case+  UseEverything -> UseEverything+  Using xs      -> Using $ f xs++-- | An imported name can be a module or a defined name.+data ImportedName' n m+  = ImportedModule  m  -- ^ Imported module name of type @m@.+  | ImportedName    n  -- ^ Imported name of type @n@.+  deriving (Eq, Ord, Show)++fromImportedName :: ImportedName' a a -> a+fromImportedName = \case+  ImportedModule x -> x+  ImportedName   x -> x++setImportedName :: ImportedName' a a -> a -> ImportedName' a a+setImportedName (ImportedName   x) y = ImportedName   y+setImportedName (ImportedModule x) y = ImportedModule y++-- | Like 'partitionEithers'.+partitionImportedNames :: [ImportedName' n m] -> ([n], [m])+partitionImportedNames = flip foldr ([], []) $ \case+  ImportedName   n -> first  (n:)+  ImportedModule m -> second (m:)++-- -- Defined in Concrete.Pretty+-- instance (Pretty n, Pretty m) => Pretty (ImportedName' n m) where+--   pretty (ImportedModule x) = "module" <+> pretty x+--   pretty (ImportedName   x) = pretty x++-- instance (Show n, Show m) => Show (ImportedName' n m) where+--   show (ImportedModule x) = "module " ++ show x+--   show (ImportedName   x) = show x++data Renaming' n m = Renaming+  { renFrom    :: ImportedName' n m+    -- ^ Rename from this name.+  , renTo      :: ImportedName' n m+    -- ^ To this one.  Must be same kind as 'renFrom'.+  , renFixity  :: Maybe Fixity+    -- ^ New fixity of 'renTo' (optional).+  , renToRange :: Range+    -- ^ The range of the \"to\" keyword.  Retained for highlighting purposes.+  }+  deriving (Eq, Show)++-- ** HasRange instances++instance (HasRange a, HasRange b) => HasRange (ImportDirective' a b) where+  getRange = importDirRange++instance (HasRange a, HasRange b) => HasRange (Using' a b) where+  getRange (Using  xs) = getRange xs+  getRange UseEverything = noRange++instance (HasRange a, HasRange b) => HasRange (Renaming' a b) where+  getRange r = getRange (renFrom r, renTo r)++instance (HasRange a, HasRange b) => HasRange (ImportedName' a b) where+  getRange (ImportedName   x) = getRange x+  getRange (ImportedModule x) = getRange x++-- ** KillRange instances++instance (KillRange a, KillRange b) => KillRange (ImportDirective' a b) where+  killRange (ImportDirective _ u h r p) =+    killRangeN (\u h r -> ImportDirective noRange u h r (p $> empty)) u h r++instance (KillRange a, KillRange b) => KillRange (Using' a b) where+  killRange (Using  i) = killRangeN Using  i+  killRange UseEverything = UseEverything++instance (KillRange a, KillRange b) => KillRange (Renaming' a b) where+  killRange (Renaming i n mf _to) = killRangeN (\ i n mf -> Renaming i n mf noRange) i n mf++instance (KillRange a, KillRange b) => KillRange (ImportedName' a b) where+  killRange (ImportedModule n) = killRangeN ImportedModule n+  killRange (ImportedName   n) = killRangeN ImportedName   n++-- ** Pretty instances++instance (Pretty a, Pretty b) => Pretty (ImportDirective' a b) where+    pretty i =+        sep [ public (publicOpen i)+            , pretty $ using i+            , prettyHiding $ hiding i+            , rename $ impRenaming i+            ]+        where+            public Just{}  = "public"+            public Nothing = empty++            prettyHiding [] = empty+            prettyHiding xs = "hiding" <+> parens (fsep $ punctuate ";" $ map pretty xs)++            rename [] = empty+            rename xs = hsep [ "renaming"+                             , parens $ fsep $ punctuate ";" $ map pretty xs+                             ]++instance (Pretty a, Pretty b) => Pretty (Using' a b) where+    pretty UseEverything = empty+    pretty (Using xs)    =+        "using" <+> parens (fsep $ punctuate ";" $ map pretty xs)++instance (Pretty a, Pretty b) => Pretty (ImportedName' a b) where+    pretty (ImportedName   a) = pretty a+    pretty (ImportedModule b) = "module" <+> pretty b++instance (Pretty a, Pretty b) => Pretty (Renaming' a b) where+    pretty (Renaming from to mfx _r) = hsep+      [ pretty from+      , "to"+      , maybe empty pretty mfx+      , case to of+          ImportedName a   -> pretty a+          ImportedModule b -> pretty b   -- don't print "module" here+      ]++-- ** NFData instances++-- | Ranges are not forced.++instance (NFData a, NFData b) => NFData (ImportDirective' a b) where+  rnf (ImportDirective _ a b c _) = rnf a `seq` rnf b `seq` rnf c++instance (NFData a, NFData b) => NFData (Using' a b) where+  rnf UseEverything = ()+  rnf (Using a)     = rnf a++-- | Ranges are not forced.++instance (NFData a, NFData b) => NFData (Renaming' a b) where+  rnf (Renaming a b c _) = rnf a `seq` rnf b `seq` rnf c++instance (NFData a, NFData b) => NFData (ImportedName' a b) where+  rnf (ImportedModule a) = rnf a+  rnf (ImportedName a)   = rnf a++-----------------------------------------------------------------------------+-- * Termination+-----------------------------------------------------------------------------++-- | Termination check? (Default = TerminationCheck).+data TerminationCheck m+  = TerminationCheck+    -- ^ Run the termination checker.+  | NoTerminationCheck+    -- ^ Skip termination checking (unsafe).+  | NonTerminating+    -- ^ Treat as non-terminating.+  | Terminating+    -- ^ Treat as terminating (unsafe).  Same effect as 'NoTerminationCheck'.+  | TerminationMeasure Range m+    -- ^ Skip termination checking but use measure instead.+    deriving (Show, Eq, Functor)++instance KillRange m => KillRange (TerminationCheck m) where+  killRange (TerminationMeasure _ m) = TerminationMeasure noRange (killRange m)+  killRange t                        = t++instance NFData a => NFData (TerminationCheck a) where+  rnf TerminationCheck         = ()+  rnf NoTerminationCheck       = ()+  rnf NonTerminating           = ()+  rnf Terminating              = ()+  rnf (TerminationMeasure _ a) = rnf a++-----------------------------------------------------------------------------+-- * Positivity+-----------------------------------------------------------------------------++-- | Positivity check? (Default = True).+data PositivityCheck = YesPositivityCheck | NoPositivityCheck+  deriving (Eq, Ord, Show, Bounded, Enum, Generic)++instance KillRange PositivityCheck where+  killRange = id++-- Semigroup and Monoid via conjunction+instance Semigroup PositivityCheck where+  NoPositivityCheck <> _ = NoPositivityCheck+  _ <> NoPositivityCheck = NoPositivityCheck+  _ <> _ = YesPositivityCheck++instance Monoid PositivityCheck where+  mempty  = YesPositivityCheck+  mappend = (<>)++instance NFData PositivityCheck++-----------------------------------------------------------------------------+-- * Universe checking+-----------------------------------------------------------------------------++-- | Universe check? (Default is yes).+data UniverseCheck = YesUniverseCheck | NoUniverseCheck+  deriving (Eq, Ord, Show, Bounded, Enum, Generic)++instance KillRange UniverseCheck where+  killRange = id++instance NFData UniverseCheck++-----------------------------------------------------------------------------+-- * Coverage+-----------------------------------------------------------------------------++-- | 'Range' of the CATCHALL pragma for a clause, if any.+--   'Nothing' means no such pragma.+data Catchall = YesCatchall Range | NoCatchall+  deriving (Eq, Show, Generic)++-- | Composition is left-biased, taking the left 'Range' if both have one.+instance Semigroup Catchall where+  NoCatchall         <> c                   = c+  c                  <> NoCatchall          = c+  c1@(YesCatchall r) <> c2@(YesCatchall r') = if null r then c2 else c1++instance Monoid Catchall where+  mempty = empty++instance Null Catchall where+  empty = NoCatchall++instance KillRange Catchall where+  killRange = \case+    YesCatchall _ -> YesCatchall noRange+    NoCatchall    -> NoCatchall++instance NFData Catchall where+  rnf = \case+    YesCatchall _ -> ()+    NoCatchall    -> ()++-- | Coverage check? (Default is yes).+data CoverageCheck = YesCoverageCheck | NoCoverageCheck+  deriving (Eq, Ord, Show, Bounded, Enum, Generic)++instance KillRange CoverageCheck where+  killRange = id++-- Semigroup and Monoid via conjunction+instance Semigroup CoverageCheck where+  NoCoverageCheck <> _ = NoCoverageCheck+  _ <> NoCoverageCheck = NoCoverageCheck+  _ <> _ = YesCoverageCheck++instance Monoid CoverageCheck where+  mempty  = YesCoverageCheck+  mappend = (<>)++instance NFData CoverageCheck++-----------------------------------------------------------------------------+-- * Rewrite Directives on the LHS+-----------------------------------------------------------------------------++-- | @RewriteEqn' qn p e@ represents the @rewrite@ and irrefutable @with@+--   clauses of the LHS.+--   @qn@ stands for the QName of the auxiliary function generated to implement the feature+--   @nm@ is the type of names for pattern variables+--   @p@  is the type of patterns+--   @e@  is the type of expressions++data RewriteEqn' qn nm p e+  = Rewrite (List1 (qn, e))             -- ^ @rewrite e@+  | Invert qn (List1 (Named nm (p, e))) -- ^ @with p <- e in eq@+  | LeftLet (List1 (p, e))              -- ^ @using p <- e@+  deriving (Eq, Show, Functor, Foldable, Traversable)++instance (NFData qn, NFData nm, NFData p, NFData e) => NFData (RewriteEqn' qn nm p e) where+  rnf = \case+    Rewrite es    -> rnf es+    Invert qn pes -> rnf (qn, pes)+    LeftLet pes   -> rnf pes++instance (Pretty nm, Pretty p, Pretty e) => Pretty (RewriteEqn' qn nm p e) where+  pretty = \case+    Rewrite es   -> prefixedThings (text "rewrite") $ List1.toList (pretty . snd <$> es)+    LeftLet pes  -> prefixedThings (text "using") [pretty p <+> "<-" <+> pretty e | (p, e) <- List1.toList pes]+    Invert _ pes -> prefixedThings (text "invert") $ List1.toList (namedWith <$> pes) where++      namedWith (Named nm (p, e)) =+        let patexp = pretty p <+> "<-" <+> pretty e in+        case nm of+          Nothing -> patexp+          Just nm -> pretty nm <+> ":" <+> patexp++instance (HasRange qn, HasRange nm, HasRange p, HasRange e) => HasRange (RewriteEqn' qn nm p e) where+  getRange = \case+    Rewrite es    -> getRange es+    Invert qn pes -> getRange (qn, pes)+    LeftLet pes   -> getRange pes++instance (KillRange qn, KillRange nm, KillRange e, KillRange p) => KillRange (RewriteEqn' qn nm p e) where+  killRange = \case+    Rewrite es    -> killRangeN Rewrite es+    Invert qn pes -> killRangeN Invert qn pes+    LeftLet pes   -> killRangeN LeftLet pes++-----------------------------------------------------------------------------+-- * Information on expanded ellipsis (@...@)+-----------------------------------------------------------------------------++-- ^ When the ellipsis in a clause is expanded, we remember that we+--   did so. We also store the number of with-arguments that are+--   included in the expanded ellipsis.+data ExpandedEllipsis+  = ExpandedEllipsis+  { ellipsisRange :: Range+  , ellipsisWithArgs :: Int+  }+  | NoEllipsis+  deriving (Show, Eq)++instance Null ExpandedEllipsis where+  empty = NoEllipsis++instance Semigroup ExpandedEllipsis where+  NoEllipsis <> e          = e+  e          <> NoEllipsis = e+  (ExpandedEllipsis r1 k1) <> (ExpandedEllipsis r2 k2) = ExpandedEllipsis (r1 <> r2) (k1 + k2)++instance Monoid ExpandedEllipsis where+  mempty  = NoEllipsis+  mappend = (<>)++instance KillRange ExpandedEllipsis where+  killRange (ExpandedEllipsis _ k) = ExpandedEllipsis noRange k+  killRange NoEllipsis             = NoEllipsis++instance NFData ExpandedEllipsis where+  rnf (ExpandedEllipsis _ a) = rnf a+  rnf NoEllipsis             = ()++-- | Notation as provided by the @syntax@ declaration.+type Notation = [NotationPart]++noNotation :: Notation+noNotation = []++-- | Positions of variables in syntax declarations.++data BoundVariablePosition = BoundVariablePosition+  { holeNumber :: !Int+    -- ^ The position (in the left-hand side of the syntax+    -- declaration) of the hole in which the variable is bound,+    -- counting from zero (and excluding parts that are not holes).+    -- For instance, for @syntax Σ A (λ x → B) = B , A , x@ the number+    -- for @x@ is @1@, corresponding to @B@ (@0@ would correspond to+    -- @A@).+  , varNumber :: !Int+    -- ^ The position in the list of variables for this particular+    -- variable, counting from zero, and including wildcards. For+    -- instance, for @syntax F (λ x _ y → A) = y ! A ! x@ the number+    -- for @x@ is @0@, the number for @_@ is @1@, and the number for+    -- @y@ is @2@.+  }+  deriving (Eq, Ord, Show)++-- | Notation parts.++data NotationPart+  = IdPart RString+    -- ^ An identifier part. For instance, for @_+_@ the only+    -- identifier part is @+@.+  | HolePart Range (NamedArg (Ranged Int))+    -- ^ A hole: a place where argument expressions can be written.+    -- For instance, for @_+_@ the two underscores are holes, and for+    -- @syntax Σ A (λ x → B) = B , A , x@ the variables @A@ and @B@+    -- are holes. The number is the position of the hole, counting+    -- from zero. For instance, the number for @A@ is @0@, and the+    -- number for @B@ is @1@.+  | VarPart Range (Ranged BoundVariablePosition)+    -- ^ A bound variable.+    --+    -- The first range is the range of the variable in the right-hand+    -- side of the syntax declaration, and the second range is the+    -- range of the variable in the left-hand side.+  | WildPart (Ranged BoundVariablePosition)+    -- ^ A wildcard (an underscore in binding position).+  deriving Show++instance Eq NotationPart where+  VarPart _ i  == VarPart _ j  = i == j+  HolePart _ x == HolePart _ y = x == y+  WildPart i   == WildPart j   = i == j+  IdPart x     == IdPart y     = x == y+  _            == _            = False++instance Ord NotationPart where+  VarPart _ i  `compare` VarPart _ j  = i `compare` j+  HolePart _ x `compare` HolePart _ y = x `compare` y+  WildPart i   `compare` WildPart j   = i `compare` j+  IdPart x     `compare` IdPart y     = x `compare` y+  VarPart{}    `compare` _            = LT+  _            `compare` VarPart{}    = GT+  HolePart{}   `compare` _            = LT+  _            `compare` HolePart{}   = GT+  WildPart{}   `compare` _            = LT+  _            `compare` WildPart{}   = GT++instance HasRange NotationPart where+  getRange = \case+    IdPart x     -> getRange x+    VarPart r _  -> r+    WildPart i   -> getRange i+    HolePart r _ -> r++instance SetRange NotationPart where+  setRange r = \case+    IdPart x     -> IdPart x+    VarPart _ i  -> VarPart r i+    WildPart i   -> WildPart i+    HolePart _ i -> HolePart r i++instance KillRange NotationPart where+  killRange = \case+    IdPart x     -> IdPart $ killRange x+    VarPart _ i  -> VarPart noRange $ killRange i+    WildPart i   -> WildPart $ killRange i+    HolePart _ x -> HolePart noRange $ killRange x++instance NFData BoundVariablePosition where+  rnf = (`seq` ())++instance NFData NotationPart where+  rnf (VarPart _ a)  = rnf a+  rnf (HolePart _ a) = rnf a+  rnf (WildPart a)   = rnf a+  rnf (IdPart a)     = rnf a
+ src/full/Agda/Syntax/Common/Aspect.hs view
@@ -0,0 +1,181 @@+module Agda.Syntax.Common.Aspect where++import Agda.Syntax.TopLevelModuleName.Boot (TopLevelModuleName')+import Agda.Syntax.Position (Range)+import Agda.Utils.Maybe+import GHC.Generics++import Data.Set (Set)++import Control.DeepSeq++data Induction = Inductive | CoInductive  -- Keep in this order!+  deriving (Eq, Ord, Show)++data Aspect+  = Comment+  | Keyword+  | String+  | Number+  | Hole+  | Symbol                     -- ^ Symbols like forall, =, ->, etc.+  | PrimitiveType              -- ^ Things like Set and Prop.+  | Name (Maybe NameKind) Bool -- ^ Is the name an operator part?+  | Pragma                     -- ^ Text occurring in pragmas that+                               --   does not have a more specific+                               --   aspect.+  | Background                 -- ^ Non-code contents in literate Agda+  | Markup+    -- ^ Delimiters used to separate the Agda code blocks from the+    -- other contents in literate Agda+    deriving (Eq, Show, Generic)++-- | @NameKind@s are figured out during scope checking.++data NameKind+  = Bound                         -- ^ Bound variable.+  | Generalizable                 -- ^ Generalizable variable.+                                  --   (This includes generalizable+                                  --   variables that have been+                                  --   generalized).+  | Constructor Induction         -- ^ Inductive or coinductive constructor.+  | Datatype+  | Field                         -- ^ Record field.+  | Function+  | Module                        -- ^ Module name.+  | Postulate+  | Primitive                     -- ^ Primitive.+  | Record                        -- ^ Record type.+  | Argument                      -- ^ Named argument, like x in {x = v}+  | Macro                         -- ^ Macro.+    deriving (Eq, Show, Generic)++-- | Other aspects, generated by type checking.+--   (These can overlap with each other and with 'Aspect's.)++data OtherAspect+  = Error+  | ErrorWarning+    -- ^ A warning that is considered fatal in the end.+  | DottedPattern+  | UnsolvedMeta+  | UnsolvedConstraint+    -- ^ Unsolved constraint not connected to meta-variable. This+    -- could for instance be an emptyness constraint.+  | TerminationProblem+  | PositivityProblem+  | Deadcode+    -- ^ Used for highlighting unreachable clauses, unreachable RHS+    -- (because of an absurd pattern), etc.+  | ShadowingInTelescope+    -- ^ Used for shadowed repeated variable names in telescopes.+  | CoverageProblem+  | IncompletePattern+    -- ^ When this constructor is used it is probably a good idea to+    -- include a 'note' explaining why the pattern is incomplete.+  | TypeChecks+    -- ^ Code which is being type-checked.+  | MissingDefinition+    -- ^ Function declaration without matching definition.+  | InstanceProblem+      -- ^ Unusable instance etc.++  -- NB: We put CatchallClause and CosmeticProblem last+  -- so that they are overwritten by other,+  -- more important, aspects in the emacs mode.+  | CosmeticProblem+      -- ^ Nothing serious, just a beauty flaw.+  | CatchallClause+  | ConfluenceProblem+    deriving (Eq, Ord, Show, Enum, Bounded, Generic)++-- | Some 'NameKind's are more informative than others.+instance Semigroup NameKind where+  -- During scope-checking of record, we build a constructor+  -- whose arguments (@Bound@ variables) are the fields.+  -- Later, we process them as @Field@s proper.+  Field    <> Bound    = Field+  Bound    <> Field    = Field+  -- -- Projections are special functions.+  -- -- TODO necessary?+  -- Field    <> Function = Field+  -- Function <> Field    = Field+  -- TODO: more overwrites?+  k1 <> k2 | k1 == k2  = k1+           | otherwise = k1 -- TODO: __IMPOSSIBLE__++-- | @NameKind@ in @Name@ can get more precise.+instance Semigroup Aspect where+  Name mk1 op1 <> Name mk2 op2 = Name (unionMaybeWith (<>) mk1 mk2) op1+    -- (op1 || op2) breaks associativity+  a1 <> a2 | a1 == a2  = a1+           | otherwise = a1 -- TODO: __IMPOSSIBLE__++------------------------------------------------------------------------+-- Highlighting information++-- | Syntactic aspects of the code. (These cannot overlap.)++-- | Meta information which can be associated with a+-- character\/character range.++data Aspects = Aspects+  { aspect       :: Maybe Aspect+  , otherAspects :: Set OtherAspect+  , note         :: String+    -- ^ This note, if not null, can be displayed as a tool-tip or+    -- something like that. It should contain useful information about+    -- the range (like the module containing a certain identifier, or+    -- the fixity of an operator).+  , definitionSite :: Maybe DefinitionSite+    -- ^ The definition site of the annotated thing, if applicable and+    --   known.+  , tokenBased :: !TokenBased+    -- ^ Is this entry token-based?+  }+  deriving (Show, Generic)++data DefinitionSite = DefinitionSite+  { defSiteModule :: (TopLevelModuleName' Range)+      -- ^ The defining module.+  , defSitePos    :: Int+      -- ^ The file position in that module. File positions are+      -- counted from 1.+  , defSiteHere   :: Bool+      -- ^ Has this @DefinitionSite@ been created at the defining site of the name?+  , defSiteAnchor :: Maybe String+      -- ^ A pretty name for the HTML linking.+  }+  deriving (Show, Generic)++instance Eq DefinitionSite where+  DefinitionSite m p _ _ == DefinitionSite m' p' _ _ = m == m' && p == p'++-- | Is the highlighting \"token-based\", i.e. based only on+-- information from the lexer?++data TokenBased = TokenBased | NotOnlyTokenBased+  deriving (Eq, Show)++instance Eq Aspects where+  Aspects a o _ d t == Aspects a' o' _ d' t' =+    (a, o, d, t) == (a', o', d', t')++instance NFData Induction where+  rnf Inductive   = ()+  rnf CoInductive = ()++instance NFData NameKind where+  rnf = \case+    Bound         -> ()+    Generalizable -> ()+    Constructor c -> rnf c+    Datatype      -> ()+    Field         -> ()+    Function      -> ()+    Module        -> ()+    Postulate     -> ()+    Primitive     -> ()+    Record        -> ()+    Argument      -> ()+    Macro         -> ()
+ src/full/Agda/Syntax/Common/KeywordRange.hs view
@@ -0,0 +1,41 @@+-- | A abstract 'Range' type dedicated to keyword occurrences in the source.++module Agda.Syntax.Common.KeywordRange+  ( KwRange  -- Do not export the constructor.+  , kwRange+  ) where++import Control.DeepSeq ( NFData(rnf) )++import Agda.Syntax.Common.Pretty+import Agda.Syntax.Position++import Agda.Utils.Null++-- | Range dedicated to a keyword or fixed token sequence.+--+-- Motivation: by lacking a 'SetRange' instance we indicate that it cannot be updated.++newtype KwRange = KwRange { theKwRange :: Range }+  deriving (Eq, Ord, Show, Null)++-- | Create a keyword range.++kwRange :: HasRange a => a -> KwRange+kwRange = KwRange . getRange++-- Instances++instance HasRange KwRange where+  getRange = theKwRange++instance KillRange KwRange where+  killRange _ = empty++-- no SetRange instance!!++instance NFData KwRange where+  rnf _ = ()++instance Pretty KwRange where+  prettyPrec i = prettyPrec i . theKwRange
+ src/full/Agda/Syntax/Common/Pretty.hs view
@@ -0,0 +1,341 @@++{-| Pretty printing functions.+-}+module Agda.Syntax.Common.Pretty+    ( module Agda.Syntax.Common.Pretty+    , module Text.PrettyPrint.Annotated+    -- This re-export can be removed once <GHC-8.4 is dropped.+    , module Data.Semigroup+    ) where++import Prelude hiding (null)++import qualified Data.List as List+import qualified Data.Foldable as Fold+import qualified Data.IntSet as IntSet+import qualified Data.IntMap as IntMap+import qualified Data.Text as T+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.IntSet (IntSet)+import Data.IntMap (IntMap)+import Data.Word (Word64, Word32)+import Data.Text (Text)+import Data.Int (Int32)+import Data.Map (Map)+import Data.Set (Set)++import qualified Text.PrettyPrint.Annotated as P+import Text.PrettyPrint.Annotated hiding+  ( Doc, TextDetails(Str), empty, (<>), sep, fsep, hsep, hcat, vcat, punctuate++  , parens, brackets, braces, quotes, doubleQuotes++  , semi, comma, colon, space, equals, lparen, rparen, lbrack, rbrack+  , lbrace, rbrace+  )++import Data.Semigroup ((<>))++import Agda.Utils.Float+import Agda.Utils.List1 (List1)+import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.Null+import Agda.Utils.Size++import Agda.Syntax.Common.Aspect+import Agda.Syntax.Position+import Agda.Utils.Impossible+import Agda.Utils.FileName+++-- * Pretty class++-- | The type of documents. We use documents annotated by 'Aspects' to+-- record syntactic highlighting information that is generated during+-- pretty-printing.+type Doc = P.Doc Aspects++-- | While 'Show' is for rendering data in Haskell syntax,+--   'Pretty' is for displaying data to the world, i.e., the+--   user and the environment.+--+--   Atomic data has no inner document structure, so just+--   implement 'pretty' as @pretty a = text $ ... a ...@.++class Pretty a where+  pretty      :: a -> Doc+  prettyPrec  :: Int -> a -> Doc+  prettyList  :: [a] -> Doc++  pretty      = prettyPrec 0+  prettyPrec  = const pretty+  prettyList  = brackets . prettyList_++  {-# MINIMAL pretty | prettyPrec #-}++-- | Use instead of 'show' when printing to world.++prettyShow :: Pretty a => a -> String+prettyShow = render . pretty++-- * Pretty instances++instance Pretty Bool    where pretty = text . show+instance Pretty Int     where pretty = text . show+instance Pretty Int32   where pretty = text . show+instance Pretty Integer where pretty = text . show+instance Pretty Word32  where pretty = text . show+instance Pretty Word64  where pretty = text . show+instance Pretty Double  where pretty = text . toStringWithoutDotZero+instance Pretty Text    where pretty = text . T.unpack++instance Pretty Char where+  pretty c = text [c]+  prettyList = text+++-- The equational constraint forces GHC to pick this instance and unify+-- the type variable, instead of deferring selection to when the type of+-- annotations is solved.+instance a ~ Aspects => Pretty (P.Doc a) where+  pretty = id++instance Pretty () where+  pretty _ = P.empty++instance (Pretty a, Pretty b) => Pretty (a, b) where+    pretty (a, b) = parens $ (pretty a <> comma) <+> pretty b++instance Pretty a => Pretty (Maybe a) where+  prettyPrec p Nothing  = P.empty+  prettyPrec p (Just x) = prettyPrec p x++instance Pretty a => Pretty [a] where+  pretty = prettyList++instance Pretty a => Pretty (List1 a) where+  pretty = prettyList . List1.toList++instance Pretty IntSet where+  pretty = prettySet . IntSet.toList++instance Pretty a => Pretty (Set a) where+  pretty = prettySet . Set.toList++instance Pretty a => Pretty (IntMap a) where+  pretty = prettyMap . IntMap.toList++instance (Pretty k, Pretty v) => Pretty (Map k v) where+  pretty = prettyMap . Map.toList++-- Pretty instances for dependencies of this module (to avoid dependency cycles)++instance Pretty AbsolutePath where+  pretty = text . filePath++instance Pretty RangeFile where+  pretty = pretty . rangeFilePath++prettyLineColumn :: Position' a -> Doc+prettyLineColumn (Pn _ _ l c) = pretty l <> dot <> pretty c++instance Pretty a => Pretty (Position' (Strict.Maybe a)) where+  pretty p = case srcFile p of+    Strict.Nothing -> prettyLineColumn p+    Strict.Just f  -> pretty f <> colon <> prettyLineColumn p++instance Pretty PositionWithoutFile where+  pretty = prettyLineColumn++instance Pretty IntervalWithoutFile where+  pretty (Interval () s e)+    | s == e    = start+    | otherwise = start <> "-" <> end+    where+      sl = posLine s+      el = posLine e+      sc = posCol s+      ec = posCol e++      start :: Doc+      start = pretty sl <> dot <> pretty sc++      end :: Doc+        | sl == el  = pretty ec+        | otherwise = pretty el <> dot <> pretty ec++instance Pretty a => Pretty (Interval' (Strict.Maybe a)) where+  pretty i@(Interval f s e) = file <> pretty (Interval () s e)+    where+      file :: Doc+      file = case f of+               Strict.Nothing -> empty+               Strict.Just f  -> pretty f <> colon++instance Pretty a => Pretty (Range' (Strict.Maybe a)) where+  pretty r = maybe empty pretty (rangeToIntervalWithFile r)++instance (Pretty a, HasRange a) => Pretty (PrintRange a) where+  pretty (PrintRange a) = pretty a <+> parens ("at" <+> pretty (getRange a))+++-- * Generalizing the original type from list to Foldable++sep, fsep, hsep, hcat, vcat :: Foldable t => t Doc -> Doc+sep  = P.sep  . Fold.toList+fsep = P.fsep . Fold.toList+hsep = P.hsep . Fold.toList+hcat = P.hcat . Fold.toList+vcat = P.vcat . Fold.toList++punctuate :: Foldable t => Doc -> t Doc -> [Doc]+punctuate d = P.punctuate d . Fold.toList++-- * 'Doc' utilities++vsep :: [Doc] -> Doc+vsep = vcat . List.intersperse ""++pwords :: String -> [Doc]+pwords = map text . words++fwords :: String -> Doc+fwords = fsep . pwords++-- | Separate, but only if both separees are not null.++hsepWith :: Doc -> Doc -> Doc -> Doc+hsepWith sep d1 d2+  | null d2   = d1+  | null d1   = d2+  | otherwise = d1 <+> sep <+> d2++-- | Comma separated list, without the brackets.+prettyList_ :: Pretty a => [a] -> Doc+prettyList_ = fsep . punctuate comma . map pretty++-- | Pretty print a set.+prettySet :: Pretty a => [a] -> Doc+prettySet = braces . prettyList_++-- | Pretty print an association list.+prettyMap :: (Pretty k, Pretty v) => [(k,v)] -> Doc+prettyMap = braces . fsep . punctuate comma . map prettyAssign++-- | Pretty print a single association.+prettyAssign :: (Pretty k, Pretty v) => (k,v) -> Doc+prettyAssign (k, v) = sep [ prettyPrec 1 k <+> hlSymbol "->", nest 2 $ pretty v ]++-- ASR (2016-12-13): In pretty >= 1.1.2.0 the below function 'mparens'+-- is called 'maybeParens'. I didn't use that name due to the issue+-- https://github.com/haskell/pretty/issues/40.++-- | Apply 'parens' to 'Doc' if boolean is true.+mparens :: Bool -> Doc -> Doc+mparens True  = parens+mparens False = id++-- | Only wrap in parens if not 'empty'+parensNonEmpty :: Doc -> Doc+parensNonEmpty d = if null d then empty else parens d++-- | Return 'empty' for empty strings.+textNonEmpty :: String -> Doc+textNonEmpty = \case+  "" -> empty+  s  -> text s++-- | @align max rows@ lays out the elements of @rows@ in two columns,+-- with the second components aligned. The alignment column of the+-- second components is at most @max@ characters to the right of the+-- left-most column.+--+-- Precondition: @max > 0@.++align :: Int -> [(String, Doc)] -> Doc+align max rows =+  vcat $ map (\(s, d) -> text s $$ nest (maxLen + 1) d) $ rows+  where maxLen = maximum $ 0 : filter (< max) (map (length . fst) rows)++-- | Handles strings with newlines properly (preserving indentation)+multiLineText :: String -> Doc+multiLineText = vcat . map text . lines++infixl 6 <?>+-- | @a <?> b = hang a 2 b@+(<?>) :: Doc -> Doc -> Doc+a <?> b = hang a 2 b++-- | @pshow = text . show@+pshow :: Show a => a -> Doc+pshow = text . show++singPlural :: Sized a => a -> c -> c -> c+singPlural xs singular plural = if natSize xs == 1 then singular else plural++pluralS :: Sized a => a -> Doc -> Doc+pluralS xs d = singPlural xs d (d <> "s")++-- | Used for with-like 'telescopes'++prefixedThings :: Doc -> [Doc] -> Doc+prefixedThings kw = \case+  []           -> P.empty+  (doc : docs) -> fsep $ (kw <+> doc) : map (hlSymbol "|" <+>) docs++-- | Attach a simple 'Aspect', rather than a full set of 'Aspects', to a+-- document.+annotateAspect :: Aspect -> Doc -> Doc+annotateAspect a = annotate a' where+  a' = Aspects+    { aspect         = Just a+    , otherAspects   = mempty+    , note           = ""+    , definitionSite = Nothing+    , tokenBased     = TokenBased+    }++-- * Syntax highlighting helpers++hlComment, hlSymbol, hlKeyword, hlString, hlNumber, hlHole, hlPrimitiveType, hlPragma+  :: Doc -> Doc++hlComment       = annotateAspect Comment+hlSymbol        = annotateAspect Symbol+hlKeyword       = annotateAspect Keyword+hlString        = annotateAspect String+hlNumber        = annotateAspect Number+hlHole          = annotateAspect Hole+hlPrimitiveType = annotateAspect PrimitiveType+hlPragma        = annotateAspect Pragma++-- * Delimiter wrappers+--+-- These use the 'Symbol' highlight for the punctuation characters.++parens       :: Doc -> Doc -- ^ Wrap document in @(...)@+brackets     :: Doc -> Doc -- ^ Wrap document in @[...]@+braces       :: Doc -> Doc -- ^ Wrap document in @{...}@+quotes       :: Doc -> Doc -- ^ Wrap document in @\'...\'@+doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@+quotes p       = hlSymbol (char '\'') <> p <> hlSymbol (char '\'')+doubleQuotes p = hlSymbol (char '"') <> p <> hlSymbol (char '"')+parens p       = lparen <> p <> rparen+brackets p     = lbrack <> p <> rbrack+braces p       = lbrace <> p <> rbrace++semi, comma, colon, dot, space, equals, lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc+semi   = hlSymbol $ char ';'+comma  = hlSymbol $ char ','+colon  = hlSymbol $ char ':'+dot    = hlSymbol $ char '.'+space  = hlSymbol $ char ' '+equals = hlSymbol $ char '='+lparen = hlSymbol $ char '('+rparen = hlSymbol $ char ')'+lbrack = hlSymbol $ char '['+rbrack = hlSymbol $ char ']'+lbrace = hlSymbol $ char '{'+rbrace = hlSymbol $ char '}'
+ src/full/Agda/Syntax/Common/Pretty/ANSI.hs view
@@ -0,0 +1,60 @@+module Agda.Syntax.Common.Pretty.ANSI where+import Control.Monad.IO.Class+import Control.Monad++import Text.PrettyPrint.Annotated.HughesPJ (renderDecoratedM)++import Agda.Interaction.Options.HasOptions+import Agda.Interaction.Options.Base+import Agda.Syntax.Common.Aspect+import Agda.Syntax.Common.Pretty+import Agda.Utils.Monad++import System.Console.ANSI+import System.IO++-- | Render an annotated, pretty-printing 'Doc'ument into a string+-- suitable for printing on VT100-compatible terminals.+renderAnsiIO :: Doc -> IO ()+renderAnsiIO = renderDecoratedM start end putStr (putStr "\n") where+  start = maybe mempty (setSGR . aspSGR) . aspect+  end _ = setSGR [Reset]++  aspSGR :: Aspect -> [SGR]+  aspSGR String        = [SetColor Foreground Dull Red]+  aspSGR Number        = [SetColor Foreground Dull Magenta]+  aspSGR PrimitiveType = [SetColor Foreground Dull Blue]+  aspSGR (Name (Just nk) _) = case nk of+    Bound                   -> []+    Generalizable           -> []+    Argument                -> []++    Constructor Inductive   -> [SetColor Foreground Dull Green]+    Constructor CoInductive -> [SetColor Foreground Dull Green]++    Field                   -> [SetColor Foreground Vivid Magenta]++    Module                  -> [SetColor Foreground Vivid Magenta]++    Function                -> [SetColor Foreground Dull Blue]+    Postulate               -> [SetColor Foreground Dull Blue]+    Datatype                -> [SetColor Foreground Dull Blue]+    Record                  -> [SetColor Foreground Dull Blue]+    Primitive               -> [SetColor Foreground Dull Blue]++    Macro                   -> [SetColor Foreground Dull Cyan]+  aspSGR _ = []++putDoc :: (MonadIO m, HasOptions m) => Doc -> m ()+putDoc doc = do+  outputcol <- liftIO (hSupportsANSI stdout)+  wantscol <- commandLineOptions+  let+    col = case optDiagnosticsColour wantscol of+      AutoColour   -> outputcol+      AlwaysColour -> True+      NeverColour  -> False++  liftIO $ if col+    then renderAnsiIO doc+    else putStrLn (render doc)
src/full/Agda/Syntax/Concrete.hs view
@@ -10,12 +10,16 @@   ( -- * Expressions     Expr(..)   , OpApp(..), fromOrdinary-  , OpAppArgs, OpAppArgs'+  , OpAppArgs, OpAppArgs', OpAppArgs0   , module Agda.Syntax.Concrete.Name   , AppView(..), appView, unAppView+  , toNamedArg, unNamedArg   , rawApp, rawAppP   , isSingleIdentifierP, removeParenP   , isPattern, isAbsurdP, isBinderP+  , observeHiding+  , observeRelevance+  , observeModifiers   , exprToPatternWithHoles   , returnExpr     -- * Bindings@@ -34,15 +38,16 @@   , ModuleAssignment(..)   , BoundName(..), mkBoundName_, mkBoundName   , TacticAttribute+  , TacticAttribute'(..)   , Telescope, Telescope1   , lamBindingsToTelescope   , makePi   , mkLam, mkLet, mkTLet     -- * Declarations+  , Declaration(..)+  , isPragma   , RecordDirective(..)-  , isRecordDirective   , RecordDirectives-  , Declaration(..)   , ModuleApplication(..)   , TypeSignature   , TypeSignatureOrInstanceBlock@@ -51,18 +56,17 @@   , AsName'(..), AsName   , OpenShortHand(..), RewriteEqn, WithExpr   , LHS(..), Pattern(..), LHSCore(..)-  , observeHiding-  , observeRelevance-  , observeModifiers   , LamClause(..)-  , RHS, RHS'(..), WhereClause, WhereClause'(..), ExprWhere(..)+  , RHS, RHS'(..)+  , WhereClause, WhereClause'(..), WhereClause_(..), ExprWhere(..)+  , whereClause_   , DoStmt(..)   , Pragma(..)   , Module(..)   , ThingWithFixity(..)   , HoleContent, HoleContent'(..)-  , topLevelModuleName   , spanAllowedBeforeModule+  , ungatherRecordDirectives   )   where @@ -70,9 +74,12 @@  import Control.DeepSeq -import Data.Data        ( Data )+import Data.Bifunctor   ( second )+import Data.DList       ( DList )+import qualified Data.DList as DL+import Data.Function    ( (&) ) import Data.Functor.Identity-import Data.Set         ( Set  )+import Data.Maybe import Data.Text        ( Text ) -- import Data.Traversable ( forM ) @@ -80,6 +87,7 @@  import Agda.Syntax.Position import Agda.Syntax.Common+import Agda.Syntax.Common.Aspect (NameKind) import Agda.Syntax.Fixity import Agda.Syntax.Literal @@ -95,6 +103,9 @@ import qualified Agda.Utils.List1 as List1 import Agda.Utils.List2       ( List2, pattern List2 ) import Agda.Utils.Null+import Agda.Utils.Set1        ( Set1 )+import qualified Agda.Utils.Set1 as Set1+import Agda.Utils.Singleton  import Agda.Utils.Impossible @@ -103,14 +114,14 @@     -- ^ An abstraction inside a special syntax declaration     --   (see Issue 358 why we introduce this).   | Ordinary e-  deriving (Data, Functor, Foldable, Traversable, Eq)+  deriving (Functor, Foldable, Traversable, Eq)  fromOrdinary :: e -> OpApp e -> e fromOrdinary d (Ordinary e) = e fromOrdinary d _            = d  data FieldAssignment' a = FieldAssignment { _nameFieldA :: Name, _exprFieldA :: a }-  deriving (Data, Functor, Foldable, Traversable, Show, Eq)+  deriving (Functor, Foldable, Traversable, Show, Eq)  type FieldAssignment = FieldAssignment' Expr @@ -119,25 +130,25 @@                            , _exprModA      :: [Expr]                            , _importDirModA :: ImportDirective                            }-  deriving (Data, Eq)+  deriving Eq  type RecordAssignment  = Either FieldAssignment ModuleAssignment type RecordAssignments = [RecordAssignment] -nameFieldA :: Lens' Name (FieldAssignment' a)+nameFieldA :: Lens' (FieldAssignment' a) Name nameFieldA f r = f (_nameFieldA r) <&> \x -> r { _nameFieldA = x } -exprFieldA :: Lens' a (FieldAssignment' a)+exprFieldA :: Lens' (FieldAssignment' a) a exprFieldA f r = f (_exprFieldA r) <&> \x -> r { _exprFieldA = x }  -- UNUSED Liang-Ting Chen 2019-07-16---qnameModA :: Lens' QName ModuleAssignment+--qnameModA :: Lens' ModuleAssignment QName --qnameModA f r = f (_qnameModA r) <&> \x -> r { _qnameModA = x } -- --exprModA :: Lens' [Expr] ModuleAssignment --exprModA f r = f (_exprModA r) <&> \x -> r { _exprModA = x } -----importDirModA :: Lens' ImportDirective ModuleAssignment+--importDirModA :: Lens' ModuleAssignment ImportDirective --importDirModA f r = f (_importDirModA r) <&> \x -> r { _importDirModA = x }  -- | Concrete expressions. Should represent exactly what the user wrote.@@ -148,10 +159,10 @@   | Underscore Range (Maybe String)            -- ^ ex: @_@ or @_A_5@   | RawApp Range (List2 Expr)                  -- ^ before parsing operators   | App Range Expr (NamedArg Expr)             -- ^ ex: @e e@, @e {e}@, or @e {x = e}@-  | OpApp Range QName (Set A.Name) OpAppArgs   -- ^ ex: @e + e@+  | OpApp Range QName (Set1 A.Name) OpAppArgs  -- ^ ex: @e + e@                                                -- The 'QName' is possibly ambiguous,                                                -- but it must correspond to one of the names in the set.-  | WithApp Range Expr [Expr]                  -- ^ ex: @e | e1 | .. | en@+  | WithApp Range Expr (List1 Expr)            -- ^ ex: @e | e1 | .. | en@   | HiddenArg Range (Named_ Expr)              -- ^ ex: @{e}@ or @{x=e}@   | InstanceArg Range (Named_ Expr)            -- ^ ex: @{{e}}@ or @{{x=e}}@   | Lam Range (List1 LamBinding) Expr          -- ^ ex: @\\x {y} -> e@ or @\\(x:A){y:B} -> e@@@ -160,17 +171,19 @@       (List1 LamClause)                        -- ^ ex: @\\ { p11 .. p1a -> e1 ; .. ; pn1 .. pnz -> en }@   | Fun Range (Arg Expr) Expr                  -- ^ ex: @e -> e@ or @.e -> e@ (NYI: @{e} -> e@)   | Pi Telescope1 Expr                         -- ^ ex: @(xs:e) -> e@ or @{xs:e} -> e@-  | Rec Range RecordAssignments                -- ^ ex: @record {x = a; y = b}@, or @record { x = a; M1; M2 }@-  | RecUpdate Range Expr [FieldAssignment]     -- ^ ex: @record e {x = a; y = b}@+  | Rec KwRange Range RecordAssignments        -- ^ ex: @record {x = a; y = b}@, or @record { x = a; M1; M2 }@+                                               --   The 'KwRange' is for the @record@ keyword.+  | RecUpdate KwRange Range Expr [FieldAssignment]+                                               -- ^ ex: @record e {x = a; y = b}@+                                               --   The 'KwRange' is for the @record@ keyword.   | Let Range (List1 Declaration) (Maybe Expr) -- ^ ex: @let Ds in e@, missing body when parsing do-notation let   | Paren Range Expr                           -- ^ ex: @(e)@   | IdiomBrackets Range [Expr]                 -- ^ ex: @(| e1 | e2 | .. | en |)@ or @(|)@   | DoBlock Range (List1 DoStmt)               -- ^ ex: @do x <- m1; m2@   | Absurd Range                               -- ^ ex: @()@ or @{}@, only in patterns   | As Range Name Expr                         -- ^ ex: @x\@p@, only in patterns-  | Dot Range Expr                             -- ^ ex: @.p@, only in patterns-  | DoubleDot Range Expr                       -- ^ ex: @..A@, used for parsing @..A -> B@-  | ETel Telescope                             -- ^ only used for printing telescopes+  | Dot KwRange Expr                           -- ^ ex: @.p@, only in patterns+  | DoubleDot KwRange Expr                     -- ^ ex: @..A@, used for parsing @..A -> B@   | Quote Range                                -- ^ ex: @quote@, should be applied to a name   | QuoteTerm Range                            -- ^ ex: @quoteTerm@, should be applied to a term   | Tactic Range Expr                          -- ^ ex: @\@(tactic t)@, used to declare tactic arguments@@ -178,20 +191,37 @@   | DontCare Expr                              -- ^ to print irrelevant things   | Equal Range Expr Expr                      -- ^ ex: @a = b@, used internally in the parser   | Ellipsis Range                             -- ^ @...@, used internally to parse patterns.+  | KnownIdent NameKind QName+    -- ^ An identifier coming from abstract syntax, for which we know a+    -- precise syntactic highlighting class (used in printing).+  | KnownOpApp NameKind Range QName (Set1 A.Name) OpAppArgs+    -- ^ An operator application coming from abstract syntax, for which+    -- we know a precise syntactic highlighting class (used in+    -- printing).   | Generalized Expr-  deriving (Data, Eq)+  deriving Eq  type OpAppArgs = OpAppArgs' Expr-type OpAppArgs' e = [NamedArg (MaybePlaceholder (OpApp e))]+type OpAppArgs' e = List1 (NamedArg (MaybePlaceholder (OpApp e)))+type OpAppArgs0 e = [NamedArg (MaybePlaceholder (OpApp e))]  -- | Concrete patterns. No literals in patterns at the moment. data Pattern-  = IdentP QName                           -- ^ @c@ or @x@+  = IdentP Bool QName                      -- ^ @c@ or @x@+                                           --+                                           -- If the boolean is+                                           -- 'False', then the+                                           -- 'QName' must not refer+                                           -- to a constructor or a+                                           -- pattern synonym. The+                                           -- value 'False' is used+                                           -- when a hidden argument+                                           -- pun is expanded.   | QuoteP Range                           -- ^ @quote@   | AppP Pattern (NamedArg Pattern)        -- ^ @p p'@ or @p {x = p'}@   | RawAppP Range (List2 Pattern)          -- ^ @p1..pn@ before parsing operators-  | OpAppP Range QName (Set A.Name)-           [NamedArg Pattern]              -- ^ eg: @p => p'@ for operator @_=>_@+  | OpAppP Range QName (Set1 A.Name)+      (List1 (NamedArg Pattern))           -- ^ eg: @p => p'@ for operator @_=>_@                                            -- The 'QName' is possibly                                            -- ambiguous, but it must                                            -- correspond to one of@@ -201,28 +231,31 @@   | ParenP Range Pattern                   -- ^ @(p)@   | WildP Range                            -- ^ @_@   | AbsurdP Range                          -- ^ @()@-  | AsP Range Name Pattern                 -- ^ @x\@p@ unused-  | DotP Range Expr                        -- ^ @.e@+  | AsP Range Name Pattern                 -- ^ @x\@p@+  | DotP KwRange Range Expr                -- ^ @.e@, the 'KwRange' is for the dot,+                                           --   the 'Range' for the whole thing (including the dot).   | LitP Range Literal                     -- ^ @0@, @1@, etc.-  | RecP Range [FieldAssignment' Pattern]  -- ^ @record {x = p; y = q}@-  | EqualP Range [(Expr,Expr)]             -- ^ @i = i1@ i.e. cubical face lattice generator+  | RecP KwRange Range [FieldAssignment' Pattern]+      -- ^ @record {x = p; y = q}@.  The 'KwRange' is for the @record@ keyword.+  | EqualP Range (List1 (Expr,Expr))       -- ^ @i = i1@ i.e. cubical face lattice generator   | EllipsisP Range (Maybe Pattern)        -- ^ @...@, only as left-most pattern.                                            --   Second arg is @Nothing@ before expansion, and                                            --   @Just p@ after expanding ellipsis to @p@.   | WithP Range Pattern                    -- ^ @| p@, for with-patterns.-  deriving (Data, Eq)+  deriving Eq  data DoStmt   = DoBind Range Pattern Expr [LamClause]   -- ^ @p ← e where cs@   | DoThen Expr   | DoLet Range (List1 Declaration)-  deriving (Data, Eq)+  deriving Eq  -- | A Binder @x\@p@, the pattern is optional data Binder' a = Binder-  { binderPattern :: Maybe Pattern-  , binderName    :: a-  } deriving (Data, Eq, Functor, Foldable, Traversable)+  { binderPattern    :: Maybe Pattern+  , binderNameOrigin :: BinderNameOrigin+  , binderName       :: a+  } deriving (Eq, Functor, Foldable, Traversable)  type Binder = Binder' BoundName @@ -230,7 +263,7 @@ mkBinder_ = mkBinder . mkBoundName_  mkBinder :: a -> Binder' a-mkBinder = Binder Nothing+mkBinder = Binder Nothing UserBinderName  -- | A lambda binding is either domain free or typed. @@ -240,7 +273,7 @@     -- ^ . @x@ or @{x}@ or @.x@ or @.{x}@ or @{.x}@ or @x\@p@ or @(p)@   | DomainFull a     -- ^ . @(xs : e)@ or @{xs : e}@-  deriving (Data, Functor, Foldable, Traversable, Eq)+  deriving (Functor, Foldable, Traversable, Eq)  -- | Drop type annotations and lets from bindings. dropTypeAndModality :: LamBinding -> [LamBinding]@@ -250,19 +283,28 @@ dropTypeAndModality (DomainFree x) = [DomainFree $ setModality defaultModality x]  data BoundName = BName-  { boundName   :: Name-  , bnameFixity :: Fixity'-  , bnameTactic :: TacticAttribute -- From @tactic attribute+  { boundName       :: Name+  , bnameFixity     :: Fixity'+  , bnameTactic     :: TacticAttribute+      -- ^ From @\@tactic@ attribute.+  , bnameIsFinite   :: Bool+      -- ^ The @\@finite@ cannot be parsed, it comes from the builtin @Partial@ only.   }-  deriving (Data, Eq)+  deriving Eq -type TacticAttribute = Maybe Expr+newtype TacticAttribute' a = TacticAttribute { theTacticAttribute :: Maybe (Ranged a) }+  deriving (Eq, Show, NFData, Functor, Foldable, Traversable, KillRange)+type TacticAttribute = TacticAttribute' Expr +instance Null (TacticAttribute' a) where+  null = isNothing . theTacticAttribute+  empty = TacticAttribute Nothing+ mkBoundName_ :: Name -> BoundName mkBoundName_ x = mkBoundName x noFixity'  mkBoundName :: Name -> Fixity' -> BoundName-mkBoundName x f = BName x f Nothing+mkBoundName x f = BName x f empty False  -- | A typed binding. @@ -273,7 +315,7 @@     -- ^ Binding @(x1\@p1 ... xn\@pn : A)@.   | TLet  Range (List1 Declaration)     -- ^ Let binding @(let Ds)@ or @(open M args)@.-  deriving (Data, Functor, Foldable, Traversable, Eq)+  deriving (Functor, Foldable, Traversable, Eq)  -- | A telescope is a sequence of typed bindings. Bound variables are in scope --   in later types.@@ -327,7 +369,7 @@   , lhsWithExpr        :: [WithExpr]     -- ^ @with e1 in eq | {e2} | ...@ (many)   }-  deriving (Data, Eq)+  deriving Eq  type RewriteEqn = RewriteEqn' () Name Pattern Expr type WithExpr   = Named Name (Arg Expr)@@ -344,45 +386,58 @@              , lhsPats         :: [NamedArg Pattern]  -- ^ More application patterns.              }   | LHSWith  { lhsHead         :: LHSCore-             , lhsWithPatterns :: [Pattern]          -- ^ Non-empty; at least one @(| p)@.+             , lhsWithPatterns :: List1 Pattern      -- ^ At least one @(| p)@.              , lhsPats         :: [NamedArg Pattern] -- ^ More application patterns.              }   | LHSEllipsis              { lhsEllipsisRange :: Range              , lhsEllipsisPat   :: LHSCore           -- ^ Pattern that was expanded from an ellipsis @...@.              }-  deriving (Data, Eq)+  deriving Eq  type RHS = RHS' Expr data RHS' e   = AbsurdRHS -- ^ No right hand side because of absurd match.   | RHS e-  deriving (Data, Functor, Foldable, Traversable, Eq)+  deriving (Functor, Foldable, Traversable, Eq)  -- | @where@ block following a clause. type WhereClause = WhereClause' [Declaration] --- The generalization @WhereClause'@ is for the sake of Concrete.Generic.+-- | The generalization @WhereClause'@ is for the sake of "Agda.Concrete.Generic". data WhereClause' decls   = NoWhere       -- ^ No @where@ clauses.   | AnyWhere Range decls       -- ^ Ordinary @where@.  'Range' of the @where@ keyword.       --   List of declarations can be empty.-  | SomeWhere Range Name Access decls+  | SomeWhere Range Erased Name Access decls       -- ^ Named where: @module M where ds@.       --   'Range' of the keywords @module@ and @where@.       --   The 'Access' flag applies to the 'Name' (not the module contents!)       --   and is propagated from the parent function.       --   List of declarations can be empty.-  deriving (Data, Eq, Functor, Foldable, Traversable)+  deriving (Eq, Functor, Foldable, Traversable) +-- | Type of @where@ block following a clause.+data WhereClause_+  = NoWhere_     -- ^ No @where@ clauses.+  | AnyWhere_    -- ^ Ordinary @where@.+  | SomeWhere_   -- ^ Named where: @module M where ...@.+  deriving (Eq, Generic)++whereClause_ :: WhereClause' a -> WhereClause_+whereClause_ = \case+  NoWhere  {} -> NoWhere_+  AnyWhere {} -> AnyWhere_+  SomeWhere{} -> SomeWhere_+ data LamClause = LamClause   { lamLHS      :: [Pattern]   -- ^ Possibly empty sequence.   , lamRHS      :: RHS-  , lamCatchAll :: Bool+  , lamCatchall :: Catchall   }-  deriving (Data, Eq)+  deriving Eq  -- | An expression followed by a where clause. --   Currently only used to give better a better error message in interaction.@@ -406,7 +461,7 @@   , asRange :: Range     -- ^ The range of the \"as\" keyword.  Retained for highlighting purposes.   }-  deriving (Data, Show, Functor, Foldable, Traversable, Eq)+  deriving (Show, Functor, Foldable, Traversable, Eq)  -- | From the parser, we get an expression for the @as@-'Name', which --   we have to parse into a 'Name'.@@ -434,10 +489,19 @@        -- ^ Range of @[no-]eta-equality@ keyword.    | PatternOrCopattern Range        -- ^ If declaration @pattern@ is present, give its range.-   deriving (Data,Eq,Show)+   deriving (Eq, Show) -type RecordDirectives = RecordDirectives' (Name, IsInstance)+type RecordDirectives = RecordDirectives' (Maybe (Name, IsInstance)) +ungatherRecordDirectives :: RecordDirectives -> [RecordDirective]+ungatherRecordDirectives (RecordDirectives ind eta pat con) = catMaybes+  [ Induction <$> ind+  , Eta <$> eta+  , PatternOrCopattern <$> pat+  , uncurry Constructor <$> con+  ]++ {-| The representation type of a declaration. The comments indicate     which type in the intended family the constructor targets. -}@@ -446,100 +510,150 @@   = TypeSig ArgInfo TacticAttribute Name Expr       -- ^ Axioms and functions can be irrelevant. (Hiding should be NotHidden)   | FieldSig IsInstance TacticAttribute Name (Arg Expr)-  | Generalize Range [TypeSignature] -- ^ Variables to be generalized, can be hidden and/or irrelevant.-  | Field Range [FieldSignature]-  | FunClause LHS RHS WhereClause Bool-  | DataSig     Range Name [LamBinding] Expr -- ^ lone data signature in mutual block-  | Data        Range Name [LamBinding] Expr [TypeSignatureOrInstanceBlock]+  | Generalize KwRange [TypeSignature] -- ^ Variables to be generalized, can be hidden and/or irrelevant.+  | Field KwRange [FieldSignature]+  | FunClause LHS RHS WhereClause Catchall+  | DataSig     Range Erased Name [LamBinding] Expr -- ^ lone data signature in mutual block+  | Data        Range Erased Name [LamBinding] Expr+                [TypeSignatureOrInstanceBlock]   | DataDef     Range Name [LamBinding] [TypeSignatureOrInstanceBlock]-  | RecordSig   Range Name [LamBinding] Expr -- ^ lone record signature in mutual block-  | RecordDef   Range Name RecordDirectives [LamBinding] [Declaration]-  | Record      Range Name RecordDirectives [LamBinding] Expr [Declaration]-  | RecordDirective RecordDirective -- ^ Should not survive beyond the parser+  | RecordSig   Range Erased Name [LamBinding] Expr -- ^ lone record signature in mutual block+  | RecordDef   Range Name [RecordDirective] [LamBinding] [Declaration]+  | Record      Range Erased Name [RecordDirective] [LamBinding] Expr+                [Declaration]   | Infix Fixity (List1 Name)   | Syntax      Name Notation -- ^ notation declaration for a name-  | PatternSyn  Range Name [Arg Name] Pattern-  | Mutual      Range [Declaration]  -- @Range@ of the whole @mutual@ block.-  | InterleavedMutual Range [Declaration]-  | Abstract    Range [Declaration]-  | Private     Range Origin [Declaration]+  | PatternSyn  Range Name [WithHiding Name] Pattern+  | Mutual      KwRange [Declaration]+  | InterleavedMutual KwRange [Declaration]+  | Abstract    KwRange [Declaration]+  | Private     KwRange Origin [Declaration]     -- ^ In "Agda.Syntax.Concrete.Definitions" we generate private blocks     --   temporarily, which should be treated different that user-declared     --   private blocks.  Thus the 'Origin'.-  | InstanceB   Range [Declaration]-    -- ^ The 'Range' here (exceptionally) only refers to the range of the+  | InstanceB   KwRange [Declaration]+    -- ^ The 'KwRange' here only refers to the range of the     --   @instance@ keyword.  The range of the whole block @InstanceB r ds@     --   is @fuseRange r ds@.-  | LoneConstructor Range [Declaration]-  | Macro       Range [Declaration]-  | Postulate   Range [TypeSignatureOrInstanceBlock]-  | Primitive   Range [TypeSignature]+  | LoneConstructor KwRange [Declaration]+  | Macro       KwRange [Declaration]+  | Postulate   KwRange [TypeSignatureOrInstanceBlock]+  | Primitive   KwRange [TypeSignature]   | Open        Range QName ImportDirective   | Import      Range QName (Maybe AsName) !OpenShortHand ImportDirective-  | ModuleMacro Range  Name ModuleApplication !OpenShortHand ImportDirective-  | Module      Range QName Telescope [Declaration]+  | ModuleMacro Range Erased  Name ModuleApplication !OpenShortHand+                ImportDirective+  | Module      Range Erased QName Telescope [Declaration]   | UnquoteDecl Range [Name] Expr+      -- ^ @unquoteDecl xs = e@   | UnquoteDef  Range [Name] Expr+      -- ^ @unquoteDef xs = e@+  | UnquoteData Range Name [Name] Expr+      -- ^ @unquoteDecl data d constructor xs = e@   | Pragma      Pragma-  deriving (Data, Eq)+  | Opaque      KwRange [Declaration]+    -- ^ @opaque ...@+  | Unfolding   KwRange [QName]+    -- ^ @unfolding ...@+  deriving Eq --- | Extract a record directive-isRecordDirective :: Declaration -> Maybe RecordDirective-isRecordDirective (RecordDirective r) = Just r-isRecordDirective (InstanceB r [RecordDirective (Constructor n p)]) = Just (Constructor n (InstanceDef r))-isRecordDirective _ = Nothing+-- | Return 'Pragma' if 'Declaration' is 'Pragma'.+{-# SPECIALIZE isPragma :: Declaration -> Maybe Pragma #-}+{-# SPECIALIZE isPragma :: Declaration -> [Pragma] #-}+isPragma :: CMaybe Pragma m => Declaration -> m+isPragma = \case+    Pragma p                -> singleton p+    Private  _ _ _          -> empty+    Abstract _ _            -> empty+    InstanceB _ _           -> empty+    Mutual _ _              -> empty+    Module _ _ _ _ _        -> empty+    Macro _ _               -> empty+    Record _ _ _ _ _ _ _    -> empty+    RecordDef _ _ _ _ _     -> empty+    TypeSig _ _ _ _         -> empty+    FieldSig _ _ _ _        -> empty+    Generalize _ _          -> empty+    Field _ _               -> empty+    FunClause _ _ _ _       -> empty+    DataSig _ _ _ _ _       -> empty+    Data _ _ _ _ _ _        -> empty+    DataDef _ _ _ _         -> empty+    RecordSig _ _ _ _ _     -> empty+    Infix _ _               -> empty+    Syntax _ _              -> empty+    PatternSyn _ _ _ _      -> empty+    InterleavedMutual _ _   -> empty+    LoneConstructor _ _     -> empty+    Postulate _ _           -> empty+    Primitive _ _           -> empty+    Open _ _ _              -> empty+    Import _ _ _ _ _        -> empty+    ModuleMacro _ _ _ _ _ _ -> empty+    UnquoteDecl _ _ _       -> empty+    UnquoteDef _ _ _        -> empty+    UnquoteData _ _ _ _     -> empty+    Opaque _ _              -> empty+    Unfolding _ _           -> empty  data ModuleApplication-  = SectionApp Range Telescope Expr-    -- ^ @tel. M args@+  = SectionApp Range Telescope QName [Expr]+    -- ^ @tel M exprs@ where @M exprs@ is a 'RawApp' just after parsing.   | RecordModuleInstance Range QName     -- ^ @M {{...}}@-  deriving (Data, Eq)+  deriving Eq  data OpenShortHand = DoOpen | DontOpen-  deriving (Data, Eq, Show, Generic)+  deriving (Eq, Show, Generic)  -- Pragmas ----------------------------------------------------------------  data Pragma-  = OptionsPragma             Range [String]-  | BuiltinPragma             Range RString QName-  | RewritePragma             Range Range [QName]        -- ^ Second Range is for REWRITE keyword.-  | ForeignPragma             Range RString String       -- ^ first string is backend name-  | CompilePragma             Range RString QName String -- ^ first string is backend name-  | StaticPragma              Range QName-  | InlinePragma              Range Bool QName  -- ^ INLINE or NOINLINE+  = OptionsPragma               Range [String]+  | BuiltinPragma               Range RString QName+  | RewritePragma               Range Range [QName]        -- ^ Second Range is for REWRITE keyword.+  | ForeignPragma               Range (Ranged BackendName) String+  | CompilePragma               Range (Ranged BackendName) QName String+  | StaticPragma                Range QName+  | InlinePragma                Range Bool QName  -- ^ INLINE or NOINLINE -  | ImpossiblePragma          Range [String]+  | ImpossiblePragma            Range [String]     -- ^ Throws an internal error in the scope checker.     --   The 'String's are words to be displayed with the error.-  | EtaPragma                 Range QName+  | EtaPragma                   Range QName     -- ^ For coinductive records, use pragma instead of regular     --   @eta-equality@ definition (as it is might make Agda loop).-  | WarningOnUsage            Range QName Text+  | WarningOnUsage              Range QName Text     -- ^ Applies to the named function-  | WarningOnImport           Range Text+  | WarningOnImport             Range Text     -- ^ Applies to the current module-  | InjectivePragma           Range QName+  | InjectivePragma             Range QName     -- ^ Mark a definition as injective for the pattern matching unifier.-  | DisplayPragma             Range Pattern Expr+  | InjectiveForInferencePragma Range QName+    -- ^ Mark a definition as injective for the conversion checker+  | DisplayPragma               Range Pattern Expr     -- ^ Display lhs as rhs (modifies the printer).    -- Attached (more or less) pragmas handled in the nicifier (Concrete.Definitions):-  | CatchallPragma            Range+  | CatchallPragma              Range     -- ^ Applies to the following function clause.-  | TerminationCheckPragma    Range (TerminationCheck Name)+  | TerminationCheckPragma      Range (TerminationCheck Name)     -- ^ Applies to the following function (and all that are mutually recursive with it)     --   or to the functions in the following mutual block.-  | NoCoverageCheckPragma     Range+  | NoCoverageCheckPragma       Range     -- ^ Applies to the following function (and all that are mutually recursive with it)     --   or to the functions in the following mutual block.-  | NoPositivityCheckPragma   Range+  | NoPositivityCheckPragma     Range     -- ^ Applies to the following data/record type or mutual block.-  | PolarityPragma            Range Name [Occurrence]-  | NoUniverseCheckPragma     Range+  | PolarityPragma              Range Name [Ranged Occurrence]+  | NoUniverseCheckPragma       Range     -- ^ Applies to the following data/record type.-  deriving (Data, Eq)+  | NotProjectionLikePragma     Range QName+    -- ^ Applies to the stated function+  | OverlapPragma             Range [QName] OverlapMode+    -- ^ Applies to the given name(s), which must be instance names+    -- (checked by the type checker).+  deriving Eq  --------------------------------------------------------------------------- @@ -550,19 +664,6 @@   , modDecls   :: [Declaration]   } --- | Computes the top-level module name.------ Precondition: The 'Module' has to be well-formed.--- This means that there are only allowed declarations before the--- first module declaration, typically import declarations.--- See 'spanAllowedBeforeModule'.--topLevelModuleName :: Module -> TopLevelModuleName-topLevelModuleName (Mod _ []) = __IMPOSSIBLE__-topLevelModuleName (Mod _ ds) = case spanAllowedBeforeModule ds of-  (_, Module _ n _ _ : _) -> toTopLevelModuleName n-  _ -> __IMPOSSIBLE__- -- | Splits off allowed (= import) declarations before the first --   non-allowed declaration. --   After successful parsing, the first non-allowed declaration@@ -610,33 +711,40 @@ data AppView = AppView Expr [NamedArg Expr]  appView :: Expr -> AppView-appView = \case-    App r e1 e2      -> vApp (appView e1) e2-    RawApp _ (List2 e1 e2 es)-                     -> AppView e1 $ map arg (e2:es)-    e                -> AppView e []+appView e = f (DL.toList ess)   where-    vApp (AppView e es) arg = AppView e (es ++ [arg])+    (f, ess) = appView' e -    arg (HiddenArg   _ e) = hide         $ defaultArg e-    arg (InstanceArg _ e) = makeInstance $ defaultArg e-    arg e                 = defaultArg (unnamed e)+    appView' :: Expr -> ([NamedArg Expr] -> AppView, DList (NamedArg Expr))+    appView' = \case+      App r e1 e2      -> appView' e1 & second (`DL.snoc` e2)+      RawApp _ (List2 e1 e2 es)+                       -> (AppView e1, DL.fromList (map toNamedArg (e2 : es)))+      e                -> (AppView e, mempty)  unAppView :: AppView -> Expr unAppView (AppView e nargs) = rawApp (e :| map unNamedArg nargs) -  where-    unNamedArg narg = ($ unArg narg) $ case getHiding narg of-      Hidden     -> HiddenArg (getRange narg)-      NotHidden  -> namedThing-      Instance{} -> InstanceArg (getRange narg)+-- | Parse outermost hiding information.+toNamedArg :: Expr -> NamedArg Expr+toNamedArg = \case+  HiddenArg   _ e -> hide         $ defaultArg e+  InstanceArg _ e -> makeInstance $ defaultArg e+  e -> defaultNamedArg e +-- | Unparse hiding information.+unNamedArg :: NamedArg Expr -> Expr+unNamedArg narg = ($ unArg narg) $ case getHiding narg of+  Hidden     -> HiddenArg (getRange narg)+  NotHidden  -> namedThing+  Instance{} -> InstanceArg (getRange narg)+ isSingleIdentifierP :: Pattern -> Maybe Name isSingleIdentifierP = \case-  IdentP (QName x) -> Just x-  WildP r          -> Just $ noName r-  ParenP _ p       -> isSingleIdentifierP p-  _                -> Nothing+  IdentP _ (QName x) -> Just x+  WildP r            -> Just $ noName r+  ParenP _ p         -> isSingleIdentifierP p+  _                  -> Nothing  removeParenP :: Pattern -> Pattern removeParenP = \case@@ -653,9 +761,9 @@ -- | Observe the relevance status of an expression observeRelevance :: Expr -> (Relevance, Expr) observeRelevance = \case-  Dot _ e       -> (Irrelevant, e)-  DoubleDot _ e -> (NonStrict, e)-  e             -> (Relevant, e)+  Dot kwr e       -> (Irrelevant (OIrrDot (getRange kwr)), e)+  DoubleDot kwr e -> (ShapeIrrelevant (OShIrrDotDot (getRange kwr)), e)+  e               -> (Relevant empty, e)  -- | Observe various modifiers applied to an expression observeModifiers :: Expr -> Arg Expr@@ -691,13 +799,14 @@ exprToPattern fallback = loop   where   loop = \case-    Ident       x        -> pure $ IdentP x+    Ident       x        -> pure $ IdentP True x     App         _ e1 e2  -> AppP <$> loop e1 <*> traverse (traverse loop) e2     Paren       r e      -> ParenP r <$> loop e     Underscore  r _      -> pure $ WildP r     Absurd      r        -> pure $ AbsurdP r     As          r x e    -> pushUnderBracesP r (AsP r x) <$> loop e-    Dot         r e      -> pure $ pushUnderBracesE r (DotP r) e+    e0@(Dot       kwr e) -> pure $ pushUnderBracesE r (DotP kwr r) e+      where r = getRange e0     -- Wen, 2020-08-27: We disallow Float patterns, since equality for floating     -- point numbers is not stable across architectures and with different     -- compiler flags.@@ -707,11 +816,11 @@     InstanceArg r e      -> InstanceP r <$> traverse loop e     RawApp      r es     -> RawAppP   r <$> traverse loop es     Quote       r        -> pure $ QuoteP r-    Equal       r e1 e2  -> pure $ EqualP r [(e1, e2)]+    Equal       r e1 e2  -> pure $ EqualP r $ singleton (e1, e2)     Ellipsis    r        -> pure $ EllipsisP r Nothing-    e@(Rec r es)+    e@(Rec kwr r es)         -- We cannot translate record expressions with module parts.-      | Just fs <- mapM maybeLeft es -> RecP r <$> traverse (traverse loop) fs+      | Just fs <- mapM maybeLeft es -> RecP kwr r <$> traverse (traverse loop) fs       | otherwise -> fallback e     -- WithApp has already lost the range information of the bars '|'     WithApp     r e es   -> do -- ApplicativeDo@@ -745,10 +854,11 @@  isBinderP :: Pattern -> Maybe Binder isBinderP = \case-  IdentP qn  -> mkBinder_ <$> isUnqualified qn+  IdentP _ qn+             -> mkBinder_ <$> isUnqualified qn   WildP r    -> pure $ mkBinder_ $ setRange r simpleHole-  AsP r n p  -> pure $ Binder (Just p) $ mkBoundName_ n-  ParenP r p -> pure $ Binder (Just p) $ mkBoundName_ $ setRange r simpleHole+  AsP r n p  -> pure $ Binder (Just p) UserBinderName $ mkBoundName_ n+  ParenP r p -> pure $ Binder (Just p) UserBinderName $ mkBoundName_ $ setRange r simpleHole   _ -> Nothing  {--------------------------------------------------------------------------@@ -767,6 +877,12 @@   null AnyWhere{} = False   null SomeWhere{} = False +instance Null WhereClause_ where+  empty = NoWhere_+  null NoWhere_ = True+  null AnyWhere_ = False+  null SomeWhere_ = False+ -- Lenses ------------------------------------------------------------------------ @@ -778,13 +894,13 @@  instance LensHiding TypedBinding where   getHiding (TBind _ (x :| _) _) = getHiding x   -- Slightly dubious-  getHiding TLet{}              = mempty+  getHiding TLet{}               = mempty   mapHiding f (TBind r xs e) = TBind r (fmap (mapHiding f) xs) e   mapHiding f b@TLet{}       = b  instance LensRelevance TypedBinding where-  getRelevance (TBind _ (x :|_) _) = getRelevance x   -- Slightly dubious-  getRelevance TLet{}              = unitRelevance+  getRelevance (TBind _ (x :| _) _) = getRelevance x   -- Slightly dubious+  getRelevance TLet{}               = unitRelevance   mapRelevance f (TBind r xs e) = TBind r (fmap (mapRelevance f) xs) e   mapRelevance f b@TLet{}       = b @@ -816,14 +932,13 @@       IdiomBrackets r _  -> r       DoBlock r _        -> r       As r _ _           -> r-      Dot r _            -> r-      DoubleDot r _      -> r+      Dot r e            -> getRange (r, e)+      DoubleDot r e      -> getRange (r, e)       Absurd r           -> r       HiddenArg r _      -> r       InstanceArg r _    -> r-      Rec r _            -> r-      RecUpdate r _ _    -> r-      ETel tel           -> getRange tel+      Rec _ r _          -> r+      RecUpdate _ r _ _  -> r       Quote r            -> r       QuoteTerm r        -> r       Unquote r          -> r@@ -832,14 +947,19 @@       Equal r _ _        -> r       Ellipsis r         -> r       Generalized e      -> getRange e+      KnownIdent _ q     -> getRange q+      KnownOpApp _ r _ _ _ -> r  -- instance HasRange Telescope where --     getRange (TeleBind bs) = getRange bs --     getRange (TeleFun x y) = fuseRange x y  instance HasRange Binder where-  getRange (Binder a b) = fuseRange a b+  getRange (Binder a _ b) = fuseRange a b +instance HasRange (TacticAttribute' a) where+  getRange = maybe noRange getRange . theTacticAttribute+ instance HasRange TypedBinding where   getRange (TBind r _ _) = r   getRange (TLet r _)    = r@@ -852,12 +972,12 @@   getRange = getRange . boundName  instance HasRange WhereClause where-  getRange  NoWhere             = noRange-  getRange (AnyWhere r ds)      = getRange (r, ds)-  getRange (SomeWhere r x _ ds) = getRange (r, x, ds)+  getRange  NoWhere               = noRange+  getRange (AnyWhere r ds)        = getRange (r, ds)+  getRange (SomeWhere r e x _ ds) = getRange (r, e, x, ds)  instance HasRange ModuleApplication where-  getRange (SectionApp r _ _) = r+  getRange (SectionApp r _ _ _) = r   getRange (RecordModuleInstance r _) = r  instance HasRange a => HasRange (FieldAssignment' a) where@@ -875,35 +995,38 @@ instance HasRange Declaration where   getRange (TypeSig _ _ x t)       = fuseRange x t   getRange (FieldSig _ _ x t)      = fuseRange x t-  getRange (Field r _)             = r+  getRange (Field kwr ds)          = fuseRange kwr ds   getRange (FunClause lhs rhs wh _) = fuseRange lhs rhs `fuseRange` wh-  getRange (DataSig r _ _ _)       = r-  getRange (Data r _ _ _ _)        = r+  getRange (DataSig r _ _ _ _)     = r+  getRange (Data r _ _ _ _ _)      = r   getRange (DataDef r _ _ _)       = r-  getRange (RecordSig r _ _ _)     = r+  getRange (RecordSig r _ _ _ _)   = r   getRange (RecordDef r _ _ _ _)   = r-  getRange (Record r _ _ _ _ _)    = r-  getRange (RecordDirective r)     = getRange r-  getRange (Mutual r _)            = r-  getRange (InterleavedMutual r _) = r-  getRange (LoneConstructor r _)   = r-  getRange (Abstract r _)          = r-  getRange (Generalize r _)        = r+  getRange (Record r _ _ _ _ _ _)  = r+  getRange (Mutual kwr ds)         = fuseRange kwr ds+  getRange (InterleavedMutual kwr ds) = fuseRange kwr ds+  getRange (LoneConstructor kwr ds)= fuseRange kwr ds+  getRange (Abstract kwr ds)       = fuseRange kwr ds+  getRange (Generalize kwr ds)     = fuseRange kwr ds   getRange (Open r _ _)            = r-  getRange (ModuleMacro r _ _ _ _) = r+  getRange (ModuleMacro r _ _ _ _ _)+                                   = r   getRange (Import r _ _ _ _)      = r-  getRange (InstanceB r _)         = r-  getRange (Macro r _)             = r-  getRange (Private r _ _)         = r-  getRange (Postulate r _)         = r-  getRange (Primitive r _)         = r-  getRange (Module r _ _ _)        = r+  getRange (InstanceB kwr _)       = getRange kwr+  getRange (Macro kwr ds)          = fuseRange kwr ds+  getRange (Private kwr _ ds)      = fuseRange kwr ds+  getRange (Postulate kwr ds)      = fuseRange kwr ds+  getRange (Primitive kwr ds)      = fuseRange kwr ds+  getRange (Module r _ _ _ _)      = r   getRange (Infix f _)             = getRange f   getRange (Syntax n _)            = getRange n   getRange (PatternSyn r _ _ _)    = r   getRange (UnquoteDecl r _ _)     = r   getRange (UnquoteDef r _ _)      = r+  getRange (UnquoteData r _ _ _)   = r   getRange (Pragma p)              = getRange p+  getRange (Opaque kwr ds)         = fuseRange kwr ds+  getRange (Unfolding kwr ds)      = fuseRange kwr ds  instance HasRange LHS where   getRange (LHS p eqns ws) = p `fuseRange` eqns `fuseRange` ws@@ -934,6 +1057,7 @@   getRange (ForeignPragma r _ _)             = r   getRange (StaticPragma r _)                = r   getRange (InjectivePragma r _)             = r+  getRange (InjectiveForInferencePragma r _) = r   getRange (InlinePragma r _ _)              = r   getRange (ImpossiblePragma r _)            = r   getRange (EtaPragma r _)                   = r@@ -946,12 +1070,14 @@   getRange (NoPositivityCheckPragma r)       = r   getRange (PolarityPragma r _ _)            = r   getRange (NoUniverseCheckPragma r)         = r+  getRange (NotProjectionLikePragma r _)     = r+  getRange (OverlapPragma r _ _)             = r  instance HasRange AsName where   getRange a = getRange (asRange a, asName a)  instance HasRange Pattern where-  getRange (IdentP x)         = getRange x+  getRange (IdentP _ x)       = getRange x   getRange (AppP p q)         = fuseRange p q   getRange (OpAppP r _ _ _)   = r   getRange (RawAppP r _)      = r@@ -963,8 +1089,8 @@   getRange (QuoteP r)         = r   getRange (HiddenP r _)      = r   getRange (InstanceP r _)    = r-  getRange (DotP r _)         = r-  getRange (RecP r _)         = r+  getRange (DotP _kwr r _)    = r+  getRange (RecP _kwr r _)    = r   getRange (EqualP r _)       = r   getRange (EllipsisP r _)    = r   getRange (WithP r _)        = r@@ -973,7 +1099,7 @@ ------------------------------------------------------------------------  instance SetRange Pattern where-  setRange r (IdentP x)         = IdentP (setRange r x)+  setRange r (IdentP c x)       = IdentP c (setRange r x)   setRange r (AppP p q)         = AppP (setRange r p) (setRange r q)   setRange r (OpAppP _ x ns ps) = OpAppP r x ns ps   setRange r (RawAppP _ ps)     = RawAppP r ps@@ -985,8 +1111,8 @@   setRange r (QuoteP _)         = QuoteP r   setRange r (HiddenP _ p)      = HiddenP r p   setRange r (InstanceP _ p)    = InstanceP r p-  setRange r (DotP _ e)         = DotP r e-  setRange r (RecP _ fs)        = RecP r fs+  setRange r (DotP _ _ e)       = DotP empty r e+  setRange r (RecP _ _ fs)      = RecP empty r fs   setRange r (EqualP _ es)      = EqualP r es   setRange r (EllipsisP _ mp)   = EllipsisP r mp   setRange r (WithP _ p)        = WithP r p@@ -999,145 +1125,153 @@ ------------------------------------------------------------------------  instance KillRange a => KillRange (FieldAssignment' a) where-  killRange (FieldAssignment a b) = killRange2 FieldAssignment a b+  killRange (FieldAssignment a b) = killRangeN FieldAssignment a b  instance KillRange ModuleAssignment where-  killRange (ModuleAssignment a b c) = killRange3 ModuleAssignment a b c+  killRange (ModuleAssignment a b c) = killRangeN ModuleAssignment a b c  instance KillRange AsName where-  killRange (AsName n _) = killRange1 (flip AsName noRange) n+  killRange (AsName n _) = killRangeN (flip AsName noRange) n  instance KillRange Binder where-  killRange (Binder a b) = killRange2 Binder a b+  killRange (Binder a o b) = killRangeN Binder a o b  instance KillRange BoundName where-  killRange (BName n f t) = killRange3 BName n f t+  killRange (BName n f t b) = killRangeN BName n f t b  instance KillRange RecordDirective where-  killRange (Induction a)          = killRange1 Induction a-  killRange (Eta a    )            = killRange1 Eta a-  killRange (Constructor a b)      = killRange2 Constructor a b+  killRange (Induction a)          = killRangeN Induction a+  killRange (Eta a    )            = killRangeN Eta a+  killRange (Constructor a b)      = killRangeN Constructor a b   killRange (PatternOrCopattern _) = PatternOrCopattern noRange  instance KillRange Declaration where-  killRange (TypeSig i t n e)       = killRange3 (TypeSig i) t n e-  killRange (FieldSig i t n e)      = killRange4 FieldSig i t n e-  killRange (Generalize r ds )      = killRange1 (Generalize noRange) ds-  killRange (Field r fs)            = killRange1 (Field noRange) fs-  killRange (FunClause l r w ca)    = killRange4 FunClause l r w ca-  killRange (DataSig _ n l e)       = killRange3 (DataSig noRange) n l e-  killRange (Data _ n l e c)        = killRange4 (Data noRange) n l e c-  killRange (DataDef _ n l c)       = killRange3 (DataDef noRange) n l c-  killRange (RecordSig _ n l e)     = killRange3 (RecordSig noRange) n l e-  killRange (RecordDef _ n dir k d) = killRange4 (RecordDef noRange) n dir k d-  killRange (RecordDirective a)     = killRange1 RecordDirective a-  killRange (Record _ n dir k e d)  = killRange5 (Record noRange) n dir k e d-  killRange (Infix f n)             = killRange2 Infix f n-  killRange (Syntax n no)           = killRange1 (\n -> Syntax n no) n-  killRange (PatternSyn _ n ns p)   = killRange3 (PatternSyn noRange) n ns p-  killRange (Mutual _ d)            = killRange1 (Mutual noRange) d-  killRange (InterleavedMutual _ d) = killRange1 (InterleavedMutual noRange) d-  killRange (LoneConstructor _ d)   = killRange1 (LoneConstructor noRange) d-  killRange (Abstract _ d)          = killRange1 (Abstract noRange) d-  killRange (Private _ o d)         = killRange2 (Private noRange) o d-  killRange (InstanceB _ d)         = killRange1 (InstanceB noRange) d-  killRange (Macro _ d)             = killRange1 (Macro noRange) d-  killRange (Postulate _ t)         = killRange1 (Postulate noRange) t-  killRange (Primitive _ t)         = killRange1 (Primitive noRange) t-  killRange (Open _ q i)            = killRange2 (Open noRange) q i-  killRange (Import _ q a o i)      = killRange3 (\q a -> Import noRange q a o) q a i-  killRange (ModuleMacro _ n m o i) = killRange3 (\n m -> ModuleMacro noRange n m o) n m i-  killRange (Module _ q t d)        = killRange3 (Module noRange) q t d-  killRange (UnquoteDecl _ x t)     = killRange2 (UnquoteDecl noRange) x t-  killRange (UnquoteDef _ x t)      = killRange2 (UnquoteDef noRange) x t-  killRange (Pragma p)              = killRange1 Pragma p+  killRange (TypeSig i t n e)       = killRangeN (TypeSig i) t n e+  killRange (FieldSig i t n e)      = killRangeN FieldSig i t n e+  killRange (Generalize r ds )      = killRangeN (Generalize empty) ds+  killRange (Field r fs)            = killRangeN (Field empty) fs+  killRange (FunClause l r w ca)    = killRangeN FunClause l r w ca+  killRange (DataSig _ er n l e)    = killRangeN (DataSig noRange) er n l e+  killRange (Data _ er n l e c)     = killRangeN (Data noRange) er n l e c+  killRange (DataDef _ n l c)       = killRangeN (DataDef noRange) n l c+  killRange (RecordSig _ er n l e)  = killRangeN (RecordSig noRange) er n l e+  killRange (RecordDef _ n dir k d) = killRangeN (RecordDef noRange) n dir k d+  killRange (Record _ er n dir k e d)+                                    = killRangeN (Record noRange) er n dir k e d+  killRange (Infix f n)             = killRangeN Infix f n+  killRange (Syntax n no)           = killRangeN (\n -> Syntax n no) n+  killRange (PatternSyn _ n ns p)   = killRangeN (PatternSyn noRange) n ns p+  killRange (Mutual _ d)            = killRangeN (Mutual empty) d+  killRange (InterleavedMutual _ d) = killRangeN (InterleavedMutual empty) d+  killRange (LoneConstructor _ d)   = killRangeN (LoneConstructor empty) d+  killRange (Abstract _ d)          = killRangeN (Abstract empty) d+  killRange (Private _ o d)         = killRangeN (Private empty) o d+  killRange (InstanceB _ d)         = killRangeN (InstanceB empty) d+  killRange (Macro _ d)             = killRangeN (Macro empty) d+  killRange (Postulate _ t)         = killRangeN (Postulate empty) t+  killRange (Primitive _ t)         = killRangeN (Primitive empty) t+  killRange (Open _ q i)            = killRangeN (Open noRange) q i+  killRange (Import _ q a o i)      = killRangeN (\q a -> Import noRange q a o) q a i+  killRange (ModuleMacro _ e n m o i)+                                    = killRangeN+                                        (\e n m -> ModuleMacro noRange e n m o)+                                        e n m i+  killRange (Module _ e q t d)      = killRangeN (Module noRange) e q t d+  killRange (UnquoteDecl _ x t)     = killRangeN (UnquoteDecl noRange) x t+  killRange (UnquoteDef _ x t)      = killRangeN (UnquoteDef noRange) x t+  killRange (UnquoteData _ xs cs t) = killRangeN (UnquoteData noRange) xs cs t+  killRange (Pragma p)              = killRangeN Pragma p+  killRange (Opaque r xs)           = killRangeN (Opaque empty) xs+  killRange (Unfolding r xs)        = killRangeN (Unfolding empty) xs  instance KillRange Expr where-  killRange (Ident q)             = killRange1 Ident q-  killRange (Lit _ l)             = killRange1 (Lit noRange) l-  killRange (QuestionMark _ n)    = QuestionMark noRange n-  killRange (Underscore _ n)      = Underscore noRange n-  killRange (RawApp _ e)          = killRange1 (RawApp noRange) e-  killRange (App _ e a)           = killRange2 (App noRange) e a-  killRange (OpApp _ n ns o)      = killRange3 (OpApp noRange) n ns o-  killRange (WithApp _ e es)      = killRange2 (WithApp noRange) e es-  killRange (HiddenArg _ n)       = killRange1 (HiddenArg noRange) n-  killRange (InstanceArg _ n)     = killRange1 (InstanceArg noRange) n-  killRange (Lam _ l e)           = killRange2 (Lam noRange) l e-  killRange (AbsurdLam _ h)       = killRange1 (AbsurdLam noRange) h-  killRange (ExtendedLam _ e lrw) = killRange2 (ExtendedLam noRange) e lrw-  killRange (Fun _ e1 e2)         = killRange2 (Fun noRange) e1 e2-  killRange (Pi t e)              = killRange2 Pi t e-  killRange (Rec _ ne)            = killRange1 (Rec noRange) ne-  killRange (RecUpdate _ e ne)    = killRange2 (RecUpdate noRange) e ne-  killRange (Let _ d e)           = killRange2 (Let noRange) d e-  killRange (Paren _ e)           = killRange1 (Paren noRange) e-  killRange (IdiomBrackets _ es)  = killRange1 (IdiomBrackets noRange) es-  killRange (DoBlock _ ss)        = killRange1 (DoBlock noRange) ss-  killRange (Absurd _)            = Absurd noRange-  killRange (As _ n e)            = killRange2 (As noRange) n e-  killRange (Dot _ e)             = killRange1 (Dot noRange) e-  killRange (DoubleDot _ e)       = killRange1 (DoubleDot noRange) e-  killRange (ETel t)              = killRange1 ETel t-  killRange (Quote _)             = Quote noRange-  killRange (QuoteTerm _)         = QuoteTerm noRange-  killRange (Unquote _)           = Unquote noRange-  killRange (Tactic _ t)          = killRange1 (Tactic noRange) t-  killRange (DontCare e)          = killRange1 DontCare e-  killRange (Equal _ x y)         = Equal noRange x y-  killRange (Ellipsis _)          = Ellipsis noRange-  killRange (Generalized e)       = killRange1 Generalized e+  killRange (Ident q)              = killRangeN Ident q+  killRange (Lit _ l)              = killRangeN (Lit noRange) l+  killRange (QuestionMark _ n)     = QuestionMark noRange n+  killRange (Underscore _ n)       = Underscore noRange n+  killRange (RawApp _ e)           = killRangeN (RawApp noRange) e+  killRange (App _ e a)            = killRangeN (App noRange) e a+  killRange (OpApp _ n ns o)       = killRangeN (OpApp noRange) n ns o+  killRange (WithApp _ e es)       = killRangeN (WithApp noRange) e es+  killRange (HiddenArg _ n)        = killRangeN (HiddenArg noRange) n+  killRange (InstanceArg _ n)      = killRangeN (InstanceArg noRange) n+  killRange (Lam _ l e)            = killRangeN (Lam noRange) l e+  killRange (AbsurdLam _ h)        = killRangeN (AbsurdLam noRange) h+  killRange (ExtendedLam _ e lrw)  = killRangeN (ExtendedLam noRange) e lrw+  killRange (Fun _ e1 e2)          = killRangeN (Fun noRange) e1 e2+  killRange (Pi t e)               = killRangeN Pi t e+  killRange (Rec _ _ ne)           = killRangeN (Rec empty noRange) ne+  killRange (RecUpdate _ _ e ne)   = killRangeN (RecUpdate empty noRange) e ne+  killRange (Let _ d e)            = killRangeN (Let noRange) d e+  killRange (Paren _ e)            = killRangeN (Paren noRange) e+  killRange (IdiomBrackets _ es)   = killRangeN (IdiomBrackets noRange) es+  killRange (DoBlock _ ss)         = killRangeN (DoBlock noRange) ss+  killRange (Absurd _)             = Absurd noRange+  killRange (As _ n e)             = killRangeN (As noRange) n e+  killRange (Dot _ e)              = killRangeN (Dot empty) e+  killRange (DoubleDot _ e)        = killRangeN (DoubleDot empty) e+  killRange (Quote _)              = Quote noRange+  killRange (QuoteTerm _)          = QuoteTerm noRange+  killRange (Unquote _)            = Unquote noRange+  killRange (Tactic _ t)           = killRangeN (Tactic noRange) t+  killRange (DontCare e)           = killRangeN DontCare e+  killRange (Equal _ x y)          = Equal noRange x y+  killRange (Ellipsis _)           = Ellipsis noRange+  killRange (Generalized e)        = killRangeN Generalized e+  killRange (KnownIdent a b)       = killRangeN (KnownIdent a) b+  killRange (KnownOpApp a b c d e) = killRangeN (KnownOpApp a) b c d e  instance KillRange LamBinding where-  killRange (DomainFree b) = killRange1 DomainFree b-  killRange (DomainFull t) = killRange1 DomainFull t+  killRange (DomainFree b) = killRangeN DomainFree b+  killRange (DomainFull t) = killRangeN DomainFull t  instance KillRange LHS where-  killRange (LHS p r w)  = killRange3 LHS p r w+  killRange (LHS p r w)  = killRangeN LHS p r w  instance KillRange LamClause where-  killRange (LamClause a b c) = killRange3 LamClause a b c+  killRange (LamClause a b c) = killRangeN LamClause a b c  instance KillRange DoStmt where-  killRange (DoBind r p e w) = killRange4 DoBind r p e w-  killRange (DoThen e)       = killRange1 DoThen e-  killRange (DoLet r ds)     = killRange2 DoLet r ds+  killRange (DoBind r p e w) = killRangeN DoBind r p e w+  killRange (DoThen e)       = killRangeN DoThen e+  killRange (DoLet r ds)     = killRangeN DoLet r ds  instance KillRange ModuleApplication where-  killRange (SectionApp _ t e)    = killRange2 (SectionApp noRange) t e-  killRange (RecordModuleInstance _ q) = killRange1 (RecordModuleInstance noRange) q+  killRange (SectionApp _ t x es)      = killRangeN (SectionApp noRange) t x es+  killRange (RecordModuleInstance _ q) = killRangeN (RecordModuleInstance noRange) q  instance KillRange e => KillRange (OpApp e) where-  killRange (SyntaxBindingLambda _ l e) = killRange2 (SyntaxBindingLambda noRange) l e-  killRange (Ordinary e)                = killRange1 Ordinary e+  killRange (SyntaxBindingLambda _ l e) = killRangeN (SyntaxBindingLambda noRange) l e+  killRange (Ordinary e)                = killRangeN Ordinary e  instance KillRange Pattern where-  killRange (IdentP q)        = killRange1 IdentP q-  killRange (AppP p ps)       = killRange2 AppP p ps-  killRange (RawAppP _ p)     = killRange1 (RawAppP noRange) p-  killRange (OpAppP _ n ns p) = killRange3 (OpAppP noRange) n ns p-  killRange (HiddenP _ n)     = killRange1 (HiddenP noRange) n-  killRange (InstanceP _ n)   = killRange1 (InstanceP noRange) n-  killRange (ParenP _ p)      = killRange1 (ParenP noRange) p+  killRange (IdentP c q)      = killRangeN IdentP c q+  killRange (AppP p ps)       = killRangeN AppP p ps+  killRange (RawAppP _ p)     = killRangeN (RawAppP noRange) p+  killRange (OpAppP _ n ns p) = killRangeN (OpAppP noRange) n ns p+  killRange (HiddenP _ n)     = killRangeN (HiddenP noRange) n+  killRange (InstanceP _ n)   = killRangeN (InstanceP noRange) n+  killRange (ParenP _ p)      = killRangeN (ParenP noRange) p   killRange (WildP _)         = WildP noRange   killRange (AbsurdP _)       = AbsurdP noRange-  killRange (AsP _ n p)       = killRange2 (AsP noRange) n p-  killRange (DotP _ e)        = killRange1 (DotP noRange) e-  killRange (LitP _ l)        = killRange1 (LitP noRange) l+  killRange (AsP _ n p)       = killRangeN (AsP noRange) n p+  killRange (DotP _ _ e)      = killRangeN (DotP empty noRange) e+  killRange (LitP _ l)        = killRangeN (LitP noRange) l   killRange (QuoteP _)        = QuoteP noRange-  killRange (RecP _ fs)       = killRange1 (RecP noRange) fs-  killRange (EqualP _ es)     = killRange1 (EqualP noRange) es-  killRange (EllipsisP _ mp)  = killRange1 (EllipsisP noRange) mp-  killRange (WithP _ p)       = killRange1 (WithP noRange) p+  killRange (RecP _ _ fs)     = killRangeN (RecP empty noRange) fs+  killRange (EqualP _ es)     = killRangeN (EqualP noRange) es+  killRange (EllipsisP _ mp)  = killRangeN (EllipsisP noRange) mp+  killRange (WithP _ p)       = killRangeN (WithP noRange) p  instance KillRange Pragma where   killRange (OptionsPragma _ s)               = OptionsPragma noRange s-  killRange (BuiltinPragma _ s e)             = killRange1 (BuiltinPragma noRange s) e-  killRange (RewritePragma _ _ qs)            = killRange1 (RewritePragma noRange noRange) qs-  killRange (StaticPragma _ q)                = killRange1 (StaticPragma noRange) q-  killRange (InjectivePragma _ q)             = killRange1 (InjectivePragma noRange) q-  killRange (InlinePragma _ b q)              = killRange1 (InlinePragma noRange b) q-  killRange (CompilePragma _ b q s)           = killRange1 (\ q -> CompilePragma noRange b q s) q+  killRange (BuiltinPragma _ s e)             = killRangeN (BuiltinPragma noRange s) e+  killRange (RewritePragma _ _ qs)            = killRangeN (RewritePragma noRange noRange) qs+  killRange (StaticPragma _ q)                = killRangeN (StaticPragma noRange) q+  killRange (InjectivePragma _ q)             = killRangeN (InjectivePragma noRange) q+  killRange (InjectiveForInferencePragma _ q) = killRangeN (InjectiveForInferencePragma noRange) q+  killRange (InlinePragma _ b q)              = killRangeN (InlinePragma noRange b) q+  killRange (CompilePragma _ b q s)           = killRangeN (\ q -> CompilePragma noRange b q s) q   killRange (ForeignPragma _ b s)             = ForeignPragma noRange b s   killRange (ImpossiblePragma _ strs)         = ImpossiblePragma noRange strs   killRange (TerminationCheckPragma _ t)      = TerminationCheckPragma noRange (killRange t)@@ -1145,24 +1279,27 @@   killRange (WarningOnUsage _ nm str)         = WarningOnUsage noRange (killRange nm) str   killRange (WarningOnImport _ str)           = WarningOnImport noRange str   killRange (CatchallPragma _)                = CatchallPragma noRange-  killRange (DisplayPragma _ lhs rhs)         = killRange2 (DisplayPragma noRange) lhs rhs-  killRange (EtaPragma _ q)                   = killRange1 (EtaPragma noRange) q+  killRange (DisplayPragma _ lhs rhs)         = killRangeN (DisplayPragma noRange) lhs rhs+  killRange (EtaPragma _ q)                   = killRangeN (EtaPragma noRange) q   killRange (NoPositivityCheckPragma _)       = NoPositivityCheckPragma noRange-  killRange (PolarityPragma _ q occs)         = killRange1 (\q -> PolarityPragma noRange q occs) q+  killRange (PolarityPragma _ q occs)         = killRangeN (\q -> PolarityPragma noRange q occs) q   killRange (NoUniverseCheckPragma _)         = NoUniverseCheckPragma noRange+  killRange (NotProjectionLikePragma _ q)     = NotProjectionLikePragma noRange q+  killRange (OverlapPragma _ q i)             = OverlapPragma noRange q i  instance KillRange RHS where   killRange AbsurdRHS = AbsurdRHS-  killRange (RHS e)   = killRange1 RHS e+  killRange (RHS e)   = killRangeN RHS e  instance KillRange TypedBinding where-  killRange (TBind _ b e) = killRange2 (TBind noRange) b e-  killRange (TLet r ds)   = killRange2 TLet r ds+  killRange (TBind _ b e) = killRangeN (TBind noRange) b e+  killRange (TLet r ds)   = killRangeN TLet r ds  instance KillRange WhereClause where-  killRange NoWhere             = NoWhere-  killRange (AnyWhere r d)      = killRange1 (AnyWhere noRange) d-  killRange (SomeWhere r n a d) = killRange3 (SomeWhere noRange) n a d+  killRange NoWhere               = NoWhere+  killRange (AnyWhere r d)        = killRangeN (AnyWhere noRange) d+  killRange (SomeWhere r e n a d) =+    killRangeN (SomeWhere noRange) e n a d  ------------------------------------------------------------------------ -- NFData instances@@ -1185,8 +1322,8 @@   rnf (ExtendedLam _ a b) = rnf a `seq` rnf b   rnf (Fun _ a b)         = rnf a `seq` rnf b   rnf (Pi a b)            = rnf a `seq` rnf b-  rnf (Rec _ a)           = rnf a-  rnf (RecUpdate _ a b)   = rnf a `seq` rnf b+  rnf (Rec _ _ a)         = rnf a+  rnf (RecUpdate _ _ a b) = rnf a `seq` rnf b   rnf (Let _ a b)         = rnf a `seq` rnf b   rnf (Paren _ a)         = rnf a   rnf (IdiomBrackets _ a) = rnf a@@ -1195,7 +1332,6 @@   rnf (As _ a b)          = rnf a `seq` rnf b   rnf (Dot _ a)           = rnf a   rnf (DoubleDot _ a)     = rnf a-  rnf (ETel a)            = rnf a   rnf (Quote _)           = ()   rnf (QuoteTerm _)       = ()   rnf (Tactic _ a)        = rnf a@@ -1204,11 +1340,13 @@   rnf (Equal _ a b)       = rnf a `seq` rnf b   rnf (Ellipsis _)        = ()   rnf (Generalized e)     = rnf e+  rnf (KnownIdent a b)    = rnf b+  rnf (KnownOpApp a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf c  -- | Ranges are not forced.  instance NFData Pattern where-  rnf (IdentP a)       = rnf a+  rnf (IdentP a b)     = rnf a `seq` rnf b   rnf (QuoteP _)       = ()   rnf (AppP a b)       = rnf a `seq` rnf b   rnf (RawAppP _ a)    = rnf a@@ -1219,9 +1357,9 @@   rnf (WildP _)        = ()   rnf (AbsurdP _)      = ()   rnf (AsP _ a b)      = rnf a `seq` rnf b-  rnf (DotP _ a)       = rnf a+  rnf (DotP _ _ a)     = rnf a   rnf (LitP _ a)       = rnf a-  rnf (RecP _ a)       = rnf a+  rnf (RecP _ _ a)     = rnf a   rnf (EqualP _ es)    = rnf es   rnf (EllipsisP _ mp) = rnf mp   rnf (WithP _ a)      = rnf a@@ -1240,13 +1378,13 @@   rnf (Generalize _ a)        = rnf a   rnf (Field _ fs)            = rnf fs   rnf (FunClause a b c d)     = rnf a `seq` rnf b `seq` rnf c `seq` rnf d-  rnf (DataSig _ a b c)       = rnf a `seq` rnf b `seq` rnf c-  rnf (Data _ a b c d)        = rnf a `seq` rnf b `seq` rnf c `seq` rnf d+  rnf (DataSig _ a b c d)     = rnf a `seq` rnf b `seq` rnf c `seq` rnf d+  rnf (Data _ a b c d e)      = rnf a `seq` rnf b `seq` rnf c `seq` rnf d+                                      `seq` rnf e   rnf (DataDef _ a b c)       = rnf a `seq` rnf b `seq` rnf c-  rnf (RecordSig _ a b c)     = rnf a `seq` rnf b `seq` rnf c+  rnf (RecordSig _ a b c d)   = rnf a `seq` rnf b `seq` rnf c `seq` rnf d   rnf (RecordDef _ a b c d)   = rnf (a, b, c, d)-  rnf (Record _ a b c d e)    = rnf (a, b, c, d, e)-  rnf (RecordDirective a)     = rnf a+  rnf (Record _ a b c d e f)  = rnf (a, b, c, d, e, f)   rnf (Infix a b)             = rnf a `seq` rnf b   rnf (Syntax a b)            = rnf a `seq` rnf b   rnf (PatternSyn _ a b c)    = rnf a `seq` rnf b `seq` rnf c@@ -1261,11 +1399,15 @@   rnf (Primitive _ a)         = rnf a   rnf (Open _ a b)            = rnf a `seq` rnf b   rnf (Import _ a b _ c)      = rnf a `seq` rnf b `seq` rnf c-  rnf (ModuleMacro _ a b _ c) = rnf a `seq` rnf b `seq` rnf c-  rnf (Module _ a b c)        = rnf a `seq` rnf b `seq` rnf c+  rnf (ModuleMacro _ a b c _ d)+                              = rnf a `seq` rnf b `seq` rnf c `seq` rnf d+  rnf (Module _ a b c d)      = rnf a `seq` rnf b `seq` rnf c `seq` rnf d   rnf (UnquoteDecl _ a b)     = rnf a `seq` rnf b   rnf (UnquoteDef _ a b)      = rnf a `seq` rnf b+  rnf (UnquoteData _ a b c)   = rnf a `seq` rnf b `seq` rnf c   rnf (Pragma a)              = rnf a+  rnf (Opaque r xs)           = rnf r `seq` rnf xs+  rnf (Unfolding r xs)        = rnf r `seq` rnf xs  instance NFData OpenShortHand @@ -1279,6 +1421,7 @@   rnf (ForeignPragma _ b s)             = rnf b `seq` rnf s   rnf (StaticPragma _ a)                = rnf a   rnf (InjectivePragma _ a)             = rnf a+  rnf (InjectiveForInferencePragma _ a) = rnf a   rnf (InlinePragma _ _ a)              = rnf a   rnf (ImpossiblePragma _ a)            = rnf a   rnf (EtaPragma _ a)                   = rnf a@@ -1291,6 +1434,8 @@   rnf (NoPositivityCheckPragma _)       = ()   rnf (PolarityPragma _ a b)            = rnf a `seq` rnf b   rnf (NoUniverseCheckPragma _)         = ()+  rnf (NotProjectionLikePragma _ q)     = rnf q+  rnf (OverlapPragma _ q i)             = rnf q `seq` rnf i  -- | Ranges are not forced. @@ -1306,7 +1451,7 @@ -- | Ranges are not forced.  instance NFData ModuleApplication where-  rnf (SectionApp _ a b)    = rnf a `seq` rnf b+  rnf (SectionApp _ a b c)       = rnf a `seq` rnf b `seq` rnf c   rnf (RecordModuleInstance _ a) = rnf a  -- | Ranges are not forced.@@ -1327,10 +1472,12 @@   rnf (ModuleAssignment a b c) = rnf a `seq` rnf b `seq` rnf c  instance NFData a => NFData (WhereClause' a) where-  rnf NoWhere             = ()-  rnf (AnyWhere _ a)      = rnf a-  rnf (SomeWhere _ a b c) = rnf a `seq` rnf b `seq` rnf c+  rnf NoWhere               = ()+  rnf (AnyWhere _ a)        = rnf a+  rnf (SomeWhere _ a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d +instance NFData WhereClause_+ instance NFData LamClause where   rnf (LamClause a b c) = rnf (a, b, c) @@ -1339,10 +1486,10 @@   rnf (DomainFull a) = rnf a  instance NFData Binder where-  rnf (Binder a b) = rnf a `seq` rnf b+  rnf (Binder a o b) = rnf (a, o, b)  instance NFData BoundName where-  rnf (BName a b c) = rnf a `seq` rnf b `seq` rnf c+  rnf (BName a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d  instance NFData a => NFData (RHS' a) where   rnf AbsurdRHS = ()
src/full/Agda/Syntax/Concrete/Attribute.hs view
@@ -3,6 +3,8 @@  module Agda.Syntax.Concrete.Attribute where +import Prelude hiding (null)+ import Control.Arrow (second) import Control.Monad (foldM) @@ -12,12 +14,14 @@ import Data.Maybe  import Agda.Syntax.Common-import Agda.Syntax.Concrete (Expr(..))+import Agda.Syntax.Concrete (Expr(..), TacticAttribute)+import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Concrete.Pretty () --instance only+import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Syntax.Position  import Agda.Utils.List1 (List1, pattern (:|))-import Agda.Utils.Pretty (prettyShow)+import Agda.Utils.Null  import Agda.Utils.Impossible @@ -26,8 +30,9 @@ data Attribute   = RelevanceAttribute Relevance   | QuantityAttribute  Quantity-  | TacticAttribute Expr+  | TacticAttribute (Ranged Expr)   | CohesionAttribute Cohesion+  | PolarityAttribute PolarityModality   | LockAttribute      Lock   deriving (Show) @@ -36,6 +41,7 @@     RelevanceAttribute r -> getRange r     QuantityAttribute q  -> getRange q     CohesionAttribute c  -> getRange c+    PolarityAttribute p  -> getRange p     TacticAttribute e    -> getRange e     LockAttribute l      -> NoRange @@ -44,6 +50,7 @@     RelevanceAttribute a -> RelevanceAttribute $ setRange r a     QuantityAttribute q  -> QuantityAttribute  $ setRange r q     CohesionAttribute c  -> CohesionAttribute  $ setRange r c+    PolarityAttribute p  -> PolarityAttribute  $ setRange r p     TacticAttribute e    -> TacticAttribute e  -- -- $ setRange r e -- SetRange Expr not yet implemented     LockAttribute l      -> LockAttribute l @@ -52,20 +59,40 @@     RelevanceAttribute a -> RelevanceAttribute $ killRange a     QuantityAttribute q  -> QuantityAttribute  $ killRange q     CohesionAttribute c  -> CohesionAttribute  $ killRange c+    PolarityAttribute p  -> PolarityAttribute  $ killRange p     TacticAttribute e    -> TacticAttribute    $ killRange e     LockAttribute l      -> LockAttribute l +-- | Parsed attribute.++data Attr = Attr+  { attrRange :: Range       -- ^ Range includes the @.+  , attrName  :: String      -- ^ Concrete, user written attribute for error reporting, not including the "@".+  , theAttr   :: Attribute   -- ^ Parsed attribute.+  } deriving (Show)++instance HasRange Attr where+  getRange = attrRange++instance SetRange Attr where+  setRange r (Attr _ x a) = Attr r x a++instance KillRange Attr where+  killRange (Attr _ x a) = Attr noRange x (killRange a)+ -- | (Conjunctive constraint.) -type LensAttribute a = (LensRelevance a, LensQuantity a, LensCohesion a, LensLock a)+type LensAttribute a = (LensRelevance a, LensQuantity a, LensCohesion a, LensModalPolarity a, LensLock a)  -- | Modifiers for 'Relevance'.  relevanceAttributeTable :: [(String, Relevance)]-relevanceAttributeTable = concat-  [ map (, Irrelevant)  [ "irr", "irrelevant" ]-  , map (, NonStrict)   [ "shirr", "shape-irrelevant" ]-  , map (, Relevant)    [ "relevant" ]+relevanceAttributeTable =+  [ ("irr"             , Irrelevant      $ OIrrIrr               noRange)+  , ("irrelevant"      , Irrelevant      $ OIrrIrrelevant        noRange)+  , ("shirr"           , ShapeIrrelevant $ OShIrrShIrr           noRange)+  , ("shape-irrelevant", ShapeIrrelevant $ OShIrrShapeIrrelevant noRange)+  , ("relevant"        , Relevant        $ ORelRelevant          noRange)   ]  -- | Modifiers for 'Quantity'.@@ -93,12 +120,34 @@   , ("flat" , Flat)   ] +-- | Information about attributes (attribute, range, printed+-- representation).+--+-- This information is returned by the parser. Code that calls the+-- parser should, if appropriate, complain if support for the given+-- attributes has not been enabled. This can be taken care of by+-- 'Agda.Syntax.Translation.ConcreteToAbstract.checkAttributes', which+-- should not be called until after pragma options have been set.++type Attributes = [Attr]++-- | Modifiers for 'Polarity'.++polarityAttributeTable :: [(String, PolarityModality)]+polarityAttributeTable =+  [ ("unused" , withStandardLock UnusedPolarity)+  , ("++" , withStandardLock StrictlyPositive)+  , ("+" , withStandardLock Positive)+  , ("-" , withStandardLock Negative)+  , ("mixed" , withStandardLock MixedPolarity)]+ -- | Modifiers for 'Quantity'.  lockAttributeTable :: [(String, Lock)] lockAttributeTable = concat   [ map (, IsNotLock) [ "notlock" ] -- default, shouldn't be used much-  , map (, IsLock) [ "lock", "tick" ] -- 🔓+  , map (, IsLock LockOTick) [ "tick" ] -- @tick+  , map (, IsLock LockOLock) [ "lock" ] -- @lock   ]  @@ -109,6 +158,7 @@   [ map (second RelevanceAttribute) relevanceAttributeTable   , map (second QuantityAttribute)  quantityAttributeTable   , map (second CohesionAttribute)  cohesionAttributeTable+  , map (second PolarityAttribute)  polarityAttributeTable   , map (second LockAttribute)      lockAttributeTable   ] @@ -119,9 +169,10 @@  -- | Parsing an expression into an attribute. -exprToAttribute :: Expr -> Maybe Attribute-exprToAttribute (Paren _ (Tactic _ t)) = Just $ TacticAttribute t-exprToAttribute e = setRange (getRange e) $ stringToAttribute $ prettyShow e+exprToAttribute :: Range -> Expr -> Maybe Attribute+exprToAttribute r = \case+  e@(Paren _ (Tactic _ t)) -> Just $ TacticAttribute $ Ranged r t+  e -> setRange r $ stringToAttribute $ prettyShow e  -- | Setting an attribute (in e.g. an 'Arg').  Overwrites previous value. @@ -130,6 +181,7 @@   RelevanceAttribute r -> setRelevance r   QuantityAttribute  q -> setQuantity  q   CohesionAttribute  c -> setCohesion  c+  PolarityAttribute  p -> setModalPolarity p   LockAttribute      l -> setLock      l   TacticAttribute t    -> id @@ -149,7 +201,7 @@  setPristineRelevance :: (LensRelevance a) => Relevance -> a -> Maybe a setPristineRelevance r a-  | getRelevance a == defaultRelevance = Just $ setRelevance r a+  | null (getRelevance a) = Just $ setRelevance r a   | otherwise = Nothing  -- | Setting 'Quantity' if unset.@@ -163,9 +215,16 @@  setPristineCohesion :: (LensCohesion a) => Cohesion -> a -> Maybe a setPristineCohesion c a-  | getCohesion a == defaultCohesion = Just $ setCohesion c a+  | null (getCohesion a) = Just $ setCohesion c a   | otherwise = Nothing +-- | Setting 'ModalPolarity' if unset.++setPristinePolarity :: (LensModalPolarity a) => PolarityModality -> a -> Maybe a+setPristinePolarity c a+  | getModalPolarity a == defaultPolarity = Just $ setModalPolarity c a+  | otherwise = Nothing+ -- | Setting 'Lock' if unset.  setPristineLock :: (LensLock a) => Lock -> a -> Maybe a@@ -180,6 +239,7 @@   RelevanceAttribute r -> setPristineRelevance r   QuantityAttribute  q -> setPristineQuantity  q   CohesionAttribute  c -> setPristineCohesion  c+  PolarityAttribute  p -> setPristinePolarity  p   LockAttribute      l -> setPristineLock      l   TacticAttribute{}    -> Just @@ -202,9 +262,10 @@   QuantityAttribute q -> Just q   _ -> Nothing -isTacticAttribute :: Attribute -> Maybe Expr-isTacticAttribute (TacticAttribute t) = Just t-isTacticAttribute _                   = Nothing+isTacticAttribute :: Attribute -> TacticAttribute+isTacticAttribute = C.TacticAttribute . \case+  TacticAttribute t -> Just t+  _ -> Nothing  relevanceAttributes :: [Attribute] -> [Attribute] relevanceAttributes = filter $ isJust . isRelevanceAttribute@@ -213,4 +274,4 @@ quantityAttributes = filter $ isJust . isQuantityAttribute  tacticAttributes :: [Attribute] -> [Attribute]-tacticAttributes = filter $ isJust . isTacticAttribute+tacticAttributes = filter $ isJust . C.theTacticAttribute . isTacticAttribute
src/full/Agda/Syntax/Concrete/Definitions.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE GADTs              #-}- -- | Preprocess 'Agda.Syntax.Concrete.Declaration's, producing 'NiceDeclaration's. -- --   * Attach fixity and syntax declarations to the definition they refer to.@@ -43,7 +41,7 @@     , Clause(..)     , DeclarationException(..)     , DeclarationWarning(..), DeclarationWarning'(..), unsafeDeclarationWarning-    , Nice, runNice+    , Nice, NiceEnv(..), runNice     , niceDeclarations     , notSoNiceDeclarations     , niceHasAbstract@@ -54,13 +52,12 @@  import Prelude hiding (null) -import Control.Monad         ( forM, guard, unless, void, when ) import Control.Monad.Except  ( )+import Control.Monad.Reader  ( asks ) import Control.Monad.State   ( MonadState(..), gets, StateT, runStateT ) import Control.Monad.Trans   ( lift )  import Data.Bifunctor-import Data.Data (Data) import Data.Either (isLeft, isRight) import Data.Function (on) import qualified Data.Map as Map@@ -79,23 +76,22 @@ import Agda.Syntax.Notation import Agda.Syntax.Concrete.Pretty () --instance only import Agda.Syntax.Concrete.Fixity+import Agda.Syntax.Common.Pretty  import Agda.Syntax.Concrete.Definitions.Errors import Agda.Syntax.Concrete.Definitions.Monad import Agda.Syntax.Concrete.Definitions.Types -import Agda.Interaction.Options.Warnings- import Agda.Utils.AffineHole import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack ) import Agda.Utils.Functor import Agda.Utils.Lens-import Agda.Utils.List (isSublistOf, spanJust)+import Agda.Utils.List (spanJust) import Agda.Utils.List1 (List1, pattern (:|), (<|)) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe+import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Pretty import Agda.Utils.Singleton import Agda.Utils.Three import Agda.Utils.Tuple@@ -111,11 +107,11 @@ --   equipped with MEASURE pragmas, or whether there is a --   NO_TERMINATION_CHECK pragma. combineTerminationChecks :: Range -> [TerminationCheck] -> Nice TerminationCheck-combineTerminationChecks r tcs = loop tcs where+combineTerminationChecks r = loop+  where   loop :: [TerminationCheck] -> Nice TerminationCheck   loop []         = return TerminationCheck   loop (tc : tcs) = do-    let failure r = declarationException $ InvalidMeasureMutual r     tc' <- loop tcs     case (tc, tc') of       (TerminationCheck      , tc'                   ) -> return tc'@@ -136,6 +132,7 @@       (Terminating           , NonTerminating        ) -> failure r       (NonTerminating        , NoTerminationCheck    ) -> failure r       (NonTerminating        , Terminating           ) -> failure r+  failure r = declarationException $ InvalidMeasureMutual r  combineCoverageChecks :: [CoverageCheck] -> CoverageCheck combineCoverageChecks = Fold.fold@@ -150,27 +147,29 @@   deriving (Eq, Show)  declKind :: NiceDeclaration -> DeclKind-declKind (FunSig r _ _ _ _ _ tc cc x _)     = LoneSigDecl r (FunName tc cc) x-declKind (NiceRecSig r _ _ pc uc x pars _)  = LoneSigDecl r (RecName pc uc) x-declKind (NiceDataSig r _ _ pc uc x pars _) = LoneSigDecl r (DataName pc uc) x-declKind (FunDef r _ abs ins tc cc x _)     = LoneDefs (FunName tc cc) [x]-declKind (NiceDataDef _ _ _ pc uc x pars _) = LoneDefs (DataName pc uc) [x]+declKind (FunSig r _ _ _ _ _ tc cc x _)      = LoneSigDecl r (FunName tc cc) x+declKind (NiceRecSig r _ _ _ pc uc x _ _)    = LoneSigDecl r (RecName pc uc) x+declKind (NiceDataSig r _ _ _ pc uc x _ _)   = LoneSigDecl r (DataName pc uc) x+declKind (FunDef r _ abs ins tc cc x _)      = LoneDefs (FunName tc cc) [x]+declKind (NiceDataDef _ _ _ pc uc x pars _)  = LoneDefs (DataName pc uc) [x]+declKind (NiceUnquoteData _ _ _ pc uc x _ _) = LoneDefs (DataName pc uc) [x] declKind (NiceRecDef _ _ _ pc uc x _ pars _) = LoneDefs (RecName pc uc) [x]-declKind (NiceUnquoteDef _ _ _ tc cc xs _)  = LoneDefs (FunName tc cc) xs-declKind Axiom{}                            = OtherDecl-declKind NiceField{}                        = OtherDecl-declKind PrimitiveFunction{}                = OtherDecl-declKind NiceMutual{}                       = OtherDecl-declKind NiceModule{}                       = OtherDecl-declKind NiceModuleMacro{}                  = OtherDecl-declKind NiceOpen{}                         = OtherDecl-declKind NiceImport{}                       = OtherDecl-declKind NicePragma{}                       = OtherDecl-declKind NiceFunClause{}                    = OtherDecl-declKind NicePatternSyn{}                   = OtherDecl-declKind NiceGeneralize{}                   = OtherDecl-declKind NiceUnquoteDecl{}                  = OtherDecl-declKind NiceLoneConstructor{}              = OtherDecl+declKind (NiceUnquoteDef _ _ _ tc cc xs _)   = LoneDefs (FunName tc cc) xs+declKind Axiom{}                             = OtherDecl+declKind NiceField{}                         = OtherDecl+declKind PrimitiveFunction{}                 = OtherDecl+declKind NiceMutual{}                        = OtherDecl+declKind NiceModule{}                        = OtherDecl+declKind NiceModuleMacro{}                   = OtherDecl+declKind NiceOpen{}                          = OtherDecl+declKind NiceImport{}                        = OtherDecl+declKind NicePragma{}                        = OtherDecl+declKind NiceFunClause{}                     = OtherDecl+declKind NicePatternSyn{}                    = OtherDecl+declKind NiceGeneralize{}                    = OtherDecl+declKind NiceUnquoteDecl{}                   = OtherDecl+declKind NiceLoneConstructor{}               = OtherDecl+declKind NiceOpaque{}                        = OtherDecl  -- | Replace (Data/Rec/Fun)Sigs with Axioms for postulated names --   The first argument is a list of axioms only.@@ -201,13 +200,15 @@       FunSig r acc abst inst _ argi _ _ x' e ->         -- #4881: Don't use the unique NameId for NoName lookups.         let x = if isNoName x' then noName (nameRange x') else x' in-        Just (x, Axiom r acc abst inst argi x' e)-      NiceRecSig r acc abst _ _ x pars t ->+        Just (x, Axiom r acc abst inst (setOrigin Inserted argi) x' e)+      NiceRecSig r erased acc abst _ _ x pars t ->         let e = Generalized $ makePi (lamBindingsToTelescope r pars) t in-        Just (x, Axiom r acc abst NotInstanceDef defaultArgInfo x e)-      NiceDataSig r acc abst _ _ x pars t ->+        Just (x, Axiom r acc abst NotInstanceDef+                   (setOrigin Inserted (setQuantity (asQuantity erased) defaultArgInfo)) x e)+      NiceDataSig r erased acc abst _ _ x pars t ->         let e = Generalized $ makePi (lamBindingsToTelescope r pars) t in-        Just (x, Axiom r acc abst NotInstanceDef defaultArgInfo x e)+        Just (x, Axiom r acc abst NotInstanceDef+                   (setOrigin Inserted (setQuantity (asQuantity erased) defaultArgInfo)) x e)       _ -> Nothing  -- | Main. Fixities (or more precisely syntax declarations) are needed when@@ -217,7 +218,7 @@    -- Run the nicifier in an initial environment. But keep the warnings.   st <- get-  put $ initNiceEnv { niceWarn = niceWarn st }+  put $ initNiceState { niceWarn = niceWarn st }   nds <- nice ds    -- Check that every signature got its definition.@@ -255,7 +256,7 @@           tc <- combineTerminationChecks (getRange d) (mutualTermination checks)           let cc = combineCoverageChecks              (mutualCoverage checks)           let pc = combinePositivityChecks            (mutualPositivity checks)-          (NiceMutual (getRange ds0) tc cc pc ds0 :) <$> inferMutualBlocks ds1+          (NiceMutual empty tc cc pc ds0 :) <$> inferMutualBlocks ds1       where         untilAllDefined :: MutualChecks -> [NiceDeclaration] -> Nice InferredMutual         untilAllDefined checks ds = do@@ -304,9 +305,13 @@         FieldSig{} -> __IMPOSSIBLE__          Generalize r [] -> justWarning $ EmptyGeneralize r-        Generalize r sigs -> do+        Generalize _ sigs -> do           gs <- forM sigs $ \case             sig@(TypeSig info tac x t) -> do+              -- Andreas, 2022-03-25, issue #5850:+              -- Warn about @variable {x} : A@ which is equivalent to @variable x : A@.+              when (getHiding info == Hidden) $+                declarationWarning $ HiddenGeneralize $ getRange x               return $ NiceGeneralize (getRange sig) PublicAccess info tac x t             _ -> __IMPOSSIBLE__           return (gs, ds)@@ -332,7 +337,7 @@               -- Subcase: The lhs is single identifier (potentially anonymous).               -- Treat it as a function clause without a type signature.               LHS p [] [] | Just x <- isSingleIdentifierP p -> do-                d  <- mkFunDef (setOrigin Inserted defaultArgInfo) termCheck covCheck x Nothing [d] -- fun def without type signature is relevant+                d  <- mkFunDef (setOrigin Inserted defaultArgInfo) termCheck covCheck x Nothing $ singleton d -- fun def without type signature is relevant                 return (d , ds)               -- Subcase: The lhs is a proper pattern.               -- This could be a let-pattern binding. Pass it on.@@ -345,7 +350,7 @@                -- The x'@NoName{} is the unique version of x@NoName{}.                removeLoneSig x                ds  <- expandEllipsis fits-               cs  <- mkClauses x' ds False+               cs  <- mkClauses x' ds empty                return ([FunDef (getRange fits) fits ConcreteDef NotInstanceDef termCheck covCheck x' cs] , rest)              -- case: clauses match more than one sigs (ambiguity)@@ -355,13 +360,15 @@         Field r [] -> justWarning $ EmptyField r         Field _ fs -> (,ds) <$> niceAxioms FieldBlock fs -        DataSig r x tel t -> do+        DataSig r erased x tel t -> do           pc <- use positivityCheckPragma           uc <- use universeCheckPragma           _ <- addLoneSig r x $ DataName pc uc-          (,ds) <$> dataOrRec pc uc NiceDataDef NiceDataSig (niceAxioms DataBlock) r x (Just (tel, t)) Nothing+          (,ds) <$> dataOrRec pc uc NiceDataDef+                      (flip NiceDataSig erased) (niceAxioms DataBlock) r+                      x (Just (tel, t)) Nothing -        Data r x tel t cs -> do+        Data r erased x tel t cs -> do           pc <- use positivityCheckPragma           -- Andreas, 2018-10-27, issue #3327           -- Propagate {-# NO_UNIVERSE_CHECK #-} pragma from signature to definition.@@ -370,7 +377,9 @@           uc <- use universeCheckPragma           uc <- if uc == NoUniverseCheck then return uc else getUniverseCheckFromSig x           mt <- defaultTypeSig (DataName pc uc) x (Just t)-          (,ds) <$> dataOrRec pc uc NiceDataDef NiceDataSig (niceAxioms DataBlock) r x ((tel,) <$> mt) (Just (tel, cs))+          (,ds) <$> dataOrRec pc uc NiceDataDef+                      (flip NiceDataSig erased) (niceAxioms DataBlock) r+                      x ((tel,) <$> mt) (Just (tel, cs))          DataDef r x tel cs -> do           pc <- use positivityCheckPragma@@ -381,15 +390,21 @@           uc <- use universeCheckPragma           uc <- if uc == NoUniverseCheck then return uc else getUniverseCheckFromSig x           mt <- defaultTypeSig (DataName pc uc) x Nothing-          (,ds) <$> dataOrRec pc uc NiceDataDef NiceDataSig (niceAxioms DataBlock) r x ((tel,) <$> mt) (Just (tel, cs))+          (,ds) <$> dataOrRec pc uc NiceDataDef+                      (flip NiceDataSig defaultErased)+                      (niceAxioms DataBlock) r x ((tel,) <$> mt)+                      (Just (tel, cs)) -        RecordSig r x tel t         -> do+        RecordSig r erased x tel t -> do           pc <- use positivityCheckPragma           uc <- use universeCheckPragma           _ <- addLoneSig r x $ RecName pc uc-          return ([NiceRecSig r PublicAccess ConcreteDef pc uc x tel t] , ds)+          return ( [NiceRecSig r erased PublicAccess ConcreteDef pc uc x+                      tel t]+                 , ds+                 ) -        Record r x dir tel t cs   -> do+        Record r erased x dir tel t cs -> do           pc <- use positivityCheckPragma           -- Andreas, 2018-10-27, issue #3327           -- Propagate {-# NO_UNIVERSE_CHECK #-} pragma from signature to definition.@@ -398,8 +413,11 @@           uc <- use universeCheckPragma           uc <- if uc == NoUniverseCheck then return uc else getUniverseCheckFromSig x           mt <- defaultTypeSig (RecName pc uc) x (Just t)-          (,ds) <$> dataOrRec pc uc (\ r o a pc uc x tel cs -> NiceRecDef r o a pc uc x dir tel cs) NiceRecSig-                      return r x ((tel,) <$> mt) (Just (tel, cs))+          (,ds) <$> dataOrRec pc uc+                      (\r o a pc uc x tel cs ->+                        NiceRecDef r o a pc uc x dir tel cs)+                      (flip NiceRecSig erased) return r x+                      ((tel,) <$> mt) (Just (tel, cs))          RecordDef r x dir tel cs   -> do           pc <- use positivityCheckPragma@@ -410,15 +428,16 @@           uc <- use universeCheckPragma           uc <- if uc == NoUniverseCheck then return uc else getUniverseCheckFromSig x           mt <- defaultTypeSig (RecName pc uc) x Nothing-          (,ds) <$> dataOrRec pc uc (\ r o a pc uc x tel cs -> NiceRecDef r o a pc uc x dir tel cs) NiceRecSig-                      return r x ((tel,) <$> mt) (Just (tel, cs))--        RecordDirective r -> justWarning $ InvalidRecordDirective (getRange r)+          (,ds) <$> dataOrRec pc uc+                      (\r o a pc uc x tel cs ->+                        NiceRecDef r o a pc uc x dir tel cs)+                      (flip NiceRecSig defaultErased) return r x+                      ((tel,) <$> mt) (Just (tel, cs))          Mutual r ds' -> do           -- The lone signatures encountered so far are not in scope           -- for the mutual definition-          forgetLoneSigs+          breakImplicitMutualBlock r "`mutual` blocks"           case ds' of             [] -> justWarning $ EmptyMutual r             _  -> (,ds) <$> (singleton <$> (mkOldMutual r =<< nice ds'))@@ -426,7 +445,7 @@         InterleavedMutual r ds' -> do           -- The lone signatures encountered so far are not in scope           -- for the mutual definition-          forgetLoneSigs+          breakImplicitMutualBlock r "`interleaved mutual` blocks"           case ds' of             [] -> justWarning $ EmptyMutual r             _  -> (,ds) <$> (singleton <$> (mkInterleavedMutual r =<< nice ds'))@@ -459,11 +478,11 @@         Primitive r []  -> justWarning $ EmptyPrimitive r         Primitive _ ds' -> (,ds) <$> (map toPrim <$> niceAxioms PrimitiveBlock ds') -        Module r x tel ds' -> return $-          ([NiceModule r PublicAccess ConcreteDef x tel ds'] , ds)+        Module r erased x tel ds' -> return $+          ([NiceModule r PublicAccess ConcreteDef erased x tel ds'], ds) -        ModuleMacro r x modapp op is -> return $-          ([NiceModuleMacro r PublicAccess x modapp op is] , ds)+        ModuleMacro r erased x modapp op is -> return $+          ([NiceModuleMacro r PublicAccess erased x modapp op is], ds)          -- Fixity and syntax declarations and polarity pragmas have         -- already been processed.@@ -488,8 +507,40 @@               mapM_ removeLoneSig xs               return ([NiceUnquoteDef r PublicAccess ConcreteDef TerminationCheck YesCoverageCheck xs e] , ds) -        Pragma p -> nicePragma p ds+        UnquoteData r xs cs e -> do+          pc <- use positivityCheckPragma+          uc <- use universeCheckPragma+          return ([NiceUnquoteData r PublicAccess ConcreteDef pc uc xs cs e], ds) +        Pragma p -> do+          -- Warn about unsafe pragmas unless we are in a builtin module.+          whenM (asks safeButNotBuiltin) $+            whenJust (unsafePragma p) $ \ w ->+              declarationWarning w+          nicePragma p ds++        Opaque r ds' -> do+          breakImplicitMutualBlock r "`opaque` blocks"++          -- Split the enclosed declarations into an initial run of+          -- 'unfolding' statements and the rest of the body.+          let+            (unfoldings, body) = flip spanMaybe ds' $ \case+              Unfolding _ ns -> pure ns+              _ -> Nothing++          -- The body of an 'opaque' definition can have mutual+          -- recursion by interleaving type signatures and definitions,+          -- just like the body of a module.+          decls0 <- nice body+          ps <- use loneSigs+          checkLoneSigs ps+          let decls = replaceSigs ps decls0+          body <- inferMutualBlocks decls+          pure ([NiceOpaque r (concat unfoldings) body], ds)++        Unfolding r _ -> declarationException $ UnfoldingOutsideOpaque r+     nicePragma :: Pragma -> [Declaration] -> Nice ([NiceDeclaration], [Declaration])      nicePragma (TerminationCheckPragma r (TerminationMeasure _ x)) ds =@@ -521,7 +572,7 @@      nicePragma (CatchallPragma r) ds =       if canHaveCatchallPragma ds then-        withCatchallPragma True $ nice1 ds+        withCatchallPragma (YesCatchall r) $ nice1 ds       else do         declarationWarning $ InvalidCatchallPragma r         nice1 ds@@ -541,7 +592,6 @@         nice1 ds      nicePragma p@CompilePragma{} ds = do-      declarationWarning $ PragmaCompiled (getRange p)       return ([NicePragma (getRange p) p], ds)      nicePragma (PolarityPragma{}) ds = return ([], ds)@@ -549,6 +599,7 @@     nicePragma (BuiltinPragma r str qn@(QName x)) ds = do       return ([NicePragma r (BuiltinPragma r str qn)], ds) +    nicePragma p@RewritePragma{} ds = return ([NicePragma (getRange p) p], ds)     nicePragma p ds = return ([NicePragma (getRange p) p], ds)      canHaveTerminationMeasure :: [Declaration] -> Bool@@ -661,8 +712,10 @@         return [ NiceField (getRange d) PublicAccess ConcreteDef i tac x argt ]       InstanceB r decls -> do         instanceBlock r =<< niceAxioms InstanceBlock decls-      Pragma p@(RewritePragma r _ _) -> do-        return [ NicePragma r p ]+      Private r o decls | PostulateBlock <- b -> do+        privateBlock r o =<< niceAxioms b decls+      Pragma p@(RewritePragma r _ _) -> return [ NicePragma r p ]+      Pragma p@(OverlapPragma r _ _) -> return [ NicePragma r p ]       d -> declarationException $ WrongContentBlock b $ getRange d      toPrim :: NiceDeclaration -> NiceDeclaration@@ -672,7 +725,7 @@     -- Create a function definition.     mkFunDef info termCheck covCheck x mt ds0 = do       ds <- expandEllipsis ds0-      cs <- mkClauses x ds False+      cs <- mkClauses x ds empty       return [ FunSig (fuseRange x t) PublicAccess ConcreteDef NotInstanceDef NotMacroDef info termCheck covCheck x t              , FunDef (getRange ds0) ds0 ConcreteDef NotInstanceDef termCheck covCheck x cs ]         where@@ -680,7 +733,8 @@      underscore r = Underscore r Nothing -+    -- Search for the first clause that does not have an ellipsis (usually the very first one)+    -- and then use its lhs pattern to replace ellipses in the subsequent clauses (if any).     expandEllipsis :: [Declaration] -> Nice [Declaration]     expandEllipsis [] = return []     expandEllipsis (d@(FunClause lhs@(LHS p _ _) _ _ _) : ds)@@ -717,21 +771,24 @@     -- Turn function clauses into nice function clauses.     mkClauses :: Name -> [Declaration] -> Catchall -> Nice [Clause]     mkClauses _ [] _ = return []-    mkClauses x (Pragma (CatchallPragma r) : cs) True  = do++    -- A CATCHALL pragma after the last clause is useless.+    mkClauses x [Pragma (CatchallPragma r)] _ = [] <$ do       declarationWarning $ InvalidCatchallPragma r-      mkClauses x cs True-    mkClauses x (Pragma (CatchallPragma r) : cs) False = do-      when (null cs) $ declarationWarning $ InvalidCatchallPragma r-      mkClauses x cs True +    mkClauses x (Pragma (CatchallPragma r) : cs) catchall = do+      -- Warn about consecutive CATCHALL pragmas+      unless (null catchall) $ declarationWarning $ InvalidCatchallPragma r+      mkClauses x cs (YesCatchall r)+     mkClauses x (FunClause lhs rhs wh ca : cs) catchall       | null (lhsWithExpr lhs) || hasEllipsis lhs  =-      (Clause x (ca || catchall) lhs rhs wh [] :) <$> mkClauses x cs False   -- Will result in an error later.+      (Clause x (ca <> catchall) lhs rhs wh [] :) <$> mkClauses x cs empty   -- Will result in an error later.      mkClauses x (FunClause lhs rhs wh ca : cs) catchall = do       when (null withClauses) $ declarationException $ MissingWithClauses x lhs-      wcs <- mkClauses x withClauses False-      (Clause x (ca || catchall) lhs rhs wh wcs :) <$> mkClauses x cs' False+      wcs <- mkClauses x withClauses empty+      (Clause x (ca <> catchall) lhs rhs wh wcs :) <$> mkClauses x cs' empty       where         (withClauses, cs') = subClauses cs @@ -755,9 +812,9 @@     couldBeCallOf :: Maybe Fixity' -> Name -> Pattern -> Bool     couldBeCallOf mFixity x p =       let-      pns        = patternNames p+      pns        = patternQNames p       xStrings   = nameStringParts x-      patStrings = concatMap nameStringParts pns+      patStrings = concatMap nameStringParts $ mapMaybe isUnqualified pns       in --          trace ("x = " ++ prettyShow x) $ --          trace ("pns = " ++ show pns) $@@ -766,15 +823,15 @@ --          trace ("mFixity = " ++ show mFixity) $       case (listToMaybe pns, mFixity) of         -- first identifier in the patterns is the fun.symbol?-        (Just y, _) | x == y -> True -- trace ("couldBe since y = " ++ prettyShow y) $ True+        (Just y, _) | Just x == isUnqualified y -> True -- trace ("couldBe since y = " ++ prettyShow y) $ True         -- are the parts of x contained in p-        _ | xStrings `isSublistOf` patStrings -> True -- trace ("couldBe since isSublistOf") $ True+        _ | xStrings `List.isSubsequenceOf` patStrings -> True         -- looking for a mixfix fun.symb         (_, Just fix) ->  -- also matches in case of a postfix            let notStrings = stringParts (theNotation fix)            in  -- trace ("notStrings = " ++ show notStrings) $                -- trace ("patStrings = " ++ show patStrings) $-               not (null notStrings) && (notStrings `isSublistOf` patStrings)+               not (null notStrings) && (notStrings `List.isSubsequenceOf` patStrings)         -- not a notation, not first id: give up         _ -> False -- trace ("couldBe not (case default)") $ False @@ -796,21 +853,22 @@     -- Turn a new style `interleaved mutual' block into a new style mutual block     -- by grouping the declarations in blocks.     mkInterleavedMutual-      :: Range                 -- Range of the whole @mutual@ block.+      :: KwRange               -- Range of the @interleaved mutual@ keywords.       -> [NiceDeclaration]     -- Declarations inside the block.       -> Nice NiceDeclaration  -- Returns a 'NiceMutual'.-    mkInterleavedMutual r ds' = do-      (other, (m, checks, _)) <- runStateT (groupByBlocks r ds') (empty, mempty, 0)+    mkInterleavedMutual kwr ds' = do+      (other, (m, checks, _)) <- runStateT (groupByBlocks kwr ds') (empty, mempty, 0)       let idecls = other ++ concatMap (uncurry interleavedDecl) (Map.toList m)       let decls0 = map snd $ List.sortBy (compare `on` fst) idecls       ps <- use loneSigs       checkLoneSigs ps       let decls = replaceSigs ps decls0       -- process the checks+      let r = fuseRange kwr ds'       tc <- combineTerminationChecks r (mutualTermination checks)       let cc = combineCoverageChecks   (mutualCoverage checks)       let pc = combinePositivityChecks (mutualPositivity checks)-      pure $ NiceMutual r tc cc pc decls+      pure $ NiceMutual kwr tc cc pc decls        where @@ -821,14 +879,14 @@         addType n c mc = do           (m, checks, i) <- get           when (isJust $ Map.lookup n m) $ lift $ declarationException $ DuplicateDefinition n-          put (Map.insert n (c i) m, mc <> checks, i+1)+          put (Map.insert n (c i) m, mc <> checks, i + 1)          addFunType d@(FunSig _ _ _ _ _ _ tc cc n _) = do            let checks = MutualChecks [tc] [cc] []            addType n (\ i -> InterleavedFun i d Nothing) checks         addFunType _ = __IMPOSSIBLE__ -        addDataType d@(NiceDataSig _ _ _ pc uc n _ _) = do+        addDataType d@(NiceDataSig _ _ _ _ pc uc n _ _) = do           let checks = MutualChecks [] [] [pc]           addType n (\ i -> InterleavedData i d Nothing) checks         addDataType _ = __IMPOSSIBLE__@@ -848,14 +906,10 @@               lift $ removeLoneSig n               -- add the constructors to the existing ones (if any)               let (cs', i') = case cs of-                    Nothing        -> ((i , ds :| [] ), i+1)+                    Nothing        -> ((i , ds :| [] ), i + 1)                     Just (i1, ds1) -> ((i1, ds <| ds1), i)               put (Map.insert n (InterleavedData i0 sig (Just cs')) m, checks, i')-            _ -> lift $ declarationWarning $ MissingDeclarations $ case mr of-                   Just r -> [(n, r)]-                   Nothing -> flip foldMap ds $ \case-                     Axiom r _ _ _ _ n _ -> [(n, r)]-                     _ -> __IMPOSSIBLE__+            _ -> lift $ declarationWarning $ MissingDataDeclaration n          addDataConstructors mr Nothing [] = pure () @@ -881,14 +935,16 @@           case Map.lookup n m of             Just (InterleavedFun i0 sig cs0) -> do               let (cs', i') = case cs0 of-                    Nothing        -> ((i,  (ds, cs) :| [] ), i+1)+                    Nothing        -> ((i,  (ds, cs) :| [] ), i + 1)                     Just (i1, cs1) -> ((i1, (ds, cs) <| cs1), i)               put (Map.insert n (InterleavedFun i0 sig (Just cs')) m, check <> checks, i')             _ -> __IMPOSSIBLE__ -- A FunDef always come after an existing FunSig!         addFunDef _ = __IMPOSSIBLE__ -        addFunClauses :: Range -> [NiceDeclaration]-                      -> StateT (InterleavedMutual, MutualChecks, DeclNum) Nice [(DeclNum, NiceDeclaration)]+        addFunClauses ::+             KwRange+          -> [NiceDeclaration]+          -> StateT (InterleavedMutual, MutualChecks, DeclNum) Nice [(DeclNum, NiceDeclaration)]         addFunClauses r (nd@(NiceFunClause _ _ _ tc cc _ d@(FunClause lhs _ _ _)) : ds) = do           -- get the candidate functions that are in this interleaved mutual block           (m, checks, i) <- get@@ -902,17 +958,17 @@             -- no candidate: keep the isolated fun clause, we'll complain about it later             [] -> do               let check = MutualChecks [tc] [cc] []-              put (m, check <> checks, i+1)+              put (m, check <> checks, i + 1)               ((i,nd) :) <$> groupByBlocks r ds             -- exactly one candidate: attach the funclause to the definition             [(n, fits0, rest)] -> do               let (checkss, fits) = unzip fits0               ds <- lift $ expandEllipsis fits-              cs <- lift $ mkClauses n ds False+              cs <- lift $ mkClauses n ds empty               case Map.lookup n m of                 Just (InterleavedFun i0 sig cs0) -> do                   let (cs', i') = case cs0 of-                        Nothing        -> ((i,  (fits,cs) :| [] ), i+1)+                        Nothing        -> ((i,  (fits,cs) :| [] ), i + 1)                         Just (i1, cs1) -> ((i1, (fits,cs) <| cs1), i)                   let checks' = Fold.fold checkss                   put (Map.insert n (InterleavedFun i0 sig (Just cs')) m, checks' <> checks, i')@@ -924,27 +980,29 @@                            $ List1.reverse $ fmap (\ (a,_,_) -> a) $ xf :| xfs         addFunClauses _ _ = __IMPOSSIBLE__ -        groupByBlocks :: Range -> [NiceDeclaration]-                      -> StateT (InterleavedMutual, MutualChecks, DeclNum) Nice [(DeclNum, NiceDeclaration)]-        groupByBlocks r []       = pure []-        groupByBlocks r (d : ds) = do+        groupByBlocks ::+              KwRange+          -> [NiceDeclaration]+          -> StateT (InterleavedMutual, MutualChecks, DeclNum) Nice [(DeclNum, NiceDeclaration)]+        groupByBlocks kwr []       = pure []+        groupByBlocks kwr (d : ds) = do           -- for most branches we deal with the one declaration and move on-          let oneOff act = act >>= \ ns -> (ns ++) <$> groupByBlocks r ds+          let oneOff act = act >>= \ ns -> (ns ++) <$> groupByBlocks kwr ds           case d of             NiceDataSig{}                -> oneOff $ [] <$ addDataType d             NiceDataDef r _ _ _ _ n _ ds -> oneOff $ [] <$ addDataConstructors (Just r) (Just n) ds-            NiceLoneConstructor r ds     -> oneOff $ [] <$ addDataConstructors Nothing Nothing ds+            NiceLoneConstructor _ ds     -> oneOff $ [] <$ addDataConstructors Nothing Nothing ds             FunSig{}                     -> oneOff $ [] <$ addFunType d             FunDef _ _ _  _ _ _ n cs                       | not (isNoName n) -> oneOff $ [] <$ addFunDef d             -- It's a bit different for fun clauses because we may need to grab a lot             -- of clauses to handle ellipses properly.-            NiceFunClause{}              -> addFunClauses r (d:ds)+            NiceFunClause{}              -> addFunClauses kwr (d:ds)             -- We do not need to worry about RecSig vs. RecDef: we know there's exactly one             -- of each for record definitions and leaving them in place should be enough!             _ -> oneOff $ do               (m, c, i) <- get -- TODO: grab checks from c?-              put (m, c, i+1)+              put (m, c, i + 1)               pure [(i,d)]      -- Extract the name of the return type (if any) of a potential constructor.@@ -968,10 +1026,10 @@     -- Turn an old-style mutual block into a new style mutual block     -- by pushing the definitions to the end.     mkOldMutual-      :: Range                 -- Range of the whole @mutual@ block.+      :: KwRange               -- Range of the @mutual@ keyword (if any).       -> [NiceDeclaration]     -- Declarations inside the block.       -> Nice NiceDeclaration  -- Returns a 'NiceMutual'.-    mkOldMutual r ds' = do+    mkOldMutual kwr ds' = do         -- Postulate the missing definitions         let ps = loneSigsFromLoneNames loneNames         checkLoneSigs ps@@ -1032,6 +1090,13 @@             NiceGeneralize{}    -> top             NiceUnquoteDecl{}   -> top             NiceUnquoteDef{}    -> bottom+            NiceUnquoteData{}   -> top++            -- Opaque blocks can not participate in old-style mutual+            -- recursion. If some of the definitions are opaque then+            -- they all need to be.+            NiceOpaque r _ _    ->+              In3 d <$ do declarationException $ OpaqueInMutual r             NicePragma r pragma -> case pragma of                OptionsPragma{}           -> top     -- error thrown in the type checker@@ -1051,12 +1116,16 @@                StaticPragma{}            -> bottom               InlinePragma{}            -> bottom+              NotProjectionLikePragma{} -> bottom +              OverlapPragma{}           -> top+               ImpossiblePragma{}        -> top     -- error thrown in scope checker               EtaPragma{}               -> bottom  -- needs record definition               WarningOnUsage{}          -> top               WarningOnImport{}         -> top               InjectivePragma{}         -> top     -- only needs name, not definition+              InjectiveForInferencePragma{} -> top               DisplayPragma{}           -> top     -- only for printing                -- The attached pragmas have already been handled at this point.@@ -1067,6 +1136,7 @@               NoUniverseCheckPragma{}   -> __IMPOSSIBLE__               NoCoverageCheckPragma{}   -> __IMPOSSIBLE__ +         -- -- Pull type signatures to the top         -- let (sigs, other) = List.partition isTypeSig ds @@ -1083,6 +1153,7 @@         -- Compute termination checking flag for mutual block         tc0 <- use terminationCheckPragma         let tcs = map termCheck ds+        let r   = fuseRange kwr ds'         tc <- combineTerminationChecks r (tc0:tcs)          -- Compute coverage checking flag for mutual block@@ -1095,15 +1166,9 @@         let pcs = map positivityCheckOldMutual ds         let pc = combinePositivityChecks (pc0:pcs) -        return $ NiceMutual r tc cc pc $ top ++ bottom-        -- return $ NiceMutual r tc pc $ other ++ defs-        -- return $ NiceMutual r tc pc $ sigs ++ other-      where--        -- isTypeSig Axiom{}                     = True-        -- isTypeSig d | LoneSig{} <- declKind d = True-        -- isTypeSig _                           = False+        return $ NiceMutual kwr tc cc pc $ top ++ bottom +      where         sigNames  = [ (r, x, k) | LoneSigDecl r k x <- map declKind ds' ]         defNames  = [ (x, k) | LoneDefs k xs <- map declKind ds', x <- xs ]         -- compute the set difference with equality just on names@@ -1119,22 +1184,24 @@         termCheck (NiceMutual _ tc _ _ _)            = tc         termCheck (NiceUnquoteDecl _ _ _ _ tc _ _ _) = tc         termCheck (NiceUnquoteDef _ _ _ tc _ _ _)    = tc-        termCheck Axiom{}             = TerminationCheck-        termCheck NiceField{}         = TerminationCheck-        termCheck PrimitiveFunction{} = TerminationCheck-        termCheck NiceModule{}        = TerminationCheck-        termCheck NiceModuleMacro{}   = TerminationCheck-        termCheck NiceOpen{}          = TerminationCheck-        termCheck NiceImport{}        = TerminationCheck-        termCheck NicePragma{}        = TerminationCheck-        termCheck NiceRecSig{}        = TerminationCheck-        termCheck NiceDataSig{}       = TerminationCheck-        termCheck NiceFunClause{}     = TerminationCheck-        termCheck NiceDataDef{}       = TerminationCheck-        termCheck NiceRecDef{}        = TerminationCheck-        termCheck NicePatternSyn{}    = TerminationCheck-        termCheck NiceGeneralize{}    = TerminationCheck+        termCheck Axiom{}               = TerminationCheck+        termCheck NiceField{}           = TerminationCheck+        termCheck PrimitiveFunction{}   = TerminationCheck+        termCheck NiceModule{}          = TerminationCheck+        termCheck NiceModuleMacro{}     = TerminationCheck+        termCheck NiceOpen{}            = TerminationCheck+        termCheck NiceImport{}          = TerminationCheck+        termCheck NicePragma{}          = TerminationCheck+        termCheck NiceRecSig{}          = TerminationCheck+        termCheck NiceDataSig{}         = TerminationCheck+        termCheck NiceFunClause{}       = TerminationCheck+        termCheck NiceDataDef{}         = TerminationCheck+        termCheck NiceRecDef{}          = TerminationCheck+        termCheck NicePatternSyn{}      = TerminationCheck+        termCheck NiceGeneralize{}      = TerminationCheck         termCheck NiceLoneConstructor{} = TerminationCheck+        termCheck NiceUnquoteData{}     = TerminationCheck+        termCheck NiceOpaque{}          = TerminationCheck          covCheck :: NiceDeclaration -> CoverageCheck         covCheck (FunSig _ _ _ _ _ _ _ cc _ _)      = cc@@ -1143,58 +1210,73 @@         covCheck (NiceMutual _ _ cc _ _)            = cc         covCheck (NiceUnquoteDecl _ _ _ _ _ cc _ _) = cc         covCheck (NiceUnquoteDef _ _ _ _ cc _ _)    = cc-        covCheck Axiom{}             = YesCoverageCheck-        covCheck NiceField{}         = YesCoverageCheck-        covCheck PrimitiveFunction{} = YesCoverageCheck-        covCheck NiceModule{}        = YesCoverageCheck-        covCheck NiceModuleMacro{}   = YesCoverageCheck-        covCheck NiceOpen{}          = YesCoverageCheck-        covCheck NiceImport{}        = YesCoverageCheck-        covCheck NicePragma{}        = YesCoverageCheck-        covCheck NiceRecSig{}        = YesCoverageCheck-        covCheck NiceDataSig{}       = YesCoverageCheck-        covCheck NiceFunClause{}     = YesCoverageCheck-        covCheck NiceDataDef{}       = YesCoverageCheck-        covCheck NiceRecDef{}        = YesCoverageCheck-        covCheck NicePatternSyn{}    = YesCoverageCheck-        covCheck NiceGeneralize{}    = YesCoverageCheck+        covCheck Axiom{}               = YesCoverageCheck+        covCheck NiceField{}           = YesCoverageCheck+        covCheck PrimitiveFunction{}   = YesCoverageCheck+        covCheck NiceModule{}          = YesCoverageCheck+        covCheck NiceModuleMacro{}     = YesCoverageCheck+        covCheck NiceOpen{}            = YesCoverageCheck+        covCheck NiceImport{}          = YesCoverageCheck+        covCheck NicePragma{}          = YesCoverageCheck+        covCheck NiceRecSig{}          = YesCoverageCheck+        covCheck NiceDataSig{}         = YesCoverageCheck+        covCheck NiceFunClause{}       = YesCoverageCheck+        covCheck NiceDataDef{}         = YesCoverageCheck+        covCheck NiceRecDef{}          = YesCoverageCheck+        covCheck NicePatternSyn{}      = YesCoverageCheck+        covCheck NiceGeneralize{}      = YesCoverageCheck         covCheck NiceLoneConstructor{} = YesCoverageCheck+        covCheck NiceUnquoteData{}     = YesCoverageCheck+        covCheck NiceOpaque{}          = YesCoverageCheck          -- ASR (26 December 2015): Do not positivity check a mutual         -- block if any of its inner declarations comes with a         -- NO_POSITIVITY_CHECK pragma. See Issue 1614.         positivityCheckOldMutual :: NiceDeclaration -> PositivityCheck         positivityCheckOldMutual (NiceDataDef _ _ _ pc _ _ _ _) = pc-        positivityCheckOldMutual (NiceDataSig _ _ _ pc _ _ _ _) = pc+        positivityCheckOldMutual (NiceDataSig _ _ _ _ pc _ _ _ _) = pc         positivityCheckOldMutual (NiceMutual _ _ _ pc _)        = pc-        positivityCheckOldMutual (NiceRecSig _ _ _ pc _ _ _ _)  = pc+        positivityCheckOldMutual (NiceRecSig _ _ _ _ pc _ _ _ _) = pc         positivityCheckOldMutual (NiceRecDef _ _ _ pc _ _ _ _ _) = pc         positivityCheckOldMutual _                              = YesPositivityCheck          -- A mutual block cannot have a measure,         -- but it can skip termination check. -    abstractBlock _ [] = return []+    abstractBlock+      :: KwRange  -- Range of @abstract@ keyword.+      -> [NiceDeclaration]+      -> Nice [NiceDeclaration]     abstractBlock r ds = do-      (ds', anyChange) <- runChangeT $ mkAbstract ds-      let inherited = r == noRange+      (ds', anyChange) <- runChangeT $ mkAbstract r ds+      let inherited = null r       if anyChange then return ds' else do         -- hack to avoid failing on inherited abstract blocks in where clauses         unless inherited $ declarationWarning $ UselessAbstract r         return ds -- no change! -    privateBlock _ _ [] = return []+    privateBlock+      :: KwRange  -- Range of @private@ keyword.+      -> Origin   -- Origin of the private block.+      -> [NiceDeclaration]+      -> Nice [NiceDeclaration]     privateBlock r o ds = do-      (ds', anyChange) <- runChangeT $ mkPrivate o ds-      if anyChange then return ds' else do-        when (o == UserWritten) $ declarationWarning $ UselessPrivate r-        return ds -- no change!+      (ds', anyChange) <- runChangeT $ mkPrivate r o ds+      -- Warn if user-written 'private' does not accomplish anything.+      when (o == UserWritten) do+        if anyChange then+          -- Andreas, 2025-03-29, user-written 'private' is useless in anonymous 'where' modules+          -- since Agda automatically inserts a 'private' there.+          whenM ((AnyWhere_ ==) <$> asks checkingWhere) warn+        else warn+      return $ if anyChange then ds' else ds+      where+        warn = declarationWarning $ UselessPrivate r      instanceBlock-      :: Range  -- Range of @instance@ keyword.+      :: KwRange  -- Range of @instance@ keyword.       -> [NiceDeclaration]       -> Nice [NiceDeclaration]-    instanceBlock _ [] = return []     instanceBlock r ds = do       let (ds', anyChange) = runChange $ mapM (mkInstance r) ds       if anyChange then return ds' else do@@ -1203,7 +1285,7 @@      -- Make a declaration eligible for instance search.     mkInstance-      :: Range  -- Range of @instance@ keyword.+      :: KwRange  -- Range of @instance@ keyword.       -> Updater NiceDeclaration     mkInstance r0 = \case         Axiom r p a i rel x e          -> (\ i -> Axiom r p a i rel x e) <$> setInstance r0 i@@ -1213,6 +1295,7 @@         NiceLoneConstructor r ds       -> NiceLoneConstructor r <$> mapM (mkInstance r0) ds         d@NiceFunClause{}              -> return d         FunDef r ds a i tc cc x cs     -> (\ i -> FunDef r ds a i tc cc x cs) <$> setInstance r0 i+        NiceOpaque r ns i              -> (\ i -> NiceOpaque r ns i) <$> traverse (mkInstance r0) i         d@NiceField{}                  -> return d  -- Field instance are handled by the parser         d@PrimitiveFunction{}          -> return d         d@NiceUnquoteDef{}             -> return d@@ -1227,22 +1310,39 @@         d@NiceRecDef{}                 -> return d         d@NicePatternSyn{}             -> return d         d@NiceGeneralize{}             -> return d+        d@NiceUnquoteData{}            -> return d      setInstance-      :: Range  -- Range of @instance@ keyword.+      :: KwRange  -- Range of @instance@ keyword.       -> Updater IsInstance     setInstance r0 = \case       i@InstanceDef{} -> return i       _               -> dirty $ InstanceDef r0 -    macroBlock r ds = mapM mkMacro ds+    macroBlock+      :: KwRange  -- Range of @macro@ keyword.+      -> [NiceDeclaration]+      -> Nice [NiceDeclaration]+    macroBlock r ds = do+      (ds', anyChange) <- runChangeT $ mkMacro ds+      if anyChange then return ds' else do+        declarationWarning $ UselessMacro r+        return ds -- no change! -    mkMacro :: NiceDeclaration -> Nice NiceDeclaration-    mkMacro = \case-        FunSig r p a i _ rel tc cc x e -> return $ FunSig r p a i MacroDef rel tc cc x e-        d@FunDef{}                     -> return d-        d                              -> declarationException (BadMacroDef d)+class MakeMacro a where+  mkMacro :: UpdaterT Nice a +  default mkMacro :: (Traversable f, MakeMacro a', a ~ f a') => UpdaterT Nice a+  mkMacro = traverse mkMacro++instance MakeMacro a => MakeMacro [a]++instance MakeMacro NiceDeclaration where+  mkMacro = \case+    FunSig r p a i _ rel tc cc x e -> dirty $ FunSig r p a i MacroDef rel tc cc x e+    d@FunDef{}                     -> return d+    d                              -> lift $ declarationException $ BadMacroDef d+ -- | Make a declaration abstract. -- -- Mark computation as 'dirty' if there was a declaration that could be made abstract.@@ -1252,10 +1352,13 @@ -- Then, nested @abstract@s would sometimes also be complained about.  class MakeAbstract a where-  mkAbstract :: UpdaterT Nice a+  mkAbstract ::+       KwRange+         -- ^ Range of the keyword @abstract@.+    -> UpdaterT Nice a -  default mkAbstract :: (Traversable f, MakeAbstract a', a ~ f a') => UpdaterT Nice a-  mkAbstract = traverse mkAbstract+  default mkAbstract :: (Traversable f, MakeAbstract a', a ~ f a') => KwRange -> UpdaterT Nice a+  mkAbstract = traverse . mkAbstract  instance MakeAbstract a => MakeAbstract [a] @@ -1264,51 +1367,61 @@ --   mkAbstract = traverse mkAbstract  instance MakeAbstract IsAbstract where-  mkAbstract = \case+  mkAbstract _ = \case     a@AbstractDef -> return a     ConcreteDef -> dirty $ AbstractDef  instance MakeAbstract NiceDeclaration where-  mkAbstract = \case-      NiceMutual r termCheck cc pc ds  -> NiceMutual r termCheck cc pc <$> mkAbstract ds-      NiceLoneConstructor r ds         -> NiceLoneConstructor r <$> mkAbstract ds-      FunDef r ds a i tc cc x cs       -> (\ a -> FunDef r ds a i tc cc x) <$> mkAbstract a <*> mkAbstract cs-      NiceDataDef r o a pc uc x ps cs  -> (\ a -> NiceDataDef r o a pc uc x ps) <$> mkAbstract a <*> mkAbstract cs-      NiceRecDef r o a pc uc x dir ps cs -> (\ a -> NiceRecDef r o a pc uc x dir ps cs) <$> mkAbstract a-      NiceFunClause r p a tc cc catchall d  -> (\ a -> NiceFunClause r p a tc cc catchall d) <$> mkAbstract a-      -- The following declarations have an @InAbstract@ field-      -- but are not really definitions, so we do count them into-      -- the declarations which can be made abstract-      -- (thus, do not notify progress with @dirty@).-      Axiom r p a i rel x e          -> return $ Axiom             r p AbstractDef i rel x e-      FunSig r p a i m rel tc cc x e -> return $ FunSig            r p AbstractDef i m rel tc cc x e-      NiceRecSig r p a pc uc x ls t  -> return $ NiceRecSig        r p AbstractDef pc uc x ls t-      NiceDataSig r p a pc uc x ls t -> return $ NiceDataSig       r p AbstractDef pc uc x ls t-      NiceField r p _ i tac x e      -> return $ NiceField         r p AbstractDef i tac x e-      PrimitiveFunction r p _ x e    -> return $ PrimitiveFunction r p AbstractDef x e-      -- Andreas, 2016-07-17 it does have effect on unquoted defs.-      -- Need to set updater state to dirty!-      NiceUnquoteDecl r p _ i tc cc x e -> tellDirty $> NiceUnquoteDecl r p AbstractDef i tc cc x e-      NiceUnquoteDef r p _ tc cc x e    -> tellDirty $> NiceUnquoteDef r p AbstractDef tc cc x e-      d@NiceModule{}                 -> return d-      d@NiceModuleMacro{}            -> return d-      d@NicePragma{}                 -> return d-      d@(NiceOpen _ _ directives)              -> do-        whenJust (publicOpen directives) $ lift . declarationWarning . OpenPublicAbstract-        return d-      d@NiceImport{}                 -> return d-      d@NicePatternSyn{}             -> return d-      d@NiceGeneralize{}             -> return d+  mkAbstract :: KwRange -> UpdaterT Nice NiceDeclaration+  mkAbstract kwr = \case+    NiceMutual r termCheck cc pc ds      -> NiceMutual r termCheck cc pc <$> mkAbstract kwr ds+    NiceLoneConstructor r ds             -> NiceLoneConstructor r <$> mkAbstract kwr ds+    FunDef r ds a i tc cc x cs           -> (\ a -> FunDef r ds a i tc cc x) <$> mkAbstract kwr a <*> mkAbstract kwr cs+    NiceDataDef r o a pc uc x ps cs      -> (\ a -> NiceDataDef r o a pc uc x ps) <$> mkAbstract kwr a <*> mkAbstract kwr cs+    NiceRecDef r o a pc uc x dir ps cs   -> (\ a -> NiceRecDef r o a pc uc x dir ps cs) <$> mkAbstract kwr a+    NiceFunClause r p a tc cc catchall d -> (\ a -> NiceFunClause r p a tc cc catchall d) <$> mkAbstract kwr a+    -- The following declarations have an @InAbstract@ field+    -- but are not really definitions, so we do count them into+    -- the declarations which can be made abstract+    -- (thus, do not notify progress with @dirty@).+    Axiom r p a i rel x e                -> return $ Axiom             r p AbstractDef i rel x e+    FunSig r p a i m rel tc cc x e       -> return $ FunSig            r p AbstractDef i m rel tc cc x e+    NiceRecSig  r er p a pc uc x ls t    -> return $ NiceRecSig     r er p AbstractDef pc uc x ls t+    NiceDataSig r er p a pc uc x ls t    -> return $ NiceDataSig    r er p AbstractDef pc uc x ls t+    NiceField r p _ i tac x e            -> return $ NiceField         r p AbstractDef i tac x e+    PrimitiveFunction r p _ x e          -> return $ PrimitiveFunction r p AbstractDef x e+    -- Andreas, 2016-07-17 it does have effect on unquoted defs.+    -- Need to set updater state to dirty!+    NiceUnquoteDecl r p _ i tc cc x e    -> tellDirty $> NiceUnquoteDecl r p AbstractDef i tc cc x e+    NiceUnquoteDef r p _ tc cc x e       -> tellDirty $> NiceUnquoteDef  r p AbstractDef tc cc x e+    NiceUnquoteData r p _ tc cc x xs e   -> tellDirty $> NiceUnquoteData r p AbstractDef tc cc x xs e+    d@NiceModule{}                       -> return d+    d@NiceModuleMacro{}                  -> return d+    d@NicePragma{}                       -> return d+    d@NiceOpen{}                         -> d <$ do+      unless (null kwr) $+        lift $ declarationWarning $ OpenImportAbstract (getRange d) kwr OpenNotImport+    d@NiceImport{}                       -> d <$ do+      unless (null kwr) $+        lift $ declarationWarning $ OpenImportAbstract (getRange d) kwr ImportMayOpen+    d@NicePatternSyn{}                   -> return d+    d@NiceGeneralize{}                   -> return d+    NiceOpaque r ns ds                   -> NiceOpaque r ns <$> mkAbstract kwr ds  instance MakeAbstract Clause where-  mkAbstract (Clause x catchall lhs rhs wh with) = do-    Clause x catchall lhs rhs <$> mkAbstract wh <*> mkAbstract with+  mkAbstract kwr (Clause x catchall lhs rhs wh with) = do+    Clause x catchall lhs rhs <$> mkAbstract kwr wh <*> mkAbstract kwr with  -- | Contents of a @where@ clause are abstract if the parent is.+--+--   These are inherited 'Abstract' blocks, indicated by an empty range+--   for the @abstract@ keyword. instance MakeAbstract WhereClause where-  mkAbstract  NoWhere             = return $ NoWhere-  mkAbstract (AnyWhere r ds)      = dirty $ AnyWhere r [Abstract noRange ds]-  mkAbstract (SomeWhere r m a ds) = dirty $ SomeWhere r m a [Abstract noRange ds]+  mkAbstract _  NoWhere               = return $ NoWhere+  mkAbstract _ (AnyWhere r ds)        = dirty $ AnyWhere r+                                                  [Abstract empty ds]+  mkAbstract _ (SomeWhere r e m a ds) = dirty $ SomeWhere r e m a+                                                  [Abstract empty ds]  -- | Make a declaration private. --@@ -1320,10 +1433,15 @@ -- Then, nested @private@s would sometimes also be complained about.  class MakePrivate a where-  mkPrivate :: Origin -> UpdaterT Nice a+  mkPrivate ::+       KwRange+         -- ^ Range of the @private@ keyword.+    -> Origin+         -- ^ Origin of the @private@ block.+    -> UpdaterT Nice a -  default mkPrivate :: (Traversable f, MakePrivate a', a ~ f a') => Origin -> UpdaterT Nice a-  mkPrivate o = traverse $ mkPrivate o+  default mkPrivate :: (Traversable f, MakePrivate a', a ~ f a') => KwRange -> Origin -> UpdaterT Nice a+  mkPrivate kwr o = traverse $ mkPrivate kwr o  instance MakePrivate a => MakePrivate [a] @@ -1332,85 +1450,95 @@ --   mkPrivate = traverse mkPrivate  instance MakePrivate Access where-  mkPrivate o = \case+  mkPrivate kwr o = \case     p@PrivateAccess{} -> return p  -- OR? return $ PrivateAccess o-    _                 -> dirty $ PrivateAccess o+    _                 -> dirty $ PrivateAccess kwr o  instance MakePrivate NiceDeclaration where-  mkPrivate o = \case-      Axiom r p a i rel x e                    -> (\ p -> Axiom r p a i rel x e)                <$> mkPrivate o p-      NiceField r p a i tac x e                -> (\ p -> NiceField r p a i tac x e)            <$> mkPrivate o p-      PrimitiveFunction r p a x e              -> (\ p -> PrimitiveFunction r p a x e)          <$> mkPrivate o p-      NiceMutual r tc cc pc ds                 -> (\ ds-> NiceMutual r tc cc pc ds)             <$> mkPrivate o ds-      NiceLoneConstructor r ds                 -> NiceLoneConstructor r                         <$> mkPrivate o ds-      NiceModule r p a x tel ds                -> (\ p -> NiceModule r p a x tel ds)            <$> mkPrivate o p-      NiceModuleMacro r p x ma op is           -> (\ p -> NiceModuleMacro r p x ma op is)       <$> mkPrivate o p-      FunSig r p a i m rel tc cc x e           -> (\ p -> FunSig r p a i m rel tc cc x e)       <$> mkPrivate o p-      NiceRecSig r p a pc uc x ls t            -> (\ p -> NiceRecSig r p a pc uc x ls t)        <$> mkPrivate o p-      NiceDataSig r p a pc uc x ls t           -> (\ p -> NiceDataSig r p a pc uc x ls t)       <$> mkPrivate o p-      NiceFunClause r p a tc cc catchall d     -> (\ p -> NiceFunClause r p a tc cc catchall d) <$> mkPrivate o p-      NiceUnquoteDecl r p a i tc cc x e        -> (\ p -> NiceUnquoteDecl r p a i tc cc x e)    <$> mkPrivate o p-      NiceUnquoteDef r p a tc cc x e           -> (\ p -> NiceUnquoteDef r p a tc cc x e)       <$> mkPrivate o p-      NicePatternSyn r p x xs p'               -> (\ p -> NicePatternSyn r p x xs p')           <$> mkPrivate o p-      NiceGeneralize r p i tac x t             -> (\ p -> NiceGeneralize r p i tac x t)         <$> mkPrivate o p+  mkPrivate kwr o = \case+      Axiom r p a i rel x e                    -> (\ p -> Axiom r p a i rel x e)                <$> mkPrivate kwr o p+      NiceField r p a i tac x e                -> (\ p -> NiceField r p a i tac x e)            <$> mkPrivate kwr o p+      PrimitiveFunction r p a x e              -> (\ p -> PrimitiveFunction r p a x e)          <$> mkPrivate kwr o p+      NiceMutual r tc cc pc ds                 -> (\ ds-> NiceMutual r tc cc pc ds)             <$> mkPrivate kwr o ds+      NiceLoneConstructor r ds                 -> NiceLoneConstructor r                         <$> mkPrivate kwr o ds+      NiceModule r p a e x tel ds              -> (\ p -> NiceModule r p a e x tel ds)          <$> mkPrivate kwr o p+      NiceModuleMacro r p e x ma op is         -> (\ p -> NiceModuleMacro r p e x ma op is)     <$> mkPrivate kwr o p+      FunSig r p a i m rel tc cc x e           -> (\ p -> FunSig r p a i m rel tc cc x e)       <$> mkPrivate kwr o p+      NiceRecSig r er p a pc uc x ls t         -> (\ p -> NiceRecSig r er p a pc uc x ls t)     <$> mkPrivate kwr o p+      NiceDataSig r er p a pc uc x ls t        -> (\ p -> NiceDataSig r er p a pc uc x ls t)    <$> mkPrivate kwr o p+      NiceFunClause r p a tc cc catchall d     -> (\ p -> NiceFunClause r p a tc cc catchall d) <$> mkPrivate kwr o p+      NiceUnquoteDecl r p a i tc cc x e        -> (\ p -> NiceUnquoteDecl r p a i tc cc x e)    <$> mkPrivate kwr o p+      NiceUnquoteDef r p a tc cc x e           -> (\ p -> NiceUnquoteDef r p a tc cc x e)       <$> mkPrivate kwr o p+      NicePatternSyn r p x xs p'               -> (\ p -> NicePatternSyn r p x xs p')           <$> mkPrivate kwr o p+      NiceGeneralize r p i tac x t             -> (\ p -> NiceGeneralize r p i tac x t)         <$> mkPrivate kwr o p+      NiceOpaque r ns ds                       -> (\ p -> NiceOpaque r ns p)                    <$> mkPrivate kwr o ds       d@NicePragma{}                           -> return d-      d@(NiceOpen _ _ directives)              -> do-        whenJust (publicOpen directives) $ lift . declarationWarning . OpenPublicPrivate-        return d-      d@NiceImport{}                           -> return d+      d@(NiceOpen r _x dir)                    -> d <$ do+        unless (null kwr) $+          whenJust (publicOpen dir) \ kwrPublic ->+            lift $ declarationWarning $ OpenImportPrivate r kwrPublic kwr OpenNotImport+      d@(NiceImport r _x _as _open dir)        -> d <$ do+        unless (null kwr) $+          whenJust (publicOpen dir) \ kwrPublic ->+            lift $ declarationWarning $ OpenImportPrivate r kwrPublic kwr ImportMayOpen       -- Andreas, 2016-07-08, issue #2089       -- we need to propagate 'private' to the named where modules-      FunDef r ds a i tc cc x cls              -> FunDef r ds a i tc cc x <$> mkPrivate o cls+      FunDef r ds a i tc cc x cls              -> FunDef r ds a i tc cc x <$> mkPrivate kwr o cls       d@NiceDataDef{}                          -> return d       d@NiceRecDef{}                           -> return d+      d@NiceUnquoteData{}                      -> return d  instance MakePrivate Clause where-  mkPrivate o (Clause x catchall lhs rhs wh with) = do-    Clause x catchall lhs rhs <$> mkPrivate o wh <*> mkPrivate o with+  mkPrivate kwr o (Clause x catchall lhs rhs wh with) = do+    Clause x catchall lhs rhs <$> mkPrivate kwr o wh <*> mkPrivate kwr o with  instance MakePrivate WhereClause where-  mkPrivate o = \case+  mkPrivate kwr o = \case     d@NoWhere    -> return d     -- @where@-declarations are protected behind an anonymous module,     -- thus, they are effectively private by default.     d@AnyWhere{} -> return d     -- Andreas, 2016-07-08-    -- A @where@-module is private if the parent function is private.+    -- A named @where@-module is private if the parent function is private.     -- The contents of this module are not private, unless declared so!     -- Thus, we do not recurse into the @ds@ (could not anyway).-    SomeWhere r m a ds -> mkPrivate o a <&> \ a' -> SomeWhere r m a' ds+    SomeWhere r e m a ds ->+      mkPrivate kwr o a <&> \a' -> SomeWhere r e m a' ds  -- The following function is (at the time of writing) only used three -- times: for building Lets, and for printing error messages.  -- | (Approximately) convert a 'NiceDeclaration' back to a list of -- 'Declaration's.-notSoNiceDeclarations :: NiceDeclaration -> [Declaration]+notSoNiceDeclarations :: NiceDeclaration -> List1 Declaration notSoNiceDeclarations = \case-    Axiom _ _ _ i rel x e          -> inst i [TypeSig rel Nothing x e]-    NiceField _ _ _ i tac x argt   -> [FieldSig i tac x argt]-    PrimitiveFunction r _ _ x e    -> [Primitive r [TypeSig (argInfo e) Nothing x (unArg e)]]-    NiceMutual r _ _ _ ds          -> [Mutual r $ concatMap notSoNiceDeclarations ds]-    NiceLoneConstructor r ds       -> [LoneConstructor r $ concatMap notSoNiceDeclarations ds]-    NiceModule r _ _ x tel ds      -> [Module r x tel ds]-    NiceModuleMacro r _ x ma o dir -> [ModuleMacro r x ma o dir]-    NiceOpen r x dir               -> [Open r x dir]-    NiceImport r x as o dir        -> [Import r x as o dir]-    NicePragma _ p                 -> [Pragma p]-    NiceRecSig r _ _ _ _ x bs e    -> [RecordSig r x bs e]-    NiceDataSig r _ _ _ _ x bs e   -> [DataSig r x bs e]-    NiceFunClause _ _ _ _ _ _ d    -> [d]-    FunSig _ _ _ i _ rel _ _ x e   -> inst i [TypeSig rel Nothing x e]-    FunDef _ ds _ _ _ _ _ _        -> ds-    NiceDataDef r _ _ _ _ x bs cs  -> [DataDef r x bs $ concatMap notSoNiceDeclarations cs]-    NiceRecDef r _ _ _ _ x dir bs ds -> [RecordDef r x dir bs ds]-    NicePatternSyn r _ n as p      -> [PatternSyn r n as p]-    NiceGeneralize r _ i tac n e   -> [Generalize r [TypeSig i tac n e]]-    NiceUnquoteDecl r _ _ i _ _ x e -> inst i [UnquoteDecl r x e]-    NiceUnquoteDef r _ _ _ _ x e    -> [UnquoteDef r x e]+    Axiom _ _ _ i rel x e            -> inst i $ TypeSig rel empty x e+    NiceField _ _ _ i tac x argt     -> singleton $ FieldSig i tac x argt+    PrimitiveFunction _ _ _ x e      -> singleton $ Primitive empty $ singleton $ TypeSig (argInfo e) empty x (unArg e)+    NiceMutual r _ _ _ ds            -> singleton $ Mutual r $ List1.concat $ fmap notSoNiceDeclarations ds+    NiceLoneConstructor r ds         -> singleton $ LoneConstructor r $ List1.concat $ fmap notSoNiceDeclarations ds+    NiceModule r _ _ e x tel ds      -> singleton $ Module r e x tel ds+    NiceModuleMacro r _ e x ma o dir+                                     -> singleton $ ModuleMacro r e x ma o dir+    NiceOpen r x dir                 -> singleton $ Open r x dir+    NiceImport r x as o dir          -> singleton $ Import r x as o dir+    NicePragma _ p                   -> singleton $ Pragma p+    NiceRecSig r er _ _ _ _ x bs e   -> singleton $ RecordSig r er x bs e+    NiceDataSig r er _ _ _ _ x bs e  -> singleton $ DataSig r er x bs e+    NiceFunClause _ _ _ _ _ _ d      -> singleton $ d+    FunSig _ _ _ i _ rel _ _ x e     -> inst i $ TypeSig rel empty x e+    FunDef _ ds _ _ _ _ _ _          -> List1.fromListSafe __IMPOSSIBLE__ ds -- TODO: use List1 in type of FunDef+    NiceDataDef r _ _ _ _ x bs cs    -> singleton $ DataDef r x bs $ List1.concat $ fmap notSoNiceDeclarations cs+    NiceRecDef r _ _ _ _ x dir bs ds -> singleton $ RecordDef r x dir bs ds+    NicePatternSyn r _ n as p        -> singleton $ PatternSyn r n as p+    NiceGeneralize _ _ i tac n e     -> singleton $ Generalize empty $ singleton $ TypeSig i tac n e+    NiceUnquoteDecl r _ _ i _ _ x e  -> inst i $ UnquoteDecl r x e+    NiceUnquoteDef r _ _ _ _ x e     -> singleton $ UnquoteDef r x e+    NiceUnquoteData r _ _ _ _ x xs e -> singleton $ UnquoteData r x xs e+    NiceOpaque r ns ds               -> singleton $ Opaque r $ (Unfolding r ns :) $ List1.concat $ fmap notSoNiceDeclarations ds   where-    inst (InstanceDef r) ds = [InstanceB r ds]-    inst NotInstanceDef  ds = ds+    inst (InstanceDef r) d = singleton $ InstanceB r $ singleton d+    inst NotInstanceDef  d = singleton d  -- | Has the 'NiceDeclaration' a field of type 'IsAbstract'? niceHasAbstract :: NiceDeclaration -> Maybe IsAbstract@@ -1420,7 +1548,7 @@     PrimitiveFunction _ _ a _ _   -> Just a     NiceMutual{}                  -> Nothing     NiceLoneConstructor{}         -> Nothing-    NiceModule _ _ a _ _ _        -> Just a+    NiceModule _ _ a _ _ _ _      -> Just a     NiceModuleMacro{}             -> Nothing     NiceOpen{}                    -> Nothing     NiceImport{}                  -> Nothing@@ -1436,3 +1564,5 @@     NiceGeneralize{}              -> Nothing     NiceUnquoteDecl _ _ a _ _ _ _ _ -> Just a     NiceUnquoteDef _ _ a _ _ _ _    -> Just a+    NiceUnquoteData _ _ a _ _ _ _ _ -> Just a+    NiceOpaque{}                    -> Nothing
src/full/Agda/Syntax/Concrete/Definitions/Errors.hs view
@@ -2,22 +2,24 @@  import Control.DeepSeq -import Data.Data- import GHC.Generics (Generic)  import Agda.Syntax.Position+import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty import Agda.Syntax.Concrete-import Agda.Syntax.Concrete.Name import Agda.Syntax.Concrete.Definitions.Types  import Agda.Interaction.Options.Warnings +import Agda.Utils.Null ( empty ) import Agda.Utils.CallStack ( CallStack ) import Agda.Utils.List1 (List1, pattern (:|)) import Agda.Utils.List2 (List2, pattern List2) import qualified Agda.Utils.List1 as List1-import Agda.Utils.Pretty+import Agda.Utils.Set1 (Set1)+import qualified Agda.Utils.Set1 as Set1+import Agda.Utils.Singleton  ------------------------------------------------------------------------ -- Errors@@ -31,12 +33,10 @@ -- | The exception type. data DeclarationException'   = MultipleEllipses Pattern-  | InvalidName Name   | DuplicateDefinition Name   | DuplicateAnonDeclaration Range   | MissingWithClauses Name LHS   | WrongDefinition Name DataRecOrFun DataRecOrFun-  | DeclarationPanic String   | WrongContentBlock KindOfBlock Range   | AmbiguousFunClauses LHS (List1 Name)       -- ^ In a mutual block, a clause could belong to any of the ≥2 type signatures ('Name').@@ -44,11 +44,40 @@       -- ^ In an interleaved mutual block, a constructor could belong to any of the data signatures ('Name')   | InvalidMeasureMutual Range       -- ^ In a mutual block, all or none need a MEASURE pragma.-      --   Range is of mutual block.+      --   'Range' is the one of the offending pragma or the mutual block.   | UnquoteDefRequiresSignature (List1 Name)   | BadMacroDef NiceDeclaration-    deriving (Data, Show)+  | UnfoldingOutsideOpaque KwRange+    -- ^ An unfolding declaration was not the first declaration+    -- contained in an opaque block.+  | OpaqueInMutual KwRange+      -- ^ @opaque@ block nested in a @mutual@ block.+      -- This can never happen, even with reordering.+      -- The 'KwRange' is the one of the @opaque@ keyword.+  | DisallowedInterleavedMutual KwRange String (List1 Name)+      -- ^ A declaration that breaks an implicit mutual block (named by+      -- the String argument) was present while the given lone type+      -- signatures were still without their definitions.+    deriving (Show, Generic) +-- | The name of the error.+declarationExceptionString :: DeclarationException' -> String+declarationExceptionString = \case+  MultipleEllipses            {} -> "MultipleEllipses"+  DuplicateDefinition         {} -> "DuplicateDefinition"+  DuplicateAnonDeclaration    {} -> "DuplicateAnonDeclaration"+  MissingWithClauses          {} -> "MissingWithClauses"+  WrongDefinition             {} -> "WrongDefinition"+  WrongContentBlock           {} -> "WrongContentBlock"+  AmbiguousFunClauses         {} -> "AmbiguousFunClauses"+  AmbiguousConstructor        {} -> "AmbiguousConstructor"+  InvalidMeasureMutual        {} -> "InvalidMeasureMutual"+  UnquoteDefRequiresSignature {} -> "UnquoteDefRequiresSignature"+  BadMacroDef                 {} -> "BadMacroDef"+  UnfoldingOutsideOpaque      {} -> "UnfoldingOutsideOpaque"+  OpaqueInMutual              {} -> "OpaqueInMutual"+  DisallowedInterleavedMutual {} -> "DisallowedInterleavedMutual"+ ------------------------------------------------------------------------ -- Warnings @@ -59,22 +88,26 @@  -- | Non-fatal errors encountered in the Nicifier. data DeclarationWarning'-  -- Please keep in alphabetical order.-  = EmptyAbstract Range    -- ^ Empty @abstract@  block.-  | EmptyConstructor Range -- ^ Empty @constructor@ block.-  | EmptyField Range       -- ^ Empty @field@     block.-  | EmptyGeneralize Range  -- ^ Empty @variable@  block.-  | EmptyInstance Range    -- ^ Empty @instance@  block-  | EmptyMacro Range       -- ^ Empty @macro@     block.-  | EmptyMutual Range      -- ^ Empty @mutual@    block.-  | EmptyPostulate Range   -- ^ Empty @postulate@ block.-  | EmptyPrivate Range     -- ^ Empty @private@   block.-  | EmptyPrimitive Range   -- ^ Empty @primitive@ block.+  -- Please keep in (mostly) alphabetical order.+  = EmptyAbstract    KwRange  -- ^ Empty @abstract@     block.+  | EmptyConstructor KwRange  -- ^ Empty @data _ where@ block.+  | EmptyField       KwRange  -- ^ Empty @field@        block.+  | EmptyGeneralize  KwRange  -- ^ Empty @variable@     block.+  | EmptyInstance    KwRange  -- ^ Empty @instance@     block+  | EmptyMacro       KwRange  -- ^ Empty @macro@        block.+  | EmptyMutual      KwRange  -- ^ Empty @mutual@       block.+  | EmptyPostulate   KwRange  -- ^ Empty @postulate@    block.+  | EmptyPrivate     KwRange  -- ^ Empty @private@      block.+  | EmptyPrimitive   KwRange  -- ^ Empty @primitive@    block.+  | EmptyPolarityPragma Range+      -- ^ POLARITY pragma without any polarities.+  | HiddenGeneralize Range+      -- ^ A 'Hidden' identifier in a @variable@ declaration.+      --   Hiding has no effect there as generalized variables are always hidden+      --   (or instance variables).   | InvalidCatchallPragma Range       -- ^ A {-\# CATCHALL \#-} pragma       --   that does not precede a function clause.-  | InvalidConstructor Range-      -- ^ Invalid definition in a constructor block   | InvalidConstructorBlock Range       -- ^ Invalid constructor block (not inside an interleaved mutual block)   | InvalidCoverageCheckPragma Range@@ -85,38 +118,58 @@   | InvalidNoUniverseCheckPragma Range       -- ^ A {-\# NO_UNIVERSE_CHECK \#-} pragma       --   that does not apply to a data or record type.-  | InvalidRecordDirective Range-      -- ^ A record directive outside of a record / below existing fields.   | InvalidTerminationCheckPragma Range       -- ^ A {-\# TERMINATING \#-} and {-\# NON_TERMINATING \#-} pragma       --   that does not apply to any function.-  | MissingDeclarations [(Name, Range)]-      -- ^ Definitions (e.g. constructors or functions) without a declaration.-  | MissingDefinitions [(Name, Range)]+  | MissingDataDeclaration Name+      -- ^ A @data@ definition without a @data@ signature.+  | MissingDefinitions (List1 (Name, Range))       -- ^ Declarations (e.g. type signatures) without a definition.   | NotAllowedInMutual Range String-  | OpenPublicPrivate Range-      -- ^ @private@ has no effect on @open public@.  (But the user might think so.)-  | OpenPublicAbstract Range-      -- ^ @abstract@ has no effect on @open public@.  (But the user might think so.)-  | PolarityPragmasButNotPostulates [Name]+  | OpenImportPrivate Range KwRange KwRange OpenOrImport+      -- ^ @private@ has no effect on @open (import) public@.  (But the user might think so.)+      --   'Range' is the range of the @open public@ or @open import public@ declaration.+      --   The first 'KwRange' is the range of the @public@ keyword.+      --   The second 'KwRange' is the range of the @private@ keyword.+  | OpenImportAbstract Range KwRange OpenOrImport+      -- ^ @abstract@ has no effect on @open@ or @import@.  (But the user might think so.)+      --   'Range' is the range of the @open@ or @import@ declaration.+      --   'KwRange' is the range of the @abstract@ keyword.+  | PolarityPragmasButNotPostulates (Set1 Name)   | PragmaNoTerminationCheck Range-  -- ^ Pragma @{-\# NO_TERMINATION_CHECK \#-}@ has been replaced-  --   by @{-\# TERMINATING \#-}@ and @{-\# NON_TERMINATING \#-}@.+      -- ^ Pragma @{-\# NO_TERMINATION_CHECK \#-}@ has been replaced+      --   by @{-\# TERMINATING \#-}@ and @{-\# NON_TERMINATING \#-}@.   | PragmaCompiled Range-  -- ^ @COMPILE@ pragmas are not allowed in safe mode+      -- ^ @COMPILE@ pragmas are not allowed in safe mode.+  | SafeFlagEta               Range -- ^ @ETA@                 pragma is unsafe.+  | SafeFlagInjective         Range -- ^ @INJECTIVE@           pragma is unsafe.+  | SafeFlagNoCoverageCheck   Range -- ^ @NON_COVERING@        pragma is unsafe.+  | SafeFlagNoPositivityCheck Range -- ^ @NO_POSITIVITY_CHECK@ pragma is unsafe.+  | SafeFlagNoUniverseCheck   Range -- ^ @NO_UNIVERSE_CHECK@   pragma is unsafe.+  | SafeFlagNonTerminating    Range -- ^ @NON_TERMINATING@     pragma is unsafe.+  | SafeFlagPolarity          Range -- ^ @POLARITY@            pragma is unsafe.+  | SafeFlagTerminating       Range -- ^ @TERMINATING@         pragma is unsafe.   | ShadowingInTelescope (List1 (Name, List2 Range))-  | UnknownFixityInMixfixDecl [Name]-  | UnknownNamesInFixityDecl [Name]-  | UnknownNamesInPolarityPragmas [Name]-  | UselessAbstract Range+  | UnknownFixityInMixfixDecl (Set1 Name)+      -- ^ Public mixfix identifiers without a fixity declaration.+  | UnknownNamesInFixityDecl (Set1 Name)+  | UnknownNamesInPolarityPragmas (Set1 Name)+  | UselessAbstract KwRange       -- ^ @abstract@ block with nothing that can (newly) be made abstract.-  | UselessInstance Range+  | UselessInstance KwRange       -- ^ @instance@ block with nothing that can (newly) become an instance.-  | UselessPrivate Range+  | UselessMacro KwRange+      -- ^ @macro@ block with nothing that can (newly) be made macro.+  | UselessPrivate KwRange       -- ^ @private@ block with nothing that can (newly) be made private.-  deriving (Data, Show, Generic)+  deriving (Show, Generic) +-- | @open@ or @import@+data OpenOrImport+  = OpenNotImport  -- ^ @open@.+  | ImportMayOpen  -- ^ @import@ or @open import@.+  deriving (Show, Generic, Enum, Bounded)+ declarationWarningName :: DeclarationWarning -> WarningName declarationWarningName = declarationWarningName' . dwWarning @@ -133,28 +186,37 @@   EmptyPrivate{}                    -> EmptyPrivate_   EmptyPostulate{}                  -> EmptyPostulate_   EmptyPrimitive{}                  -> EmptyPrimitive_+  EmptyPolarityPragma{}             -> EmptyPolarityPragma_+  HiddenGeneralize{}                -> HiddenGeneralize_   InvalidCatchallPragma{}           -> InvalidCatchallPragma_-  InvalidConstructor{}              -> InvalidConstructor_   InvalidConstructorBlock{}         -> InvalidConstructorBlock_   InvalidNoPositivityCheckPragma{}  -> InvalidNoPositivityCheckPragma_   InvalidNoUniverseCheckPragma{}    -> InvalidNoUniverseCheckPragma_-  InvalidRecordDirective{}          -> InvalidRecordDirective_   InvalidTerminationCheckPragma{}   -> InvalidTerminationCheckPragma_   InvalidCoverageCheckPragma{}      -> InvalidCoverageCheckPragma_-  MissingDeclarations{}             -> MissingDeclarations_+  MissingDataDeclaration{}          -> MissingDataDeclaration_   MissingDefinitions{}              -> MissingDefinitions_   NotAllowedInMutual{}              -> NotAllowedInMutual_-  OpenPublicPrivate{}               -> OpenPublicPrivate_-  OpenPublicAbstract{}              -> OpenPublicAbstract_+  OpenImportPrivate{}               -> OpenImportPrivate_+  OpenImportAbstract{}              -> OpenImportAbstract_   PolarityPragmasButNotPostulates{} -> PolarityPragmasButNotPostulates_   PragmaNoTerminationCheck{}        -> PragmaNoTerminationCheck_   PragmaCompiled{}                  -> PragmaCompiled_+  SafeFlagEta                    {} -> SafeFlagEta_+  SafeFlagInjective              {} -> SafeFlagInjective_+  SafeFlagNoCoverageCheck        {} -> SafeFlagNoCoverageCheck_+  SafeFlagNoPositivityCheck      {} -> SafeFlagNoPositivityCheck_+  SafeFlagNoUniverseCheck        {} -> SafeFlagNoUniverseCheck_+  SafeFlagNonTerminating         {} -> SafeFlagNonTerminating_+  SafeFlagPolarity               {} -> SafeFlagPolarity_+  SafeFlagTerminating            {} -> SafeFlagTerminating_   ShadowingInTelescope{}            -> ShadowingInTelescope_   UnknownFixityInMixfixDecl{}       -> UnknownFixityInMixfixDecl_   UnknownNamesInFixityDecl{}        -> UnknownNamesInFixityDecl_   UnknownNamesInPolarityPragmas{}   -> UnknownNamesInPolarityPragmas_   UselessAbstract{}                 -> UselessAbstract_   UselessInstance{}                 -> UselessInstance_+  UselessMacro{}                    -> UselessMacro_   UselessPrivate{}                  -> UselessPrivate_  -- | Nicifier warnings turned into errors in @--safe@ mode.@@ -174,30 +236,79 @@   EmptyPrivate{}                    -> False   EmptyPostulate{}                  -> False   EmptyPrimitive{}                  -> False+  EmptyPolarityPragma{}             -> False+  HiddenGeneralize{}                -> False   InvalidCatchallPragma{}           -> False-  InvalidConstructor{}              -> False   InvalidConstructorBlock{}         -> False   InvalidNoPositivityCheckPragma{}  -> False   InvalidNoUniverseCheckPragma{}    -> False-  InvalidRecordDirective{}          -> False   InvalidTerminationCheckPragma{}   -> False   InvalidCoverageCheckPragma{}      -> False-  MissingDeclarations{}             -> True  -- not safe-  MissingDefinitions{}              -> True  -- not safe+  MissingDataDeclaration{}          -> True  -- not safe+  MissingDefinitions{}              -> False -- not safe but deferred until after typechecking   NotAllowedInMutual{}              -> False -- really safe?-  OpenPublicPrivate{}               -> False-  OpenPublicAbstract{}              -> False+  OpenImportPrivate{}               -> False+  OpenImportAbstract{}              -> False   PolarityPragmasButNotPostulates{} -> False   PragmaNoTerminationCheck{}        -> True  -- not safe   PragmaCompiled{}                  -> True  -- not safe+  SafeFlagEta                    {} -> True+  SafeFlagInjective              {} -> True+  SafeFlagNoCoverageCheck        {} -> True+  SafeFlagNoPositivityCheck      {} -> True+  SafeFlagNoUniverseCheck        {} -> True+  SafeFlagNonTerminating         {} -> True+  SafeFlagPolarity               {} -> True+  SafeFlagTerminating            {} -> True   ShadowingInTelescope{}            -> False   UnknownFixityInMixfixDecl{}       -> False   UnknownNamesInFixityDecl{}        -> False   UnknownNamesInPolarityPragmas{}   -> False   UselessAbstract{}                 -> False   UselessInstance{}                 -> False+  UselessMacro{}                    -> False   UselessPrivate{}                  -> False +-- | Pragmas not allowed in @--safe@ mode produce an 'unsafeDeclarationWarning'.+--+unsafePragma :: CMaybe DeclarationWarning' m => Pragma -> m+unsafePragma p =+  case p of+    BuiltinPragma{}            -> empty+    CatchallPragma{}           -> empty+    CompilePragma{}            -> singleton $ PragmaCompiled r+    DisplayPragma{}            -> empty+    EtaPragma{}                -> singleton $ SafeFlagEta r+    ForeignPragma{}            -> empty+    ImpossiblePragma{}         -> empty+    InjectivePragma{}          -> singleton $ SafeFlagInjective r+    InjectiveForInferencePragma{} -> empty+    InlinePragma{}             -> empty+    NoCoverageCheckPragma{}    -> singleton $ SafeFlagNoCoverageCheck r+    NoPositivityCheckPragma{}  -> singleton $ SafeFlagNoPositivityCheck r+    NoUniverseCheckPragma{}    -> singleton $ SafeFlagNoUniverseCheck r+    NotProjectionLikePragma{}  -> empty+    OptionsPragma{}            -> empty+    PolarityPragma{}           -> singleton $ SafeFlagPolarity r+    RewritePragma{}            -> empty+      -- @RewritePragma@ already requires --rewriting which is incompatible with --safe+    StaticPragma{}             -> empty+    TerminationCheckPragma _ m ->+      case m of+        NonTerminating         -> singleton $ SafeFlagNonTerminating r+        Terminating            -> singleton $ SafeFlagTerminating r+        TerminationCheck       -> empty+        TerminationMeasure{}   -> empty+        -- @NO_TERMINATION_CHECK@ pragma was removed, but still parses. See Issue #1763.+        -- There is the unsafe @'PragmaNoTerminationCheck'@ warning thrown already,+        -- so we need not throw anything here.+        NoTerminationCheck     -> empty+    WarningOnImport{}          -> empty+    WarningOnUsage{}           -> empty+    OverlapPragma{}            -> empty+  where+    r = getRange p+ ------------------------------------------------------------------------ -- Instances @@ -206,64 +317,73 @@  instance HasRange DeclarationException' where   getRange (MultipleEllipses d)                 = getRange d-  getRange (InvalidName x)                      = getRange x   getRange (DuplicateDefinition x)              = getRange x   getRange (DuplicateAnonDeclaration r)         = r   getRange (MissingWithClauses x lhs)           = getRange lhs   getRange (WrongDefinition x k k')             = getRange x   getRange (AmbiguousFunClauses lhs xs)         = getRange lhs   getRange (AmbiguousConstructor r _ _)         = r-  getRange (DeclarationPanic _)                 = noRange   getRange (WrongContentBlock _ r)              = r   getRange (InvalidMeasureMutual r)             = r-  getRange (UnquoteDefRequiresSignature x)      = getRange x+  getRange (UnquoteDefRequiresSignature xs)     = getRange xs   getRange (BadMacroDef d)                      = getRange d+  getRange (UnfoldingOutsideOpaque kwr)         = getRange kwr+  getRange (OpaqueInMutual kwr)                 = getRange kwr+  getRange (DisallowedInterleavedMutual kwr _ _)= getRange kwr  instance HasRange DeclarationWarning where   getRange (DeclarationWarning _ w) = getRange w  instance HasRange DeclarationWarning' where-  getRange (UnknownNamesInFixityDecl xs)        = getRange xs-  getRange (UnknownFixityInMixfixDecl xs)       = getRange xs-  getRange (UnknownNamesInPolarityPragmas xs)   = getRange xs-  getRange (PolarityPragmasButNotPostulates xs) = getRange xs-  getRange (MissingDeclarations xs)             = getRange xs-  getRange (MissingDefinitions xs)              = getRange xs-  getRange (UselessPrivate r)                   = r-  getRange (NotAllowedInMutual r x)             = r-  getRange (UselessAbstract r)                  = r-  getRange (UselessInstance r)                  = r-  getRange (EmptyConstructor r)                 = r-  getRange (EmptyMutual r)                      = r-  getRange (EmptyAbstract r)                    = r-  getRange (EmptyPrivate r)                     = r-  getRange (EmptyInstance r)                    = r-  getRange (EmptyMacro r)                       = r-  getRange (EmptyPostulate r)                   = r-  getRange (EmptyGeneralize r)                  = r-  getRange (EmptyPrimitive r)                   = r-  getRange (EmptyField r)                       = r-  getRange (InvalidTerminationCheckPragma r)    = r-  getRange (InvalidCoverageCheckPragma r)       = r-  getRange (InvalidNoPositivityCheckPragma r)   = r-  getRange (InvalidCatchallPragma r)            = r-  getRange (InvalidConstructor r)               = r-  getRange (InvalidConstructorBlock r)          = r-  getRange (InvalidNoUniverseCheckPragma r)     = r-  getRange (InvalidRecordDirective r)           = r-  getRange (PragmaNoTerminationCheck r)         = r-  getRange (PragmaCompiled r)                   = r-  getRange (OpenPublicAbstract r)               = r-  getRange (OpenPublicPrivate r)                = r-  getRange (ShadowingInTelescope ns)            = getRange ns+  getRange = \case+    EmptyAbstract kwr                  -> getRange kwr+    EmptyConstructor kwr               -> getRange kwr+    EmptyField kwr                     -> getRange kwr+    EmptyGeneralize kwr                -> getRange kwr+    EmptyInstance kwr                  -> getRange kwr+    EmptyMacro kwr                     -> getRange kwr+    EmptyMutual kwr                    -> getRange kwr+    EmptyPostulate kwr                 -> getRange kwr+    EmptyPrimitive kwr                 -> getRange kwr+    EmptyPrivate kwr                   -> getRange kwr+    EmptyPolarityPragma r              -> r+    HiddenGeneralize r                 -> r+    InvalidCatchallPragma r            -> r+    InvalidConstructorBlock r          -> r+    InvalidCoverageCheckPragma r       -> r+    InvalidNoPositivityCheckPragma r   -> r+    InvalidNoUniverseCheckPragma r     -> r+    InvalidTerminationCheckPragma r    -> r+    MissingDataDeclaration x           -> getRange x+    MissingDefinitions xs              -> getRange xs+    NotAllowedInMutual r x             -> r+    OpenImportAbstract r _kwr _        -> getRange r+    OpenImportPrivate  _r kwr _kwr _   -> getRange kwr+    PolarityPragmasButNotPostulates xs -> getRange xs+    PragmaCompiled r                   -> r+    PragmaNoTerminationCheck r         -> r+    SafeFlagEta r                      -> r+    SafeFlagInjective r                -> r+    SafeFlagNoCoverageCheck r          -> r+    SafeFlagNoPositivityCheck r        -> r+    SafeFlagNoUniverseCheck r          -> r+    SafeFlagNonTerminating r           -> r+    SafeFlagPolarity r                 -> r+    SafeFlagTerminating r              -> r+    ShadowingInTelescope ns            -> getRange ns+    UnknownFixityInMixfixDecl xs       -> getRange xs+    UnknownNamesInFixityDecl xs        -> getRange xs+    UnknownNamesInPolarityPragmas xs   -> getRange xs+    UselessAbstract kwr                -> getRange kwr+    UselessInstance kwr                -> getRange kwr+    UselessMacro kwr                   -> getRange kwr+    UselessPrivate kwr                 -> getRange kwr  -- These error messages can (should) be terminated by a dot ".", -- there is no error context printed after them. instance Pretty DeclarationException' where   pretty (MultipleEllipses p) = fsep $     pwords "Multiple ellipses in left-hand side" ++ [pretty p]-  pretty (InvalidName x) = fsep $-    pwords "Invalid name:" ++ [pretty x]   pretty (DuplicateDefinition x) = fsep $     pwords "Duplicate definition of" ++ [pretty x]   pretty (DuplicateAnonDeclaration _) = fsep $@@ -289,7 +409,7 @@     ]   pretty (WrongContentBlock b _)      = fsep . pwords $     case b of-      PostulateBlock -> "A postulate block can only contain type signatures, possibly under keyword instance"+      PostulateBlock -> "A `postulate` block can only contain type signatures, possibly under keywords `instance` and `private`"       DataBlock -> "A data definition can only contain type signatures, possibly under keyword instance"       _ -> "Unexpected declaration"   pretty (InvalidMeasureMutual _) = fsep $@@ -298,75 +418,147 @@     pwords "Missing type signatures for unquoteDef" ++ map pretty (List1.toList xs)   pretty (BadMacroDef nd) = fsep $     text (declName nd) : pwords "are not allowed in macro blocks"-  pretty (DeclarationPanic s) = text s+  pretty (UnfoldingOutsideOpaque _) = fsep . pwords $+    "Unfolding declarations can only appear as the first declaration immediately contained in an opaque block."+  pretty (OpaqueInMutual _) = fsep $+    pwords "Opaque blocks can not participate in mutual recursion. If the opaque definitions are to be mutually recursive, move the `mutual` block inside the `opaque` block."+  pretty (DisallowedInterleavedMutual _ what xs) = vcat $ List1.concat+    [ singleton $ fsep $ pwords "The following names are declared, but not accompanied by a definition:"+      -- Andreas, 2023-09-07, issue #6823: print also the range.+      -- Print a bullet list; thus, the plural version of this error message is sufficient.+    , fmap (("-" <+>) . pretty . PrintRange) xs+    , singleton $ fwords $ "Since " ++ what ++ " can not participate in mutual recursion, their definition must be given before this point."+    ]  instance Pretty DeclarationWarning where   pretty (DeclarationWarning _ w) = pretty w  instance Pretty DeclarationWarning' where-  pretty (UnknownNamesInFixityDecl xs) = fsep $-    pwords "The following names are not declared in the same scope as their syntax or fixity declaration (i.e., either not in scope at all, imported from another module, or declared in a super module):"-    ++ punctuate comma (map pretty xs)-  pretty (UnknownFixityInMixfixDecl xs) = fsep $-    pwords "The following mixfix names do not have an associated fixity declaration:"-    ++ punctuate comma (map pretty xs)-  pretty (UnknownNamesInPolarityPragmas xs) = fsep $-    pwords "The following names are not declared in the same scope as their polarity pragmas (they could for instance be out of scope, imported from another module, or declared in a super module):"-    ++ punctuate comma  (map pretty xs)-  pretty (MissingDeclarations xs) = fsep $-   pwords "The following names are defined but not accompanied by a declaration:"-   ++ punctuate comma (map (pretty . fst) xs)-  pretty (MissingDefinitions xs) = fsep $-   pwords "The following names are declared but not accompanied by a definition:"-   ++ punctuate comma (map (pretty . fst) xs)-  pretty (NotAllowedInMutual r nd) = fsep $-    text nd : pwords "in mutual blocks are not supported.  Suggestion: get rid of the mutual block by manually ordering declarations"-  pretty (PolarityPragmasButNotPostulates xs) = fsep $-    pwords "Polarity pragmas have been given for the following identifiers which are not postulates:"-    ++ punctuate comma (map pretty xs)-  pretty (UselessPrivate _)      = fsep $-    pwords "Using private here has no effect. Private applies only to declarations that introduce new identifiers into the module, like type signatures and data, record, and module declarations."-  pretty (UselessAbstract _)      = fsep $-    pwords "Using abstract here has no effect. Abstract applies to only definitions like data definitions, record type definitions and function clauses."-  pretty (UselessInstance _)      = fsep $-    pwords "Using instance here has no effect. Instance applies only to declarations that introduce new identifiers into the module, like type signatures and axioms."-  pretty (EmptyMutual    _)  = fsep $ pwords "Empty mutual block."-  pretty EmptyConstructor{}  = fsep $ pwords "Empty constructor block."-  pretty (EmptyAbstract  _)  = fsep $ pwords "Empty abstract block."-  pretty (EmptyPrivate   _)  = fsep $ pwords "Empty private block."-  pretty (EmptyInstance  _)  = fsep $ pwords "Empty instance block."-  pretty (EmptyMacro     _)  = fsep $ pwords "Empty macro block."-  pretty (EmptyPostulate _)  = fsep $ pwords "Empty postulate block."-  pretty (EmptyGeneralize _) = fsep $ pwords "Empty variable block."-  pretty (EmptyPrimitive _)  = fsep $ pwords "Empty primitive block."-  pretty (EmptyField _)      = fsep $ pwords "Empty field block."-  pretty InvalidRecordDirective{} = fsep $-    pwords "Record directives can only be used inside record definitions and before field declarations."-  pretty (InvalidTerminationCheckPragma _) = fsep $-    pwords "Termination checking pragmas can only precede a function definition or a mutual block (that contains a function definition)."-  pretty InvalidConstructor{} = fsep $-    pwords "`constructor' blocks may only contain type signatures for constructors."-  pretty InvalidConstructorBlock{} = fsep $-    pwords "No `constructor' blocks outside of `interleaved mutual' blocks."-  pretty (InvalidCoverageCheckPragma _)    = fsep $-    pwords "Coverage checking pragmas can only precede a function definition or a mutual block (that contains a function definition)."-  pretty (InvalidNoPositivityCheckPragma _) = fsep $-    pwords "NO_POSITIVITY_CHECKING pragmas can only precede a data/record definition or a mutual block (that contains a data/record definition)."-  pretty (InvalidCatchallPragma _) = fsep $-    pwords "The CATCHALL pragma can only precede a function clause."-  pretty (InvalidNoUniverseCheckPragma _) = fsep $-    pwords "NO_UNIVERSE_CHECKING pragmas can only precede a data/record definition."-  pretty (PragmaNoTerminationCheck _) = fsep $-    pwords "Pragma {-# NO_TERMINATION_CHECK #-} has been removed.  To skip the termination check, label your definitions either as {-# TERMINATING #-} or {-# NON_TERMINATING #-}."-  pretty (PragmaCompiled _) = fsep $-    pwords "COMPILE pragma not allowed in safe mode."-  pretty (OpenPublicAbstract _) = fsep $-    pwords "public does not have any effect in an abstract block."-  pretty (OpenPublicPrivate _) = fsep $-    pwords "public does not have any effect in a private block."-  pretty (ShadowingInTelescope nrs) = fsep $-    pwords "Shadowing in telescope, repeated variable names:"-    ++ punctuate comma (fmap (pretty . fst) nrs)+  pretty = \case +    UnknownNamesInFixityDecl xs -> fsep $+      pwords "The following names are not declared in the same scope as their syntax or fixity declaration (i.e., either not in scope at all, imported from another module, or declared in a super module):"+      ++ punctuate comma (fmap pretty $ Set1.toList xs)++    UnknownFixityInMixfixDecl xs -> fsep $+      pwords "The following mixfix names do not have an associated fixity declaration:"+      ++ punctuate comma (fmap pretty $ Set1.toList xs)++    UnknownNamesInPolarityPragmas xs -> fsep $+      pwords "The following names are not declared in the same scope as their polarity pragmas (they could for instance be out of scope, imported from another module, or declared in a super module):"+      ++ punctuate comma (fmap pretty $ Set1.toList xs)++    MissingDataDeclaration x -> fsep $ concat+      [ pwords "Data definition"+      , [ pretty x ]+      , pwords "misses a data declaration"+      ]++    MissingDefinitions xs -> fsep $+     pwords "The following names are declared but not accompanied by a definition:"+     ++ punctuate comma (fmap (pretty . fst) xs)++    NotAllowedInMutual r nd -> fsep $+      text nd : pwords "in mutual blocks are not supported.  Suggestion: get rid of the mutual block by manually ordering declarations"++    PolarityPragmasButNotPostulates xs -> fsep $+      pwords "Polarity pragmas have been given for the following identifiers which are not postulates:"+      ++ punctuate comma (fmap pretty $ Set1.toList xs)++    UselessPrivate _ -> fsep $+      pwords "Using private here has no effect. Private applies only to declarations that introduce new identifiers into the module, like type signatures and data, record, and module declarations."++    UselessAbstract _ -> fsep $+      pwords "Using abstract here has no effect. Abstract applies to only definitions like data definitions, record type definitions and function clauses."++    UselessInstance _ -> fsep $+      pwords "Using instance here has no effect. Instance applies only to declarations that introduce new identifiers into the module, like type signatures and axioms."++    UselessMacro _ -> fsep $+      pwords "Using a macro block here has no effect. `macro' applies only to function definitions."++    EmptyMutual    _ -> fsep $ pwords "Empty mutual block."++    EmptyConstructor{}  -> fsep $ pwords "Empty constructor block."++    EmptyAbstract  _ -> fsep $ pwords "Empty abstract block."++    EmptyPrivate   _ -> fsep $ pwords "Empty private block."++    EmptyInstance  _ -> fsep $ pwords "Empty instance block."++    EmptyMacro     _ -> fsep $ pwords "Empty macro block."++    EmptyPostulate _ -> fsep $ pwords "Empty postulate block."++    EmptyGeneralize _ -> fsep $ pwords "Empty variable block."++    EmptyPrimitive _ -> fsep $ pwords "Empty primitive block."++    EmptyField _ -> fsep $ pwords "Empty field block."++    EmptyPolarityPragma _ -> fsep $ pwords "POLARITY pragma without polarities (ignored)."++    HiddenGeneralize _ -> fsep $ pwords "Declaring a variable as hidden has no effect in a variable block. Generalization never introduces visible arguments."++    InvalidTerminationCheckPragma _ -> fsep $+      pwords "Termination checking pragmas can only precede a function definition or a mutual block (that contains a function definition)."++    InvalidConstructorBlock{} -> fsep $+      pwords "No `data _ where' blocks outside of `interleaved mutual' blocks."++    InvalidCoverageCheckPragma _ -> fsep $+      pwords "Coverage checking pragmas can only precede a function definition or a mutual block (that contains a function definition)."++    InvalidNoPositivityCheckPragma _ -> fsep $+      pwords "NO_POSITIVITY_CHECKING pragmas can only precede a data/record definition or a mutual block (that contains a data/record definition)."++    InvalidCatchallPragma _ -> fsep $+      pwords "The CATCHALL pragma can only precede a function clause."++    InvalidNoUniverseCheckPragma _ -> fsep $+      pwords "NO_UNIVERSE_CHECKING pragmas can only precede a data/record definition."++    PragmaNoTerminationCheck _ -> fsep $+      pwords "Pragma {-# NO_TERMINATION_CHECK #-} has been removed.  To skip the termination check, label your definitions either as {-# TERMINATING #-} or {-# NON_TERMINATING #-}."++    PragmaCompiled _ -> fsep $+      pwords "COMPILE pragma not allowed in safe mode."++    OpenImportAbstract _ _ openOrImport -> fsep $ concat+      [ pwords "`abstract' does not have any effect on"+      , [ pretty openOrImport ]+      , pwords "so better place this statement outside of the abstract block"+      ]++    OpenImportPrivate _ _ _ _openOrImport -> fsep $ concat+      [ pwords "`private' does not have any effect on"+      , pwords "`open public'"+      , pwords "so better place this statement outside of the private block"+      ]++    ShadowingInTelescope nrs -> fsep $+      pwords "Shadowing in telescope, repeated variable names:"+      ++ punctuate comma (fmap (pretty . fst) nrs)++    SafeFlagEta               _ -> unsafePragma "ETA"+    SafeFlagInjective         _ -> unsafePragma "INJECTIVE"+    SafeFlagNoCoverageCheck   _ -> unsafePragma "NON_COVERING"+    SafeFlagNoPositivityCheck _ -> unsafePragma "NO_POSITIVITY_CHECK"+    SafeFlagNoUniverseCheck   _ -> unsafePragma "NO_UNIVERSE_CHECK"+    SafeFlagNonTerminating    _ -> unsafePragma "NON_TERMINATING"+    SafeFlagPolarity          _ -> unsafePragma "POLARITY"+    SafeFlagTerminating       _ -> unsafePragma "TERMINATING"++    where+      unsafePragma s = fsep $ ["Cannot", "use", s] ++ pwords "pragma with safe flag."++instance Pretty OpenOrImport where+  pretty = \case+    OpenNotImport -> "`open'"+    ImportMayOpen -> "`import'"++instance NFData DeclarationException' instance NFData DeclarationWarning instance NFData DeclarationWarning'+instance NFData OpenOrImport
src/full/Agda/Syntax/Concrete/Definitions/Monad.hs view
@@ -1,7 +1,12 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Syntax.Concrete.Definitions.Monad where -import Control.Monad        ( unless )+import Prelude hiding ( null )++import Control.Monad        () import Control.Monad.Except ( MonadError(..), ExceptT, runExceptT )+import Control.Monad.Reader ( MonadReader, ReaderT, runReaderT ) import Control.Monad.State  ( MonadState(..), modify, State, runState )  import Data.Bifunctor (second)@@ -10,32 +15,48 @@  import Agda.Syntax.Position import Agda.Syntax.Common hiding (TerminationCheck())+import Agda.Syntax.Concrete ( WhereClause_ ) import Agda.Syntax.Concrete.Name import Agda.Syntax.Concrete.Definitions.Types import Agda.Syntax.Concrete.Definitions.Errors  import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack ) import Agda.Utils.Lens+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Null (Null(..))  import Agda.Utils.Impossible  -- | Nicifier monad. --   Preserve the state when throwing an exception. -newtype Nice a = Nice { unNice :: ExceptT DeclarationException (State NiceEnv) a }+newtype Nice a = Nice { unNice :: ReaderT NiceEnv (ExceptT DeclarationException (State NiceState)) a }   deriving ( Functor, Applicative, Monad-           , MonadState NiceEnv, MonadError DeclarationException+           , MonadReader NiceEnv, MonadState NiceState, MonadError DeclarationException            )  -- | Run a Nicifier computation, return result and warnings --   (in chronological order).-runNice :: Nice a -> (Either DeclarationException a, NiceWarnings)-runNice m = second (reverse . niceWarn) $-  runExceptT (unNice m) `runState` initNiceEnv+runNice :: NiceEnv -> Nice a -> (Either DeclarationException a, NiceWarnings)+runNice env m = second (reverse . niceWarn) $+  runExceptT (unNice m `runReaderT` env) `runState` initNiceState --- | Nicifier state.+instance Null a => Null (Nice a) where+  empty = pure empty+  null _ = __IMPOSSIBLE__ +-- | Nicifier parameters.+ data NiceEnv = NiceEnv+  { safeButNotBuiltin :: Bool+       -- ^ We are in a module declared @--safe@ which is not a builtin module.+  , checkingWhere     :: WhereClause_+       -- ^ Are we checking a @where@ module?+  }++-- | Nicifier state.++data NiceState = NiceState   { _loneSigs :: LoneSigs     -- ^ Lone type signatures that wait for their definition.   , _termChk  :: TerminationCheck@@ -61,6 +82,7 @@       --   than the key of 'LoneSigs' pointing to it.   , loneSigKind  :: DataRecOrFun   }+  deriving Show  type LoneSigs     = Map Name LoneSig      -- ^ We retain the 'Name' also in the codomain since@@ -79,19 +101,19 @@  -- | Initial nicifier state. -initNiceEnv :: NiceEnv-initNiceEnv = NiceEnv+initNiceState :: NiceState+initNiceState = NiceState   { _loneSigs = Map.empty   , _termChk  = TerminationCheck   , _posChk   = YesPositivityCheck   , _uniChk   = YesUniverseCheck-  , _catchall = False+  , _catchall = empty   , _covChk   = YesCoverageCheck   , niceWarn  = []   , _nameId   = NameId 1 noModuleNameHash   } -lensNameId :: Lens' NameId NiceEnv+lensNameId :: Lens' NiceState NameId lensNameId f e = f (_nameId e) <&> \ i -> e { _nameId = i }  nextNameId :: Nice NameId@@ -104,7 +126,7 @@  -- | Lens for field '_loneSigs'. -loneSigs :: Lens' LoneSigs NiceEnv+loneSigs :: Lens' NiceState LoneSigs loneSigs f e = f (_loneSigs e) <&> \ s -> e { _loneSigs = s }  -- | Adding a lone signature to the state.@@ -113,9 +135,9 @@ addLoneSig :: Range -> Name -> DataRecOrFun -> Nice Name addLoneSig r x k = do   -- Andreas, 2020-05-19, issue #4157, make '_' unique.-  x' <- if not $ isNoName x then return x else do-    i <- nextNameId-    return x{ nameId = i }+  x' <- case x of+    Name{}     -> pure x+    NoName r _ -> NoName r <$> nextNameId   loneSigs %== \ s -> do     let (mr, s') = Map.insertLookupWithKey (\ _k new _old -> new) x (LoneSig r x' k) s     case mr of@@ -139,17 +161,27 @@ noLoneSigs :: Nice Bool noLoneSigs = null <$> use loneSigs --- | Ensure that all forward declarations have been given a definition.- forgetLoneSigs :: Nice () forgetLoneSigs = loneSigs .= Map.empty +-- | Ensure that all forward declarations have been given a definition. checkLoneSigs :: LoneSigs -> Nice () checkLoneSigs xs = do   forgetLoneSigs-  unless (Map.null xs) $ declarationWarning $ MissingDefinitions $-    map (\s -> (loneSigName s , loneSigRange s)) $ Map.elems xs+  List1.unlessNull (Map.elems xs) \ ss -> declarationWarning $ MissingDefinitions $+    fmap (\s -> (loneSigName s , loneSigRange s)) ss +-- | Ensure that all forward declarations have been given a definition,+-- raising an error indicating *why* they would have had to have been+-- defined.+breakImplicitMutualBlock :: KwRange -> String -> Nice ()+breakImplicitMutualBlock r why = do+  m <- use loneSigs+  List1.unlessNull (Map.elems m) $ \ xs ->+    declarationException $ DisallowedInterleavedMutual r why $+      -- Andreas, 2023-09-07: We discard the 'loneSigRange's because the 'Name' already has a range.+      fmap loneSigName xs+ -- | Get names of lone function signatures, plus their unique names.  loneFuns :: LoneSigs -> [(Name,Name)]@@ -162,7 +194,7 @@  -- | Lens for field '_termChk'. -terminationCheckPragma :: Lens' TerminationCheck NiceEnv+terminationCheckPragma :: Lens' NiceState TerminationCheck terminationCheckPragma f e = f (_termChk e) <&> \ s -> e { _termChk = s }  withTerminationCheckPragma :: TerminationCheck -> Nice a -> Nice a@@ -173,7 +205,7 @@   terminationCheckPragma .= tc_old   return result -coverageCheckPragma :: Lens' CoverageCheck NiceEnv+coverageCheckPragma :: Lens' NiceState CoverageCheck coverageCheckPragma f e = f (_covChk e) <&> \ s -> e { _covChk = s }  withCoverageCheckPragma :: CoverageCheck -> Nice a -> Nice a@@ -186,7 +218,7 @@  -- | Lens for field '_posChk'. -positivityCheckPragma :: Lens' PositivityCheck NiceEnv+positivityCheckPragma :: Lens' NiceState PositivityCheck positivityCheckPragma f e = f (_posChk e) <&> \ s -> e { _posChk = s }  withPositivityCheckPragma :: PositivityCheck -> Nice a -> Nice a@@ -199,7 +231,7 @@  -- | Lens for field '_uniChk'. -universeCheckPragma :: Lens' UniverseCheck NiceEnv+universeCheckPragma :: Lens' NiceState UniverseCheck universeCheckPragma f e = f (_uniChk e) <&> \ s -> e { _uniChk = s }  withUniverseCheckPragma :: UniverseCheck -> Nice a -> Nice a@@ -218,7 +250,7 @@  -- | Lens for field '_catchall'. -catchallPragma :: Lens' Catchall NiceEnv+catchallPragma :: Lens' NiceState Catchall catchallPragma f e = f (_catchall e) <&> \ s -> e { _catchall = s }  -- | Get current catchall pragma, and reset it for the next clause.@@ -226,7 +258,7 @@ popCatchallPragma :: Nice Catchall popCatchallPragma = do   ca <- use catchallPragma-  catchallPragma .= False+  catchallPragma .= empty   return ca  withCatchallPragma :: Catchall -> Nice a -> Nice a
src/full/Agda/Syntax/Concrete/Definitions/Types.hs view
@@ -2,7 +2,6 @@  import Control.DeepSeq -import Data.Data import Data.Map (Map) import Data.Semigroup ( Semigroup(..) ) @@ -12,10 +11,10 @@ import Agda.Syntax.Common hiding (TerminationCheck()) import qualified Agda.Syntax.Common as Common import Agda.Syntax.Concrete-import Agda.Syntax.Concrete.Name-import Agda.Syntax.Concrete.Pretty+import Agda.Syntax.Concrete.Name   ()+import Agda.Syntax.Concrete.Pretty () -import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.Impossible import Agda.Utils.List1 (List1) import qualified Agda.Utils.List1 as List1@@ -53,14 +52,18 @@       --   ('Hiding' should be 'NotHidden'.)   | NiceField Range Access IsAbstract IsInstance TacticAttribute Name (Arg Expr)   | PrimitiveFunction Range Access IsAbstract Name (Arg Expr)-  | NiceMutual Range TerminationCheck CoverageCheck PositivityCheck [NiceDeclaration]-  | NiceModule Range Access IsAbstract QName Telescope [Declaration]-  | NiceModuleMacro Range Access Name ModuleApplication OpenShortHand ImportDirective+  | NiceMutual KwRange TerminationCheck CoverageCheck PositivityCheck [NiceDeclaration]+  | NiceModule Range Access IsAbstract Erased QName Telescope+      [Declaration]+  | NiceModuleMacro Range Access Erased Name ModuleApplication+      OpenShortHand ImportDirective   | NiceOpen Range QName ImportDirective   | NiceImport Range QName (Maybe AsName) OpenShortHand ImportDirective   | NicePragma Range Pragma-  | NiceRecSig Range Access IsAbstract PositivityCheck UniverseCheck Name [LamBinding] Expr-  | NiceDataSig Range Access IsAbstract PositivityCheck UniverseCheck Name [LamBinding] Expr+  | NiceRecSig Range Erased Access IsAbstract PositivityCheck+      UniverseCheck Name [LamBinding] Expr+  | NiceDataSig Range Erased Access IsAbstract PositivityCheck+      UniverseCheck Name [LamBinding] Expr   | NiceFunClause Range Access IsAbstract TerminationCheck CoverageCheck Catchall Declaration     -- ^ An uncategorized function clause, could be a function clause     --   without type signature or a pattern lhs (e.g. for irrefutable let).@@ -73,14 +76,16 @@       --   Andreas, 2017-01-01: Because of issue #2372, we add 'IsInstance' here.       --   An alias should know that it is an instance.   | NiceDataDef Range Origin IsAbstract PositivityCheck UniverseCheck Name [LamBinding] [NiceConstructor]-  | NiceLoneConstructor Range [NiceConstructor]-  | NiceRecDef Range Origin IsAbstract PositivityCheck UniverseCheck Name RecordDirectives [LamBinding] [Declaration]+  | NiceLoneConstructor KwRange [NiceConstructor]+  | NiceRecDef Range Origin IsAbstract PositivityCheck UniverseCheck Name [RecordDirective] [LamBinding] [Declaration]       -- ^ @(Maybe Range)@ gives range of the 'pattern' declaration.-  | NicePatternSyn Range Access Name [Arg Name] Pattern+  | NicePatternSyn Range Access Name [WithHiding Name] Pattern   | NiceGeneralize Range Access ArgInfo TacticAttribute Name Expr   | NiceUnquoteDecl Range Access IsAbstract IsInstance TerminationCheck CoverageCheck [Name] Expr   | NiceUnquoteDef Range Access IsAbstract TerminationCheck CoverageCheck [Name] Expr-  deriving (Data, Show, Generic)+  | NiceUnquoteData Range Access IsAbstract PositivityCheck UniverseCheck Name [Name] Expr+  | NiceOpaque KwRange [QName] [NiceDeclaration]+  deriving (Show, Generic)  instance NFData NiceDeclaration @@ -89,8 +94,6 @@ -- | Termination measure is, for now, a variable name. type Measure = Name -type Catchall = Bool- -- | Only 'Axiom's. type NiceConstructor = NiceTypeSignature @@ -100,7 +103,7 @@ -- | One clause in a function definition. There is no guarantee that the 'LHS' --   actually declares the 'Name'. We will have to check that later. data Clause = Clause Name Catchall LHS RHS WhereClause [Clause]-    deriving (Data, Show, Generic)+    deriving (Show, Generic)  instance NFData Clause @@ -173,9 +176,11 @@  interleavedDecl :: Name -> InterleavedDecl -> [(DeclNum, NiceDeclaration)] interleavedDecl k = \case-  InterleavedData i d@(NiceDataSig _ acc abs pc uc _ pars _) ds ->-    let fpars = concatMap dropTypeAndModality pars-        ddef  = NiceDataDef noRange UserWritten abs pc uc k fpars+  InterleavedData i d@(NiceDataSig _ _ acc abs pc uc _ pars _) ds ->+    let fpars   = concatMap dropTypeAndModality pars+        r       = getRange (k, fpars)+        ddef cs = NiceDataDef (getRange (r, cs)) UserWritten+                    abs pc uc k fpars cs     in (i,d) : maybe [] (\ (j, dss) -> [(j, ddef (sconcat (List1.reverse dss)))]) ds   InterleavedFun i d@(FunSig r acc abs inst mac info tc cc n e) dcs ->     let fdef dcss = let (dss, css) = List1.unzip dcss in@@ -191,15 +196,16 @@   | FieldBlock      -- ^ @field@.  Ensured by parser.   | DataBlock       -- ^ @data ... where@.  Here we got a bad error message for Agda-2.5 (Issue 1698).   | ConstructorBlock  -- ^ @constructor@, in @interleaved mutual@.-  deriving (Data, Eq, Ord, Show)+  deriving (Eq, Ord, Show, Generic) +instance NFData KindOfBlock  instance HasRange NiceDeclaration where   getRange (Axiom r _ _ _ _ _ _)           = r   getRange (NiceField r _ _ _ _ _ _)       = r-  getRange (NiceMutual r _ _ _ _)          = r-  getRange (NiceModule r _ _ _ _ _ )       = r-  getRange (NiceModuleMacro r _ _ _ _ _)   = r+  getRange (NiceMutual kwr _ _ _ ds)       = fuseRange kwr ds+  getRange (NiceModule r _ _ _ _ _ _ )     = r+  getRange (NiceModuleMacro r _ _ _ _ _ _) = r   getRange (NiceOpen r _ _)                = r   getRange (NiceImport r _ _ _ _)          = r   getRange (NicePragma r _)                = r@@ -207,15 +213,17 @@   getRange (FunSig r _ _ _ _ _ _ _ _ _)    = r   getRange (FunDef r _ _ _ _ _ _ _)        = r   getRange (NiceDataDef r _ _ _ _ _ _ _)   = r-  getRange (NiceLoneConstructor r _)       = r+  getRange (NiceLoneConstructor kwr ds)    = fuseRange kwr ds   getRange (NiceRecDef r _ _ _ _ _ _ _ _)  = r-  getRange (NiceRecSig r _ _ _ _ _ _ _)    = r-  getRange (NiceDataSig r _ _ _ _ _ _ _)   = r+  getRange (NiceRecSig r _ _ _ _ _ _ _ _)  = r+  getRange (NiceDataSig r _ _ _ _ _ _ _ _) = r   getRange (NicePatternSyn r _ _ _ _)      = r   getRange (NiceGeneralize r _ _ _ _ _)    = r   getRange (NiceFunClause r _ _ _ _ _ _)   = r   getRange (NiceUnquoteDecl r _ _ _ _ _ _ _) = r-  getRange (NiceUnquoteDef r _ _ _ _ _ _)    = r+  getRange (NiceUnquoteDef r _ _ _ _ _ _)  = r+  getRange (NiceUnquoteData r _ _ _ _ _ _ _) = r+  getRange (NiceOpaque kwr xs ds)          = getRange (kwr, xs, ds)  instance Pretty NiceDeclaration where   pretty = \case@@ -223,23 +231,25 @@     NiceField _ _ _ _ _ x _        -> text "field" <+> pretty x     PrimitiveFunction _ _ _ x _    -> text "primitive" <+> pretty x     NiceMutual{}                   -> text "mutual"-    NiceModule _ _ _ x _ _         -> text "module" <+> pretty x <+> text "where"-    NiceModuleMacro _ _ x _ _ _    -> text "module" <+> pretty x <+> text "= ..."+    NiceOpaque _ _ ds              -> text "opaque" <+> nest 2 (vcat (map pretty ds))+    NiceModule _ _ _ _ x _ _       -> text "module" <+> pretty x <+> text "where"+    NiceModuleMacro _ _ _ x _ _ _  -> text "module" <+> pretty x <+> text "= ..."     NiceOpen _ x _                 -> text "open" <+> pretty x     NiceImport _ x _ _ _           -> text "import" <+> pretty x     NicePragma{}                   -> text "{-# ... #-}"-    NiceRecSig _ _ _ _ _ x _ _     -> text "record" <+> pretty x-    NiceDataSig _ _ _ _ _ x _ _    -> text "data" <+> pretty x+    NiceRecSig _ _ _ _ _ _ x _ _   -> text "record" <+> pretty x+    NiceDataSig _ _ _ _ _ _ x _ _  -> text "data" <+> pretty x     NiceFunClause{}                -> text "<function clause>"     FunSig _ _ _ _ _ _ _ _ x _     -> pretty x <+> colon <+> text "_"     FunDef _ _ _ _ _ _ x _         -> pretty x <+> text "= _"     NiceDataDef _ _ _ _ _ x _ _    -> text "data" <+> pretty x <+> text "where"-    NiceLoneConstructor _ ds       -> text "constructor"+    NiceLoneConstructor _ _        -> text "data _ where"     NiceRecDef _ _ _ _ _ x  _ _ _  -> text "record" <+> pretty x <+> text "where"     NicePatternSyn _ _ x _ _       -> text "pattern" <+> pretty x     NiceGeneralize _ _ _ _ x _     -> text "variable" <+> pretty x     NiceUnquoteDecl _ _ _ _ _ _ xs _ -> text "<unquote declarations>"     NiceUnquoteDef _ _ _ _ _ xs _    -> text "<unquote definitions>"+    NiceUnquoteData _ _ _ _ _ x xs _ -> text "<unquote data types>"  declName :: NiceDeclaration -> String declName Axiom{}             = "Postulates"@@ -255,6 +265,7 @@ declName NiceGeneralize{}    = "Generalized variables" declName NiceUnquoteDecl{}   = "Unquoted declarations" declName NiceUnquoteDef{}    = "Unquoted definitions"+declName NiceUnquoteData{}   = "Unquoted data types" declName NiceRecSig{}        = "Records" declName NiceDataSig{}       = "Data types" declName NiceFunClause{}     = "Functions without a type signature"@@ -263,6 +274,7 @@ declName NiceRecDef{}        = "Records" declName NiceDataDef{}       = "Data types" declName NiceLoneConstructor{} = "Constructors"+declName NiceOpaque{}          = "Opaque blocks"   data InMutual@@ -285,7 +297,9 @@     -- ^ Name of a record type   | FunName TerminationCheck CoverageCheck     -- ^ Name of a function.-  deriving (Data, Show)+  deriving (Show, Generic)++instance NFData DataRecOrFun  -- Ignore pragmas when checking equality instance Eq DataRecOrFun where
src/full/Agda/Syntax/Concrete/Fixity.hs view
@@ -1,6 +1,8 @@-{-# LANGUAGE CPP                        #-}+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Collecting fixity declarations (and polarity pragmas) for concrete --   declarations.+ module Agda.Syntax.Concrete.Fixity   ( Fixities, Polarities, MonadFixityError(..)   , DoWarn(..)@@ -12,35 +14,38 @@ import Control.Monad import Data.Map (Map) import qualified Data.Map as Map+import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set-#if __GLASGOW_HASKELL__ < 804-import Data.Semigroup-#endif -import Agda.Syntax.Builtin (isBuiltinNoDef)+import Agda.Syntax.Builtin (builtinById, isBuiltinNoDef) import Agda.Syntax.Common import Agda.Syntax.Concrete import Agda.Syntax.Position-import Agda.TypeChecking.Positivity.Occurrence (Occurrence)+import Agda.TypeChecking.Positivity.Occurrence (PragmaPolarities)  import Agda.Utils.CallStack (HasCallStack) import Agda.Utils.Functor+import Agda.Utils.List1 (List1) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Null-import Agda.Utils.Impossible+import Agda.Utils.Set1 (Set1)+import qualified Agda.Utils.Set1 as Set1+import Agda.Utils.Tuple (Pair(Pair)) +import Agda.Utils.Impossible  type Fixities   = Map Name Fixity'-type Polarities = Map Name [Occurrence]+type Polarities = Map Name PragmaPolarities  class Monad m => MonadFixityError m where-  throwMultipleFixityDecls            :: [(Name, [Fixity'])] -> m a-  throwMultiplePolarityPragmas        :: [Name] -> m a-  warnUnknownNamesInFixityDecl        :: HasCallStack => [Name] -> m ()-  warnUnknownNamesInPolarityPragmas   :: HasCallStack => [Name] -> m ()-  warnUnknownFixityInMixfixDecl       :: HasCallStack => [Name] -> m ()-  warnPolarityPragmasButNotPostulates :: HasCallStack => [Name] -> m ()+  throwMultipleFixityDecls            :: List1 (Name, Pair Fixity') -> m a+  throwMultiplePolarityPragmas        :: List1 Name -> m a+  warnUnknownNamesInFixityDecl        :: HasCallStack => Set1 Name -> m ()+  warnUnknownNamesInPolarityPragmas   :: HasCallStack => Set1 Name -> m ()+  warnUnknownFixityInMixfixDecl       :: HasCallStack => Set1 Name -> m ()+  warnPolarityPragmasButNotPostulates :: HasCallStack => Set1 Name -> m ()+  warnEmptyPolarityPragma             :: HasCallStack => Range -> m ()  -- | Add more fixities. Throw an exception for multiple fixity declarations. --   OR:  Disjoint union of fixity maps.  Throws exception if not disjoint.@@ -48,7 +53,7 @@ plusFixities :: MonadFixityError m => Fixities -> Fixities -> m Fixities plusFixities m1 m2     -- If maps are not disjoint, report conflicts as exception.-    | not (null isect) = throwMultipleFixityDecls isect+    | Just ds <- List1.nonEmpty isect = throwMultipleFixityDecls ds     -- Otherwise, do the union.     | otherwise        = return $ Map.unionWithKey mergeFixites m1 m2   where@@ -62,7 +67,7 @@                       | otherwise = __IMPOSSIBLE__      -- Compute a list of conflicts in a format suitable for error reporting.-    isect = [ (x, map (Map.findWithDefault __IMPOSSIBLE__ x) [m1,m2])+    isect = [ (x, fmap (Map.findWithDefault __IMPOSSIBLE__ x) $ Pair m1 m2)             | (x, False) <- Map.assocs $ Map.intersectionWith compatible m1 m2 ]      -- Check for no conflict.@@ -90,11 +95,11 @@     p <- mergePolarities p1 p2     return (f, p)     where-    mergePolarities p1 p2-      | Set.null i = return (Map.union p1 p2)-      | otherwise  = throwMultiplePolarityPragmas (Set.toList i)-      where-      i = Set.intersection (Map.keysSet p1) (Map.keysSet p2)+    -- Merge disjoint maps.+    mergePolarities p1 p2 =+      List1.ifNull (Map.keys $ Map.intersection p1 p2)+        {-then-} (return $ Map.union p1 p2)+        {-else-} \ ks -> throwMultiplePolarityPragmas ks  instance MonadFixityError m => Monoid (MonadicFixPol m) where   mempty  = MonadicFixPol $ return (Map.empty, Map.empty)@@ -116,35 +121,37 @@    -- If we have names in fixity declarations which are not defined in the   -- appropriate scope, raise a warning and delete them from fixs.-  fixs <- ifNull (Map.keysSet fixs Set.\\ declared) (return fixs) $ \ unknownFixs -> do-    when (doWarn == DoWarn) $ warnUnknownNamesInFixityDecl $ Set.toList unknownFixs+  fixs <- Set1.ifNull (Map.keysSet fixs Set.\\ declared) (return fixs) $ \ unknownFixs -> do+    when (doWarn == DoWarn) $ warnUnknownNamesInFixityDecl unknownFixs     -- Note: Data.Map.restrictKeys requires containers >= 0.5.8.2     -- return $ Map.restrictKeys fixs declared     return $ Map.filterWithKey (\ k _ -> Set.member k declared) fixs    -- Same for undefined names in polarity declarations.-  pols <- ifNull (Map.keysSet pols Set.\\ declared) (return pols) $+  pols <- Set1.ifNull (Map.keysSet pols Set.\\ declared) (return pols) $     \ unknownPols -> do-      when (doWarn == DoWarn) $ warnUnknownNamesInPolarityPragmas $ Set.toList unknownPols+      when (doWarn == DoWarn) $ warnUnknownNamesInPolarityPragmas unknownPols       -- Note: Data.Map.restrictKeys requires containers >= 0.5.8.2       -- return $ Map.restrictKeys polarities declared       return $ Map.filterWithKey (\ k _ -> Set.member k declared) pols    -- If we have public mixfix identifiers without a corresponding fixity   -- declaration, we raise a warning-  ifNull (Set.filter isOpenMixfix publicNames Set.\\ Map.keysSet fixs) (return ()) $-    when (doWarn == DoWarn) . warnUnknownFixityInMixfixDecl . Set.toList+  Set1.unlessNull (Set.filter isOpenMixfix publicNames Set.\\ Map.keysSet fixs) $+    when (doWarn == DoWarn) . warnUnknownFixityInMixfixDecl    -- Check that every polarity pragma is used for a postulate.-  ifNull (Map.keysSet pols Set.\\ postulates) (return ()) $-    when (doWarn == DoWarn) . warnPolarityPragmasButNotPostulates . Set.toList+  Set1.unlessNull (Map.keysSet pols Set.\\ postulates) $+    when (doWarn == DoWarn) . warnPolarityPragmasButNotPostulates    return (fixs, pols)  fixitiesAndPolarities' :: MonadFixityError m => [Declaration] -> MonadicFixPol m fixitiesAndPolarities' = foldMap $ \case   -- These declarations define polarities:-  Pragma (PolarityPragma _ x occs) -> returnPol $ Map.singleton x occs+  Pragma (PolarityPragma r x occs) ->+    List1.ifNull occs (MonadicFixPol $ warnEmptyPolarityPragma r $> mempty) {-else-} \ occs ->+      returnPol $ Map.singleton x occs   -- These declarations define fixities:   Syntax x syn    -> returnFix $ Map.singleton x (Fixity' noFixity syn $ getRange x)   Infix  f xs     -> returnFix $ Map.fromList $ for (List1.toList xs) $ \ x -> (x, Fixity' f noNotation $ getRange x)@@ -155,6 +162,7 @@   Private _ _ ds' -> fixitiesAndPolarities' ds'   InstanceB _ ds' -> fixitiesAndPolarities' ds'   Macro     _ ds' -> fixitiesAndPolarities' ds'+  Opaque    _ ds' -> fixitiesAndPolarities' ds'   -- All other declarations are ignored.   -- We expand these boring cases to trigger a revisit   -- in case the @Declaration@ type is extended in the future.@@ -169,7 +177,6 @@   RecordSig       {}  -> mempty   RecordDef       {}  -> mempty   Record          {}  -> mempty-  RecordDirective {}  -> mempty   LoneConstructor {}  -> mempty   PatternSyn      {}  -> mempty   Postulate       {}  -> mempty@@ -180,7 +187,9 @@   Module          {}  -> mempty   UnquoteDecl     {}  -> mempty   UnquoteDef      {}  -> mempty+  UnquoteData     {}  -> mempty   Pragma          {}  -> mempty+  Unfolding       {}  -> mempty  data DeclaredNames = DeclaredNames { _allNames, _postulates, _privateNames :: Set Name } @@ -208,41 +217,48 @@ --   i.e., do not go into modules. declaredNames :: Declaration -> DeclaredNames declaredNames = \case-  TypeSig _ _ x _      -> declaresName x-  FieldSig _ _ x _     -> declaresName x-  Field _ fs           -> foldMap declaredNames fs+  TypeSig _ _ x _       -> declaresName x+  FieldSig _ _ x _      -> declaresName x+  Field _ fs            -> foldMap declaredNames fs   FunClause (LHS p [] []) _ _ _-    | IdentP (QName x) <- removeParenP p-                       -> declaresName x-  FunClause{}          -> mempty-  DataSig _ x _ _      -> declaresName x-  DataDef _ _ _ cs     -> foldMap declaredNames cs-  Data _ x _ _ cs      -> declaresName x <> foldMap declaredNames cs-  RecordSig _ x _ _    -> declaresName x-  RecordDef _ x d _ _  -> declaresNames $     foldMap (:[]) (fst <$> recConstructor d)-  Record _ x d _ _ _   -> declaresNames $ x : foldMap (:[]) (fst <$> recConstructor d)-  RecordDirective _    -> mempty-  Infix _ _            -> mempty-  Syntax _ _           -> mempty-  PatternSyn _ x _ _   -> declaresName x-  Mutual    _ ds       -> foldMap declaredNames ds+    | IdentP _ (QName x) <- removeParenP p+                        -> declaresName x+  FunClause{}           -> mempty+  DataSig _ _ x _ _     -> declaresName x+  DataDef _ _ _ cs      -> foldMap declaredNames cs+  Data _ _ x _ _ cs     -> declaresName x <> foldMap declaredNames cs+  RecordSig _ _ x _ _   -> declaresName x+  RecordDef _ x ds _ _  -> declaresNames $     maybeToList (recDirConstructor ds)+  Record _ _ x ds _ _ _ -> declaresNames $ x : maybeToList (recDirConstructor ds)+  Infix _ _             -> mempty+  Syntax _ _            -> mempty+  PatternSyn _ x _ _    -> declaresName x+  Mutual    _ ds        -> foldMap declaredNames ds   InterleavedMutual    _ ds -> foldMap declaredNames ds-  LoneConstructor _ ds -> foldMap declaredNames ds-  Abstract  _ ds       -> foldMap declaredNames ds-  Private _ _ ds       -> allPrivateNames $ foldMap declaredNames ds-  InstanceB _ ds       -> foldMap declaredNames ds-  Macro     _ ds       -> foldMap declaredNames ds-  Postulate _ ds       -> allPostulates $ foldMap declaredNames ds-  Primitive _ ds       -> foldMap declaredNames ds-  Generalize _ ds      -> foldMap declaredNames ds-  Open{}               -> mempty-  Import{}             -> mempty-  ModuleMacro{}        -> mempty-  Module{}             -> mempty-  UnquoteDecl _ xs _   -> declaresNames xs-  UnquoteDef{}         -> mempty+  LoneConstructor _ ds  -> foldMap declaredNames ds+  Abstract  _ ds        -> foldMap declaredNames ds+  Private _ _ ds        -> allPrivateNames $ foldMap declaredNames ds+  InstanceB _ ds        -> foldMap declaredNames ds+  Macro     _ ds        -> foldMap declaredNames ds+  Postulate _ ds        -> allPostulates $ foldMap declaredNames ds+  Primitive _ ds        -> foldMap declaredNames ds+  Generalize _ ds       -> foldMap declaredNames ds+  Opaque _ ds           -> foldMap declaredNames ds+  Open{}                -> mempty+  Unfolding{}           -> mempty+  Import{}              -> mempty+  ModuleMacro{}         -> mempty+  Module{}              -> mempty+  UnquoteDecl _ xs _    -> declaresNames xs+  UnquoteDef{}          -> mempty+  UnquoteData _ x cs _  -> declaresNames (x:cs)   -- BUILTIN pragmas which do not require an accompanying definition declare   -- the (unqualified) name they mention.   Pragma (BuiltinPragma _ b (QName x))-    | isBuiltinNoDef $ rangedThing b -> declaresName x+    | any isBuiltinNoDef . builtinById $ rangedThing b -> declaresName x   Pragma{}             -> mempty++recDirConstructor :: [RecordDirective] -> Maybe Name+recDirConstructor = listToMaybe . mapMaybe \case+  Constructor x _ -> Just x+  _ -> Nothing
src/full/Agda/Syntax/Concrete/Generic.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Generic traversal and reduce for concrete syntax, --   in the style of "Agda.Syntax.Internal.Generic".@@ -7,6 +8,7 @@ module Agda.Syntax.Concrete.Generic where  import Data.Bifunctor+import Data.Functor  import Agda.Syntax.Common import Agda.Syntax.Concrete@@ -17,6 +19,9 @@  import Agda.Utils.Impossible +-- Generic traversals for concrete expressions.+-- ========================================================================+ -- | Generic traversals for concrete expressions. -- --   Note: does not go into patterns!@@ -44,7 +49,8 @@   traverseExpr = traverse . traverseExpr  --- * Instances for things that do not contain expressions.+-- Instances for things that do not contain expressions.+---------------------------------------------------------------------------  instance ExprLike () where   mapExpr _      = id@@ -66,7 +72,8 @@   foldExpr _ _   = mempty   traverseExpr _ = return --- * Instances for collections and decorations.+-- Instances for collections and decorations.+---------------------------------------------------------------------------  instance ExprLike a => ExprLike [a] instance ExprLike a => ExprLike (List1 a)@@ -75,10 +82,12 @@  instance ExprLike a => ExprLike (Arg a) instance ExprLike a => ExprLike (Named name a)+instance ExprLike a => ExprLike (Ranged a) instance ExprLike a => ExprLike (WithHiding a)  instance ExprLike a => ExprLike (MaybePlaceholder a) instance ExprLike a => ExprLike (RHS' a)+instance ExprLike a => ExprLike (TacticAttribute' a) instance ExprLike a => ExprLike (TypedBinding' a) instance ExprLike a => ExprLike (WhereClause' a) @@ -102,44 +111,46 @@   traverseExpr f (x, y, z, w) = (,,,) <$> traverseExpr f x <*> traverseExpr f y <*> traverseExpr f z <*> traverseExpr f w   foldExpr     f (x, y, z, w) = foldExpr f x `mappend` foldExpr f y `mappend` foldExpr f z `mappend` foldExpr f w --- * Interesting instances+-- Interesting instances+---------------------------------------------------------------------------  instance ExprLike Expr where   mapExpr f e0 = case e0 of-     Ident{}            -> f $ e0-     Lit{}              -> f $ e0-     QuestionMark{}     -> f $ e0-     Underscore{}       -> f $ e0-     RawApp r es        -> f $ RawApp r               $ mapE es-     App r e es         -> f $ App r       (mapE e)   $ mapE es-     OpApp r q ns es    -> f $ OpApp r q ns           $ mapE es-     WithApp r e es     -> f $ WithApp r   (mapE e)   $ mapE es-     HiddenArg r e      -> f $ HiddenArg r            $ mapE e-     InstanceArg r e    -> f $ InstanceArg r          $ mapE e-     Lam r bs e         -> f $ Lam r       (mapE bs)  $ mapE e-     AbsurdLam{}        -> f $ e0-     ExtendedLam r e cs -> f $ ExtendedLam r e        $ mapE cs-     Fun r a b          -> f $ Fun r     (mapE <$> a) $ mapE b-     Pi tel e           -> f $ Pi          (mapE tel) $ mapE e-     Rec r es           -> f $ Rec r                  $ mapE es-     RecUpdate r e es   -> f $ RecUpdate r (mapE e)   $ mapE es-     Let r ds e         -> f $ Let r       (mapE ds)  $ mapE e-     Paren r e          -> f $ Paren r                $ mapE e-     IdiomBrackets r es -> f $ IdiomBrackets r        $ mapE es-     DoBlock r ss       -> f $ DoBlock r              $ mapE ss-     Absurd{}           -> f $ e0-     As r x e           -> f $ As r x                 $ mapE e-     Dot r e            -> f $ Dot r                  $ mapE e-     DoubleDot r e      -> f $ DoubleDot r            $ mapE e-     ETel tel           -> f $ ETel                   $ mapE tel-     Tactic r e         -> f $ Tactic r     (mapE e)-     Quote{}            -> f $ e0-     QuoteTerm{}        -> f $ e0-     Unquote{}          -> f $ e0-     DontCare e         -> f $ DontCare               $ mapE e-     Equal{}            -> f $ e0-     Ellipsis{}         -> f $ e0-     Generalized e      -> f $ Generalized            $ mapE e+     Ident{}                 -> f $ e0+     Lit{}                   -> f $ e0+     QuestionMark{}          -> f $ e0+     Underscore{}            -> f $ e0+     RawApp r es             -> f $ RawApp r               $ mapE es+     App r e es              -> f $ App r       (mapE e)   $ mapE es+     OpApp r q ns es         -> f $ OpApp r q ns           $ mapE es+     WithApp r e es          -> f $ WithApp r   (mapE e)   $ mapE es+     HiddenArg r e           -> f $ HiddenArg r            $ mapE e+     InstanceArg r e         -> f $ InstanceArg r          $ mapE e+     Lam r bs e              -> f $ Lam r       (mapE bs)  $ mapE e+     AbsurdLam{}             -> f $ e0+     ExtendedLam r e cs      -> f $ ExtendedLam r e        $ mapE cs+     Fun r a b               -> f $ Fun r     (mapE <$> a) $ mapE b+     Pi tel e                -> f $ Pi          (mapE tel) $ mapE e+     Rec kwr r es            -> f $ Rec kwr r              $ mapE es+     RecUpdate kwr r e es    -> f $ RecUpdate kwr r (mapE e) $ mapE es+     Let r ds e              -> f $ Let r       (mapE ds)  $ mapE e+     Paren r e               -> f $ Paren r                $ mapE e+     IdiomBrackets r es      -> f $ IdiomBrackets r        $ mapE es+     DoBlock r ss            -> f $ DoBlock r              $ mapE ss+     Absurd{}                -> f $ e0+     As r x e                -> f $ As r x                 $ mapE e+     Dot r e                 -> f $ Dot r                  $ mapE e+     DoubleDot r e           -> f $ DoubleDot r            $ mapE e+     Tactic r e              -> f $ Tactic r     (mapE e)+     Quote{}                 -> f $ e0+     QuoteTerm{}             -> f $ e0+     Unquote{}               -> f $ e0+     DontCare e              -> f $ DontCare               $ mapE e+     Equal{}                 -> f $ e0+     Ellipsis{}              -> f $ e0+     Generalized e           -> f $ Generalized            $ mapE e+     KnownIdent{}            -> f $ e0+     KnownOpApp nk r q ns es -> f $ KnownOpApp nk r q ns   $ mapE es    where      mapE :: ExprLike e => e -> e      mapE = mapExpr f@@ -187,7 +198,8 @@ instance (ExprLike qn, ExprLike e) => ExprLike (RewriteEqn' qn nm p e) where   mapExpr f = \case     Rewrite es    -> Rewrite (mapExpr f es)-    Invert qn pes -> Invert qn (fmap (fmap $ fmap $ mapExpr f) pes)+    Invert qn pes -> Invert qn $ (fmap . fmap . fmap . mapExpr) f pes+    LeftLet pes   -> LeftLet $ (fmap . fmap . mapExpr) f pes   foldExpr     = __IMPOSSIBLE__   traverseExpr = __IMPOSSIBLE__ @@ -206,7 +218,7 @@  instance ExprLike ModuleApplication where   mapExpr f = \case-     SectionApp r bs e -> SectionApp r (mapE bs) $ mapE e+     SectionApp r bs x es -> SectionApp r (mapE bs) x $ mapE es      e@RecordModuleInstance{} -> e    where      mapE :: ExprLike e => e -> e@@ -219,14 +231,15 @@      TypeSig ai t x e          -> TypeSig ai (mapE t) x (mapE e)      FieldSig i t n e          -> FieldSig i (mapE t) n (mapE e)      Field r fs                -> Field r                              $ map (mapExpr f) fs-     FunClause lhs rhs wh ca   -> FunClause (mapE lhs) (mapE rhs) (mapE wh) (mapE ca)-     DataSig r x bs e          -> DataSig r x (mapE bs)                $ mapE e+     FunClause lhs rhs wh ca   -> FunClause (mapE lhs) (mapE rhs) (mapE wh) ca+     DataSig r er x bs e       -> DataSig r er x (mapE bs)             $ mapE e      DataDef r n bs cs         -> DataDef r n (mapE bs)                $ mapE cs-     Data r n bs e cs          -> Data r n (mapE bs) (mapE e)          $ mapE cs-     RecordSig r ind bs e      -> RecordSig r ind (mapE bs)            $ mapE e+     Data r er n bs e cs       -> Data r er n (mapE bs) (mapE e)       $ mapE cs+     RecordSig r er ind bs e   -> RecordSig r er ind (mapE bs)         $ mapE e      RecordDef r n dir tel ds  -> RecordDef r n dir (mapE tel)         $ mapE ds-     Record r n dir tel e ds   -> Record r n dir (mapE tel) (mapE e)   $ mapE ds-     e@RecordDirective{}       -> e+     Record r er n dir tel e ds+                               -> Record r er n dir (mapE tel) (mapE e)+                                                                       $ mapE ds      e@Infix{}                 -> e      e@Syntax{}                -> e      e@PatternSyn{}            -> e@@ -240,13 +253,17 @@      Postulate r ds            -> Postulate r                          $ mapE ds      Primitive r ds            -> Primitive r                          $ mapE ds      Generalize r ds           -> Generalize r                         $ mapE ds+     Opaque  r ds              -> Opaque r                             $ mapE ds      e@Open{}                  -> e      e@Import{}                -> e-     ModuleMacro r n es op dir -> ModuleMacro r n (mapE es) op dir-     Module r n tel ds         -> Module r n (mapE tel)                $ mapE ds+     ModuleMacro r e n es op dir+                               -> ModuleMacro r e n (mapE es) op dir+     Module r e n tel ds       -> Module r e n (mapE tel)              $ mapE ds      UnquoteDecl r x e         -> UnquoteDecl r x (mapE e)      UnquoteDef r x e          -> UnquoteDef r x (mapE e)+     UnquoteData r x xs e      -> UnquoteData r x xs (mapE e)      e@Pragma{}                -> e+     e@Unfolding{}             -> e    where      mapE :: ExprLike e => e -> e      mapE = mapExpr f@@ -264,3 +281,111 @@   traverseExpr = __IMPOSSIBLE__  -}++-- Generic traversals for concrete declarations.+-- ========================================================================++class FoldDecl a where++  -- | Collect declarations and subdeclarations, transitively.+  -- Prefix-order tree traversal.+  foldDecl :: Monoid m => (Declaration -> m) -> a -> m++  default foldDecl :: (Monoid m, Foldable t, FoldDecl b, t b ~ a)+    => (Declaration -> m) -> a -> m+  foldDecl = foldMap . foldDecl++instance FoldDecl a => FoldDecl [a]+instance FoldDecl a => FoldDecl (List1 a)+instance FoldDecl a => FoldDecl (List2 a)+instance FoldDecl a => FoldDecl (WhereClause' a)++instance FoldDecl Declaration where+  foldDecl f d = f d <> case d of+    Private  _ _        ds  -> foldDecl f ds+    Abstract _          ds  -> foldDecl f ds+    InstanceB _         ds  -> foldDecl f ds+    InterleavedMutual _ ds  -> foldDecl f ds+    LoneConstructor _   ds  -> foldDecl f ds+    Mutual _            ds  -> foldDecl f ds+    Module _ _ _ _      ds  -> foldDecl f ds+    Macro _             ds  -> foldDecl f ds+    Record _ _ _ _ _ _  ds  -> foldDecl f ds+    RecordDef _ _ _ _   ds  -> foldDecl f ds+    TypeSig _ _ _ _         -> mempty+    FieldSig _ _ _ _        -> mempty+    Generalize _ _          -> mempty+    Field _ _               -> mempty+    FunClause _ _ wh _      -> foldDecl f wh+    DataSig _ _ _ _ _       -> mempty+    Data _ _ _ _ _ _        -> mempty+    DataDef _ _ _ _         -> mempty+    RecordSig _ _ _ _ _     -> mempty+    Infix _ _               -> mempty+    Syntax _ _              -> mempty+    PatternSyn _ _ _ _      -> mempty+    Postulate _ _           -> mempty+    Primitive _ _           -> mempty+    Open _ _ _              -> mempty+    Import _ _ _ _ _        -> mempty+    ModuleMacro _ _ _ _ _ _ -> mempty+    UnquoteDecl _ _ _       -> mempty+    UnquoteDef _ _ _        -> mempty+    UnquoteData _ _ _ _     -> mempty+    Pragma _                -> mempty+    Opaque _ ds             -> foldDecl f ds+    Unfolding _ _           -> mempty++class TraverseDecl a where++  -- | Update declarations and their subdeclarations.+  -- Prefix-order traversal: traverses subdeclarations of updated declaration.+  --+  preTraverseDecl :: Monad m => (Declaration -> m Declaration) -> a -> m a++  default preTraverseDecl :: (Monad m, Traversable t, TraverseDecl b, t b ~ a)+    => (Declaration -> m Declaration) -> a -> m a+  preTraverseDecl = traverse . preTraverseDecl++instance TraverseDecl a => TraverseDecl [a]+instance TraverseDecl a => TraverseDecl (List1 a)+instance TraverseDecl a => TraverseDecl (List2 a)+instance TraverseDecl a => TraverseDecl (WhereClause' a)++instance TraverseDecl Declaration where+  preTraverseDecl f d0 = do+    d <- f d0+    case d of+      Private  r o        ds     -> Private r o             <$> preTraverseDecl f ds+      Abstract r          ds     -> Abstract r              <$> preTraverseDecl f ds+      InstanceB r         ds     -> InstanceB r             <$> preTraverseDecl f ds+      InterleavedMutual r ds     -> InterleavedMutual r     <$> preTraverseDecl f ds+      LoneConstructor r   ds     -> LoneConstructor r       <$> preTraverseDecl f ds+      Mutual r            ds     -> Mutual r                <$> preTraverseDecl f ds+      Module r er n tel   ds     -> Module r er n tel       <$> preTraverseDecl f ds+      Macro r             ds     -> Macro r                 <$> preTraverseDecl f ds+      Opaque r ds                -> Opaque r                <$> preTraverseDecl f ds+      Record r er n dir tel t ds -> Record r er n dir tel t <$> preTraverseDecl f ds+      RecordDef r n dir tel   ds -> RecordDef r n dir tel   <$> preTraverseDecl f ds+      TypeSig _ _ _ _            -> return d+      FieldSig _ _ _ _           -> return d+      Generalize _ _             -> return d+      Field _ _                  -> return d+      FunClause lhs rhs wh ca    -> preTraverseDecl f wh <&> \ wh' -> FunClause lhs rhs wh' ca+      DataSig _ _ _ _ _          -> return d+      Data _ _ _ _ _ _           -> return d+      DataDef _ _ _ _            -> return d+      RecordSig _ _ _ _ _        -> return d+      Infix _ _                  -> return d+      Syntax _ _                 -> return d+      PatternSyn _ _ _ _         -> return d+      Postulate _ _              -> return d+      Primitive _ _              -> return d+      Open _ _ _                 -> return d+      Import _ _ _ _ _           -> return d+      ModuleMacro _ _ _ _ _ _    -> return d+      UnquoteDecl _ _ _          -> return d+      UnquoteDef _ _ _           -> return d+      UnquoteData _ _ _ _        -> return d+      Pragma _                   -> return d+      Unfolding _ _              -> return d
src/full/Agda/Syntax/Concrete/Glyph.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-| Choice of Unicode or ASCII glyphs. -} module Agda.Syntax.Concrete.Glyph@@ -18,18 +20,29 @@  import GHC.Generics (Generic) +import Agda.Utils.Boolean import Agda.Utils.List import Agda.Utils.Null-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty  -- | We want to know whether we are allowed to insert unicode characters or not. data UnicodeOrAscii-  = UnicodeOk-  | AsciiOnly+  = UnicodeOk  -- ^ 'true': Unicode characters are allowed.+  | AsciiOnly  -- ^ 'false: Stick to ASCII.   deriving (Show, Eq, Enum, Bounded, Generic)  instance NFData UnicodeOrAscii +instance Boolean UnicodeOrAscii where+  fromBool = \case+    True -> UnicodeOk+    False -> AsciiOnly++instance IsBool UnicodeOrAscii where+  toBool = \case+    UnicodeOk -> True+    AsciiOnly -> False+ {-# NOINLINE unsafeUnicodeOrAsciiIORef #-} unsafeUnicodeOrAsciiIORef :: IORef UnicodeOrAscii unsafeUnicodeOrAsciiIORef = UNSAFE.unsafePerformIO $ newIORef UnicodeOk@@ -58,24 +71,24 @@  specialCharactersUnicode :: SpecialCharacters specialCharactersUnicode = SpecialCharacters-  { _dbraces = (("\x2983 " <>) . (<> " \x2984"))-  , _lambda  = "\x03bb"-  , _arrow   = "\x2192"-  , _forallQ = "\x2200"-  , _leftIdiomBrkt  = "\x2987"-  , _rightIdiomBrkt = "\x2988"-  , _emptyIdiomBrkt = "\x2987\x2988"+  { _dbraces        = ((hlSymbol "\x2983 " <>) . (<> hlSymbol " \x2984"))+  , _lambda         = hlSymbol "\x03bb"+  , _arrow          = hlSymbol "\x2192"+  , _forallQ        = hlSymbol "\x2200"+  , _leftIdiomBrkt  = hlSymbol "\x2987"+  , _rightIdiomBrkt = hlSymbol "\x2988"+  , _emptyIdiomBrkt = hlSymbol "\x2987\x2988"   }  specialCharactersAscii :: SpecialCharacters specialCharactersAscii = SpecialCharacters-  { _dbraces = braces . braces'-  , _lambda  = "\\"-  , _arrow   = "->"-  , _forallQ = "forall"-  , _leftIdiomBrkt  = "(|"-  , _rightIdiomBrkt = "|)"-  , _emptyIdiomBrkt = "(|)"+  { _dbraces        = braces . braces'+  , _lambda         = hlSymbol "\\"+  , _arrow          = hlSymbol "->"+  , _forallQ        = hlSymbol "forall"+  , _leftIdiomBrkt  = hlSymbol "(|"+  , _rightIdiomBrkt = hlSymbol "|)"+  , _emptyIdiomBrkt = hlSymbol "(|)"   }  -- | Return the glyph set based on a given (unicode or ascii) glyph mode@@ -103,7 +116,7 @@  -- forall quantifier forallQ :: Doc-forallQ = _forallQ specialCharacters+forallQ = hlSymbol $ _forallQ specialCharacters  -- left, right, and empty idiom bracket leftIdiomBrkt, rightIdiomBrkt, emptyIdiomBrkt :: Doc
src/full/Agda/Syntax/Concrete/Name.hs view
@@ -6,27 +6,20 @@ import Control.DeepSeq  import Data.ByteString.Char8 (ByteString)-import Data.Function+import Data.Function (on) import qualified Data.Foldable as Fold-import qualified Data.List as List-import Data.Data (Data)  import GHC.Generics (Generic) -import System.FilePath- import Agda.Syntax.Common-import Agda.Syntax.Concrete.Glyph import Agda.Syntax.Position -import Agda.Utils.FileName import Agda.Utils.Lens import Agda.Utils.List  (last1) import Agda.Utils.List1 (List1, pattern (:|), (<|)) import qualified Agda.Utils.List1 as List1-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.Singleton-import Agda.Utils.Size import Agda.Utils.Suffix  import Agda.Utils.Impossible@@ -49,7 +42,6 @@     { nameRange     :: Range     , nameId        :: NameId     }-  deriving Data  type NameParts = List1 NamePart @@ -72,7 +64,7 @@ data NamePart   = Hole       -- ^ @_@ part.   | Id RawName  -- ^ Identifier part.-  deriving (Data, Generic)+  deriving Generic  -- | Define equality on @Name@ to ignore range so same names in different --   locations are equal.@@ -115,27 +107,13 @@ data QName   = Qual  Name QName -- ^ @A.rest@.   | QName Name       -- ^ @x@.-  deriving (Data, Eq, Ord)+  deriving (Eq, Ord)  instance Underscore QName where   underscore = QName underscore   isUnderscore (QName x) = isUnderscore x   isUnderscore Qual{}    = False --- | Top-level module names.  Used in connection with the file system.------   Invariant: The list must not be empty.--data TopLevelModuleName = TopLevelModuleName-  { moduleNameRange :: Range-  , moduleNameParts :: List1 String-  }-  deriving (Show, Data, Generic)--instance Eq    TopLevelModuleName where (==)    = (==)    `on` moduleNameParts-instance Ord   TopLevelModuleName where compare = compare `on` moduleNameParts-instance Sized TopLevelModuleName where size    = size     .   moduleNameParts- ------------------------------------------------------------------------ -- * Constructing simple 'Name's. ------------------------------------------------------------------------@@ -157,7 +135,7 @@ ------------------------------------------------------------------------  -- | Don't use on 'NoName{}'.-lensNameParts :: Lens' NameParts Name+lensNameParts :: Lens' Name NameParts lensNameParts f = \case   n@Name{} -> f (nameNameParts n) <&> \ ps -> n { nameNameParts = ps }   NoName{} -> __IMPOSSIBLE__@@ -179,7 +157,7 @@ stringNameParts :: String -> NameParts stringNameParts ""  = singleton $ Id "_"  -- NoName stringNameParts "_" = singleton $ Id "_"  -- NoName-stringNameParts s = List1.fromList $ loop s+stringNameParts s = List1.fromListSafe __IMPOSSIBLE__ $ loop s   where   loop ""                              = []   loop ('_':s)                         = Hole : loop s@@ -223,10 +201,10 @@ ------------------------------------------------------------------------  data NameInScope = InScope | NotInScope-  deriving (Eq, Show, Data)+  deriving (Eq, Show)  class LensInScope a where-  lensInScope :: Lens' NameInScope a+  lensInScope :: Lens' a NameInScope    isInScope :: a -> NameInScope   isInScope x = x ^. lensInScope@@ -288,7 +266,7 @@ nextName             _ NoName{} = __IMPOSSIBLE__  -- | Zoom on the last non-hole in a name.-lastIdPart :: Lens' RawName NameParts+lastIdPart :: Lens' NameParts RawName lastIdPart f = loop   where   loop = \case@@ -308,7 +286,7 @@ -- | Lens for accessing and modifying the suffix of a name. --   The suffix of a @NoName@ is always @Nothing@, and should not be --   changed.-nameSuffix :: Lens' (Maybe Suffix) Name+nameSuffix :: Lens' Name (Maybe Suffix) nameSuffix (f :: Maybe Suffix -> f (Maybe Suffix)) = \case    n@NoName{} -> f Nothing <&> \case@@ -343,7 +321,7 @@ ------------------------------------------------------------------------  -- | Lens for the unqualified part of a QName-lensQNameName :: Lens' Name QName+lensQNameName :: Lens' QName Name lensQNameName f (QName n)  = QName <$> f n lensQNameName f (Qual m n) = Qual m <$> lensQNameName f n @@ -377,37 +355,6 @@ isUnqualified (QName n) = Just n  --------------------------------------------------------------------------- * Operations on 'TopLevelModuleName'----------------------------------------------------------------------------- | Turns a qualified name into a 'TopLevelModuleName'. The qualified--- name is assumed to represent a top-level module name.--toTopLevelModuleName :: QName -> TopLevelModuleName-toTopLevelModuleName q = TopLevelModuleName (getRange q) $-  fmap nameToRawName $ qnameParts q---- | Turns a top-level module name into a file name with the given--- suffix.--moduleNameToFileName :: TopLevelModuleName -> String -> FilePath-moduleNameToFileName (TopLevelModuleName _ ms) ext =-  joinPath (List1.init ms) </> List1.last ms <.> ext---- | Finds the current project's \"root\" directory, given a project--- file and the corresponding top-level module name.------ Example: If the module \"A.B.C\" is located in the file--- \"/foo/A/B/C.agda\", then the root is \"/foo/\".------ Precondition: The module name must be well-formed.--projectRoot :: AbsolutePath -> TopLevelModuleName -> AbsolutePath-projectRoot file (TopLevelModuleName _ m) =-  mkAbsolute $-    iterate takeDirectory (filePath file) !! length m-------------------------------------------------------------------------- -- * No name stuff ------------------------------------------------------------------------ @@ -445,8 +392,6 @@ instance IsNoName a => IsNoName (Ranged a) where instance IsNoName a => IsNoName (WithOrigin a) where --- no instance for TopLevelModuleName- ------------------------------------------------------------------------ -- * Showing names ------------------------------------------------------------------------@@ -473,9 +418,6 @@     | otherwise      = pretty m <> "." <> pretty x   pretty (QName x)  = pretty x -instance Pretty TopLevelModuleName where-  pretty (TopLevelModuleName _ ms) = text $ List.intercalate "." $ List1.toList ms- ------------------------------------------------------------------------ -- * Range instances ------------------------------------------------------------------------@@ -488,9 +430,6 @@     getRange (QName  x) = getRange x     getRange (Qual n x) = fuseRange n x -instance HasRange TopLevelModuleName where-  getRange = moduleNameRange- instance SetRange Name where   setRange r (Name _ nis ps) = Name r nis ps   setRange r (NoName _ i)  = NoName r i@@ -499,9 +438,6 @@   setRange r (QName x)  = QName (setRange r x)   setRange r (Qual n x) = Qual (setRange r n) (setRange r x) -instance SetRange TopLevelModuleName where-  setRange r (TopLevelModuleName _ x) = TopLevelModuleName r x- instance KillRange QName where   killRange (QName x) = QName $ killRange x   killRange (Qual n x) = killRange n `Qual` killRange x@@ -510,9 +446,6 @@   killRange (Name r nis ps)  = Name (killRange r) nis ps   killRange (NoName r i)     = NoName (killRange r) i -instance KillRange TopLevelModuleName where-  killRange (TopLevelModuleName _ x) = TopLevelModuleName noRange x- ------------------------------------------------------------------------ -- * NFData instances ------------------------------------------------------------------------@@ -534,5 +467,3 @@ instance NFData QName where   rnf (Qual a b) = rnf a `seq` rnf b   rnf (QName a)  = rnf a--instance NFData TopLevelModuleName
src/full/Agda/Syntax/Concrete/Operators.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wunused-imports #-} +{-# LANGUAGE DataKinds #-}+ {-| The parser doesn't know about operators and parses everything as normal     function application. This module contains the functions that parses the     operators properly. For a stand-alone implementation of this see@@ -12,23 +13,19 @@  module Agda.Syntax.Concrete.Operators     ( parseApplication-    , parseModuleApplication+    , parseArguments     , parseLHS     , parsePattern     , parsePatternSyn     ) where -import Control.Applicative ( Alternative((<|>)))-import Control.Arrow (second)+import Control.Applicative ( Alternative( (<|>) ) ) import Control.Monad.Except (throwError)  import Data.Either (partitionEithers)-import qualified Data.Foldable as Fold-import Data.Function+import qualified Data.Function import qualified Data.List as List import Data.Maybe-import Data.Map (Map)-import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Traversable as Trav@@ -38,10 +35,10 @@ import Agda.Syntax.Concrete.Operators.Parser import Agda.Syntax.Concrete.Operators.Parser.Monad hiding (parse) import Agda.Syntax.Concrete.Pattern-import qualified Agda.Syntax.Abstract.Name as A import Agda.Syntax.Position import Agda.Syntax.Notation import Agda.Syntax.Scope.Base+import Agda.Syntax.Scope.Flat import Agda.Syntax.Scope.Monad  import Agda.TypeChecking.Monad.Base (typeError, TypeError(..), LHSOrPatSyn(..))@@ -49,10 +46,11 @@ import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.State (getScope) +import Agda.Utils.Function (applyWhen, applyWhenJust) import Agda.Utils.Either-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.List-import Agda.Utils.List1 (List1, pattern (:|))+import Agda.Utils.List1 (List1, pattern (:|), (<|)) import Agda.Utils.List2 (List2, pattern List2) import qualified Agda.Utils.List1 as List1 import qualified Agda.Utils.List2 as List2@@ -81,45 +79,6 @@ -- * Building the parser --------------------------------------------------------------------------- -type FlatScope = Map QName [AbstractName]---- | Compute all defined names in scope and their fixities/notations.--- Note that overloaded names (constructors) can have several--- fixities/notations. Then we 'mergeNotations'. (See issue 1194.)-getDefinedNames :: KindsOfNames -> FlatScope -> [[NewNotation]]-getDefinedNames kinds names =-  [ mergeNotations $ map (namesToNotation x . A.qnameName . anameName) ds-  | (x, ds) <- Map.toList names-  , any ((`elemKindsOfNames` kinds) . anameKind) ds-  , not (null ds)-  ]-  -- Andreas, 2013-03-21 see Issue 822-  -- Names can have different kinds, i.e., 'defined' and 'constructor'.-  -- We need to consider all names that have *any* matching kind,-  -- not only those whose first appearing kind is matching.---- | Compute all names (first component) and operators/notations--- (second component) in scope.-localNames :: FlatScope -> ScopeM ([QName], [NewNotation])-localNames flat = do-  let defs = getDefinedNames allKindsOfNames flat-  locals <- nubOn fst . notShadowedLocals <$> getLocalVars-  -- Note: Debug printout aligned with the one in buildParsers.-  reportS "scope.operators" 50-    [ "flat  = " ++ prettyShow flat-    , "defs  = " ++ prettyShow defs-    , "locals= " ++ prettyShow locals-    ]-  let localNots  = map localOp locals-      notLocal   = not . hasElem (map notaName localNots) . notaName-      otherNots  = concatMap (filter notLocal) defs-  return $ second (map useDefaultFixity) $ split $ localNots ++ otherNots-  where-    localOp (x, y) = namesToNotation (QName x) y-    split          = partitionEithers . concatMap opOrNot-    opOrNot n      = Left (notaName n) :-                     [Right n | not (null (notation n))]- -- | A data structure used internally by 'buildParsers'. data InternalParsers e = InternalParsers   { pTop    :: Parser e e@@ -129,10 +88,6 @@   , pAtom   :: Parser e e   } --- | Expression kinds: Expressions or patterns.-data ExprKind = IsExpr | IsPattern-  deriving (Eq, Show)- -- | The data returned by 'buildParsers'.  data Parsers e = Parsers@@ -169,6 +124,8 @@   :: forall e. IsExpr e   => ExprKind      -- ^ Should expressions or patterns be parsed?+  -> Maybe QName+     -- ^ Are we trying to parse the lhs of the function given here?   -> [QName]      -- ^ This list must include every name part in the      -- expression/pattern to be parsed (excluding name parts inside@@ -178,10 +135,13 @@      -- grammar if all of the notation's name parts are present in      -- the list of names.   -> ScopeM (Parsers e)-buildParsers kind exprNames = do+buildParsers kind top exprNames0 = do+    let exprNames = applyWhenJust top (:) exprNames0     flat         <- flattenScope (qualifierModules exprNames) <$>                       getScope-    (names, ops) <- localNames flat+    (names, ops0) <- localNames kind top flat+    let ops | kind == IsPattern = filter (not . isLambdaNotation) ops0+            | otherwise         = ops0      let -- All names.         namesInExpr :: Set QName@@ -224,9 +184,9 @@           Trie.member (addHole withHole p) partListsInExpr           where           p = case n of-            NormalHole{} : IdPart p : _ -> rangedThing p-            IdPart p : _                -> rangedThing p-            _                           -> __IMPOSSIBLE__+            HolePart{} : IdPart p : _ -> rangedThing p+            IdPart p : _              -> rangedThing p+            _                         -> __IMPOSSIBLE__          -- Is the last identifier part present in n present in the         -- expression, without any succeeding name parts, except for a@@ -235,9 +195,9 @@           Trie.member (addHole withHole p) reversedPartListsInExpr           where           p = case reverse n of-            NormalHole{} : IdPart p : _ -> rangedThing p-            IdPart p : _                -> rangedThing p-            _                           -> __IMPOSSIBLE__+            HolePart{} : IdPart p : _ -> rangedThing p+            IdPart p : _              -> rangedThing p+            _                         -> __IMPOSSIBLE__          -- Are the initial and final identifier parts present with         -- the right mix of leading and trailing underscores?@@ -281,11 +241,11 @@                        (someKindsOfNames [ConName, CoConName, FldName, PatternSynName]) flat         conNames   = Set.fromList $                        filter (flip Set.member namesInExpr) $-                       map (notaName . head) cons+                       map (notaName . List1.head) cons         conParts   = Set.fromList $                        concatMap notationNames $                        filter (or . partsPresent) $-                       concat cons+                       List1.concat cons          allNames   = Set.fromList $                        filter (flip Set.member namesInExpr) names@@ -343,9 +303,8 @@         -- level comes first.         relatedOperators :: [(PrecedenceLevel, [NotationSection])]         relatedOperators =-          map (\((l, ns) : rest) -> (l, ns ++ concatMap snd rest)) .-          List.groupBy ((==) `on` fst) .-          List.sortBy (compare `on` fst) .+          map (\((l, ns) :| rest) -> (l, ns ++ concatMap snd rest)) .+          List1.groupOn fst .           mapMaybe (\n -> case level n of                             Unrelated     -> Nothing                             r@(Related l) ->@@ -367,7 +326,7 @@      let g = Data.Function.fix $ \p -> InternalParsers               { pTop    = memoise TopK $-                          Fold.asum $+                          Agda.Utils.List.asum $                             foldr (\(l, ns) higher ->                                        mkP (Right l) parseSections                                            (pTop p) ns higher True) (pApp p)@@ -378,7 +337,7 @@               , pApp    = memoise AppK $ appP (pNonfix p) (pArgs p)               , pArgs   = argsP (pNonfix p)               , pNonfix = memoise NonfixK $-                          Fold.asum $+                          Agda.Utils.List.asum $                             pAtom p :                             map (\sect ->                               let n = sectNotation sect@@ -403,8 +362,8 @@               }      -- Andreas, 2020-06-03 #4712-    -- Note: needs Agda to be compiled with DEBUG to print the grammar.-    reportSDoc "scope.grammar" 10 $ return $+    -- Note: needs Agda to be compiled with DEBUG_PARSING to print the grammar.+    reportSDoc "scope.grammar" 20 $ return $       "Operator grammar:" $$ nest 2 (grammar (pTop g))      return $ Parsers@@ -443,44 +402,74 @@             -> Parser e e         mkP key parseSections p0 ops higher includeHigher =             memoise (NodeK key) $-              Fold.asum $-                (if includeHigher then (higher :) else id) $+              Agda.Utils.List.asum $+                applyWhen includeHigher (higher :) $                 catMaybes [nonAssoc, preRights, postLefts]-            where-            choice :: forall k.-                      NK k -> [NotationSection] ->-                      Parser e (OperatorType k e)-            choice k =-              Fold.asum .-              map (\sect ->-                let n = sectNotation sect+          where+            -- Andreas, 2025-02-27+            -- Break up the choice function into its three cases,+            -- so that matching on @k@ does not have to be performed+            -- inside the mapped function @(\ sect -> ...)@.+            --+            -- choice :: forall k.+            --           NK k -> [NotationSection] ->+            --           Parser e (OperatorType k e)+            -- choice k =+            --   Agda.Utils.List.asum .+            --   map (\sect ->+            --     let n = sectNotation sect -                    inner :: forall k.-                             NK k -> Parser e (OperatorType k e)-                    inner = opP parseSections p0 n-                in-                case k of-                  In   -> inner In+            --         inner :: forall k.+            --                  NK k -> Parser e (OperatorType k e)+            --         inner = opP parseSections p0 n+            --     in+            --     case k of+            --       In   -> inner In -                  Pre  -> if isinfix n || ispostfix n-                          then flip ($) <$> placeholder Beginning-                                        <*> inner In-                          else inner Pre+            --       Pre  -> if isinfix n || ispostfix n+            --               then flip ($) <$> placeholder Beginning+            --                             <*> inner In+            --               else inner Pre -                  Post -> if isinfix n || isprefix n-                          then flip <$> inner In-                                    <*> placeholder End-                          else inner Post+            --       Post -> if isinfix n || isprefix n+            --               then flip <$> inner In+            --                         <*> placeholder End+            --               else inner Post -                  Non  -> __IMPOSSIBLE__)+            --       Non  -> __IMPOSSIBLE__) +            choiceIn :: [NotationSection] -> Parser e (OperatorType 'InfixNotation e)+            choiceIn =+              Agda.Utils.List.asum .+              map \ sect -> opP parseSections p0 (sectNotation sect) In++            choicePre :: [NotationSection] -> Parser e (OperatorType 'PrefixNotation e)+            choicePre =+              Agda.Utils.List.asum .+              map \ sect -> do+                let n = sectNotation sect+                if   isinfix n || ispostfix n+                then flip ($) <$> placeholder Beginning+                              <*> opP parseSections p0 n In+                else opP parseSections p0 n Pre++            choicePost :: [NotationSection] -> Parser e (OperatorType 'PostfixNotation e)+            choicePost =+              Agda.Utils.List.asum .+              map \ sect -> do+                let n = sectNotation sect+                if isinfix n || isprefix n+                then flip <$> opP parseSections p0 n In+                          <*> placeholder End+                else opP parseSections p0 n Post+             nonAssoc :: Maybe (Parser e e)             nonAssoc = case filter (isInfix NonAssoc) ops of               []  -> Nothing               ops -> Just $                 (\x f y -> f (noPlaceholder x) (noPlaceholder y))                   <$> higher-                  <*> choice In ops+                  <*> choiceIn ops                   <*> higher              or p1 []   p2 []   = Nothing@@ -490,10 +479,10 @@              preRight :: Maybe (Parser e (MaybePlaceholder e -> e))             preRight =-              or (choice Pre)+              or choicePre                  (filter isPrefix ops)                  (\ops -> flip ($) <$> (noPlaceholder <$> higher)-                                   <*> choice In ops)+                                   <*> choiceIn ops)                  (filter (isInfix RightAssoc) ops)              preRights :: Maybe (Parser e e)@@ -505,9 +494,9 @@              postLeft :: Maybe (Parser e (MaybePlaceholder e -> e))             postLeft =-              or (choice Post)+              or choicePost                  (filter isPostfix ops)-                 (\ops -> flip <$> choice In ops+                 (\ops -> flip <$> choiceIn ops                                <*> (noPlaceholder <$> higher))                  (filter (isInfix LeftAssoc) ops) @@ -524,31 +513,39 @@ -- * Parse functions --------------------------------------------------------------------------- --- | Returns the list of possible parses.+-- | Parses all 'RawAppP' in the given pattern using the given parser.+--   Returns the list of possible parses.+--+--   Naturally, does not recurse into 'DotP' as this contains no pattern.+--+--   Returns the empty list if the given parser does so+--   or if a 'HiddenP' or 'InstanceP' is encountered. parsePat   :: ([Pattern] -> [Pattern]) -- ^ Turns a 'RawAppP' into possible parses.   -> Pattern                  -- ^ Pattern possibly containing 'RawAppP's.   -> [Pattern]                -- ^ Possible parses, not containing 'RawAppP's.-parsePat prs = \case+parsePat parse = loop+  where+  loop = \case     AppP p (Arg info q) ->-        fullParen' <$> (AppP <$> parsePat prs p <*> (Arg info <$> traverse (parsePat prs) q))-    RawAppP _ ps     -> fullParen' <$> (parsePat prs =<< prs (List2.toList ps))-    OpAppP r d ns ps -> fullParen' . OpAppP r d ns <$> (mapM . traverse . traverse) (parsePat prs) ps+        fullParen' <$> (AppP <$> loop p <*> (Arg info <$> traverse loop q))+    RawAppP _ ps     -> fullParen' <$> (loop =<< parse (List2.toList ps))+    OpAppP r d ns ps -> fullParen' . OpAppP r d ns <$> (mapM . traverse . traverse) loop ps     HiddenP _ _      -> fail "bad hidden argument"     InstanceP _ _    -> fail "bad instance argument"-    AsP r x p        -> AsP r x <$> parsePat prs p+    AsP r x p        -> AsP r x <$> loop p     p@DotP{}         -> return p-    ParenP r p       -> fullParen' <$> parsePat prs p+    ParenP r p       -> fullParen' <$> loop p     p@WildP{}        -> return p     p@AbsurdP{}      -> return p     p@LitP{}         -> return p     p@QuoteP{}       -> return p     p@IdentP{}       -> return p-    RecP r fs        -> RecP r <$> mapM (traverse (parsePat prs)) fs+    RecP kwr r fs    -> RecP kwr r <$> mapM (traverse loop) fs     p@EqualP{}       -> return p -- Andrea: cargo culted from DotP     EllipsisP r mp   -> caseMaybe mp (fail "bad ellipsis") $ \p ->-                          EllipsisP r . Just <$> parsePat prs p-    WithP r p        -> WithP r <$> parsePat prs p+                          EllipsisP r . Just <$> loop p+    WithP r p        -> WithP r <$> loop p   {- Implement parsing of copattern left hand sides, e.g.@@ -599,8 +596,13 @@  -- | Parses a left-hand side, workhorse for 'parseLHS'. ---parseLHS'-  :: LHSOrPatSyn+parseLHS' ::+     DisplayLHS+       -- ^ Are we parsing a 'DisplayPragma'?+       --   Then defined names are recognized as constructors.+       --+       --   In this case, 'LHSOrPatSyn' is 'IsLHS' and 'Maybe QName' is 'Just'.+  -> LHSOrPatSyn        -- ^ Are we trying to parse a lhs or a pattern synonym?        --   For error reporting only!   -> Maybe QName@@ -609,23 +611,23 @@   -> Pattern        -- ^ Thing to parse.   -> ScopeM (ParseLHS, [NotationSection])-       -- ^ The returned list contains all operators/notations/sections that-       -- were used to generate the grammar.+       -- ^ The returned list contains all operators\/notations\/sections that+       --   were used to generate the grammar. -parseLHS' IsLHS (Just qn) WildP{} =+parseLHS' NoDisplayLHS IsLHS (Just qn) WildP{} =     return (ParseLHS qn $ LHSHead qn [], []) -parseLHS' lhsOrPatSyn top p = do+parseLHS' displayLhs lhsOrPatSyn top p = do      -- Build parser.-    patP <- buildParsers IsPattern (patternQNames p)+    patP <- buildParsers IsPattern top (patternQNames p)      -- Run parser, forcing result.     let ps   = let result = parsePat (parser patP) p                in  foldr seq () result `seq` result      -- Classify parse results.-    let cons = getNames (someKindsOfNames [ConName, CoConName, PatternSynName])+    let cons = getNames (someKindsOfNames $ applyWhen displayLhs (defNameKinds ++) conLikeNameKinds)                         (flattenedScope patP)     let flds = getNames (someKindsOfNames [FldName])                         (flattenedScope patP)@@ -636,18 +638,18 @@       [ "Possible parses for lhs:" ] ++ map (nest 2 . pretty . snd) results     case results of         -- Unique result.-        [(_,lhs)] -> do reportS "scope.operators" 50 $ "Parsed lhs:" <+> pretty lhs-                        return (lhs, operators patP)+        [(_,lhs)] -> (lhs, operators patP) <$ do+                       reportS "scope.operators" 50 $ "Parsed lhs:" <+> pretty lhs         -- No result.-        []        -> typeError $ OperatorInformation (operators patP)-                               $ NoParseForLHS lhsOrPatSyn (catMaybes errs) p+        []        -> typeError $ OperatorInformation (operators patP) $+                       NoParseForLHS lhsOrPatSyn (catMaybes errs) p         -- Ambiguous result.-        rs        -> typeError $ OperatorInformation (operators patP)-                               $ AmbiguousParseForLHS lhsOrPatSyn p $-                       map (fullParen . fst) rs+        r0:r1:rs  -> typeError $ OperatorInformation (operators patP) $+                       AmbiguousParseForLHS lhsOrPatSyn p $+                         fmap (fullParen . fst) $ List2 r0 r1 rs     where         getNames kinds flat =-          map (notaName . head) $ getDefinedNames kinds flat+          map (notaName . List1.head) $ getDefinedNames kinds flat          -- The pattern is retained for error reporting in case of ambiguous parses.         validPattern :: PatternCheckConfig -> Pattern -> PM (Pattern, ParseLHS)@@ -677,12 +679,12 @@   case patternAppView p of      -- case @f ps@-    Arg _ (Named _ (IdentP x)) :| ps | Just x == topName conf -> do+    Arg _ (Named _ (IdentP _ x)) :| ps | Just x == topName conf -> do       mapM_ (valid . namedArg) ps       return $ ParseLHS x $ lhsCoreAddSpine (LHSHead x []) ps      -- case @d ps@-    Arg _ (Named _ (IdentP x)) :| ps | fldName conf x -> do+    Arg _ (Named _ (IdentP _ x)) :| ps | fldName conf x -> do        -- Step 1: check for valid copattern lhs.       ps0 :: [NamedArg ParseLHS] <- mapM classPat ps@@ -728,9 +730,16 @@   -- | Parses a left-hand side, and makes sure that it defined the expected name.-parseLHS :: QName -> Pattern -> ScopeM LHSCore-parseLHS top p = billToParser IsPattern $ do-  (res, ops) <- parseLHS' IsLHS (Just top) p+parseLHS ::+     DisplayLHS+       -- ^ Are we parsing a 'DisplayPragma'?+  -> QName+       -- ^ Name of the definition.+  -> Pattern+       -- ^ Full left hand side.+  -> ScopeM LHSCore+parseLHS displayLhs top p = billToParser IsPattern $ do+  (res, ops) <- parseLHS' displayLhs IsLHS (Just top) p   case res of     ParseLHS f lhs -> return lhs     _ -> typeError $ OperatorInformation ops@@ -745,7 +754,7 @@  parsePatternOrSyn :: LHSOrPatSyn -> Pattern -> ScopeM Pattern parsePatternOrSyn lhsOrPatSyn p = billToParser IsPattern $ do-  (res, ops) <- parseLHS' lhsOrPatSyn Nothing p+  (res, ops) <- parseLHS' NoDisplayLHS lhsOrPatSyn Nothing p   case res of     ParsePattern p -> return p     _ -> typeError $ OperatorInformation ops@@ -762,14 +771,34 @@ validConPattern cons = loop   where   loop p = case appView p of-      WithP _ p :| [] -> loop p-      _ :| []         -> ok-      IdentP x :| ps-        | cons x      -> mapM_ loop ps-        | otherwise   -> failure-      QuoteP _ :| [_] -> ok-      DotP _ e :| ps  -> mapM_ loop ps-      _               -> failure++      -- Eliminated by appView:+      AppP{}      :| _   -> __IMPOSSIBLE__+      OpAppP{}    :| _   -> __IMPOSSIBLE__+      ParenP{}    :| _   -> __IMPOSSIBLE__+      RawAppP{}   :| _   -> __IMPOSSIBLE__+      HiddenP{}   :| _   -> __IMPOSSIBLE__+      InstanceP{} :| _   -> __IMPOSSIBLE__++      -- Hopeful cases:+      WithP _ p   :| []  -> loop p+      _           :| []  -> ok+      IdentP _ x  :| ps+        | cons x         -> mapM_ loop ps+        | otherwise      -> failure+      QuoteP _    :| [_] -> ok+      DotP _ _ _  :| ps  -> mapM_ loop ps++      -- Failures:+      AbsurdP{}   :| _:_ -> failure+      AsP{}       :| _:_ -> failure+      EllipsisP{} :| _:_ -> failure+      EqualP{}    :| _:_ -> failure+      LitP{}      :| _:_ -> failure+      QuoteP{}    :| _:_ -> failure+      RecP{}      :| _:_ -> failure+      WildP{}     :| _:_ -> failure+      WithP{}     :| _:_ -> failure     where     ok      = return ()     failure = throwError $ Just p@@ -781,7 +810,7 @@   where   loop acc = \case     AppP p a         -> loop (namedArg a : acc) p-    OpAppP _ op _ ps -> (IdentP op :| fmap namedArg ps)+    OpAppP _ op _ ps -> (IdentP True op <| fmap namedArg ps)                           `List1.appendList`                         reverse acc     ParenP _ p       -> loop acc p@@ -814,7 +843,7 @@ parseApplication es  = billToParser IsExpr $ do     let es0 = List2.toList es     -- Build the parser-    p <- buildParsers IsExpr [ q | Ident q <- es0 ]+    p <- buildParsers IsExpr Nothing [ q | Ident q <- es0 ]      -- Parse     let result = parser p es0@@ -829,40 +858,33 @@                          $ AmbiguousParseForApplication es                          $ fmap fullParen (e :| es') -parseModuleIdentifier :: Expr -> ScopeM QName-parseModuleIdentifier (Ident m) = return m-parseModuleIdentifier e = typeError $ NotAModuleExpr e+-- | Parse the arguments of a raw application with known head.+--+parseArguments ::+     Expr                   -- ^ Head+  -> [Expr]                 -- ^ Raw arguments+  -> ScopeM [NamedArg Expr] -- ^ Operator-parsed arguments+parseArguments hd = \case+  [] -> return []+  es@(e1 : rest) -> billToParser IsExpr $ do -parseRawModuleApplication :: List2 Expr -> ScopeM (QName, [NamedArg Expr])-parseRawModuleApplication es@(List2 e e2 rest) = billToParser IsExpr $ do-    let es_args = e2:rest-    m <- parseModuleIdentifier e+    -- Form the raw application for error reporting+    let es2 = List2 hd e1 rest      -- Build the arguments parser-    p <- buildParsers IsExpr [ q | Ident q <- es_args ]+    p <- buildParsers IsExpr Nothing [ q | Ident q <- es ]      -- Parse     -- TODO: not sure about forcing-    case {-force $-} argsParser p es_args of-        [as] -> return (m, as)+    case {-force $-} argsParser p es of+        [as] -> return as         []   -> typeError $ OperatorInformation (operators p)-                          $ NoParseForApplication es+                          $ NoParseForApplication es2         as : ass -> do-          let f = fullParen . foldl (App noRange) (Ident m)+          let f = fullParen . foldl (App noRange) hd           typeError $ OperatorInformation (operators p)-                    $ AmbiguousParseForApplication es+                    $ AmbiguousParseForApplication es2                     $ fmap f (as :| ass)---- | Parse an expression into a module application---   (an identifier plus a list of arguments).-parseModuleApplication :: Expr -> ScopeM (QName, [NamedArg Expr])-parseModuleApplication (RawApp _ es) = parseRawModuleApplication es-parseModuleApplication (App r e1 e2) = do -- TODO: do we need this case?-    (m, args) <- parseModuleApplication e1-    return (m, args ++ [e2])-parseModuleApplication e = do-    m <- parseModuleIdentifier e-    return (m, [])  --------------------------------------------------------------------------- -- * Inserting parenthesis
src/full/Agda/Syntax/Concrete/Operators/Parser.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE GADTs        #-}+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE DataKinds    #-}  module Agda.Syntax.Concrete.Operators.Parser where@@ -7,10 +8,11 @@ import Control.Monad ((<=<))  import Data.Either+import Data.Function (on) import Data.Kind ( Type )+import qualified Data.List as List import Data.Maybe import qualified Data.Strict.Maybe as Strict-import Data.Set (Set)  import Agda.Syntax.Position import qualified Agda.Syntax.Abstract.Name as A@@ -20,10 +22,11 @@ import Agda.Syntax.Concrete.Operators.Parser.Monad hiding (parse) import qualified Agda.Syntax.Concrete.Operators.Parser.Monad as P -import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.List  ( spanEnd ) import Agda.Utils.List1 ( List1, pattern (:|), (<|) ) import qualified Agda.Utils.List1 as List1+import Agda.Utils.Set1  ( Set1 ) import Agda.Utils.Singleton  import Agda.Utils.Impossible@@ -53,7 +56,7 @@     | WildV e     | OtherV e     | AppV e (NamedArg e)-    | OpAppV QName (Set A.Name) (OpAppArgs' e)+    | OpAppV QName (Set1 A.Name) (OpAppArgs' e)       -- ^ The 'QName' is possibly ambiguous, but it must correspond       -- to one of the names in the set.     | HiddenArgV (Named_ e)@@ -96,7 +99,8 @@  instance IsExpr Pattern where     exprView = \case-        IdentP x         -> LocalV x+        IdentP True x    -> LocalV x+        IdentP False _   -> __IMPOSSIBLE__         AppP e1 e2       -> AppV e1 e2         OpAppP r d ns es -> OpAppV d ns $ (fmap . fmap . fmap) (noPlaceholder . Ordinary) es         HiddenP _ e      -> HiddenArgV e@@ -105,9 +109,9 @@         e@WildP{}        -> WildV e         e                -> OtherV e     unExprView = \case-        LocalV x       -> IdentP x+        LocalV x       -> IdentP True x         AppV e1 e2     -> AppP e1 e2-        OpAppV d ns es -> let ess :: [NamedArg Pattern]+        OpAppV d ns es -> let ess :: List1 (NamedArg Pattern)                               ess = (fmap . fmap . fmap)                                       (\case                                           Placeholder{}     -> __IMPOSSIBLE__@@ -263,9 +267,11 @@           -- away here.           unExprView (LocalV q')         else-          unExprView (OpAppV q' names args)+          List1.ifNull args+            {-then-} (unExprView $ LocalV q')+            {-else-} $ unExprView . OpAppV q' names         where-        args = map (findExprFor (f normal) binders) [0..lastHole]+        args = fmap (findExprFor (f normal) binders) [0..lastHole]         q'   = setRange range q   in @@ -277,39 +283,39 @@    where -  (leadingHoles, syn1)                  = span    isNormalHole syn-  (withoutExternalHoles, trailingHoles) = spanEnd isNormalHole syn1+  (leadingHoles, syn1)                  = span    isAHole syn+  (withoutExternalHoles, trailingHoles) = spanEnd isAHole syn1    leadingHole = case leadingHoles of-    [NormalHole _ h] -> h-    _                -> __IMPOSSIBLE__+    [HolePart _ h] -> h+    _              -> __IMPOSSIBLE__    trailingHole = case trailingHoles of-    [NormalHole _ h] -> h-    _                -> __IMPOSSIBLE__+    [HolePart _ h] -> h+    _              -> __IMPOSSIBLE__    worker ::     [Name] -> Notation ->     Parser e (Range, [Either (MaybePlaceholder e, NamedArg (Ranged Int))-                             (LamBinding, Ranged Int)])+                             (LamBinding, Ranged BoundVariablePosition)])   worker ms []              = pure (noRange, [])   worker ms (IdPart x : xs) =     (\r1 (r2, es) -> (fuseRanges r1 r2, es))       <$> partP ms (rangedThing x)       <*> worker [] xs           -- Only the first part is qualified.-  worker ms (NormalHole _ h : xs) =+  worker ms (HolePart _ h : xs) =     (\e (r, es) -> (r, Left (e, h) : es))       <$> maybePlaceholder             (if isOp && parseSections == ParseSections              then Just Middle else Nothing)             p       <*> worker ms xs-  worker ms (WildHole h : xs) =+  worker ms (WildPart h : xs) =     (\(r, es) -> let anon = mkBinder_ simpleHole                  in (r, Right (mkBinding h anon) : es))       <$> worker ms xs-  worker ms (BindHole _ h : xs) = do+  worker ms (VarPart _ h : xs) = do     (\ b (r, es) -> (r, Right (mkBinding h b) : es))            -- Andreas, 2011-04-07 put just 'Relevant' here, is this            -- correct?@@ -322,18 +328,24 @@    findExprFor ::     [(MaybePlaceholder e, NamedArg (Ranged Int))] ->-    [(LamBinding, Ranged Int)] -> Int ->+    [(LamBinding, Ranged BoundVariablePosition)] -> Int ->     NamedArg (MaybePlaceholder (OpApp e))   findExprFor normalHoles binders n =     case [ h | h@(_, m) <- normalHoles, rangedThing (namedArg m) == n ] of       [(Placeholder p,     arg)] -> set (Placeholder p) arg       [(NoPlaceholder _ e, arg)] ->-        List1.ifNull [ b | (b, m) <- binders, rangedThing m == n ]+        List1.ifNull+          (map snd $+           List.sortBy (compare `on` fst)+             [ (varNumber (rangedThing m), b)+             | (b, m) <- binders+             , holeNumber (rangedThing m) == n+             ])         {-then-} (set (noPlaceholder (Ordinary e)) arg) -- no variable to bind         {-else-} $ \ bs -> set (noPlaceholder (SyntaxBindingLambda (fuseRange bs e) bs e)) arg       _ -> __IMPOSSIBLE__ -  noPlaceholders :: OpAppArgs' e -> Int+  noPlaceholders :: OpAppArgs0 e -> Int   noPlaceholders = sum . fmap (isPlaceholder . namedArg)     where     isPlaceholder NoPlaceholder{} = 0
src/full/Agda/Syntax/Concrete/Operators/Parser/Monad.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ ------------------------------------------------------------------------ -- | The parser monad used by the operator parser ------------------------------------------------------------------------@@ -18,9 +20,10 @@  import Data.Hashable import GHC.Generics (Generic)-import Text.PrettyPrint.HughesPJ  import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty+ import qualified Agda.Utils.Parser.MemoisedCPS as Parser  -- | Memoisation keys.@@ -40,7 +43,7 @@ -- | The parser monad.  type Parser tok a =-#ifdef DEBUG+#ifdef DEBUG_PARSING   Parser.ParserWithGrammar #else   Parser.Parser
src/full/Agda/Syntax/Concrete/Pattern.hs view
@@ -17,7 +17,7 @@ import Agda.Utils.Functor import Agda.Utils.Impossible import Agda.Utils.List-import Agda.Utils.List1  ( List1, pattern (:|) )+import Agda.Utils.List1  ( List1, pattern (:|), (<|) ) import Agda.Utils.List2  ( List2 ) import Agda.Utils.Maybe import Agda.Utils.Singleton@@ -77,9 +77,9 @@ -- -- (This view discards 'PatInfo'.) data LHSPatternView-  = LHSAppP  [NamedArg Pattern]+  = LHSAppP  (List1 (NamedArg Pattern))       -- ^ Application patterns (non-empty list).-  | LHSWithP [Pattern]+  | LHSWithP (List1 Pattern)       -- ^ With patterns (non-empty list).       --   These patterns are not prefixed with 'WithP'. @@ -91,21 +91,22 @@ lhsPatternView [] = Nothing lhsPatternView (p0 : ps) =   case namedArg p0 of-    WithP _i p   -> Just (LHSWithP (p : map namedArg ps1), ps2)+    WithP _i p   -> Just (LHSWithP (p :| map namedArg ps1), ps2)       where       (ps1, ps2) = spanJust isWithP ps     -- If the next pattern is an application pattern, collect more of these-    _ -> Just (LHSAppP (p0 : ps1), ps2)+    _ -> Just (LHSAppP (p0 :| ps1), ps2)       where       (ps1, ps2) = span (isNothing . isWithP) ps  -- | Add applicative patterns (non-projection / non-with patterns) to the right.-lhsCoreApp :: LHSCore -> [NamedArg Pattern] -> LHSCore-lhsCoreApp core ps = core { lhsPats = lhsPats core ++ ps }+lhsCoreApp :: LHSCore -> List1 (NamedArg Pattern) -> LHSCore+lhsCoreApp (LHSEllipsis r core) ps = LHSEllipsis r $ lhsCoreApp core ps+lhsCoreApp core ps = core { lhsPats = lhsPats core ++ List1.toList ps }  -- | Add with-patterns to the right.-lhsCoreWith :: LHSCore -> [Pattern] -> LHSCore-lhsCoreWith (LHSWith core wps []) wps' = LHSWith core (wps ++ wps') []+lhsCoreWith :: LHSCore -> List1 Pattern -> LHSCore+lhsCoreWith (LHSWith core wps []) wps' = LHSWith core (wps <> wps') [] lhsCoreWith core                  wps' = LHSWith core wps' []  -- | Append patterns to 'LHSCore', separating with patterns from the rest.@@ -168,8 +169,8 @@   traverseCPatternA = traverse . traverseCPatternA    -- | Traverse pattern.-  traverseCPatternM-    :: Monad m => (Pattern -> m Pattern)  -- ^ @pre@: Modification before recursion.+  traverseCPatternM :: Monad m+    => (Pattern -> m Pattern)  -- ^ @pre@: Modification before recursion.     -> (Pattern -> m Pattern)  -- ^ @post@: Modification after recursion.     -> p -> m p @@ -192,12 +193,12 @@       ParenP _ p      -> foldrCPattern f p       AsP _ _ p       -> foldrCPattern f p       WithP _ p       -> foldrCPattern f p-      RecP _ ps       -> foldrCPattern f ps+      RecP _ _ ps     -> foldrCPattern f ps       EllipsisP _ mp  -> foldrCPattern f mp       -- Nonrecursive cases:-      IdentP _        -> mempty+      IdentP _ _      -> mempty       WildP _         -> mempty-      DotP _ _        -> mempty+      DotP _ _ _      -> mempty       AbsurdP _       -> mempty       LitP _ _        -> mempty       QuoteP _        -> mempty@@ -213,12 +214,12 @@       ParenP    r p       -> ParenP r      <$> traverseCPatternA f p       AsP       r x p     -> AsP r x       <$> traverseCPatternA f p       WithP     r p       -> WithP r       <$> traverseCPatternA f p-      RecP      r ps      -> RecP r        <$> traverseCPatternA f ps+      RecP  kwr r ps      -> RecP kwr r    <$> traverseCPatternA f ps       EllipsisP r mp      -> EllipsisP r   <$> traverseCPatternA f mp       -- Nonrecursive cases:-      IdentP _        -> pure p0+      IdentP _ _      -> pure p0       WildP _         -> pure p0-      DotP _ _        -> pure p0+      DotP _ _ _      -> pure p0       AbsurdP _       -> pure p0       LitP _ _        -> pure p0       QuoteP _        -> pure p0@@ -236,12 +237,12 @@       ParenP    r p       -> ParenP r      <$> traverseCPatternM pre post p       AsP       r x p     -> AsP r x       <$> traverseCPatternM pre post p       WithP     r p       -> WithP r       <$> traverseCPatternM pre post p-      RecP      r ps      -> RecP r        <$> traverseCPatternM pre post ps+      RecP  kwr r ps      -> RecP kwr r    <$> traverseCPatternM pre post ps       EllipsisP r mp      -> EllipsisP r   <$> traverseCPatternM pre post mp       -- Nonrecursive cases:-      IdentP _        -> return p0+      IdentP _ _      -> return p0       WildP _         -> return p0-      DotP _ _        -> return p0+      DotP _ _ _      -> return p0       AbsurdP _       -> return p0       LitP _ _        -> return p0       QuoteP _        -> return p0@@ -306,7 +307,7 @@   where   f :: Pattern -> Endo [QName]   f = \case-    IdentP x       -> Endo (x :)+    IdentP _ x     -> Endo (x :)     OpAppP _ x _ _ -> Endo (x :)     AsP _ x _      -> mempty  -- x must be a bound name, can't be a constructor!     AppP _ _       -> mempty@@ -316,11 +317,11 @@     ParenP _ _     -> mempty     WildP _        -> mempty     AbsurdP _      -> mempty-    DotP _ _       -> mempty+    DotP _ _ _     -> mempty     LitP _ _       -> mempty     QuoteP _       -> mempty     InstanceP _ _  -> mempty-    RecP _ _       -> mempty+    RecP _ _ _     -> mempty     EqualP _ _     -> mempty     EllipsisP _ _  -> mempty @@ -380,7 +381,7 @@ patternAppView :: Pattern -> List1 (NamedArg Pattern) patternAppView = \case     AppP p arg      -> patternAppView p `List1.appendList` [arg]-    OpAppP _ x _ ps -> defaultNamedArg (IdentP x) :| ps+    OpAppP _ x _ ps -> defaultNamedArg (IdentP True x) <| ps     ParenP _ p      -> patternAppView p     RawAppP _ _     -> __IMPOSSIBLE__     p               -> singleton $ defaultNamedArg p
src/full/Agda/Syntax/Concrete/Pretty.hs view
@@ -1,6 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} - {-| Pretty printer for the concrete syntax. -} module Agda.Syntax.Concrete.Pretty@@ -18,18 +17,19 @@  import Agda.Syntax.Common import Agda.Syntax.Concrete-import Agda.Syntax.Position import Agda.Syntax.Concrete.Glyph  import Agda.Utils.Float (toStringWithoutDotZero) import Agda.Utils.Function import Agda.Utils.Functor-import Agda.Utils.List1 ( List1, pattern (:|) )+import Agda.Utils.List1 ( List1, pattern (:|), (<|) ) import qualified Agda.Utils.List1 as List1 import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe import Agda.Utils.Null-import Agda.Utils.Pretty+import qualified Agda.Syntax.Common.Aspect as Asp+import Agda.Syntax.Common.Pretty+import Agda.Interaction.Options ( HasOptions(pragmaOptions), optPolarity )  import Agda.Utils.Impossible @@ -42,9 +42,6 @@ deriving instance Show LamBinding deriving instance Show BoundName deriving instance Show ModuleAssignment-deriving instance (Show a, Show b) => Show (ImportDirective' a b)-deriving instance (Show a, Show b) => Show (Using' a b)-deriving instance (Show a, Show b) => Show (Renaming' a b) deriving instance Show Pragma deriving instance Show RHS deriving instance Show LHS@@ -69,87 +66,53 @@   []       -> "{}"   (d : ds) -> sep (["{" <+> d] ++ map (";" <+>) ds ++ ["}"]) --- | @prettyHiding info visible doc@ puts the correct braces---   around @doc@ according to info @info@ and returns---   @visible doc@ if the we deal with a visible thing.-prettyHiding :: LensHiding a => a -> (Doc -> Doc) -> Doc -> Doc-prettyHiding a parens =-  case getHiding a of-    Hidden     -> braces'-    Instance{} -> dbraces-    NotHidden  -> parens--prettyRelevance :: LensRelevance a => a -> Doc -> Doc-prettyRelevance a d =-  if render d == "_" then d else pretty (getRelevance a) <> d--prettyQuantity :: LensQuantity a => a -> Doc -> Doc-prettyQuantity a d =-  if render d == "_" then d else pretty (getQuantity a) <+> d--prettyErased :: Erased -> Doc -> Doc-prettyErased = prettyQuantity . asQuantity--prettyCohesion :: LensCohesion a => a -> Doc -> Doc-prettyCohesion a d =-  if render d == "_" then d else pretty (getCohesion a) <+> d- prettyTactic :: BoundName -> Doc -> Doc prettyTactic = prettyTactic' . bnameTactic +prettyFiniteness :: BoundName -> Doc -> Doc+prettyFiniteness name+  | bnameIsFinite name = ("@finite" <+>)+  | otherwise = id+ prettyTactic' :: TacticAttribute -> Doc -> Doc-prettyTactic' Nothing  d = d-prettyTactic' (Just t) d = "@" <> (parens ("tactic" <+> pretty t) <+> d)+prettyTactic' t = (pretty t <+>) -instance (Pretty a, Pretty b) => Pretty (a, b) where-    pretty (a, b) = parens $ (pretty a <> comma) <+> pretty b+instance Pretty a => Pretty (TacticAttribute' a) where+  pretty (TacticAttribute t) =+    ifNull (pretty t) empty \ d -> "@" <> parens ("tactic" <+> d)  instance Pretty (ThingWithFixity Name) where     pretty (ThingWithFixity n _) = pretty n -instance Pretty a => Pretty (WithHiding a) where-  pretty w = prettyHiding w id $ pretty $ dget w--instance Pretty Relevance where-  pretty Relevant   = empty-  pretty Irrelevant = "."-  pretty NonStrict  = ".."--instance Pretty Q0Origin where-  pretty = \case-    Q0Inferred -> empty-    Q0{}       -> "@0"-    Q0Erased{} -> "@erased"--instance Pretty Q1Origin where-  pretty = \case-    Q1Inferred -> empty-    Q1{}       -> "@1"-    Q1Linear{} -> "@linear"--instance Pretty QωOrigin where-  pretty = \case-    QωInferred -> empty-    Qω{}       -> "@ω"-    QωPlenty{} -> "@plenty"--instance Pretty Quantity where-  pretty = \case-    Quantity0 o -> ifNull (pretty o) "@0" id-    Quantity1 o -> ifNull (pretty o) "@1" id-    Quantityω o -> pretty o--instance Pretty Cohesion where-  pretty Flat   = "@♭"-  pretty Continuous = mempty-  pretty Squash  = "@⊤"--instance Pretty Modality where-  pretty mod = hsep-    [ pretty (getRelevance mod)-    , pretty (getQuantity mod)-    , pretty (getCohesion mod)-    ]+-- | Show the attributes necessary to recover a modality, in long-form+-- (e.g. using at-syntax rather than dots). For the default modality,+-- the result is at-ω (rather than the empty document). Suitable for+-- showing modalities outside of binders.+attributesForModality :: HasOptions m => Modality -> m Doc+attributesForModality mod@(Modality r q c p)+  | mod `elem` [defaultCheckModality, defaultModality] = do+      showPolarity <- optPolarity <$> pragmaOptions+      pure $ text "@ω" <+> if showPolarity then polarity else empty+  | otherwise = pure $ fsep $ catMaybes [relevance, quantity, cohesion, Just polarity]+  where+    relevance = case r of+      Relevant        {} -> Nothing+      Irrelevant      {} -> Just "@irrelevant"+      ShapeIrrelevant {} -> Just "@shape-irrelevant"+    quantity = case q of+      Quantity0{} -> Just "@0"+      Quantity1{} -> Just "@1"+      Quantityω{} -> Nothing+    cohesion = case c of+      Flat{}       -> Just "@♭"+      Continuous{} -> Nothing+      Squash{}     -> Just "@⊤"+    polarity = case modPolarityAnn p of+      MixedPolarity    -> "@mixed"+      Positive         -> "@+"+      Negative         -> "@-"+      StrictlyPositive -> "@++"+      UnusedPolarity   -> "@unused"  instance Pretty (OpApp Expr) where   pretty (Ordinary e) = pretty e@@ -160,13 +123,13 @@   pretty (NoPlaceholder _ e) = pretty e  instance Pretty Expr where-    pretty e =-        case e of+    pretty = \case             Ident x          -> pretty x+            KnownIdent nk x  -> annotateAspect (Asp.Name (Just nk) False) (pretty x)             Lit _ l          -> pretty l-            QuestionMark _ n -> "?" <> maybe empty (text . show) n+            QuestionMark _ n -> hlSymbol "?" <> maybe empty (text . show) n             Underscore _ n   -> maybe underscore text n-            App _ _ _        ->+            e@(App _ _ _)    ->                 case appView e of                     AppView e1 args     ->                         fsep $ pretty e1 : map pretty args@@ -174,10 +137,11 @@ --                          , nest 2 $ fsep $ map pretty args --                          ]             RawApp _ es    -> fsep $ map pretty $ List2.toList es-            OpApp _ q _ es -> fsep $ prettyOpApp q es+            OpApp _ q _ es         -> fsep $ prettyOpApp (Asp.Name Nothing True) q es+            KnownOpApp nk _ q _ es -> fsep $ prettyOpApp (Asp.Name (Just nk) True) q es              WithApp _ e es -> fsep $-              pretty e : map (("|" <+>) . pretty) es+              pretty e <| fmap ((hlSymbol "|" <+>) . pretty) es              HiddenArg _ e -> braces' $ pretty e             InstanceArg _ e -> dbraces $ pretty e@@ -191,7 +155,7 @@               lambda <+>               prettyErased e (bracesAndSemicolons (fmap pretty pes))             Fun _ e1 e2 ->-                sep [ prettyCohesion e1 (prettyQuantity e1 (pretty e1)) <+> arrow+                sep [ pretty (getModality e1) <+> pretty e1 <+> arrow                     , pretty e2                     ]             Pi tel e ->@@ -199,8 +163,8 @@                     , pretty e                     ]             Let _ ds me  ->-                sep [ "let" <+> vcat (fmap pretty ds)-                    , maybe empty (\ e -> "in" <+> pretty e) me+                sep [ hlKeyword "let" <+> vcat (fmap pretty ds)+                    , maybe empty (\ e -> hlKeyword "in" <+> pretty e) me                     ]             Paren _ e -> parens $ pretty e             IdiomBrackets _ es ->@@ -208,29 +172,28 @@                 []   -> emptyIdiomBrkt                 [e]  -> leftIdiomBrkt <+> pretty e <+> rightIdiomBrkt                 e:es -> leftIdiomBrkt <+> pretty e <+> fsep (map (("|" <+>) . pretty) es) <+> rightIdiomBrkt-            DoBlock _ ss -> "do" <+> vcat (fmap pretty ss)-            As _ x e  -> pretty x <> "@" <> pretty e-            Dot _ e   -> "." <> pretty e-            DoubleDot _ e  -> ".." <> pretty e-            Absurd _  -> "()"-            Rec _ xs  -> sep ["record", bracesAndSemicolons (map pretty xs)]-            RecUpdate _ e xs ->-              sep ["record" <+> pretty e, bracesAndSemicolons (map pretty xs)]-            ETel []  -> "()"-            ETel tel -> fsep $ map pretty tel-            Quote _ -> "quote"-            QuoteTerm _ -> "quoteTerm"-            Unquote _  -> "unquote"-            Tactic _ t -> "tactic" <+> pretty t+            DoBlock _ ss -> hlKeyword "do" <+> vcat (fmap pretty ss)+            As _ x e  -> pretty x <> hlSymbol "@" <> pretty e+            Dot _ e   -> hlSymbol "." <> pretty e+            DoubleDot _ e  -> hlSymbol ".." <> pretty e+            Absurd _  -> hlSymbol "()"+            Rec _ _ xs ->+              sep [hlKeyword "record", bracesAndSemicolons (map pretty xs)]+            RecUpdate _ _ e xs ->+              sep [hlKeyword "record" <+> pretty e, bracesAndSemicolons (map pretty xs)]+            Quote _ -> hlKeyword "quote"+            QuoteTerm _ -> hlKeyword "quoteTerm"+            Unquote _  -> hlKeyword "unquote"+            Tactic _ t -> hlKeyword "tactic" <+> pretty t             -- Andreas, 2011-10-03 print irrelevant things as .(e)-            DontCare e -> "." <> parens (pretty e)-            Equal _ a b -> pretty a <+> "=" <+> pretty b-            Ellipsis _  -> "..."+            DontCare e -> hlSymbol "." <> parens (pretty e)+            Equal _ a b -> pretty a <+> equals <+> pretty b+            Ellipsis _  -> hlSymbol "..."             Generalized e -> pretty e         where-          absurd NotHidden  = "()"-          absurd Instance{} = "{{}}"-          absurd Hidden     = "{}"+          absurd NotHidden  = parens mempty+          absurd Instance{} = dbraces mempty+          absurd Hidden     = braces mempty  instance (Pretty a, Pretty b) => Pretty (Either a b) where   pretty = either pretty pretty@@ -250,8 +213,10 @@       pretty' (RHS e)   = arrow <+> pretty e       pretty' AbsurdRHS = empty +-- Andreas, 2024-02-25+-- Q: Can we always ignore the tactic and the finiteness here? instance Pretty BoundName where-  pretty BName{ boundName = x } = pretty x+  pretty (BName x _fix _tac _fin) = pretty x  data NamedBinding = NamedBinding   { withHiding   :: Bool@@ -265,29 +230,36 @@   | otherwise              = Nothing  instance Pretty a => Pretty (Binder' a) where-  pretty (Binder mpat n) = let d = pretty n in case mpat of-    Nothing  -> d-    Just pat -> d <+> "@" <+> parens (pretty pat)+  pretty (Binder mpat UserBinderName n) =+    applyWhenJust mpat (\ pat -> (<+> ("@" <+> parens (pretty pat)))) $ pretty n -instance Pretty NamedBinding where-  pretty (NamedBinding withH x) = prH $-    if | Just l <- isLabeled x -> text l <+> "=" <+> pretty xb-       | otherwise             -> pretty xb+  pretty (Binder pat InsertedBinderName n) = case pat of+    Just pat -> parens (pretty pat)+    Nothing  -> pretty n +instance Pretty NamedBinding where+  pretty (NamedBinding withH+           x@(Arg (ArgInfo h (Modality r q c p) _o _fv (Annotation lock))+               (Named _mn xb@(Binder _mp _ (BName _y _fix t _fin))))) =+    applyWhen withH prH $+    applyWhenJust (isLabeled x) (\ l -> (text l <+>) . ("=" <+>)) (pretty xb)+      -- isLabeled looks at _mn and _y+      -- pretty xb prints also the pattern _mp     where--    xb = namedArg x-    bn = binderName xb-    prH | withH     = prettyRelevance x-                    . prettyHiding x mparens-                    . prettyCohesion x-                    . prettyQuantity x-                    . prettyTactic bn-        | otherwise = id-    -- Parentheses are needed when an attribute @... is present-    mparens-      | noUserQuantity x, Nothing <- bnameTactic bn = id-      | otherwise = parens+    prH = prettyRelevance r+        . prettyHiding h mparens+        . (coh <+>)+        . (qnt <+>)+        . (pol <+>)+        . (lck <+>)+        . (tac <+>)+    coh = pretty c+    qnt = pretty q+    pol = pretty p+    tac = pretty t+    lck = pretty lock+    -- Parentheses are needed when an attribute @... is printed+    mparens = applyUnless (null coh && null qnt && null lck && null tac && null pol) parens  instance Pretty LamBinding where     pretty (DomainFree x) = pretty (NamedBinding True x)@@ -300,8 +272,11 @@     pretty (TBind _ xs e) = fsep       [ prettyRelevance y         $ prettyHiding y parens+        $ prettyFiniteness (binderName $ namedArg y)         $ prettyCohesion y         $ prettyQuantity y+        $ prettyLock y+        $ prettyPolarity y         $ prettyTactic (binderName $ namedArg y) $         sep [ fsep (map (pretty . NamedBinding False) ys)             , ":" <+> pretty e ]@@ -338,14 +313,19 @@  instance Pretty WhereClause where   pretty  NoWhere = empty-  pretty (AnyWhere _ [Module _ x [] ds]) | isNoName (unqualify x)+  pretty (AnyWhere _ [Module _ NotErased{} x [] ds])+    | isNoName (unqualify x)                        = vcat [ "where", nest 2 (vcat $ map pretty ds) ]   pretty (AnyWhere _ ds) = vcat [ "where", nest 2 (vcat $ map pretty ds) ]-  pretty (SomeWhere _ m a ds) =-    vcat [ hsep $ applyWhen (a == PrivateAccess UserWritten) ("private" :)-             [ "module", pretty m, "where" ]+  pretty (SomeWhere _ erased m a ds) =+    vcat [ hsep $ privateWhenUserWritten a+             [ "module", prettyErased erased (pretty m), "where" ]          , nest 2 (vcat $ map pretty ds)          ]+    where+      privateWhenUserWritten = \case+        PrivateAccess _ UserWritten -> ("private" :)+        _ -> id  instance Pretty LHS where   pretty (LHS p eqs es) = sep@@ -369,12 +349,16 @@   pretty (LHSWith h wps ps) = if null ps then doc else       sep $ parens doc : map (parens . pretty) ps     where-    doc = sep $ pretty h : map (("|" <+>) . pretty) wps+    doc = sep $ pretty h <$ fmap (("|" <+>) . pretty) wps   pretty (LHSEllipsis r p) = "..."  instance Pretty ModuleApplication where-  pretty (SectionApp _ bs e) = fsep (map pretty bs) <+> "=" <+> pretty e-  pretty (RecordModuleInstance _ rec) = "=" <+> pretty rec <+> "{{...}}"+  pretty (SectionApp _ bs x es) = fsep $ concat+    [ map pretty bs+    , [ "=", pretty x ]+    , map pretty es+    ]+  pretty (RecordModuleInstance _ x) = "=" <+> pretty x <+> "{{...}}"  instance Pretty DoStmt where   pretty (DoBind _ p e cs) =@@ -386,134 +370,138 @@   pretty (DoLet _ ds) = "let" <+> vcat (fmap pretty ds)  instance Pretty Declaration where-    prettyList = vcat . map pretty-    pretty d =-        case d of-            TypeSig i tac x e ->-                sep [ prettyTactic' tac $ prettyRelevance i $ prettyCohesion i $ prettyQuantity i $ pretty x <+> ":"-                    , nest 2 $ pretty e-                    ]--            FieldSig inst tac x (Arg i e) ->-                mkInst inst $ mkOverlap i $-                prettyRelevance i $ prettyHiding i id $ prettyCohesion i $ prettyQuantity i $-                pretty $ TypeSig (setRelevance Relevant i) tac x e--                where--                  mkInst (InstanceDef _) d = sep [ "instance", nest 2 d ]-                  mkInst NotInstanceDef  d = d--                  mkOverlap i d | isOverlappable i = "overlap" <+> d-                                | otherwise        = d+  prettyList = vcat . map pretty+  pretty = \case+    TypeSig i tac x e ->+      sep [ prettyTactic' tac $ prettyRelevance i $ prettyCohesion i $ prettyQuantity i $ prettyPolarity i $ pretty x <+> ":"+          , nest 2 $ pretty e+          ]+    FieldSig inst tac x (Arg i e) ->+      mkInst inst $ mkOverlap i $+      -- We print relevance before hiding, need to clear it before printing the rest of the attributes with TypeSig.+      prettyRelevance i $ prettyHiding i id $+      pretty $ TypeSig (setRelevance relevant i) tac x e+      where+        mkInst (InstanceDef _) d = sep [ "instance", nest 2 d ]+        mkInst NotInstanceDef  d = d -            Field _ fs ->-              sep [ "field"-                  , nest 2 $ vcat (map pretty fs)+        mkOverlap i d | isYesOverlap i = "overlap" <+> d+                      | otherwise      = d+    Field _ fs ->+      sep [ "field"+          , nest 2 $ vcat (map pretty fs)+          ]+    FunClause lhs rhs wh _ ->+      sep [ pretty lhs+          , nest 2 $ pretty rhs+          ] $$ nest 2 (pretty wh)+    DataSig _ erased x tel e ->+      sep [ hsep  [ "data"+                  , prettyErased erased (pretty x)+                  , fsep (map pretty tel)                   ]-            FunClause lhs rhs wh _ ->-                sep [ pretty lhs-                    , nest 2 $ pretty rhs-                    ] $$ nest 2 (pretty wh)-            DataSig _ x tel e ->-                sep [ hsep  [ "data"-                            , pretty x-                            , fcat (map pretty tel)-                            ]-                    , nest 2 $ hsep-                            [ ":"-                            , pretty e-                            ]-                    ]-            Data _ x tel e cs ->-                sep [ hsep  [ "data"-                            , pretty x-                            , fcat (map pretty tel)-                            ]-                    , nest 2 $ hsep-                            [ ":"-                            , pretty e-                            , "where"-                            ]-                    ] $$ nest 2 (vcat $ map pretty cs)-            DataDef _ x tel cs ->-                sep [ hsep  [ "data"-                            , pretty x-                            , fcat (map pretty tel)-                            ]-                    , nest 2 $ "where"-                    ] $$ nest 2 (vcat $ map pretty cs)-            RecordSig _ x tel e ->-                sep [ hsep  [ "record"-                            , pretty x-                            , fcat (map pretty tel)-                            ]-                    , nest 2 $ hsep-                            [ ":"-                            , pretty e-                            ]-                    ]-            Record _ x dir tel e cs ->-              pRecord x dir tel (Just e) cs-            RecordDef _ x dir tel cs ->-              pRecord x dir tel Nothing cs-            RecordDirective r -> pRecordDirective r-            Infix f xs  ->-                pretty f <+> fsep (punctuate comma $ fmap pretty xs)-            Syntax n xs -> "syntax" <+> pretty n <+> "..."-            PatternSyn _ n as p -> "pattern" <+> pretty n <+> fsep (map pretty as)-                                     <+> "=" <+> pretty p-            Mutual _ ds     -> namedBlock "mutual" ds-            InterleavedMutual _ ds  -> namedBlock "interleaved mutual" ds-            LoneConstructor _ ds -> namedBlock "constructor" ds-            Abstract _ ds   -> namedBlock "abstract" ds-            Private _ _ ds  -> namedBlock "private" ds-            InstanceB _ ds  -> namedBlock "instance" ds-            Macro _ ds      -> namedBlock "macro" ds-            Postulate _ ds  -> namedBlock "postulate" ds-            Primitive _ ds  -> namedBlock "primitive" ds-            Generalize _ ds -> namedBlock "variable" ds-            Module _ x tel ds ->-                hsep [ "module"-                     , pretty x-                     , fcat (map pretty tel)-                     , "where"-                     ] $$ nest 2 (vcat $ map pretty ds)-            ModuleMacro _ x (SectionApp _ [] e) DoOpen i | isNoName x ->-                sep [ pretty DoOpen-                    , nest 2 $ pretty e-                    , nest 4 $ pretty i-                    ]-            ModuleMacro _ x (SectionApp _ tel e) open i ->-                sep [ pretty open <+> "module" <+> pretty x <+> fcat (map pretty tel)-                    , nest 2 $ "=" <+> pretty e <+> pretty i-                    ]-            ModuleMacro _ x (RecordModuleInstance _ rec) open i ->-                sep [ pretty open <+> "module" <+> pretty x-                    , nest 2 $ "=" <+> pretty rec <+> "{{...}}"-                    ]-            Open _ x i  -> hsep [ "open", pretty x, pretty i ]-            Import _ x rn open i   ->-                hsep [ pretty open, "import", pretty x, as rn, pretty i ]-                where-                    as Nothing  = empty-                    as (Just x) = "as" <+> pretty (asName x)-            UnquoteDecl _ xs t ->-              sep [ "unquoteDecl" <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ]-            UnquoteDef _ xs t ->-              sep [ "unquoteDef" <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ]-            Pragma pr   -> sep [ "{-#" <+> pretty pr, "#-}" ]-        where-            namedBlock s ds =-                sep [ text s-                    , nest 2 $ vcat $ map pretty ds-                    ]+          , nest 2 $ hsep+                  [ ":"+                  , pretty e+                  ]+          ]+    Data _ erased x tel e cs ->+      sep [ hsep  [ "data"+                  , prettyErased erased (pretty x)+                  , fsep (map pretty tel)+                  ]+          , nest 2 $ hsep+                  [ ":"+                  , pretty e+                  , "where"+                  ]+          ] $$ nest 2 (vcat $ map pretty cs)+    DataDef _ x tel cs ->+      sep [ hsep  [ "data"+                  , pretty x+                  , fsep (map pretty tel)+                  ]+          , nest 2 $ "where"+          ] $$ nest 2 (vcat $ map pretty cs)+    RecordSig _ erased x tel e ->+      sep [ hsep  [ "record"+                  , prettyErased erased (pretty x)+                  , fsep (map pretty tel)+                  ]+          , nest 2 $ hsep+                  [ ":"+                  , pretty e+                  ]+          ]+    Record _ erased x dir tel e cs ->+      pRecord erased x dir tel (Just e) cs+    RecordDef _ x dir tel cs ->+      pRecord defaultErased x dir tel Nothing cs+    Infix f xs  ->+      pretty f <+> fsep (punctuate comma $ fmap pretty xs)+    Syntax n xs -> "syntax" <+> pretty n <+> "..."+    PatternSyn _ n as p -> "pattern" <+> pretty n <+> fsep (map pretty as)+                             <+> "=" <+> pretty p+    Mutual _ ds     -> namedBlock "mutual" ds+    InterleavedMutual _ ds  -> namedBlock "interleaved mutual" ds+    LoneConstructor _ ds -> namedBlock "data _ where" ds+    Abstract _ ds   -> namedBlock "abstract" ds+    Private _ _ ds  -> namedBlock "private" ds+    InstanceB _ ds  -> namedBlock "instance" ds+    Macro _ ds      -> namedBlock "macro" ds+    Postulate _ ds  -> namedBlock "postulate" ds+    Primitive _ ds  -> namedBlock "primitive" ds+    Generalize _ ds -> namedBlock "variable" ds+    Opaque _ ds     -> namedBlock "opaque" ds+    Unfolding _ rs  -> "unfolding" <+> braces (fsep (punctuate semi (pretty <$> rs)))+    Module _ erased x tel ds ->+      hsep [ "module"+           , prettyErased erased (pretty x)+           , fsep (map pretty tel)+           , "where"+           ] $$ nest 2 (vcat $ map pretty ds)+    ModuleMacro _ NotErased{} x (SectionApp _ [] y es) DoOpen i+      | isNoName x ->+      sep [ pretty DoOpen+          , nest 2 $ fsep $ pretty y : map pretty es+          , nest 4 $ pretty i+          ]+    ModuleMacro _ erased x (SectionApp _ tel y es) open i ->+      sep [ pretty open <+> "module" <+>+            prettyErased erased (pretty x) <+> fsep (map pretty tel)+          , nest 2 $ fsep $ concat [ [ "=", pretty y ], map pretty es, [ pretty i ] ]+          ]+    ModuleMacro _ erased x (RecordModuleInstance _ rec) open i ->+      sep [ pretty open <+> "module" <+> prettyErased erased (pretty x)+          , nest 2 $ "=" <+> pretty rec <+> "{{...}}"+          ]+    Open _ x i  -> hsep [ "open", pretty x, pretty i ]+    Import _ x rn open i   ->+      hsep [ pretty open, "import", pretty x, as rn, pretty i ]+      where+        as Nothing  = empty+        as (Just x) = "as" <+> pretty (asName x)+    UnquoteDecl _ xs t ->+      sep [ "unquoteDecl" <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ]+    UnquoteDef _ xs t ->+      sep [ "unquoteDef" <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ]+    UnquoteData _ x xs t ->+      sep [ "unquoteData" <+> pretty x <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ]+    Pragma pr   -> sep [ "{-#" <+> pretty pr, "#-}" ]+    where+      namedBlock s ds =+          sep [ text s+              , nest 2 $ vcat $ map pretty ds+              ]  pHasEta0 :: HasEta0 -> Doc pHasEta0 = \case   YesEta   -> "eta-equality"   NoEta () -> "no-eta-equality" +instance Pretty RecordDirective where+  pretty = pRecordDirective+ pRecordDirective :: RecordDirective -> Doc pRecordDirective = \case   Induction ind -> pretty (rangedThing ind)@@ -525,25 +513,23 @@   PatternOrCopattern{} -> "pattern"  pRecord-  :: Name-  -> RecordDirectives+  :: Erased+  -> Name+  -> [RecordDirective]   -> [LamBinding]   -> Maybe Expr   -> [Declaration]   -> Doc-pRecord x (RecordDirectives ind eta pat con) tel me ds = vcat+pRecord erased x directives tel me ds = vcat     [ sep       [ hsep  [ "record"-              , pretty x-              , fcat (map pretty tel)+              , prettyErased erased (pretty x)+              , fsep (map pretty tel)               ]       , nest 2 $ pType me       ]     , nest 2 $ vcat $ concat-      [ pInd-      , pEta-      , pPat-      , pCon+      [ map pretty directives       , map pretty ds       ]     ]@@ -554,16 +540,6 @@                 ]         pType Nothing  =                   "where"-        pInd = maybeToList $ pretty . rangedThing <$> ind-        pEta = maybeToList $ eta <&> pHasEta0-        pPat = maybeToList $ "pattern" <$ pat-        -- pEta = caseMaybe eta [] $ \case-        --   YesEta -> [ "eta-equality" ]-        --   NoEta  -> "no-eta-equality" : pPat-        -- pPat = \case-        --   PatternMatching   -> [ "pattern" ]-        --   CopatternMatching -> []-        pCon = maybeToList $ (("constructor" <+>) . pretty) . fst <$> con  instance Pretty OpenShortHand where     pretty DoOpen = "open"@@ -575,15 +551,19 @@     pretty (RewritePragma _ _ xs)    =       hsep [ "REWRITE", hsep $ map pretty xs ]     pretty (CompilePragma _ b x e) =-      hsep [ "COMPILE", text (rangedThing b), pretty x, text e ]+      hsep [ "COMPILE", pretty (rangedThing b), pretty x, textNonEmpty e ]     pretty (ForeignPragma _ b s) =-      vcat $ text ("FOREIGN " ++ rangedThing b) : map text (lines s)+      vcat $ hsep [ "FOREIGN", pretty (rangedThing b) ] : map text (lines s)     pretty (StaticPragma _ i) =       hsep $ ["STATIC", pretty i]     pretty (InjectivePragma _ i) =       hsep $ ["INJECTIVE", pretty i]+    pretty (InjectiveForInferencePragma _ i) =+      hsep $ ["INJECTIVE_FOR_INFERENCE", pretty i]     pretty (InlinePragma _ True i) =       hsep $ ["INLINE", pretty i]+    pretty (NotProjectionLikePragma _ i) =+      hsep $ ["NOT_PROJECTION_LIKE", pretty i]     pretty (InlinePragma _ False i) =       hsep $ ["NOINLINE", pretty i]     pretty (ImpossiblePragma _ strs) =@@ -598,36 +578,21 @@         Terminating            -> "TERMINATING"         TerminationMeasure _ x -> hsep $ ["MEASURE", pretty x]     pretty (NoCoverageCheckPragma _) = "NON_COVERING"-    pretty (WarningOnUsage _ nm str) = hsep [ "WARNING_ON_USAGE", pretty nm, text (T.unpack str) ]-    pretty (WarningOnImport _ str)   = hsep [ "WARNING_ON_IMPORT", text (T.unpack str) ]+    pretty (WarningOnUsage _ nm str) = hsep [ "WARNING_ON_USAGE", pretty nm, text (show str) ]+    pretty (WarningOnImport _ str)   = hsep [ "WARNING_ON_IMPORT", text (show str) ]     pretty (CatchallPragma _) = "CATCHALL"     pretty (DisplayPragma _ lhs rhs) = "DISPLAY" <+> sep [ pretty lhs <+> "=", nest 2 $ pretty rhs ]     pretty (NoPositivityCheckPragma _) = "NO_POSITIVITY_CHECK"     pretty (PolarityPragma _ q occs) =       hsep ("POLARITY" : pretty q : map pretty occs)     pretty (NoUniverseCheckPragma _) = "NO_UNIVERSE_CHECK"--instance Pretty Associativity where-  pretty = \case-    LeftAssoc  -> "infixl"-    RightAssoc -> "infixr"-    NonAssoc   -> "infix"--instance Pretty FixityLevel where-  pretty = \case-    Unrelated  -> empty-    Related d  -> text $ toStringWithoutDotZero d--instance Pretty Fixity where-  pretty (Fixity _ level ass) = case level of-    Unrelated  -> empty-    Related{}  -> pretty ass <+> pretty level+    pretty (OverlapPragma _ x m) = hsep [pretty m, pretty x] -instance Pretty GenPart where-    pretty (IdPart x)   = text $ rangedThing x-    pretty BindHole{}   = underscore-    pretty NormalHole{} = underscore-    pretty WildHole{}   = underscore+instance Pretty NotationPart where+    pretty (IdPart x) = text $ rangedThing x+    pretty HolePart{} = underscore+    pretty VarPart{}  = underscore+    pretty WildPart{} = underscore      prettyList = hcat . map pretty @@ -636,44 +601,30 @@       | null nota = pretty fix       | otherwise = "syntax" <+> pretty nota - -- Andreas 2010-09-21: do not print relevance in general, only in function types!- -- Andreas 2010-09-24: and in record fields-instance Pretty a => Pretty (Arg a) where-  prettyPrec p (Arg ai e) = prettyHiding ai localParens $ prettyPrec p' e-      where p' | visible ai = p-               | otherwise  = 0-            localParens | getOrigin ai == Substitution = parens-                        | otherwise = id--instance Pretty e => Pretty (Named_ e) where-  prettyPrec p (Named nm e)-    | Just s <- bareNameOf nm = mparens (p > 0) $ sep [ text s <+> "=", pretty e ]-    | otherwise               = prettyPrec p e- instance Pretty Pattern where     prettyList = fsep . map pretty     pretty = \case-            IdentP x        -> pretty x+            IdentP _ x      -> pretty x             AppP p1 p2      -> sep [ pretty p1, nest 2 $ pretty p2 ]             RawAppP _ ps    -> fsep $ map pretty $ List2.toList ps-            OpAppP _ q _ ps -> fsep $ prettyOpApp q $ fmap (fmap (fmap (NoPlaceholder Strict.Nothing))) ps+            OpAppP _ q _ ps -> fsep $ prettyOpApp (Asp.Name Nothing True) q $ fmap (fmap (fmap (NoPlaceholder Strict.Nothing))) ps             HiddenP _ p     -> braces' $ pretty p             InstanceP _ p   -> dbraces $ pretty p             ParenP _ p      -> parens $ pretty p             WildP _         -> underscore             AsP _ x p       -> pretty x <> "@" <> pretty p-            DotP _ p        -> "." <> pretty p+            DotP _ _ p      -> "." <> pretty p             AbsurdP _       -> "()"             LitP _ l        -> pretty l             QuoteP _        -> "quote"-            RecP _ fs       -> sep [ "record", bracesAndSemicolons (map pretty fs) ]-            EqualP _ es     -> sep $ [ parens (sep [pretty e1, "=", pretty e2]) | (e1,e2) <- es ]+            RecP _ _ fs     -> sep [ "record", bracesAndSemicolons (map pretty fs) ]+            EqualP _ es     -> sep $ for es \ (e1, e2) -> parens $ sep [pretty e1, "=", pretty e2]             EllipsisP _ mp  -> "..."             WithP _ p       -> "|" <+> pretty p  prettyOpApp :: forall a .-  Pretty a => QName -> [NamedArg (MaybePlaceholder a)] -> [Doc]-prettyOpApp q es = merge [] $ prOp ms xs es+  Pretty a => Asp.Aspect -> QName -> List1 (NamedArg (MaybePlaceholder a)) -> [Doc]+prettyOpApp asp q es = merge [] $ prOp ms xs $ List1.toList es   where     -- ms: the module part of the name.     ms = List1.init (qnameParts q)@@ -689,7 +640,7 @@         NoPlaceholder{} -> (pretty e, Nothing) : prOp ms xs es           -- Module qualifier needs to go on section holes (#3072)     prOp _  (Hole : _)  []       = __IMPOSSIBLE__-    prOp ms (Id x : xs) es       = ( qual ms $ pretty $ simpleName x+    prOp ms (Id x : xs) es       = ( qual ms $ annotateAspect asp $ pretty $ simpleName x                                    , Nothing                                    ) : prOp [] xs es       -- Qualify the name part with the module.@@ -719,41 +670,3 @@     mergeLeft d before = case before of       []     -> (d,      [])       b : bs -> (b <> d, bs)--instance (Pretty a, Pretty b) => Pretty (ImportDirective' a b) where-    pretty i =-        sep [ public (publicOpen i)-            , pretty $ using i-            , prettyHiding $ hiding i-            , rename $ impRenaming i-            ]-        where-            public Just{}  = "public"-            public Nothing = empty--            prettyHiding [] = empty-            prettyHiding xs = "hiding" <+> parens (fsep $ punctuate ";" $ map pretty xs)--            rename [] = empty-            rename xs = hsep [ "renaming"-                             , parens $ fsep $ punctuate ";" $ map pretty xs-                             ]--instance (Pretty a, Pretty b) => Pretty (Using' a b) where-    pretty UseEverything = empty-    pretty (Using xs)    =-        "using" <+> parens (fsep $ punctuate ";" $ map pretty xs)--instance (Pretty a, Pretty b) => Pretty (Renaming' a b) where-    pretty (Renaming from to mfx _r) = hsep-      [ pretty from-      , "to"-      , maybe empty pretty mfx-      , case to of-          ImportedName a   -> pretty a-          ImportedModule b -> pretty b   -- don't print "module" here-      ]--instance (Pretty a, Pretty b) => Pretty (ImportedName' a b) where-    pretty (ImportedName   a) = pretty a-    pretty (ImportedModule b) = "module" <+> pretty b
src/full/Agda/Syntax/DoNotation.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-|     Desugaring for do-notation. Uses whatever `_>>=_` and `_>>_` happen to be     in scope.@@ -25,7 +27,7 @@  -} module Agda.Syntax.DoNotation (desugarDoNotation) where -import Data.Maybe+import Prelude hiding (null)  import Agda.Syntax.Common import Agda.Syntax.Position@@ -35,10 +37,11 @@ import Agda.Syntax.Scope.Monad import Agda.TypeChecking.Monad -import Agda.Utils.List   ( initMaybe ) import Agda.Utils.List1  ( List1, pattern (:|) ) import qualified Agda.Utils.List1 as List1-import Agda.Utils.Pretty ( prettyShow )+import Agda.Syntax.Common.Pretty ( prettyShow )++import Agda.Utils.Null import Agda.Utils.Singleton  import Agda.Utils.Impossible@@ -100,12 +103,12 @@   desugarDo0 :: [DoStmt] -> ScopeM Expr   desugarDo0 ss = List1.ifNull ss failure $ desugarDo qBind qThen -  failure = genericError+  failure = doNotationError     "The last statement in a 'do' block must be an expression or an absurd match."  singleName :: Pattern -> Maybe Name singleName = \case-  IdentP (QName x) -> Just x+  IdentP _ (QName x) -> Just x   _ -> Nothing  matchingBind :: QName -> Range -> Pattern -> Expr -> Expr -> [LamClause] -> Expr@@ -117,7 +120,7 @@   where     mainClause = LamClause { lamLHS      = [p]                            , lamRHS      = RHS body-                           , lamCatchAll = False }+                           , lamCatchall = empty }      -- Add parens to left-hand sides.     addParens c = c { lamLHS = addP (lamLHS c) }@@ -140,6 +143,9 @@ ensureInScope q = do   r <- resolveName q   case r of-    UnknownName -> genericError $+    UnknownName -> doNotationError $       prettyShow q ++ " needs to be in scope to desugar 'do' block"     _ -> return ()++doNotationError :: String -> ScopeM a+doNotationError = typeError . DoNotationError
src/full/Agda/Syntax/Fixity.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  {-| Definitions for fixity, precedence levels, and declared syntax. -}@@ -5,14 +6,12 @@  import Control.DeepSeq -import Data.Data (Data)- import GHC.Generics (Generic)  import Agda.Syntax.Position import Agda.Syntax.Common -import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty  import Agda.Utils.Impossible @@ -21,7 +20,7 @@  -- | Decorating something with @Fixity'@. data ThingWithFixity x = ThingWithFixity x Fixity'-  deriving (Functor, Foldable, Traversable, Data, Show)+  deriving (Functor, Foldable, Traversable, Show)  instance LensFixity' (ThingWithFixity a) where   lensFixity' f (ThingWithFixity a fix') = ThingWithFixity a <$> f fix'@@ -32,7 +31,7 @@ -- | Do we prefer parens around arguments like @λ x → x@ or not? --   See 'lamBrackets'. data ParenPreference = PreferParen | PreferParenless-  deriving (Eq, Ord, Show, Data, Generic)+  deriving (Eq, Ord, Show, Generic)  instance NFData ParenPreference @@ -49,7 +48,7 @@                 | LeftOperandCtx Fixity | RightOperandCtx Fixity ParenPreference                 | FunctionCtx | ArgumentCtx ParenPreference | InsideOperandCtx                 | WithFunCtx | WithArgCtx | DotPatternCtx-    deriving (Show, Data, Eq, Generic)+    deriving (Show, Eq, Generic)  instance NFData Precedence
src/full/Agda/Syntax/IdiomBrackets.hs view
@@ -13,7 +13,7 @@ import Agda.TypeChecking.Monad  import Agda.Utils.List1  ( List1, pattern (:|), (<|) )-import Agda.Utils.Pretty ( prettyShow )+import Agda.Syntax.Common.Pretty ( prettyShow ) import Agda.Utils.Singleton  parseIdiomBracketsSeq :: Range -> [Expr] -> ScopeM Expr@@ -45,22 +45,25 @@ appViewM :: Expr -> ScopeM (List1 Expr) appViewM = \case     e@App{}         -> let AppView e' es = appView e in (e' :|) <$> mapM onlyVisible es-    OpApp _ op _ es -> (Ident op :|) <$> mapM (ordinary <=< noPlaceholder <=< onlyVisible) es+    OpApp _ op _ es -> (Ident op <|) <$> mapM (ordinary <=< noPlaceholder <=< onlyVisible) es     e               -> return $ singleton e   where     onlyVisible a       | defaultNamedArg () == fmap (() <$) a = return $ namedArg a-      | otherwise = genericError "Only regular arguments are allowed in idiom brackets (no implicit or instance arguments)"-    noPlaceholder Placeholder{}       = genericError "Naked sections are not allowed in idiom brackets"+      | otherwise = idiomBracketError "Only regular arguments are allowed in idiom brackets (no implicit or instance arguments)"+    noPlaceholder Placeholder{}       = idiomBracketError "Naked sections are not allowed in idiom brackets"     noPlaceholder (NoPlaceholder _ x) = return x      ordinary (Ordinary a) = return a-    ordinary _ = genericError "Binding syntax is not allowed in idiom brackets"+    ordinary _ = idiomBracketError "Binding syntax is not allowed in idiom brackets"  ensureInScope :: QName -> ScopeM () ensureInScope q = do   r <- resolveName q   case r of-    UnknownName -> genericError $+    UnknownName -> idiomBracketError $       prettyShow q ++ " needs to be in scope to use idiom brackets " ++ prettyShow leftIdiomBrkt ++ " ... " ++ prettyShow rightIdiomBrkt     _ -> return ()++idiomBracketError :: String -> ScopeM a+idiomBracketError = typeError . IdiomBracketError
src/full/Agda/Syntax/Info.hs view
@@ -11,7 +11,6 @@  import Control.DeepSeq -import Data.Data (Data) import Data.Semigroup (Semigroup)  import GHC.Generics (Generic)@@ -21,7 +20,7 @@ import Agda.Syntax.Position import Agda.Syntax.Concrete import Agda.Syntax.Fixity-import Agda.Syntax.Scope.Base (ScopeInfo, emptyScopeInfo)+import Agda.Syntax.Scope.Base (ScopeInfo)  import Agda.Utils.Functor import Agda.Utils.Null@@ -30,36 +29,67 @@     Meta information  --------------------------------------------------------------------------} +-- | Kind of a meta: the method how to solve it.+--+data MetaKind+  = InstanceMeta     -- ^ Meta variable solved by instance search.+  | UnificationMeta  -- ^ Meta variable solved by unification (default).+  deriving (Show, Eq, Generic)++instance Null MetaKind where+  empty = UnificationMeta++instance NFData MetaKind++-- | Default meta kind from its 'Hiding' context.+--+hidingToMetaKind :: Hiding -> MetaKind+hidingToMetaKind = \case+  Instance{} -> InstanceMeta+  Hidden     -> UnificationMeta+  NotHidden  -> UnificationMeta++-- | Name suggestion for meta variable.  Empty string means no suggestion.+type MetaNameSuggestion = String++-- | Information associated to a meta variable in the abstract syntax.+-- data MetaInfo = MetaInfo   { metaRange          :: Range   , metaScope          :: ScopeInfo   , metaNumber         :: Maybe MetaId-  , metaNameSuggestion :: String+  , metaNameSuggestion :: MetaNameSuggestion+  , metaKind           :: MetaKind   }-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  emptyMetaInfo :: MetaInfo emptyMetaInfo = MetaInfo   { metaRange          = noRange-  , metaScope          = emptyScopeInfo+  , metaScope          = empty   , metaNumber         = Nothing   , metaNameSuggestion = ""+  , metaKind           = empty   } +instance Null MetaInfo where+  empty = emptyMetaInfo+ instance HasRange MetaInfo where   getRange = metaRange  instance KillRange MetaInfo where   killRange m = m { metaRange = noRange } -instance NFData MetaInfo+instance NFData MetaInfo where+  rnf (MetaInfo _ a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d  {--------------------------------------------------------------------------     General expression information  --------------------------------------------------------------------------}  newtype ExprInfo = ExprRange Range-  deriving (Data, Show, Eq, Null, NFData)+  deriving (Show, Eq, Null, NFData)  exprNoRange :: ExprInfo exprNoRange = ExprRange noRange@@ -80,7 +110,7 @@   , appOrigin :: Origin   , appParens :: ParenPreference -- ^ Do we prefer a lambda argument with or without parens?   }-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  -- | Default is system inserted and prefer parens. defaultAppInfo :: Range -> AppInfo@@ -90,6 +120,9 @@ defaultAppInfo_ :: AppInfo defaultAppInfo_ = defaultAppInfo noRange +instance Null AppInfo where+  empty = defaultAppInfo_+ instance HasRange AppInfo where   getRange = appRange @@ -117,7 +150,7 @@   , minfoDirective :: Maybe ImportDirective     -- ^ Retained for @abstractToConcrete@ of 'ModuleMacro'.   }-  deriving (Data, Eq, Show, Generic)+  deriving (Eq, Show, Generic)  instance HasRange ModuleInfo where   getRange = minfoRange@@ -135,7 +168,7 @@ ---------------------------------------------------------------------------  newtype LetInfo = LetRange Range-  deriving (Data, Show, Eq, Null, NFData)+  deriving (Show, Eq, Null, NFData)  instance HasRange LetInfo where   getRange (LetRange r)   = r@@ -151,19 +184,20 @@   { defFixity   :: Fixity'   , defAccess   :: Access   , defAbstract :: IsAbstract+  , defOpaque   :: IsOpaque   , defInstance :: IsInstance   , defMacro    :: IsMacro   , defInfo     :: DeclInfo-  , defTactic   :: Maybe t+  , defTactic   :: TacticAttribute' t   }-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  mkDefInfo :: Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t mkDefInfo x f a ab r = mkDefInfoInstance x f a ab NotInstanceDef NotMacroDef r  -- | Same as @mkDefInfo@ but where we can also give the @IsInstance@ mkDefInfoInstance :: Name -> Fixity' -> Access -> IsAbstract -> IsInstance -> IsMacro -> Range -> DefInfo' t-mkDefInfoInstance x f a ab i m r = DefInfo f a ab i m (DeclInfo x r) Nothing+mkDefInfoInstance x f a ab i m r = DefInfo f a ab TransparentDef i m (DeclInfo x r) empty  instance HasRange (DefInfo' t) where   getRange = getRange . defInfo@@ -178,9 +212,15 @@ instance LensIsAbstract (DefInfo' t) where   lensIsAbstract f i = (f $! defAbstract i) <&> \ a -> i { defAbstract = a } +instance LensIsOpaque (DefInfo' t) where+  lensIsOpaque f i = (f $! defOpaque i) <&> \ a -> i { defOpaque = a }+ instance AnyIsAbstract (DefInfo' t) where   anyIsAbstract = defAbstract +instance AllAreOpaque (DefInfo' t) where+  jointOpacity = jointOpacity . defOpaque+ instance NFData t => NFData (DefInfo' t)  {--------------------------------------------------------------------------@@ -191,7 +231,7 @@   { declName  :: Name   , declRange :: Range   }-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  instance HasRange DeclInfo where   getRange = declRange@@ -214,7 +254,7 @@   , mutualPositivityCheck  :: PositivityCheck   , mutualRange            :: Range   }-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  -- | Default value for 'MutualInfo'. instance Null MutualInfo where@@ -235,7 +275,7 @@ data LHSInfo = LHSInfo   { lhsRange    :: Range   , lhsEllipsis :: ExpandedEllipsis-  } deriving (Data, Show, Eq, Generic)+  } deriving (Show, Eq, Generic)  instance HasRange LHSInfo where   getRange (LHSInfo r _) = r@@ -256,7 +296,7 @@ -- | For a general pattern we remember the source code position. newtype PatInfo   = PatRange Range-  deriving (Data, Eq, Null, Semigroup, Monoid, Show, SetRange, HasRange,+  deriving (Eq, Null, Semigroup, Monoid, Show, SetRange, HasRange,             KillRange, NFData)  -- | Empty range for patterns.@@ -271,7 +311,7 @@   , conPatInfo     :: PatInfo   , conPatLazy     :: ConPatLazy   }-  deriving (Data, Eq, Show, Generic)+  deriving (Eq, Show, Generic)  instance HasRange ConPatInfo where   getRange = getRange . conPatInfo@@ -288,6 +328,6 @@ data ConPatLazy   = ConPatLazy   -- ^ Dotted constructor.   | ConPatEager  -- ^ Ordinary constructor.-  deriving (Data, Eq, Ord, Show, Bounded, Enum, Generic)+  deriving (Eq, Ord, Show, Bounded, Enum, Generic)  instance NFData ConPatLazy
src/full/Agda/Syntax/Internal.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE PatternSynonyms            #-}  module Agda.Syntax.Internal     ( module Agda.Syntax.Internal     , module Agda.Syntax.Internal.Blockers     , module Agda.Syntax.Internal.Elim+    , module Agda.Syntax.Internal.Univ     , module Agda.Syntax.Abstract.Name     , MetaId(..), ProblemId(..)     ) where@@ -13,25 +13,21 @@ import Control.Monad.Identity import Control.DeepSeq -import Data.Function+import Data.Function (on) import qualified Data.List as List import Data.Maybe import Data.Semigroup ( Semigroup, (<>), Sum(..) )-import qualified Data.Set as Set-import Data.Set (Set) -import Data.Traversable-import Data.Data (Data)- import GHC.Generics (Generic)  import Agda.Syntax.Position import Agda.Syntax.Common import Agda.Syntax.Literal-import Agda.Syntax.Concrete.Pretty (prettyHiding) import Agda.Syntax.Abstract.Name import Agda.Syntax.Internal.Blockers import Agda.Syntax.Internal.Elim+import Agda.Syntax.Internal.Univ+import Agda.Syntax.Common.Pretty  import Agda.Utils.CallStack     ( CallStack@@ -41,13 +37,11 @@     , withCallerCallStack     ) -import Agda.Utils.Empty-+import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.Null import Agda.Utils.Size-import Agda.Utils.Pretty import Agda.Utils.Tuple  import Agda.Utils.Impossible@@ -65,34 +59,35 @@ --   'Arg' is used for actual arguments ('Var', 'Con', 'Def' etc.) --   and in 'Abstract' syntax and other situations. -----   [ cubical ] When @domFinite = True@ for the domain of a 'Pi'---   type, the elements should be compared by tabulating the domain type.---   Only supported in case the domain type is primIsOne, to obtain---   the correct equality for partial elements.+--   [ cubical ] When @annFinite (argInfoAnnotation domInfo) = True@ for+--   the domain of a 'Pi' type, the elements should be compared by+--   tabulating the domain type.  Only supported in case the domain type+--   is primIsOne, to obtain the correct equality for partial elements. -- data Dom' t e = Dom   { domInfo   :: ArgInfo-  , domFinite :: !Bool   , domName   :: Maybe NamedName  -- ^ e.g. @x@ in @{x = y : A} -> B@.+  , domIsFinite :: Bool+    -- ^ Is this a Π-type (False), or a partial type (True)?   , domTactic :: Maybe t        -- ^ "@tactic e".   , unDom     :: e-  } deriving (Data, Show, Functor, Foldable, Traversable)+  } deriving (Show, Functor, Foldable, Traversable)  type Dom = Dom' Term  instance Decoration (Dom' t) where-  traverseF f (Dom ai b x t a) = Dom ai b x t <$> f a+  traverseF f (Dom ai x t b a) = Dom ai x t b <$> f a  instance HasRange a => HasRange (Dom' t a) where   getRange = getRange . unDom  instance (KillRange t, KillRange a) => KillRange (Dom' t a) where-  killRange (Dom info b x t a) = killRange5 Dom info b x t a+  killRange (Dom info x t b a) = killRangeN Dom info x t b a  -- | Ignores 'Origin' and 'FreeVariables' and tactic. instance Eq a => Eq (Dom' t a) where-  Dom (ArgInfo h1 m1 _ _ a1) b1 s1 _ x1 == Dom (ArgInfo h2 m2 _ _ a2) b2 s2 _ x2 =-    (h1, m1, a1, b1, s1, x1) == (h2, m2, a2, b2, s2, x2)+  Dom (ArgInfo h1 m1 _ _ a1) s1 f1 _ x1 == Dom (ArgInfo h2 m2 _ _ a2) s2 f2 _ x2 =+    (h1, m1, a1, s1, f1, x1) == (h2, m2, a2, s2, f2, x2)  instance LensNamed (Dom' t e) where   type NameOf (Dom' t e) = NamedName@@ -103,6 +98,10 @@   setArgInfo ai dom = dom { domInfo = ai }   mapArgInfo f  dom = dom { domInfo = f $ domInfo dom } +instance LensLock (Dom' t e) where+  getLock = getLock . getArgInfo+  setLock = mapArgInfo . setLock+ -- The other lenses are defined through LensArgInfo  instance LensHiding        (Dom' t e) where@@ -116,6 +115,7 @@ instance LensRelevance (Dom' t e) where instance LensQuantity  (Dom' t e) where instance LensCohesion  (Dom' t e) where+instance LensModalPolarity (Dom' t e) where  argFromDom :: Dom' t a -> Arg a argFromDom Dom{domInfo = i, unDom = a} = Arg i a@@ -129,10 +129,10 @@ -- often for class AddContext.  domFromArg :: Arg a -> Dom a-domFromArg (Arg i a) = Dom i False Nothing Nothing a+domFromArg (Arg i a) = Dom i Nothing False Nothing a  domFromNamedArg :: NamedArg a -> Dom a-domFromNamedArg (Arg i a) = Dom i False (nameOf a) Nothing (namedThing a)+domFromNamedArg (Arg i a) = Dom i (nameOf a) False Nothing (namedThing a)  defaultDom :: a -> Dom a defaultDom = defaultArgDom defaultArgInfo@@ -148,11 +148,27 @@ type Args       = [Arg Term] type NamedArgs  = [NamedArg Term] -data DataOrRecord+data DataOrRecord' p   = IsData-  | IsRecord PatternOrCopattern-  deriving (Data, Show, Eq, Generic)+  | IsRecord p+  deriving (Show, Eq, Generic) +type DataOrRecord = DataOrRecord' PatternOrCopattern+type DataOrRecord_ = DataOrRecord' ()++pattern IsRecord_ :: DataOrRecord_+pattern IsRecord_ = IsRecord ()++instance PatternMatchingAllowed DataOrRecord where+  patternMatchingAllowed = \case+    IsData -> True+    IsRecord patCopat -> patternMatchingAllowed patCopat++instance CopatternMatchingAllowed DataOrRecord where+  copatternMatchingAllowed = \case+    IsData -> False+    IsRecord patCopat -> copatternMatchingAllowed patCopat+ -- | Store the names of the record fields in the constructor. --   This allows reduction of projection redexes outside of TCM. --   For instance, during substitution and application.@@ -163,7 +179,7 @@   , conFields     :: [Arg QName]   -- ^ The name of the record fields.       --   'Arg' is stored since the info in the constructor args       --   might not be accurate because of subtyping (issue #2170).-  } deriving (Data, Show, Generic)+  } deriving (Show, Generic)  instance Eq ConHead where   (==) = (==) `on` conName@@ -180,6 +196,9 @@ instance SetRange ConHead where   setRange r = mapConName (setRange r) +instance CopatternMatchingAllowed ConHead where+  copatternMatchingAllowed = copatternMatchingAllowed . conDataRecord+ class LensConName a where   getConName :: a -> QName   setConName :: QName -> a -> a@@ -225,7 +244,7 @@             --   where they can affect type checking, so syntactic checks are free to ignore the             --   eliminators, which are only there to ease debugging when a dummy term incorrectly             --   leaks into a relevant position.-  deriving (Data, Show)+  deriving Show  type ConInfo = ConOrigin @@ -242,7 +261,7 @@                -- ^ The body has (at least) one free variable.                --   Danger: 'unAbs' doesn't shift variables properly            | NoAbs { absName :: ArgName, unAbs :: a }-  deriving (Data, Functor, Foldable, Traversable, Generic)+  deriving (Functor, Foldable, Traversable, Generic)  instance Decoration Abs where   traverseF f (Abs   x a) = Abs   x <$> f a@@ -251,7 +270,7 @@ -- | Types are terms with a sort annotation. -- data Type'' t a = El { _getSort :: Sort' t, unEl :: a }-  deriving (Data, Show, Functor, Foldable, Traversable)+  deriving (Show, Functor, Foldable, Traversable)  type Type' a = Type'' Term a @@ -261,7 +280,7 @@   traverseF f (El s a) = El s <$> f a  class LensSort a where-  lensSort ::  Lens' Sort a+  lensSort ::  Lens' a Sort   getSort  :: a -> Sort   getSort a = a ^. lensSort @@ -284,22 +303,26 @@ --   and so on. data Tele a = EmptyTel             | ExtendTel a (Abs (Tele a))  -- ^ 'Abs' is never 'NoAbs'.-  deriving (Data, Show, Functor, Foldable, Traversable, Generic)+  deriving (Show, Functor, Foldable, Traversable, Generic)  type Telescope = Tele (Dom Type) -data IsFibrant = IsFibrant | IsStrict-  deriving (Data, Show, Eq, Ord, Generic)+data UnivSize+  = USmall  -- ^ @Prop/Set/SSet ℓ@.+  | ULarge  -- ^ @(Prop/Set/SSet)ωᵢ@.+  deriving stock (Eq, Show)  -- | Sorts. -- data Sort' t-  = Type (Level' t)  -- ^ @Set ℓ@.-  | Prop (Level' t)  -- ^ @Prop ℓ@.-  | Inf IsFibrant Integer      -- ^ @Setωᵢ@.-  | SSet (Level' t)  -- ^ @SSet ℓ@.+  = Univ Univ (Level' t)+      -- ^ @Prop ℓ@, @Set ℓ@, @SSet ℓ@.+  | Inf Univ !Integer+      -- ^ @Propωᵢ@, @(S)Setωᵢ@.   | SizeUniv    -- ^ @SizeUniv@, a sort inhabited by type @Size@.   | LockUniv    -- ^ @LockUniv@, a sort for locks.+  | LevelUniv   -- ^ @LevelUniv@, a sort inhabited by type @Level@. When --level-universe isn't on, this universe reduces to @Set 0@+  | IntervalUniv -- ^ @IntervalUniv@, a sort inhabited by the cubical interval.   | PiSort (Dom' t t) (Sort' t) (Abs (Sort' t)) -- ^ Sort of the pi type.   | FunSort (Sort' t) (Sort' t) -- ^ Sort of a (non-dependent) function type.   | UnivSort (Sort' t) -- ^ Sort of another sort.@@ -310,19 +333,29 @@     --   Replaces the abuse of @Prop@ for a dummy sort.     --   The @String@ typically describes the location where we create this dummy,     --   but can contain other information as well.-  deriving (Data, Show)+  deriving Show +pattern Prop, Type, SSet :: Level' t -> Sort' t+pattern Prop l = Univ UProp l+pattern Type l = Univ UType l+pattern SSet l = Univ USSet l++{-# COMPLETE+  Prop, Type, SSet, Inf,+  SizeUniv, LockUniv, LevelUniv, IntervalUniv,+  PiSort, FunSort, UnivSort, MetaS, DefS, DummyS #-}+ type Sort = Sort' Term  -- | A level is a maximum expression of a closed level and 0..n --   'PlusLevel' expressions each of which is an atom plus a number.-data Level' t = Max Integer [PlusLevel' t]-  deriving (Show, Data, Functor, Foldable, Traversable)+data Level' t = Max !Integer [PlusLevel' t]+  deriving (Show, Functor, Foldable, Traversable)  type Level = Level' Term -data PlusLevel' t = Plus Integer t-  deriving (Show, Data, Functor, Foldable, Traversable)+data PlusLevel' t = Plus !Integer t+  deriving (Show, Functor, Foldable, Traversable)  type PlusLevel = PlusLevel' Term type LevelAtom = Term@@ -333,7 +366,7 @@  -- | Newtypes for terms that produce a dummy, rather than crash, when --   applied to incompatible eliminations.-newtype BraveTerm = BraveTerm { unBrave :: Term } deriving (Data, Show)+newtype BraveTerm = BraveTerm { unBrave :: Term } deriving Show  --------------------------------------------------------------------------- -- * Blocked Terms@@ -366,28 +399,22 @@ --  For the purpose of the permutation and the body dot patterns count --  as variables. TODO: Change this! data Clause = Clause-    { clauseLHSRange  :: Range-    , clauseFullRange :: Range-    , clauseTel       :: Telescope+    { clauseLHSRange    :: Range+    , clauseFullRange   :: Range+    , clauseTel         :: Telescope       -- ^ @Δ@: The types of the pattern variables in dependency order.-    , namedClausePats :: NAPs+    , namedClausePats   :: NAPs       -- ^ @Δ ⊢ ps@.  The de Bruijn indices refer to @Δ@.-    , clauseBody      :: Maybe Term+    , clauseBody        :: Maybe Term       -- ^ @Just v@ with @Δ ⊢ v@ for a regular clause, or @Nothing@ for an       --   absurd one.-    , clauseType      :: Maybe (Arg Type)+    , clauseType        :: Maybe (Arg Type)       -- ^ @Δ ⊢ t@.  The type of the rhs under @clauseTel@.       --   Used, e.g., by @TermCheck@.       --   Can be 'Irrelevant' if we encountered an irrelevant projection       --   pattern on the lhs.-    , clauseCatchall  :: Bool+    , clauseCatchall    :: Catchall       -- ^ Clause has been labelled as CATCHALL.-    , clauseExact       :: Maybe Bool-      -- ^ Pattern matching of this clause is exact, no catch-all case.-      --   Computed by the coverage checker.-      --   @Nothing@ means coverage checker has not run yet (clause may be inexact).-      --   @Just False@ means clause is not exact.-      --   @Just True@ means clause is exact.     , clauseRecursive   :: Maybe Bool       -- ^ @clauseBody@ contains recursive calls; computed by termination checker.       --   @Nothing@ means that termination checker has not run yet,@@ -400,10 +427,12 @@       --   @Nothing@ means coverage checker has not run yet (clause may be unreachable).       --   @Just False@ means clause is not unreachable.       --   @Just True@ means clause is unreachable.-    , clauseEllipsis  :: ExpandedEllipsis+    , clauseEllipsis    :: ExpandedEllipsis       -- ^ Was this clause created by expansion of an ellipsis?+    , clauseWhereModule :: Maybe ModuleName+      -- ^ Keeps track of the module name associate with the clause's where clause.     }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  clausePats :: Clause -> [Arg DeBruijnPattern] clausePats = map (fmap namedThing) . namedClausePats@@ -423,7 +452,7 @@ data PatternInfo = PatternInfo   { patOrigin :: PatOrigin   , patAsNames :: [Name]-  } deriving (Data, Show, Eq, Generic)+  } deriving (Show, Eq, Generic)  defaultPatternInfo :: PatternInfo defaultPatternInfo = PatternInfo PatOSystem []@@ -432,6 +461,7 @@ data PatOrigin   = PatOSystem         -- ^ Pattern inserted by the system   | PatOSplit          -- ^ Pattern generated by case split+  | PatOSplitArg ArgName -- ^ Argument to pattern generated by case split   | PatOVar Name       -- ^ User wrote a variable pattern   | PatODot            -- ^ User wrote a dot pattern   | PatOWild           -- ^ User wrote a wildcard pattern@@ -439,7 +469,7 @@   | PatORec            -- ^ User wrote a record pattern   | PatOLit            -- ^ User wrote a literal pattern   | PatOAbsurd         -- ^ User wrote an absurd pattern-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  -- | Patterns are variables, constructors, or wildcards. --   @QName@ is used in @ConP@ rather than @Name@ since@@ -463,7 +493,7 @@     -- ^ Path elimination pattern, like @VarP@ but keeps track of endpoints.   | DefP PatternInfo QName [NamedArg (Pattern' x)]     -- ^ Used for HITs, the QName should be the one from primHComp.-  deriving (Data, Show, Functor, Foldable, Traversable, Generic)+  deriving (Show, Functor, Foldable, Traversable, Generic)  type Pattern = Pattern' PatVarName     -- ^ The @PatVarName@ is a name suggestion.@@ -480,8 +510,8 @@ -- | Type used when numbering pattern variables. data DBPatVar = DBPatVar   { dbPatVarName  :: PatVarName-  , dbPatVarIndex :: Int-  } deriving (Data, Show, Eq, Generic)+  , dbPatVarIndex :: !Int+  } deriving (Show, Eq, Generic)  type DeBruijnPattern = Pattern' DBPatVar @@ -528,7 +558,7 @@     --   variables they bind are unused. The GHC backend compiles lazy matches     --   to lazy patterns in Haskell (TODO: not yet).   }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  noConPatternInfo :: ConPatternInfo noConPatternInfo = ConPatternInfo defaultPatternInfo False False Nothing False@@ -546,6 +576,7 @@     patToConO = \case       PatOSystem -> ConOSystem       PatOSplit  -> ConOSplit+      PatOSplitArg{} -> ConOSystem       PatOVar{}  -> ConOSystem       PatODot    -> ConOSystem       PatOWild   -> ConOSystem@@ -597,27 +628,6 @@ patternOrigin :: Pattern' x -> Maybe PatOrigin patternOrigin = fmap patOrigin . patternInfo --- | Does the pattern perform a match that could fail?-properlyMatching :: Pattern' a -> Bool-properlyMatching = properlyMatching' True True--properlyMatching'-  :: Bool       -- ^ Should absurd patterns count as proper match?-  -> Bool       -- ^ Should projection patterns count as proper match?-  -> Pattern' a -- ^ The pattern.-  -> Bool-properlyMatching' absP projP = \case-  p | absP && patternOrigin p == Just PatOAbsurd -> True-  ConP _ ci ps    -- record constructors do not count as proper matches themselves-    | conPRecord ci -> List.any (properlyMatching . namedArg) ps-    | otherwise     -> True-  LitP{}    -> True-  DefP{}    -> True-  ProjP{}   -> projP-  VarP{}    -> False-  DotP{}    -> False-  IApplyP{} -> False- instance IsProjP (Pattern' a) where   isProjP = \case     ProjP o d -> Just (o, unambiguous d)@@ -648,14 +658,16 @@     --     Γ ⊢ u :# ρ : Δ, A     --   @ -  | Strengthen Impossible (Substitution' a)+  | Strengthen Impossible !Int (Substitution' a)     -- ^ Strengthening substitution.  First argument is @__IMPOSSIBLE__@.-    --   Apply this to a term which does not contain variable 0-    --   to lower all de Bruijn indices by one.-    --   @-    --             Γ ⊢ ρ : Δ+    --   In @'Strengthen err n ρ@ the number @n@ must be non-negative.+    --   This substitution should only be applied to values @t@ for+    --   which none of the variables @0@ up to @n - 1@ are free in+    --   @t[ρ]@, and in that case @n@ is subtracted from all free de+    --   Bruijn indices in @t[ρ]@.+    --        Γ ⊢ ρ : Δ    |Θ| = n     --     ----------------------------    --     Γ ⊢ Strengthen ρ : Δ, A+    --     Γ ⊢ Strengthen n ρ : Δ, Θ     --   @    | Wk !Int (Substitution' a)@@ -701,17 +713,38 @@ -- | View type as equality type.  data EqualityView-  = EqualityType-    { eqtSort  :: Sort     -- ^ Sort of this type.-    , eqtName  :: QName    -- ^ Builtin EQUALITY.-    , eqtParams :: [Arg Term] -- ^ Hidden.  Empty or @Level@.-    , eqtType  :: Arg Term -- ^ Hidden-    , eqtLhs   :: Arg Term -- ^ NotHidden-    , eqtRhs   :: Arg Term -- ^ NotHidden+  = EqualityViewType EqualityTypeData+      -- ^ A type of the form @u ≡ v@ decomposed into its parts.+      --   Used as type for the @rewrite@ expression.+  | OtherType Type+      -- ^ A reduced type used as type for a @with@ expression.+  | IdiomType Type+      -- ^ A reduced type used as type for the @with@ inspect idiom.++data EqualityTypeData = EqualityTypeData+    { _eqtRange  :: Range       -- ^ Range of the @rewrite@ expression, if any.+    , _eqtSort   :: Sort        -- ^ Sort of this type.+    , _eqtName   :: QName       -- ^ Builtin EQUALITY.+    , _eqtParams :: Args        -- ^ Hidden.  Empty or @Level@.+    , _eqtType   :: Arg Term    -- ^ Hidden.+    , _eqtLhs    :: Arg Term    -- ^ NotHidden.+    , _eqtRhs    :: Arg Term    -- ^ NotHidden.     }-  | OtherType Type -- ^ reduced-  | IdiomType Type -- ^ reduced +pattern EqualityType ::+     Range+  -> Sort+  -> QName+  -> Args+  -> Arg Term+  -> Arg Term+  -> Arg Term+  -> EqualityView+pattern EqualityType{ eqtRange, eqtSort, eqtName, eqtParams, eqtType, eqtLhs, eqtRhs } =+  EqualityViewType (EqualityTypeData eqtRange eqtSort eqtName eqtParams eqtType eqtLhs eqtRhs)++{-# COMPLETE EqualityType, OtherType, IdiomType #-}+ isEqualityType :: EqualityView -> Bool isEqualityType EqualityType{} = True isEqualityType OtherType{}    = False@@ -792,10 +825,8 @@ dummyTermWith :: DummyTermKind -> CallStack -> Term dummyTermWith kind cs = flip Dummy [] $ concat [kind, ": ", dummyLocName cs] --- | A dummy level to constitute a level/sort created at location.---   Note: use macro __DUMMY_LEVEL__ !-dummyLevel :: CallStack -> Level-dummyLevel = atomicLevel . dummyTermWith "dummyLevel"+__DUMMY_TERM_WITH__ :: HasCallStack => DummyTermKind -> Term+__DUMMY_TERM_WITH__ = withCallerCallStack . dummyTermWith  -- | A dummy term created at location. --   Note: use macro __DUMMY_TERM__ !@@ -805,6 +836,11 @@ __DUMMY_TERM__ :: HasCallStack => Term __DUMMY_TERM__ = withCallerCallStack dummyTerm +-- | A dummy level to constitute a level/sort created at location.+--   Note: use macro __DUMMY_LEVEL__ !+dummyLevel :: CallStack -> Level+dummyLevel = atomicLevel . dummyTermWith "dummyLevel"+ __DUMMY_LEVEL__ :: HasCallStack => Level __DUMMY_LEVEL__ = withCallerCallStack dummyLevel @@ -865,14 +901,40 @@ mkSSet :: Integer -> Sort mkSSet n = SSet $ ClosedLevel n +impossibleTerm :: CallStack -> Term+impossibleTerm = flip Dummy [] . show . Impossible++---------------------------------------------------------------------------+-- * Sorts.+---------------------------------------------------------------------------+ isSort :: Term -> Maybe Sort isSort = \case   Sort s -> Just s   _      -> Nothing -impossibleTerm :: CallStack -> Term-impossibleTerm = flip Dummy [] . show . Impossible+-- | Get the flavor of the universe. 'Nothing' could also mean "don't know".+sortUniv :: Sort' t -> Maybe Univ+sortUniv = \case+  Univ u _ -> Just u+  Inf  u _ -> Just u+  _        -> Nothing +-- | Is this a Prop universe?  Answers are yes ('True') or maybe ('False').+isProp :: Sort' t -> Bool+isProp = (Just UProp ==) . sortUniv++-- | Is this a strict universe inhabitable by data types?+isStrictDataSort :: Sort' t -> Bool+isStrictDataSort = maybe False ((IsStrict ==) . univFibrancy) . sortUniv++-- | Turn a known 'UProp' sort into a 'UType' sort, leave others unchanged.+propToType :: Sort' t -> Sort' t+propToType = \case+  Univ UProp l -> Univ UType l+  Inf  UProp l -> Inf  UType l+  s -> s+ --------------------------------------------------------------------------- -- * Telescopes. ---------------------------------------------------------------------------@@ -919,7 +981,7 @@ telToList (ExtendTel _    NoAbs{}   ) = __IMPOSSIBLE__  -- | Lens to edit a 'Telescope' as a list.-listTel :: Lens' ListTel Telescope+listTel :: Lens' Telescope ListTel listTel f = fmap telFromList . f . telToList  -- | Drop the types from a telescope.@@ -993,12 +1055,12 @@  -- | Convert top-level postfix projections into prefix projections. unSpine :: Term -> Term-unSpine = unSpine' $ const True+unSpine = unSpine' $ \_ _ -> True  -- | Convert 'Proj' projection eliminations --   according to their 'ProjOrigin' into --   'Def' projection applications.-unSpine' :: (ProjOrigin -> Bool) -> Term -> Term+unSpine' :: (ProjOrigin -> QName -> Bool) -> Term -> Term unSpine' p v =   case hasElims v of     Just (h, es) -> loop h [] es@@ -1007,9 +1069,9 @@     loop :: (Elims -> Term) -> Elims -> Elims -> Term     loop h res es =       case es of-        []                   -> v-        Proj o f : es' | p o -> loop (Def f) [Apply (defaultArg v)] es'-        e        : es'       -> loop h (e : res) es'+        []                     -> v+        Proj o f : es' | p o f -> loop (Def f) [Apply (defaultArg v)] es'+        e        : es'         -> loop h (e : res) es'       where v = h $ reverse res  -- | A view distinguishing the neutrals @Var@, @Def@, and @MetaV@ which@@ -1022,10 +1084,6 @@     MetaV x es -> Just (MetaV x, es)     Con{}      -> Nothing     Lit{}      -> Nothing-    -- Andreas, 2016-04-13, Issue 1932: We convert λ x → x .f  into f-    Lam h (Abs _ v) | visible h -> case v of-      Var 0 [Proj _o f] -> Just (Def f, [])-      _ -> Nothing     Lam{}      -> Nothing     Pi{}       -> Nothing     Sort{}     -> Nothing@@ -1034,6 +1092,26 @@     Dummy{}    -> Nothing  ---------------------------------------------------------------------------+-- * Type family for type-directed operations.+---------------------------------------------------------------------------++-- @TypeOf a@ contains sufficient type information to do+-- a type-directed traversal of @a@.+type family TypeOf a++type instance TypeOf Term        = Type                  -- Type of the term+type instance TypeOf Elims       = (Type, Elims -> Term) -- Head symbol type + constructor+type instance TypeOf (Abs Term)  = (Dom Type, Abs Type)  -- Domain type + codomain type+type instance TypeOf (Abs Type)  = Dom Type              -- Domain type+type instance TypeOf (Arg a)     = Dom (TypeOf a)+type instance TypeOf (Dom a)     = TypeOf a+type instance TypeOf Type        = ()+type instance TypeOf Sort        = ()+type instance TypeOf Level       = ()+type instance TypeOf [PlusLevel] = ()+type instance TypeOf PlusLevel   = ()++--------------------------------------------------------------------------- -- * Null instances. --------------------------------------------------------------------------- @@ -1045,11 +1123,12 @@ -- | A 'null' clause is one with no patterns and no rhs. --   Should not exist in practice. instance Null Clause where-  empty = Clause empty empty empty empty empty empty False Nothing Nothing Nothing empty-  null (Clause _ _ tel pats body _ _ _ _ _ _)+  empty = Clause empty empty empty empty empty empty empty empty empty empty empty+  null (Clause _ _ tel pats body _ _ _ _ _ wm)     =  null tel     && null pats     && null body+    && null wm   ---------------------------------------------------------------------------@@ -1076,8 +1155,12 @@   size  EmptyTel         = 0   size (ExtendTel _ tel) = 1 + size tel +  natSize EmptyTel          = Zero+  natSize (ExtendTel _ tel) = Succ $ natSize tel+ instance Sized a => Sized (Abs a) where-  size = size . unAbs+  size    = size    . unAbs+  natSize = natSize . unAbs  -- | The size of a term is roughly the number of nodes in its --   syntax tree.  This number need not be precise for logical@@ -1114,12 +1197,12 @@  instance TermSize Sort where   tsize = \case-    Type l    -> 1 + tsize l-    Prop l    -> 1 + tsize l+    Univ _ l  -> 1 + tsize l     Inf _ _   -> 1-    SSet l    -> 1 + tsize l     SizeUniv  -> 1     LockUniv  -> 1+    LevelUniv -> 1+    IntervalUniv -> 1     PiSort a s1 s2 -> 1 + tsize a + tsize s1 + tsize s2     FunSort s1 s2 -> 1 + tsize s1 + tsize s2     UnivSort s -> 1 + tsize s@@ -1134,12 +1217,12 @@   tsize (Plus _ a)      = tsize a  instance TermSize a => TermSize (Substitution' a) where-  tsize IdS                = 1-  tsize (EmptyS _)         = 1-  tsize (Wk _ rho)         = 1 + tsize rho-  tsize (t :# rho)         = 1 + tsize t + tsize rho-  tsize (Strengthen _ rho) = 1 + tsize rho-  tsize (Lift _ rho)       = 1 + tsize rho+  tsize IdS                  = 1+  tsize (EmptyS _)           = 1+  tsize (Wk _ rho)           = 1 + tsize rho+  tsize (t :# rho)           = 1 + tsize t + tsize rho+  tsize (Strengthen _ _ rho) = 1 + tsize rho+  tsize (Lift _ rho)         = 1 + tsize rho  --------------------------------------------------------------------------- -- * KillRange instances.@@ -1149,80 +1232,80 @@   killRange = id  instance KillRange ConHead where-  killRange (ConHead c d i fs) = killRange4 ConHead c d i fs+  killRange (ConHead c d i fs) = killRangeN ConHead c d i fs  instance KillRange Term where   killRange = \case-    Var i vs    -> killRange1 (Var i) vs-    Def c vs    -> killRange2 Def c vs-    Con c ci vs -> killRange3 Con c ci vs-    MetaV m vs  -> killRange1 (MetaV m) vs-    Lam i f     -> killRange2 Lam i f-    Lit l       -> killRange1 Lit l-    Level l     -> killRange1 Level l-    Pi a b      -> killRange2 Pi a b-    Sort s      -> killRange1 Sort s-    DontCare mv -> killRange1 DontCare mv+    Var i vs    -> killRangeN (Var i) vs+    Def c vs    -> killRangeN Def c vs+    Con c ci vs -> killRangeN Con c ci vs+    MetaV m vs  -> killRangeN (MetaV m) vs+    Lam i f     -> killRangeN Lam i f+    Lit l       -> killRangeN Lit l+    Level l     -> killRangeN Level l+    Pi a b      -> killRangeN Pi a b+    Sort s      -> killRangeN Sort s+    DontCare mv -> killRangeN DontCare mv     v@Dummy{}   -> v  instance KillRange Level where-  killRange (Max n as) = killRange1 (Max n) as+  killRange (Max n as) = killRangeN (Max n) as  instance KillRange PlusLevel where-  killRange (Plus n l) = killRange1 (Plus n) l+  killRange (Plus n l) = killRangeN (Plus n) l  instance (KillRange a) => KillRange (Type' a) where-  killRange (El s v) = killRange2 El s v+  killRange (El s v) = killRangeN El s v  instance KillRange Sort where   killRange = \case-    Inf f n    -> Inf f n+    Inf u n    -> Inf u n     SizeUniv   -> SizeUniv     LockUniv   -> LockUniv-    Type a     -> killRange1 Type a-    Prop a     -> killRange1 Prop a-    SSet a     -> killRange1 SSet a-    PiSort a s1 s2 -> killRange3 PiSort a s1 s2-    FunSort s1 s2 -> killRange2 FunSort s1 s2-    UnivSort s -> killRange1 UnivSort s-    MetaS x es -> killRange1 (MetaS x) es-    DefS d es  -> killRange2 DefS d es+    LevelUniv  -> LevelUniv+    IntervalUniv -> IntervalUniv+    Univ u a   -> killRangeN (Univ u) a+    PiSort a s1 s2 -> killRangeN PiSort a s1 s2+    FunSort s1 s2 -> killRangeN FunSort s1 s2+    UnivSort s -> killRangeN UnivSort s+    MetaS x es -> killRangeN (MetaS x) es+    DefS d es  -> killRangeN DefS d es     s@DummyS{} -> s  instance KillRange Substitution where-  killRange IdS                  = IdS-  killRange (EmptyS err)         = EmptyS err-  killRange (Wk n rho)           = killRange1 (Wk n) rho-  killRange (t :# rho)           = killRange2 (:#) t rho-  killRange (Strengthen err rho) = killRange1 (Strengthen err) rho-  killRange (Lift n rho)         = killRange1 (Lift n) rho+  killRange IdS                    = IdS+  killRange (EmptyS err)           = EmptyS err+  killRange (Wk n rho)             = killRangeN (Wk n) rho+  killRange (t :# rho)             = killRangeN (:#) t rho+  killRange (Strengthen err n rho) = killRangeN (Strengthen err n) rho+  killRange (Lift n rho)           = killRangeN (Lift n) rho  instance KillRange PatOrigin where   killRange = id  instance KillRange PatternInfo where-  killRange (PatternInfo o xs) = killRange2 PatternInfo o xs+  killRange (PatternInfo o xs) = killRangeN PatternInfo o xs  instance KillRange ConPatternInfo where-  killRange (ConPatternInfo i mr b mt lz) = killRange1 (ConPatternInfo i mr b) mt lz+  killRange (ConPatternInfo i mr b mt lz) = killRangeN (ConPatternInfo i mr b) mt lz  instance KillRange DBPatVar where-  killRange (DBPatVar x i) = killRange2 DBPatVar x i+  killRange (DBPatVar x i) = killRangeN DBPatVar x i  instance KillRange a => KillRange (Pattern' a) where   killRange p =     case p of-      VarP o x         -> killRange2 VarP o x-      DotP o v         -> killRange2 DotP o v-      ConP con info ps -> killRange3 ConP con info ps-      LitP o l         -> killRange2 LitP o l-      ProjP o q        -> killRange1 (ProjP o) q-      IApplyP o u t x  -> killRange3 (IApplyP o) u t x-      DefP o q ps      -> killRange2 (DefP o) q ps+      VarP o x         -> killRangeN VarP o x+      DotP o v         -> killRangeN DotP o v+      ConP con info ps -> killRangeN ConP con info ps+      LitP o l         -> killRangeN LitP o l+      ProjP o q        -> killRangeN (ProjP o) q+      IApplyP o u t x  -> killRangeN (IApplyP o) u t x+      DefP o q ps      -> killRangeN (DefP o) q ps  instance KillRange Clause where-  killRange (Clause rl rf tel ps body t catchall exact recursive unreachable ell) =-    killRange10 Clause rl rf tel ps body t catchall exact recursive unreachable ell+  killRange (Clause rl rf tel ps body t catchall recursive unreachable ell wm) =+    killRangeN Clause rl rf tel ps body t catchall recursive unreachable ell wm  instance KillRange a => KillRange (Tele a) where   killRange = fmap killRange@@ -1241,12 +1324,16 @@   prettyPrec = pr     where     pr p rho = case rho of-      IdS              -> "idS"-      EmptyS err       -> "emptyS"-      t :# rho         -> mparens (p > 2) $ sep [ pr 2 rho <> ",", prettyPrec 3 t ]-      Strengthen _ rho -> mparens (p > 9) $ "strS" <+> pr 10 rho-      Wk n rho         -> mparens (p > 9) $ text ("wkS " ++ show n) <+> pr 10 rho-      Lift n rho       -> mparens (p > 9) $ text ("liftS " ++ show n) <+> pr 10 rho+      IdS                -> "idS"+      EmptyS err         -> "emptyS"+      t :# rho           -> mparens (p > 2) $+                            sep [ pr 2 rho <> ",", prettyPrec 3 t ]+      Strengthen _ n rho -> mparens (p > 9) $+                            text ("strS " ++ show n) <+> pr 10 rho+      Wk n rho           -> mparens (p > 9) $+                            text ("wkS " ++ show n) <+> pr 10 rho+      Lift n rho         -> mparens (p > 9) $+                            text ("liftS " ++ show n) <+> pr 10 rho  instance Pretty Term where   prettyPrec p v =@@ -1260,10 +1347,10 @@       Def q els            -> pretty q `pApp` els       Con c ci vs          -> pretty (conName c) `pApp` vs       Pi a (NoAbs _ b)     -> mparens (p > 0) $-        sep [ prettyPrec 1 (unDom a) <+> "->"+        sep [ pretty (getModality a) <+> prettyPrec 1 (unDom a) <+> "->"             , nest 2 $ pretty b ]       Pi a b               -> mparens (p > 0) $-        sep [ pDom (domInfo a) (text (absName b) <+> ":" <+> pretty (unDom a)) <+> "->"+        sep [ pDom (domInfo a) (pretty (getModality a) <+> text (absName b) <+> ":" <+> pretty (unDom a)) <+> "->"             , nest 2 $ pretty (unAbs b) ]       Sort s      -> prettyPrec p s       Level l     -> prettyPrec p l@@ -1279,10 +1366,12 @@   pretty (NoAbs x t) = "NoAbs" <+> (text x <> ".") <+> pretty t  instance (Pretty t, Pretty e) => Pretty (Dom' t e) where-  pretty dom = pTac <+> pDom dom (pretty $ unDom dom)+  pretty dom = pLock <+> pTac <+> pDom dom (pretty (getModality dom) <+> pretty (unDom dom))     where       pTac | Just t <- domTactic dom = "@" <> parens ("tactic" <+> pretty t)            | otherwise               = empty+      pLock | IsLock{} <- getLock dom = "@lock"+            | otherwise = empty  pDom :: LensHiding a => a -> Doc -> Doc pDom i =@@ -1327,21 +1416,16 @@ instance Pretty Sort where   prettyPrec p s =     case s of-      Type (ClosedLevel 0) -> "Set"-      Type (ClosedLevel n) -> text $ "Set" ++ show n-      Type l -> mparens (p > 9) $ "Set" <+> prettyPrec 10 l-      Prop (ClosedLevel 0) -> "Prop"-      Prop (ClosedLevel n) -> text $ "Prop" ++ show n-      Prop l -> mparens (p > 9) $ "Prop" <+> prettyPrec 10 l-      Inf f 0 -> text $ addS f "Setω"-      Inf f n -> text $ addS f "Setω" ++ show n-      SSet l -> mparens (p > 9) $ "SSet" <+> prettyPrec 10 l+      Univ u (ClosedLevel n) -> text $ suffix n $ showUniv u+      Univ u l -> mparens (p > 9) $ text (showUniv u) <+> prettyPrec 10 l+      Inf u n -> text $ suffix n $ showUniv u ++ "ω"       SizeUniv -> "SizeUniv"       LockUniv -> "LockUniv"+      LevelUniv -> "LevelUniv"+      IntervalUniv -> "IntervalUniv"       PiSort a s1 s2 -> mparens (p > 9) $-        "piSort" <+> pDom (domInfo a) (text (absName s2) <+> ":" <+> pretty (unDom a))-                      <+> parens (sep [ text ("λ " ++ absName s2 ++ " ->")-                                      , nest 2 $ pretty (unAbs s2) ])+        "piSort" <+> pDom (domInfo a) (text (absName s2) <+> ":" <+> pretty (unDom a) <+> ":" <+> pretty s1)+                      <+> parens (pretty (unAbs s2))       FunSort a b -> mparens (p > 9) $         "funSort" <+> prettyPrec 10 a <+> prettyPrec 10 b       UnivSort s -> mparens (p > 9) $ "univSort" <+> prettyPrec 10 s@@ -1349,8 +1433,7 @@       DefS d es  -> prettyPrec p $ Def d es       DummyS s   -> parens $ text s    where-     addS IsFibrant t = t-     addS IsStrict  t = "S" ++ t+     suffix n = applyWhen (n /= 0) (++ show n)  instance Pretty Type where   prettyPrec p (El _ a) = prettyPrec p a@@ -1380,6 +1463,12 @@   prettyPrec n (IApplyP _o _ _ x) = prettyPrec n x --  prettyPrec n (IApplyP _o u0 u1 x) = text "@[" <> prettyPrec 0 u0 <> text ", " <> prettyPrec 0 u1 <> text "]" <> prettyPrec n x +instance Pretty a => Pretty (Blocked a) where+  pretty = \case+    NotBlocked ReallyNotBlocked a -> pretty a+    NotBlocked nb a -> pretty a <+> ("[ blocked on" <+> pretty nb <+> "]")+    Blocked     b a -> pretty a <+> ("[ stuck on" <+> pretty  b <+> "]")+ ----------------------------------------------------------------------------- -- * NFData instances -----------------------------------------------------------------------------@@ -1405,12 +1494,12 @@  instance NFData Sort where   rnf = \case-    Type l   -> rnf l-    Prop l   -> rnf l+    Univ _ l   -> rnf l     Inf _ _  -> ()-    SSet l   -> rnf l     SizeUniv -> ()     LockUniv -> ()+    LevelUniv -> ()+    IntervalUniv -> ()     PiSort a b c -> rnf (a, b, unAbs c)     FunSort a b -> rnf (a, b)     UnivSort a -> rnf a@@ -1425,9 +1514,9 @@   rnf (Plus n l) = rnf (n, l)  instance NFData e => NFData (Dom e) where-  rnf (Dom a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e+  rnf (Dom a c d e f) = rnf a `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f -instance NFData DataOrRecord+instance NFData a => NFData (DataOrRecord' a) instance NFData ConHead instance NFData a => NFData (Abs a) instance NFData a => NFData (Tele a)
src/full/Agda/Syntax/Internal/Blockers.hs view
@@ -3,7 +3,6 @@  import Control.DeepSeq -import Data.Data (Data) import Data.Set (Set) import qualified Data.Set as Set import Data.Semigroup@@ -11,9 +10,10 @@ import GHC.Generics (Generic)  import Agda.Syntax.Common+import Agda.Syntax.Abstract.Name (QName) import Agda.Syntax.Internal.Elim -import Agda.Utils.Pretty hiding ((<>))+import Agda.Syntax.Common.Pretty hiding ((<>)) import Agda.Utils.Functor  ---------------------------------------------------------------------------@@ -30,8 +30,8 @@     -- ^ Not enough arguments were supplied to complete the matching.   | AbsurdMatch     -- ^ We matched an absurd clause, results in a neutral 'Def'.-  | MissingClauses-    -- ^ We ran out of clauses, all considered clauses+  | MissingClauses QName+    -- ^ We ran out of clauses for 'QName', all considered clauses     --   produced an actual mismatch.     --   This can happen when try to reduce a function application     --   but we are still missing some function clauses.@@ -39,7 +39,7 @@   | ReallyNotBlocked     -- ^ Reduction was not blocked, we reached a whnf     --   which can be anything but a stuck @'Def'@.-  deriving (Show, Data, Generic)+  deriving (Show, Generic)  -- | 'ReallyNotBlocked' is the unit. --   'MissingClauses' is dominant.@@ -47,8 +47,8 @@ instance Semigroup (NotBlocked' t) where   ReallyNotBlocked <> b = b   -- MissingClauses is dominant (absorptive)-  b@MissingClauses <> _ = b-  _ <> b@MissingClauses = b+  b@MissingClauses{} <> _ = b+  _ <> b@MissingClauses{} = b   -- StuckOn is second strongest   b@StuckOn{}      <> _ = b   _ <> b@StuckOn{}      = b@@ -61,13 +61,22 @@  instance NFData t => NFData (NotBlocked' t) +instance Pretty t => Pretty (NotBlocked' t) where+  pretty = \case+    StuckOn e        -> "elimination" <+> pretty e+    Underapplied     -> "missing elimination (underapplied)"+    AbsurdMatch      -> "absurd match"+    MissingClauses x -> "missing clause for" <+> pretty x+    ReallyNotBlocked -> "(not stuck)"+ -- | What is causing the blocking? Or in other words which metas or problems need to be solved to --   unblock the blocked computation/constraint. data Blocker = UnblockOnAll (Set Blocker)              | UnblockOnAny (Set Blocker)              | UnblockOnMeta MetaId     -- ^ Unblock if meta is instantiated              | UnblockOnProblem ProblemId-  deriving (Data, Show, Eq, Ord, Generic)+             | UnblockOnDef QName       -- ^ Unblock when function is defined+  deriving (Show, Eq, Ord, Generic)  instance NFData Blocker @@ -101,12 +110,18 @@ unblockOnEither :: Blocker -> Blocker -> Blocker unblockOnEither a b = unblockOnAny $ Set.fromList [a, b] +unblockOnBoth :: Blocker -> Blocker -> Blocker+unblockOnBoth a b = unblockOnAll $ Set.fromList [a, b]+ unblockOnMeta :: MetaId -> Blocker unblockOnMeta = UnblockOnMeta  unblockOnProblem :: ProblemId -> Blocker unblockOnProblem = UnblockOnProblem +unblockOnDef :: QName -> Blocker+unblockOnDef = UnblockOnDef+ unblockOnAllMetas :: Set MetaId -> Blocker unblockOnAllMetas = unblockOnAll . Set.mapMonotonic unblockOnMeta @@ -118,39 +133,52 @@ onBlockingMetasM f (UnblockOnAny bs)    = unblockOnAny . Set.fromList <$> mapM (onBlockingMetasM f) (Set.toList bs) onBlockingMetasM f (UnblockOnMeta x)    = f x onBlockingMetasM f b@UnblockOnProblem{} = pure b+onBlockingMetasM f b@UnblockOnDef{}     = pure b  allBlockingMetas :: Blocker -> Set MetaId allBlockingMetas (UnblockOnAll us)  = Set.unions $ map allBlockingMetas $ Set.toList us allBlockingMetas (UnblockOnAny us)  = Set.unions $ map allBlockingMetas $ Set.toList us allBlockingMetas (UnblockOnMeta x)  = Set.singleton x allBlockingMetas UnblockOnProblem{} = Set.empty+allBlockingMetas UnblockOnDef{}     = Set.empty  allBlockingProblems :: Blocker -> Set ProblemId allBlockingProblems (UnblockOnAll us)    = Set.unions $ map allBlockingProblems $ Set.toList us allBlockingProblems (UnblockOnAny us)    = Set.unions $ map allBlockingProblems $ Set.toList us allBlockingProblems UnblockOnMeta{}      = Set.empty allBlockingProblems (UnblockOnProblem p) = Set.singleton p+allBlockingProblems UnblockOnDef{}       = Set.empty --- Note: We pick the All rather than the Any as the semigroup instance.+allBlockingDefs :: Blocker -> Set QName+allBlockingDefs (UnblockOnAll us)  = Set.unions $ map allBlockingDefs $ Set.toList us+allBlockingDefs (UnblockOnAny us)  = Set.unions $ map allBlockingDefs $ Set.toList us+allBlockingDefs UnblockOnMeta{}    = Set.empty+allBlockingDefs UnblockOnProblem{} = Set.empty+allBlockingDefs (UnblockOnDef q)   = Set.singleton q++{- There are two possible instances of Semigroup, so we don't commit+   to either one. instance Semigroup Blocker where   x <> y = unblockOnAll $ Set.fromList [x, y]  instance Monoid Blocker where   mempty = alwaysUnblock   mappend = (<>)+-}  instance Pretty Blocker where   pretty (UnblockOnAll us)      = "all" <> parens (fsep $ punctuate "," $ map pretty $ Set.toList us)   pretty (UnblockOnAny us)      = "any" <> parens (fsep $ punctuate "," $ map pretty $ Set.toList us)   pretty (UnblockOnMeta m)      = pretty m   pretty (UnblockOnProblem pid) = "problem" <+> pretty pid+  pretty (UnblockOnDef q)       = "definition" <+> pretty q  -- | Something where a meta variable may block reduction. Notably a top-level meta is considered --   blocking. This did not use to be the case (pre Aug 2020). data Blocked' t a   = Blocked    { theBlocker      :: Blocker,       ignoreBlocking :: a }   | NotBlocked { blockingStatus  :: NotBlocked' t, ignoreBlocking :: a }-  deriving (Data, Show, Functor, Foldable, Traversable, Generic)+  deriving (Show, Functor, Foldable, Traversable, Generic)  instance Decoration (Blocked' t) where   traverseF f (Blocked b x)     = Blocked b <$> f x@@ -162,7 +190,7 @@   f <*> e = ((f $> ()) `mappend` (e $> ())) $> ignoreBlocking f (ignoreBlocking e)  instance Semigroup a => Semigroup (Blocked' t a) where-  Blocked x a    <> Blocked y b    = Blocked (x <> y) (a <> b)+  Blocked x a    <> Blocked y b    = Blocked (unblockOnBoth x y) (a <> b)   b@Blocked{}    <> NotBlocked{}   = b   NotBlocked{}   <> b@Blocked{}    = b   NotBlocked x a <> NotBlocked y b = NotBlocked (x <> y) (a <> b)@@ -198,10 +226,9 @@ --   (Missing ordinary pattern would mean the @e@ is of function type, --   but we cannot match against something of function type.) stuckOn :: Elim' t -> NotBlocked' t -> NotBlocked' t-stuckOn e r =-  case r of-    MissingClauses   -> r-    StuckOn{}        -> r+stuckOn e = \case+    r@MissingClauses{} -> r+    r@StuckOn{}        -> r     Underapplied     -> r'     AbsurdMatch      -> r'     ReallyNotBlocked -> r'@@ -227,6 +254,10 @@ notBlocked_ :: Blocked' t () notBlocked_ = notBlocked () +getBlocker :: Blocked' t a -> Blocker+getBlocker (Blocked b _) = b+getBlocker NotBlocked{}  = neverUnblock+ ----------------------------------------------------------------------------- -- * Waking up logic -----------------------------------------------------------------------------@@ -256,10 +287,18 @@   where     u' = unblockMeta x u +wakeIfBlockedOnDef :: QName -> Blocker -> WakeUp+wakeIfBlockedOnDef q u+  | u' == alwaysUnblock = WakeUp+  | otherwise           = DontWakeUp (Just u')+  where+    u' = unblockDef q u+ unblockMeta :: MetaId -> Blocker -> Blocker unblockMeta x u@(UnblockOnMeta y) | x == y    = alwaysUnblock                                   | otherwise = u unblockMeta _ u@UnblockOnProblem{} = u+unblockMeta _ u@UnblockOnDef{}     = u unblockMeta x (UnblockOnAll us)    = unblockOnAll $ Set.map (unblockMeta x) us unblockMeta x (UnblockOnAny us)    = unblockOnAny $ Set.map (unblockMeta x) us @@ -267,5 +306,14 @@ unblockProblem p u@(UnblockOnProblem q) | p == q    = alwaysUnblock                                         | otherwise = u unblockProblem _ u@UnblockOnMeta{} = u+unblockProblem _ u@UnblockOnDef{}  = u unblockProblem p (UnblockOnAll us) = unblockOnAll $ Set.map (unblockProblem p) us unblockProblem p (UnblockOnAny us) = unblockOnAny $ Set.map (unblockProblem p) us++unblockDef :: QName -> Blocker -> Blocker+unblockDef q u@(UnblockOnDef q') | q == q'   = alwaysUnblock+                                 | otherwise = u+unblockDef q u@UnblockOnMeta{} = u+unblockDef q u@UnblockOnProblem{} = u+unblockDef q (UnblockOnAll us) = unblockOnAll $ Set.map (unblockDef q) us+unblockDef q (UnblockOnAny us) = unblockOnAny $ Set.map (unblockDef q) us
src/full/Agda/Syntax/Internal/Defs.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Extract used definitions from terms. @@ -75,12 +76,12 @@  instance GetDefs Sort where   getDefs = \case-    Type l    -> getDefs l-    Prop l    -> getDefs l+    Univ _ l  -> getDefs l     Inf _ _   -> return ()-    SSet l    -> getDefs l     SizeUniv  -> return ()     LockUniv  -> return ()+    LevelUniv -> return ()+    IntervalUniv -> return ()     PiSort a s1 s2 -> getDefs a >> getDefs s1 >> getDefs s2     FunSort s1 s2 -> getDefs s1 >> getDefs s2     UnivSort s  -> getDefs s@@ -105,3 +106,11 @@  instance (GetDefs a, GetDefs b) => GetDefs (a,b) where   getDefs (a,b) = getDefs a >> getDefs b++instance GetDefs Telescope where+  getDefs = getDefs . telToList++-- no defs here++instance {-# OVERLAPPING #-} GetDefs String where+  getDefs _ = return ()
src/full/Agda/Syntax/Internal/Elim.hs view
@@ -1,15 +1,14 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Syntax.Internal.Elim where  import Control.DeepSeq-import Data.Data (Data)  import Agda.Syntax.Common-import Agda.Syntax.Concrete.Pretty () -- Pretty Arg instance import Agda.Syntax.Position import Agda.Syntax.Abstract.Name -import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.Empty import Agda.Utils.Maybe import Agda.Utils.Tuple@@ -20,7 +19,7 @@   = Apply (Arg a)         -- ^ Application.   | Proj ProjOrigin QName -- ^ Projection.  'QName' is name of a record projection.   | IApply a a a -- ^ IApply x y r, x and y are the endpoints-  deriving (Data, Show, Functor, Foldable, Traversable)+  deriving (Show, Functor, Foldable, Traversable)  -- | This instance cheats on 'Proj', use with care. --   'Proj's are always assumed to be 'UserWritten', since they have no 'ArgInfo'.@@ -42,6 +41,13 @@ isApplyElim' :: Empty -> Elim' a -> Arg a isApplyElim' e = fromMaybe (absurd e) . isApplyElim +-- | Only 'Apply' variant.+isProperApplyElim :: Elim' a -> Bool+isProperApplyElim = \case+  Apply _  -> True+  IApply{} -> False+  Proj{}   -> False+ -- | Drop 'Apply' constructors. (Safe) allApplyElims :: [Elim' a] -> Maybe [Arg a] allApplyElims = mapM isApplyElim@@ -80,4 +86,3 @@   rnf (Apply x) = rnf x   rnf Proj{}    = ()   rnf (IApply x y r) = rnf x `seq` rnf y `seq` rnf r-
src/full/Agda/Syntax/Internal/Generic.hs view
@@ -1,15 +1,12 @@-{-# LANGUAGE CPP          #-}  -- | Tree traversal for internal syntax.  module Agda.Syntax.Internal.Generic where -#if __GLASGOW_HASKELL__ < 804-import Data.Monoid ((<>))-#endif import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Utils.Functor+import Agda.Utils.List1 (List1)  -- | Generic term traversal. --@@ -61,6 +58,7 @@ instance TermLike a => TermLike (Arg a)        where instance TermLike a => TermLike (Dom a)        where instance TermLike a => TermLike [a]            where+instance TermLike a => TermLike (List1 a)      where instance TermLike a => TermLike (Maybe a)      where instance TermLike a => TermLike (Blocked a)    where instance TermLike a => TermLike (Abs a)        where@@ -96,7 +94,7 @@     t@Lit{}     -> f t     Sort s      -> f =<< Sort <$> traverseTermM f s     DontCare mv -> f =<< DontCare <$> traverseTermM f mv-    t@Dummy{}   -> f t+    Dummy s xs  -> f =<< Dummy s <$> traverseTermM f xs    foldTerm f t = f t `mappend` case t of     Var i xs    -> foldTerm f xs@@ -109,7 +107,7 @@     Lit _       -> mempty     Sort s      -> foldTerm f s     DontCare mv -> foldTerm f mv-    Dummy{}     -> mempty+    Dummy _ xs  -> foldTerm f xs  instance TermLike Level where   traverseTermM f (Max n as) = Max n <$> traverseTermM f as@@ -125,32 +123,32 @@  instance TermLike Sort where   traverseTermM f = \case-    Type l     -> Type <$> traverseTermM f l-    Prop l     -> Prop <$> traverseTermM f l+    Univ u l   -> Univ u <$> traverseTermM f l     s@(Inf _ _)-> pure s-    SSet l     -> SSet <$> traverseTermM f l     s@SizeUniv -> pure s     s@LockUniv -> pure s+    s@LevelUniv -> pure s+    s@IntervalUniv -> pure s     PiSort a b c -> PiSort   <$> traverseTermM f a <*> traverseTermM f b <*> traverseTermM f c     FunSort a b -> FunSort   <$> traverseTermM f a <*> traverseTermM f b     UnivSort a -> UnivSort <$> traverseTermM f a     MetaS x es -> MetaS x  <$> traverseTermM f es     DefS q es  -> DefS q   <$> traverseTermM f es-    s@DummyS{} -> pure s+    s@(DummyS _) -> pure s    foldTerm f = \case-    Type l     -> foldTerm f l-    Prop l     -> foldTerm f l+    Univ _ l   -> foldTerm f l     Inf _ _    -> mempty-    SSet l     -> foldTerm f l     SizeUniv   -> mempty     LockUniv   -> mempty+    LevelUniv  -> mempty+    IntervalUniv -> mempty     PiSort a b c -> foldTerm f a <> foldTerm f b <> foldTerm f c     FunSort a b -> foldTerm f a <> foldTerm f b     UnivSort a -> foldTerm f a     MetaS _ es -> foldTerm f es     DefS _ es  -> foldTerm f es-    DummyS{}   -> mempty+    DummyS _   -> mempty  instance TermLike EqualityView where @@ -159,7 +157,7 @@       <$> traverseTermM f t     IdiomType t -> IdiomType       <$> traverseTermM f t-    EqualityType s eq l t a b -> EqualityType s eq+    EqualityType r s eq l t a b -> EqualityType r s eq       <$> traverse (traverseTermM f) l       <*> traverseTermM f t       <*> traverseTermM f a@@ -168,7 +166,7 @@   foldTerm f = \case     OtherType t -> foldTerm f t     IdiomType t -> foldTerm f t-    EqualityType s eq l t a b -> foldTerm f (l ++ [t, a, b])+    EqualityType _r _s _eq l t a b -> foldTerm f (l ++ [t, a, b])  -- | Put it in a monad to make it possible to do strictly. copyTerm :: (TermLike a, Monad m) => a -> m a
src/full/Agda/Syntax/Internal/MetaVars.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Syntax.Internal.MetaVars where @@ -23,13 +24,18 @@ instance AllMetas Type instance TermLike a => AllMetas (Elim' a) instance TermLike a => AllMetas (Tele a)-instance TermLike a => AllMetas (Dom a) +instance (AllMetas a, AllMetas b) => AllMetas (Dom' a b) where+  allMetas f (Dom _ _ _ t e) = allMetas f t <> allMetas f e+ -- These types need to be packed up as a Term to get the metas. instance AllMetas Sort      where allMetas f   = allMetas f . Sort instance AllMetas Level     where allMetas f   = allMetas f . Level instance AllMetas PlusLevel where allMetas f l = allMetas f (Max 0 [l]) +instance {-# OVERLAPPING #-} AllMetas String where+  allMetas f _ = mempty+ -- Generic instances instance (AllMetas a, AllMetas b) => AllMetas (a, b) where   allMetas f (x, y) = allMetas f x <> allMetas f y@@ -51,12 +57,12 @@   metas (Sort s)    = sortMetas s   metas _           = mempty -  sortMetas Type{}        = mempty-  sortMetas Prop{}        = mempty-  sortMetas SSet{}        = mempty+  sortMetas Univ{}        = mempty   sortMetas Inf{}         = mempty   sortMetas SizeUniv{}    = mempty   sortMetas LockUniv{}    = mempty+  sortMetas LevelUniv     = mempty+  sortMetas IntervalUniv{} = mempty   sortMetas (PiSort _ s1 s2)  = sortMetas s1 <> sortMetas (unAbs s2)  -- the domain is a term so is covered by the fold   sortMetas (FunSort a b) = sortMetas a <> sortMetas b   sortMetas (UnivSort s)  = sortMetas s
src/full/Agda/Syntax/Internal/Names.hs view
@@ -1,9 +1,10 @@+{-# OPTIONS_GHC -Wunused-imports #-} --- | Extract all names from things.+-- | Extract all names and meta-variables from things.  module Agda.Syntax.Internal.Names where -import Data.List.NonEmpty (NonEmpty(..))+import Data.HashMap.Strict (HashMap) import Data.Map (Map) import Data.Set (Set) @@ -12,206 +13,384 @@ import Agda.Syntax.Internal import qualified Agda.Syntax.Concrete as C import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Treeless  import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.CompiledClause +import Agda.Utils.List1 (List1)+import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Singleton import Agda.Utils.Impossible +-- | Some or all of the 'QName's that can be found in the given thing.+ namesIn :: (NamesIn a, Collection QName m) => a -> m namesIn = namesIn' singleton +-- | Some or all of the 'QName's that can be found in the given thing.++namesIn' :: (NamesIn a, Monoid m) => (QName -> m) -> a -> m+namesIn' f = namesAndMetasIn' (either f mempty)++-- | Some or all of the meta-variables that can be found in the given+-- thing.++metasIn :: (NamesIn a, Collection MetaId m) => a -> m+metasIn = metasIn' singleton++-- | Some or all of the meta-variables that can be found in the given+-- thing.++-- TODO: Does this function make+-- Agda.Syntax.Internal.MetaVars.allMetas superfluous? Maybe not,+-- allMetas ignores the first argument of PiSort.++metasIn' :: (NamesIn a, Monoid m) => (MetaId -> m) -> a -> m+metasIn' f = namesAndMetasIn' (either mempty f)++-- | Some or all of the names and meta-variables that can be found in+-- the given thing.++namesAndMetasIn ::+  (NamesIn a, Collection QName m1, Collection MetaId m2) =>+  a -> (m1, m2)+namesAndMetasIn =+  namesAndMetasIn'+    (either (\x -> (singleton x, mempty))+            (\m -> (mempty, singleton m)))+ class NamesIn a where-  namesIn' :: Monoid m => (QName -> m) -> a -> m+  -- | Some or all of the names and meta-variables that can be found+  -- in the given thing.+  namesAndMetasIn' :: Monoid m => (Either QName MetaId -> m) -> a -> m -  default namesIn' :: (Monoid m, Foldable f, NamesIn b, f b ~ a) => (QName -> m) -> a -> m-  namesIn' = foldMap . namesIn'+  default namesAndMetasIn' ::+    (Monoid m, Foldable f, NamesIn b, f b ~ a) =>+    (Either QName MetaId -> m) -> a -> m+  namesAndMetasIn' = foldMap . namesAndMetasIn'  -- Generic collections instance NamesIn a => NamesIn (Maybe a)+instance NamesIn a => NamesIn (Strict.Maybe a) instance NamesIn a => NamesIn [a]-instance NamesIn a => NamesIn (NonEmpty a)+instance NamesIn a => NamesIn (List1 a) instance NamesIn a => NamesIn (Set a) instance NamesIn a => NamesIn (Map k a)  -- Decorations instance NamesIn a => NamesIn (Arg a)-instance NamesIn a => NamesIn (Dom a) instance NamesIn a => NamesIn (Named n a) instance NamesIn a => NamesIn (Abs a) instance NamesIn a => NamesIn (WithArity a) instance NamesIn a => NamesIn (Open a) instance NamesIn a => NamesIn (C.FieldAssignment' a) +instance (NamesIn a, NamesIn b) => NamesIn (Dom' a b) where+  namesAndMetasIn' sg (Dom _ _ _ t e) =+    mappend (namesAndMetasIn' sg t) (namesAndMetasIn' sg e)++ -- Specific collections instance NamesIn a => NamesIn (Tele a)  -- Tuples  instance (NamesIn a, NamesIn b) => NamesIn (a, b) where-  namesIn' sg (x, y) = mappend (namesIn' sg x) (namesIn' sg y)+  namesAndMetasIn' sg (x, y) =+    namesAndMetasIn' sg x <> namesAndMetasIn' sg y+  {-# INLINE namesAndMetasIn' #-}  instance (NamesIn a, NamesIn b, NamesIn c) => NamesIn (a, b, c) where-  namesIn' sg (x, y, z) = namesIn' sg (x, (y, z))+  namesAndMetasIn' sg (x, y, z) =+    namesAndMetasIn' sg x <> namesAndMetasIn' sg y <> namesAndMetasIn' sg z+  {-# INLINE namesAndMetasIn' #-}  instance (NamesIn a, NamesIn b, NamesIn c, NamesIn d) => NamesIn (a, b, c, d) where-  namesIn' sg (x, y, z, u) = namesIn' sg ((x, y), (z, u))+  namesAndMetasIn' sg (x, y, z, u) =+    namesAndMetasIn' sg x <> namesAndMetasIn' sg y <> namesAndMetasIn' sg z <> namesAndMetasIn' sg u+  {-# INLINE namesAndMetasIn' #-} +instance+  (NamesIn a, NamesIn b, NamesIn c, NamesIn d, NamesIn e) =>+  NamesIn (a, b, c, d, e) where+  namesAndMetasIn' sg (x, y, z, u, v) =+    namesAndMetasIn' sg x <> namesAndMetasIn' sg y <> namesAndMetasIn' sg z <> namesAndMetasIn' sg u+    <> namesAndMetasIn' sg v+  {-# INLINE namesAndMetasIn' #-}++instance+  (NamesIn a, NamesIn b, NamesIn c, NamesIn d, NamesIn e, NamesIn f) =>+  NamesIn (a, b, c, d, e, f) where+  namesAndMetasIn' sg (x, y, z, u, v, w) =+    namesAndMetasIn' sg x <> namesAndMetasIn' sg y <> namesAndMetasIn' sg z <> namesAndMetasIn' sg u+    <> namesAndMetasIn' sg v <> namesAndMetasIn' sg w+  {-# INLINE namesAndMetasIn' #-}+ instance NamesIn CompKit where-  namesIn' sg (CompKit a b) = namesIn' sg (a,b)+  namesAndMetasIn' sg (CompKit a b) = namesAndMetasIn' sg (a,b) --- Base case+-- Base cases  instance NamesIn QName where-  namesIn' sg x = sg x  -- interesting case!+  namesAndMetasIn' sg x = sg (Left x)  -- interesting case! +instance NamesIn MetaId where+  namesAndMetasIn' sg x = sg (Right x)+ instance NamesIn ConHead where-  namesIn' sg h = namesIn' sg (conName h)+  namesAndMetasIn' sg h = namesAndMetasIn' sg (conName h) +instance NamesIn Bool where+  namesAndMetasIn' _ _ = mempty+ -- Andreas, 2017-07-27 -- In the following clauses, the choice of fields is not obvious -- to the reader.  Please comment on the choices.------ Also, this would be more robust if these were constructor-style--- matches instead of record-style matches.--- If someone adds a field containing names, this would go unnoticed.  instance NamesIn Definition where-  namesIn' sg def = namesIn' sg (defType def, theDef def, defDisplay def)+  namesAndMetasIn' sg+    (Defn _ _ t _ _ _ disp _ _ _ _ _ _ _ _ _ _ def) =+    namesAndMetasIn' sg (t, def, disp)  instance NamesIn Defn where-  namesIn' sg = \case+  namesAndMetasIn' sg = \case     Axiom _            -> mempty-    DataOrRecSig{}     -> mempty-    GeneralizableVar{} -> mempty-    PrimitiveSort{}    -> mempty+    DataOrRecSig _     -> mempty+    GeneralizableVar _ -> mempty+    PrimitiveSort _ s  -> namesAndMetasIn' sg s     AbstractDefn{}     -> __IMPOSSIBLE__     -- Andreas 2017-07-27, Q: which names can be in @cc@ which are not already in @cl@?-    Function    { funClauses = cl, funCompiled = cc }-      -> namesIn' sg (cl, cc)-    Datatype    { dataClause = cl, dataCons = cs, dataSort = s }-      -> namesIn' sg (cl, cs, s)-    Record      { recClause = cl, recConHead = c, recFields = fs, recComp = comp }-      -> namesIn' sg (cl, c, fs, comp)-      -- Don't need recTel since those will be reachable from the constructor-    Constructor { conSrcCon = c, conData = d, conComp = kit, conProj = fs }-      -> namesIn' sg (c, d, kit, fs)-    Primitive   { primClauses = cl, primCompiled = cc }-      -> namesIn' sg (cl, cc)+    Function cl cc _ _ _ _ _ _ _ _ el _ _ _+      -> namesAndMetasIn' sg (cl, cc, el)+    Datatype _ _ cl cs s _ _ _ trX trD+      -> namesAndMetasIn' sg (cl, cs, s, trX, trD)+    Record _ cl c _ fs recTel _ _ _ _ _ _ comp+      -> namesAndMetasIn' sg (cl, c, fs, recTel, comp)+    Constructor _ _ c d _ kit fs _ _ _ _+      -> namesAndMetasIn' sg (c, d, kit, fs)+    Primitive _ _ cl _ cc _+      -> namesAndMetasIn' sg (cl, cc)  instance NamesIn Clause where-  namesIn' sg Clause{ clauseTel = tel, namedClausePats = ps, clauseBody = b, clauseType = t } =-    namesIn' sg (tel, ps, b, t)+  namesAndMetasIn' sg (Clause _ _ tel ps b t _ _ _ _ _) =+    namesAndMetasIn' sg (tel, ps, b, t)  instance NamesIn CompiledClauses where-  namesIn' sg (Case _ c) = namesIn' sg c-  namesIn' sg (Done _ v) = namesIn' sg v-  namesIn' sg Fail{}     = mempty+  namesAndMetasIn' sg (Case _ c) = namesAndMetasIn' sg c+  namesAndMetasIn' sg (Done _ v) = namesAndMetasIn' sg v+  namesAndMetasIn' sg (Fail _)   = mempty  -- Andreas, 2017-07-27 -- Why ignoring the litBranches? instance NamesIn a => NamesIn (Case a) where-  namesIn' sg Branches{ conBranches = bs, catchAllBranch = c } =-    namesIn' sg (bs, c)+  namesAndMetasIn' sg (Branches _ bs _ _ c _ _) =+    namesAndMetasIn' sg (bs, c)  instance NamesIn (Pattern' a) where-  namesIn' sg = \case-    VarP{}          -> mempty-    LitP _ l        -> namesIn' sg l-    DotP _ v        -> namesIn' sg v-    ConP c _ args   -> namesIn' sg (c, args)-    DefP o q args   -> namesIn' sg (q, args)-    ProjP _ f       -> namesIn' sg f-    IApplyP _ t u _ -> namesIn' sg (t, u)+  namesAndMetasIn' sg = \case+    VarP _ _        -> mempty+    LitP _ l        -> namesAndMetasIn' sg l+    DotP _ v        -> namesAndMetasIn' sg v+    ConP c cpi args -> namesAndMetasIn' sg (c, cpi, args)+    DefP o q args   -> namesAndMetasIn' sg (q, args)+    ProjP _ f       -> namesAndMetasIn' sg f+    IApplyP _ t u _ -> namesAndMetasIn' sg (t, u)  instance NamesIn a => NamesIn (Type' a) where-  namesIn' sg (El s t) = namesIn' sg (s, t)+  namesAndMetasIn' sg (El s t) = namesAndMetasIn' sg (s, t)  instance NamesIn Sort where-  namesIn' sg = \case-    Type l      -> namesIn' sg l-    Prop l      -> namesIn' sg l+  namesAndMetasIn' sg = \case+    Univ _ l    -> namesAndMetasIn' sg l     Inf _ _     -> mempty-    SSet l      -> namesIn' sg l     SizeUniv    -> mempty     LockUniv    -> mempty-    PiSort a b c  -> namesIn' sg (a, b, c)-    FunSort a b -> namesIn' sg (a, b)-    UnivSort a  -> namesIn' sg a-    MetaS _ es  -> namesIn' sg es-    DefS d es   -> namesIn' sg (d, es)-    DummyS{}    -> mempty+    LevelUniv   -> mempty+    IntervalUniv -> mempty+    PiSort a b c  -> namesAndMetasIn' sg (a, b, c)+    FunSort a b -> namesAndMetasIn' sg (a, b)+    UnivSort a  -> namesAndMetasIn' sg a+    MetaS x es  -> namesAndMetasIn' sg (x, es)+    DefS d es   -> namesAndMetasIn' sg (d, es)+    DummyS _    -> mempty  instance NamesIn Term where-  namesIn' sg = \case-    Var _ args   -> namesIn' sg args-    Lam _ b      -> namesIn' sg b-    Lit l        -> namesIn' sg l-    Def f args   -> namesIn' sg (f, args)-    Con c _ args -> namesIn' sg (c, args)-    Pi a b       -> namesIn' sg (a, b)-    Sort s       -> namesIn' sg s-    Level l      -> namesIn' sg l-    MetaV _ args -> namesIn' sg args-    DontCare v   -> namesIn' sg v-    Dummy{}      -> mempty+  namesAndMetasIn' sg = \case+    Var _ args   -> namesAndMetasIn' sg args+    Lam _ b      -> namesAndMetasIn' sg b+    Lit l        -> namesAndMetasIn' sg l+    Def f args   -> namesAndMetasIn' sg (f, args)+    Con c _ args -> namesAndMetasIn' sg (c, args)+    Pi a b       -> namesAndMetasIn' sg (a, b)+    Sort s       -> namesAndMetasIn' sg s+    Level l      -> namesAndMetasIn' sg l+    MetaV x args -> namesAndMetasIn' sg (x, args)+    DontCare v   -> namesAndMetasIn' sg v+    Dummy _ args -> namesAndMetasIn' sg args  instance NamesIn Level where-  namesIn' sg (Max _ ls) = namesIn' sg ls+  namesAndMetasIn' sg (Max _ ls) = namesAndMetasIn' sg ls  instance NamesIn PlusLevel where-  namesIn' sg (Plus _ l) = namesIn' sg l+  namesAndMetasIn' sg (Plus _ l) = namesAndMetasIn' sg l --- For QName literals!+-- For QName and Meta literals! instance NamesIn Literal where-  namesIn' sg = \case-    LitNat{}      -> mempty-    LitWord64{}   -> mempty-    LitString{}   -> mempty-    LitChar{}     -> mempty-    LitFloat{}    -> mempty-    LitQName    x -> namesIn' sg x-    LitMeta{}     -> mempty+  namesAndMetasIn' sg = \case+    LitNat _    -> mempty+    LitWord64 _ -> mempty+    LitString _ -> mempty+    LitChar _   -> mempty+    LitFloat _  -> mempty+    LitQName x  -> namesAndMetasIn' sg x+    LitMeta _ m -> namesAndMetasIn' sg m  instance NamesIn a => NamesIn (Elim' a) where-  namesIn' sg (Apply arg)      = namesIn' sg arg-  namesIn' sg (Proj _ f)       = namesIn' sg f-  namesIn' sg (IApply x y arg) = namesIn' sg (x, y, arg)+  namesAndMetasIn' sg (Apply arg)      = namesAndMetasIn' sg arg+  namesAndMetasIn' sg (Proj _ f)       = namesAndMetasIn' sg f+  namesAndMetasIn' sg (IApply x y arg) = namesAndMetasIn' sg (x, y, arg) +instance NamesIn a => NamesIn (Substitution' a) where+  namesAndMetasIn' sg = \case+    IdS              -> mempty+    EmptyS _         -> mempty+    t :# s           -> namesAndMetasIn' sg (t, s)+    Strengthen _ _ s -> namesAndMetasIn' sg s+    Wk _ s           -> namesAndMetasIn' sg s+    Lift _ s         -> namesAndMetasIn' sg s+ instance NamesIn DisplayForm where-  namesIn' sg (Display _ ps v) = namesIn' sg (ps, v)+  namesAndMetasIn' sg (Display _ ps v) = namesAndMetasIn' sg (ps, v)  instance NamesIn DisplayTerm where-  namesIn' sg = \case-    DWithApp v us es -> namesIn' sg (v, us, es)-    DCon c _ vs      -> namesIn' sg (c, vs)-    DDef f es        -> namesIn' sg (f, es)-    DDot v           -> namesIn' sg v-    DTerm v          -> namesIn' sg v+  namesAndMetasIn' sg = \case+    DWithApp v us es -> namesAndMetasIn' sg (v, us, es)+    DCon c _ vs      -> namesAndMetasIn' sg (c, vs)+    DDef f es        -> namesAndMetasIn' sg (f, es)+    DDot' v es       -> namesAndMetasIn' sg (v, es)+    DTerm' v es      -> namesAndMetasIn' sg (v, es) +instance NamesIn a => NamesIn (Builtin a) where+  namesAndMetasIn' sg = \case+    Builtin t -> namesAndMetasIn' sg t+    Prim x    -> namesAndMetasIn' sg x+    BuiltinRewriteRelations xs -> namesAndMetasIn' sg xs++-- | Note that the 'primFunImplementation' is skipped.+instance NamesIn PrimFun where+  namesAndMetasIn' sg = \case+    PrimFun x _ _ _ -> namesAndMetasIn' sg x++instance NamesIn Section where+  namesAndMetasIn' sg = \case+    Section tel -> namesAndMetasIn' sg tel++instance NamesIn NLPat where+  namesAndMetasIn' sg = \case+    PVar _ _      -> mempty+    PDef a b      -> namesAndMetasIn' sg (a, b)+    PLam _ a      -> namesAndMetasIn' sg a+    PPi a b       -> namesAndMetasIn' sg (a, b)+    PSort a       -> namesAndMetasIn' sg a+    PBoundVar _ a -> namesAndMetasIn' sg a+    PTerm a       -> namesAndMetasIn' sg a++instance NamesIn NLPType where+  namesAndMetasIn' sg = \case+    NLPType a b -> namesAndMetasIn' sg (a, b)++instance NamesIn NLPSort where+  namesAndMetasIn' sg = \case+    PUniv _ a     -> namesAndMetasIn' sg a+    PInf _ _      -> mempty+    PSizeUniv     -> mempty+    PLockUniv     -> mempty+    PLevelUniv    -> mempty+    PIntervalUniv -> mempty++instance NamesIn RewriteRule where+  namesAndMetasIn' sg = \case+    RewriteRule a b c d e f _ _ ->+      namesAndMetasIn' sg (a, b, c, d, e, f)++instance (NamesIn a, NamesIn b) => NamesIn (HashMap a b) where+  namesAndMetasIn' sg map = foldMap (namesAndMetasIn' sg) map++instance NamesIn System where+  namesAndMetasIn' sg (System tel cs) = namesAndMetasIn' sg (tel, cs)++instance NamesIn ExtLamInfo where+  namesAndMetasIn' sg (ExtLamInfo _ _ s) = namesAndMetasIn' sg s++instance NamesIn a => NamesIn (FunctionInverse' a) where+  namesAndMetasIn' sg = \case+    NotInjective -> mempty+    Inverse m  -> namesAndMetasIn' sg m++instance NamesIn TTerm where+  namesAndMetasIn' sg = \case+    TVar _         -> mempty+    TPrim _        -> mempty+    TDef x         -> namesAndMetasIn' sg x+    TApp t xs      -> namesAndMetasIn' sg (t, xs)+    TLam t         -> namesAndMetasIn' sg t+    TLit l         -> namesAndMetasIn' sg l+    TCon x         -> namesAndMetasIn' sg x+    TLet t1 t2     -> namesAndMetasIn' sg (t1, t2)+    TCase _ c t ts -> namesAndMetasIn' sg (c, t, ts)+    TUnit          -> mempty+    TSort          -> mempty+    TErased        -> mempty+    TCoerce t      -> namesAndMetasIn' sg t+    TError _       -> mempty++instance NamesIn TAlt where+  namesAndMetasIn' sg = \case+    TACon x _ t   -> namesAndMetasIn' sg (x, t)+    TAGuard t1 t2 -> namesAndMetasIn' sg (t1, t2)+    TALit l t     -> namesAndMetasIn' sg (l, t)++instance NamesIn CaseType where+  namesAndMetasIn' sg = \case+    CTData x   -> namesAndMetasIn' sg x+    CTNat      -> mempty+    CTInt      -> mempty+    CTChar     -> mempty+    CTString   -> mempty+    CTFloat    -> mempty+    CTQName    -> mempty++instance NamesIn CaseInfo where+  namesAndMetasIn' sg (CaseInfo _ _ t) = namesAndMetasIn' sg t++instance NamesIn Compiled where+  namesAndMetasIn' sg (Compiled t _) = namesAndMetasIn' sg t+ -- Pattern synonym stuff --  newtype PSyn = PSyn A.PatternSynDefn instance NamesIn PSyn where-  namesIn' sg (PSyn (_args, p)) = namesIn' sg p+  namesAndMetasIn' sg (PSyn (_args, p)) = namesAndMetasIn' sg p +instance NamesIn ConPatternInfo where+  namesAndMetasIn' sg (ConPatternInfo _ _ _ ty _) = namesAndMetasIn' sg ty+ instance NamesIn (A.Pattern' a) where-  namesIn' sg = \case-    A.VarP{}               -> mempty-    A.ConP _ c args        -> namesIn' sg (c, args)-    A.ProjP _ _ d          -> namesIn' sg d-    A.DefP _ f args        -> namesIn' sg (f, args)-    A.WildP{}              -> mempty-    A.AsP _ _ p            -> namesIn' sg p-    A.AbsurdP{}            -> mempty-    A.LitP _ l             -> namesIn' sg l-    A.PatternSynP _ c args -> namesIn' sg (c, args)-    A.RecP _ fs            -> namesIn' sg fs+  namesAndMetasIn' sg = \case+    A.VarP _               -> mempty+    A.ConP _ c args        -> namesAndMetasIn' sg (c, args)+    A.ProjP _ _ d          -> namesAndMetasIn' sg d+    A.DefP _ f args        -> namesAndMetasIn' sg (f, args)+    A.WildP _              -> mempty+    A.AsP _ _ p            -> namesAndMetasIn' sg p+    A.AbsurdP _            -> mempty+    A.LitP _ l             -> namesAndMetasIn' sg l+    A.PatternSynP _ c args -> namesAndMetasIn' sg (c, args)+    A.RecP _ _ fs          -> namesAndMetasIn' sg fs     A.DotP{}               -> __IMPOSSIBLE__    -- Dot patterns are not allowed in pattern synonyms     A.EqualP{}             -> __IMPOSSIBLE__    -- Andrea: should we allow these in pattern synonyms?-    A.WithP _ p            -> namesIn' sg p-    A.AnnP _ a p           -> __IMPOSSIBLE__    -- Type annotations are not (yet) allowed in pattern synonyms+    A.WithP _ p            -> namesAndMetasIn' sg p  instance NamesIn AmbiguousQName where-  namesIn' sg (AmbQ cs) = namesIn' sg cs+  namesAndMetasIn' sg (AmbQ cs) = namesAndMetasIn' sg cs
src/full/Agda/Syntax/Internal/Pattern.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.Syntax.Internal.Pattern where @@ -355,3 +356,10 @@       LitP{}      -> []       ProjP{}     -> []       IApplyP _ _ _ x -> [(x, defaultModality)]+++hasDefP :: [NamedArg DeBruijnPattern] -> Bool+hasDefP ps = getAny $ flip foldPattern ps $ \ (x :: DeBruijnPattern) ->+                  case x of+                    DefP{} -> Any True+                    _      -> Any False
src/full/Agda/Syntax/Internal/SanityCheck.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Sanity checking for internal syntax. Mostly checking variable scoping. module Agda.Syntax.Internal.SanityCheck where @@ -9,7 +11,7 @@ import Agda.TypeChecking.Monad  import Agda.Utils.List ( dropEnd, initWithDefault )-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.Size import Agda.Utils.Impossible @@ -19,7 +21,7 @@   case filter bad (Set.toList $ allFreeVars v) of     [] -> return ()     xs -> do-      reportSDoc "impossible" 1 . return $+      alwaysReportSDoc "impossible" 1 . return $         sep [ hang "Sanity check failed for" 2                    (hang (pretty tel <+> "|-") 2 (pretty v))             , text $ "out of scope: " ++ show xs ]@@ -34,31 +36,41 @@   where     go gamma rho delta =       case rho of-        IdS      -> unless (size gamma == size delta) $ err $ "idS:" <+> hang (pretty gamma <+> "/=") 2 (pretty delta)-        EmptyS _ -> unless (size delta == 0) $ err $ "emptyS:" <+> pretty delta <+> "is not empty"++        IdS      -> do+          unless (size gamma == size delta) $ err $+            "idS:" <+> hang (pretty gamma <+> "/=") 2 (pretty delta)++        EmptyS _ -> do+          unless (null delta) $ err $+            "emptyS:" <+> pretty delta <+> "is not empty"+         v :# rho -> do-          unless (size delta > 0) $ err $ "consS: empty target"+          when (null delta) $ err $ "consS: empty target"           sanityCheckVars gamma v           sanityCheckSubst gamma rho (dropLast delta)-        Strengthen _ rho -> do-          unless (size delta > 0) $ err $ "strS: empty target"-          sanityCheckSubst gamma rho (dropLast delta)++        Strengthen _ n rho -> do+          unless (natSize delta >= toEnum n) $ err $ "strS: empty target"+          sanityCheckSubst gamma rho (dropLastN n delta)+         Wk n rho -> do-          unless (size gamma >= n) $ err $ "wkS:" <+> sep [ "|" <> pretty gamma <> "|"-                                                               , text $ "< " ++ show n ]+          unless (natSize gamma >= toEnum n) $ err $+            "wkS:" <+> sep [ "|" <> pretty gamma <> "|" , text $ "< " ++ show n ]           sanityCheckSubst (dropLastN n gamma) rho delta+         Lift n rho -> do-          unless (size gamma >= n) $ err $ "liftS: source" <+> sep [ "|" <> pretty gamma <> "|"-                                                                        , text $ "< " ++ show n ]-          unless (size delta >= n) $ err $ "liftS: target" <+> sep [ "|" <> pretty delta <> "|"-                                                                        , text $ "< " ++ show n ]+          unless (natSize gamma >= toEnum n) $ err $+            "liftS: source" <+> sep [ "|" <> pretty gamma <> "|" , text $ "< " ++ show n ]+          unless (natSize delta >= toEnum n) $ err $+            "liftS: target" <+> sep [ "|" <> pretty delta <> "|" , text $ "< " ++ show n ]           sanityCheckSubst (dropLastN n gamma) rho (dropLastN n delta)      dropLast = telFromList . initWithDefault __IMPOSSIBLE__ . telToList     dropLastN n = telFromList . dropEnd n . telToList      err reason = do-      reportSDoc "impossible" 1 . return $+      alwaysReportSDoc "impossible" 1 . return $         sep [ hang "Sanity check failed for" 2 $               hang (pretty gamma <+> "|-") 2 $               hang (pretty rho <+> ":") 2 $
+ src/full/Agda/Syntax/Internal/Univ.hs view
@@ -0,0 +1,103 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE DeriveAnyClass             #-}++-- | Kinds of standard universes: @Prop@, @Type@, @SSet@.++module Agda.Syntax.Internal.Univ where++import Control.DeepSeq ( NFData  )+import GHC.Generics    ( Generic )++import Agda.Utils.Boolean++-- * Types+---------------------------------------------------------------------------++-- | Flavor of standard universe (@Prop < Type < SSet@,).+data Univ+  = UProp  -- ^ Fibrant universe of propositions.+  | UType  -- ^ Fibrant universe.+  | USSet  -- ^ Non-fibrant universe.+  deriving stock (Eq, Ord, Show, Bounded, Enum, Generic)+  deriving anyclass NFData+    -- NB: for deriving Ord, keep ordering UProp < UType < USSet!++-- | We have @IsFibrant < IsStrict@.+data IsFibrant+  = IsFibrant  -- ^ Fibrant universe.+  | IsStrict   -- ^ Non-fibrant universe.+  deriving (Show, Eq, Ord, Generic)+    -- NB: for deriving Ord, keep ordering IsFibrant < IsStrict!++instance Boolean IsFibrant where+  fromBool = \case+    True -> IsFibrant+    False -> IsStrict++instance IsBool IsFibrant where+  toBool = \case+    IsFibrant -> True+    IsStrict -> False++-- * Universe kind arithmetic+---------------------------------------------------------------------------++-- | The successor universe type of a universe.+univUniv :: Univ -> Univ+univUniv = \case+  UProp -> UType+  UType -> UType+  USSet -> USSet++-- | Compute the universe type of a function space from the universe types of domain and codomain.+funUniv :: Univ -> Univ -> Univ+funUniv = curry $ \case+  (USSet, _) -> USSet+  (_, USSet) -> USSet+  (_, u)     -> u++-- ** Inverting 'funUniv'++-- | Conclude @u1@ from @funUniv u1 u2@ and @u2@.++domainUniv ::+      Bool       -- ^ Have 'UProp'?+   -> Univ       -- ^ 'Univ' kind of the 'funSort'.+   -> Univ       -- ^ 'Univ' kind of the codomain.+   -> Maybe Univ -- ^ 'Univ' kind of the domain, if unique.+domainUniv propEnabled u = \case+  USSet -> Nothing+  _  | u == USSet  -> Just USSet+     | propEnabled -> Nothing+     | otherwise   -> Just UType++-- | Conclude @u2@ from @funUniv u1 u2@ and @u1@.++codomainUniv ::+      Univ       -- ^ 'Univ' kind of the 'funSort'.+   -> Univ       -- ^ 'Univ' kind of the domain.+   -> Maybe Univ -- ^ 'Univ' kind of the codomain, if uniquely exists.+codomainUniv u = \case+  USSet -> Nothing+  _ -> Just u++-- * Fibrancy++-- | Fibrancy of standard universes.++univFibrancy :: Univ -> IsFibrant+univFibrancy = \case+  UProp -> IsFibrant+  UType -> IsFibrant+  USSet -> IsStrict++-- * Printing++-- | Hacky showing of standard universes, does not take actual names into account.++showUniv :: Univ -> String+showUniv = \case+  UProp -> "Prop"+  UType -> "Set"+  USSet -> "SSet"
src/full/Agda/Syntax/Literal.hs view
@@ -5,16 +5,16 @@ import Data.Char import Data.Word -import Data.Data (Data) import Data.Text (Text) import qualified Data.Text as T  import Agda.Syntax.Position import Agda.Syntax.Common import Agda.Syntax.Abstract.Name-import Agda.Utils.FileName+import Agda.Syntax.TopLevelModuleName.Boot (TopLevelModuleName')+import Agda.Syntax.Position (Range) import Agda.Utils.Float ( doubleDenotEq, doubleDenotOrd )-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty  type RLiteral = Ranged Literal data Literal@@ -24,15 +24,15 @@   | LitString !Text   | LitChar   !Char   | LitQName  !QName-  | LitMeta   AbsolutePath MetaId-  deriving (Data, Show)+  | LitMeta   !(TopLevelModuleName' Range) !MetaId+  deriving Show  instance Pretty Literal where-    pretty (LitNat n)     = pretty n-    pretty (LitWord64 n)  = pretty n-    pretty (LitFloat d)   = pretty d-    pretty (LitString s)  = text $ showText s ""-    pretty (LitChar c)    = text $ "'" ++ showChar' c "'"+    pretty (LitNat n)     = hlNumber $ pretty n+    pretty (LitWord64 n)  = hlNumber $ pretty n+    pretty (LitFloat d)   = hlNumber $ pretty d+    pretty (LitString s)  = hlString . text $ showText s ""+    pretty (LitChar c)    = hlString . text $ "'" ++ showChar' c "'"     pretty (LitQName x)   = pretty x     pretty (LitMeta _ x)  = pretty x @@ -91,8 +91,8 @@   killRange (LitFloat  x) = LitFloat  x   killRange (LitString x) = LitString x   killRange (LitChar   x) = LitChar   x-  killRange (LitQName  x) = killRange1 LitQName x-  killRange (LitMeta f x) = LitMeta f x+  killRange (LitQName  x) = killRangeN LitQName x+  killRange (LitMeta m x) = LitMeta (killRange m) x  -- | Ranges are not forced. @@ -103,4 +103,4 @@   rnf (LitString _  ) = ()   rnf (LitChar _    ) = ()   rnf (LitQName a   ) = rnf a-  rnf (LitMeta _ x  ) = rnf x+  rnf (LitMeta m _  ) = rnf m
src/full/Agda/Syntax/Notation.hs view
@@ -1,4 +1,4 @@-+{-# OPTIONS_GHC -Wunused-imports #-}  {-| As a concrete name, a notation is a non-empty list of alternating 'IdPart's and holes.     In contrast to concrete names, holes can be binders.@@ -20,32 +20,34 @@ import Control.Monad.Except  import qualified Data.List as List-import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as Set  import GHC.Generics (Generic)  import qualified Agda.Syntax.Abstract.Name as A import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty import Agda.Syntax.Concrete.Name import Agda.Syntax.Concrete.Pretty() import Agda.Syntax.Position  import Agda.Utils.Lens import Agda.Utils.List+import Agda.Utils.List1           ( List1, pattern (:|) ) import qualified Agda.Utils.List1 as List1+import Agda.Utils.Set1            ( Set1 )+import qualified Agda.Utils.Set1  as Set1 import Agda.Utils.Null-import Agda.Utils.Pretty+import Agda.Utils.Singleton  import Agda.Utils.Impossible --- | Data type constructed in the Happy parser; converted to 'GenPart'---   before it leaves the Happy code.+-- | Data type constructed in the Happy parser; converted to+-- 'NotationPart' before it leaves the Happy code. data HoleName-  = LambdaHole { _bindHoleName :: RString-               , holeName      :: RString }-    -- ^ @\ x -> y@; 1st argument is the bound name (unused for now).+  = LambdaHole { _bindHoleNames :: List1 RString+               , holeName       :: RString+               }+    -- ^ @λ x₁ … xₙ → y@: The first argument contains the bound names.   | ExprHole   { holeName      :: RString }     -- ^ Simple named hole with hiding. @@ -59,32 +61,25 @@ stringParts gs = [ rangedThing x | IdPart x <- gs ]  -- | Target argument position of a part (Nothing if it is not a hole).-holeTarget :: GenPart -> Maybe Int-holeTarget (BindHole _   n) = Just $ rangedThing n-holeTarget (WildHole     n) = Just $ rangedThing n-holeTarget (NormalHole _ n) = Just $ rangedThing $ namedArg n-holeTarget IdPart{}         = Nothing---- | Is the part a hole? WildHoles don't count since they don't correspond to---   anything the user writes.-isAHole :: GenPart -> Bool-isAHole BindHole{}   = True-isAHole NormalHole{} = True-isAHole WildHole{}   = False-isAHole IdPart{}     = False+holeTarget :: NotationPart -> Maybe Int+holeTarget (VarPart _ n)  = Just $ holeNumber $ rangedThing n+holeTarget (WildPart n)   = Just $ holeNumber $ rangedThing n+holeTarget (HolePart _ n) = Just $ rangedThing $ namedArg n+holeTarget IdPart{}       = Nothing --- | Is the part a normal hole?-isNormalHole :: GenPart -> Bool-isNormalHole NormalHole{} = True-isNormalHole BindHole{}   = False-isNormalHole WildHole{}   = False-isNormalHole IdPart{}     = False+-- | Is the part a hole?+isAHole :: NotationPart -> Bool+isAHole HolePart{} = True+isAHole VarPart{}  = False+isAHole WildPart{} = False+isAHole IdPart{}   = False  -- | Is the part a binder?-isBindingHole :: GenPart -> Bool-isBindingHole BindHole{} = True-isBindingHole WildHole{} = True-isBindingHole _          = False+isBinder :: NotationPart -> Bool+isBinder HolePart{} = False+isBinder VarPart{}  = True+isBinder WildPart{} = True+isBinder IdPart{}   = False  -- | Classification of notations. @@ -101,7 +96,7 @@ notationKind :: Notation -> NotationKind notationKind []  = NoNotation notationKind (h:syn) =-  case (isNormalHole h, isNormalHole $ last1 h syn) of+  case (isAHole h, isAHole $ last1 h syn) of     (True , True ) -> InfixNotation     (True , False) -> PostfixNotation     (False, True ) -> PrefixNotation@@ -109,16 +104,16 @@  -- | From notation with names to notation with indices. -----   Example:---   @---      ids   = ["for", "x", "∈", "xs", "return", "e"]---      holes = [ LambdaHole "x" "e",  ExprHole "xs" ]---   @---   creates the notation+--   An example (with some parts of the code omitted):+--   The lists+--   @["for", "x", "∈", "xs", "return", "e"]@+--   and+--   @['LambdaHole' ("x" :| []) "e", 'ExprHole' "xs"]@+--   are mapped to the following notation: --   @---      [ IdPart "for"    , BindHole 0---      , IdPart "∈"      , NormalHole 1---      , IdPart "return" , NormalHole 0+--      [ 'IdPart' "for"    , 'VarPart' ('BoundVariablePosition' 0 0)+--      , 'IdPart' "∈"      , 'HolePart' 1+--      , 'IdPart' "return" , 'HolePart' 0 --      ] --   @ mkNotation :: [NamedArg HoleName] -> [RString] -> Either String Notation@@ -126,21 +121,21 @@ mkNotation holes ids = do   unless uniqueHoleNames     $ throwError "syntax must use unique argument names"   let xs :: Notation = map mkPart ids+  unless (isExprLinear xs)   $ throwError "syntax must use holes exactly once"+  unless (isLambdaLinear xs) $ throwError "syntax must use binding holes exactly once"   unless (noAdjacentHoles xs)  $ throwError $ concat      [ "syntax must not contain adjacent holes ("      , prettyHoles      , ")"      ]-  unless (isExprLinear xs)   $ throwError "syntax must use holes exactly once"-  unless (isLambdaLinear xs) $ throwError "syntax must use binding holes exactly once"   -- Andreas, 2018-10-18, issue #3285:   -- syntax that is just a single hole is ill-formed and crashes the operator parser   when   (isSingleHole xs)   $ throwError "syntax cannot be a single hole"-  return $ insertWildHoles xs+  return $ insertWildParts xs     where       holeNames :: [RString]       holeNames = map namedArg holes >>= \case-        LambdaHole x y -> [x, y]+        LambdaHole _ y -> [y]         ExprHole y     -> [y]        prettyHoles :: String@@ -153,55 +148,86 @@       numberedHoles :: [(Int, NamedArg HoleName)]       numberedHoles = zip holeNumbers holes -      -- The WildHoles don't correspond to anything in the right-hand side so+      -- The WildParts don't correspond to anything in the right-hand side so       -- we add them next to their corresponding body. Slightly subtle: due to       -- the way the operator parsing works they can't be added first or last.-      insertWildHoles :: [GenPart] -> [GenPart]-      insertWildHoles xs = foldr ins xs wilds+      insertWildParts :: [NotationPart] -> [NotationPart]+      insertWildParts xs = foldr ins xs wilds         where-          wilds = [ i | (_, WildHole i) <- holeMap ]-          ins w (NormalHole r h : hs)-            | namedArg h == w = NormalHole r h : WildHole w : hs+          wilds = [ i | (_, WildPart i) <- holeMap ]++          ins w (HolePart r h : hs)+            | namedArg h == fmap holeNumber w =+              HolePart r h : WildPart w : hs           ins w (h : hs) = h : insBefore w hs           ins _ [] = __IMPOSSIBLE__ -          insBefore w (NormalHole r h : hs)-            | namedArg h == w = WildHole w : NormalHole r h : hs+          insBefore w (HolePart r h : hs)+            | namedArg h == fmap holeNumber w =+              WildPart w : HolePart r h : hs           insBefore w (h : hs) = h : insBefore w hs           insBefore _ [] = __IMPOSSIBLE__ -      -- Create a map (association list) from hole names to holes.-      -- A @LambdaHole@ contributes two entries:-      -- both names are mapped to the same number,-      -- but distinguished by BindHole vs. NormalHole.-      holeMap :: [(RString, GenPart)]+      -- A map (association list) from hole names to notation parts. A+      -- @LambdaHole@ contributes one or more entries, one @HolePart@+      -- and zero or more @VarPart@s or @WildParts@, all mapped to the+      -- same number.+      holeMap :: [(RString, NotationPart)]       holeMap = do-        (i, h) <- numberedHoles    -- v This range is filled in by mkPart-        let ri x = Ranged (getRange x) i-            normalHole y = NormalHole noRange $ fmap (ri y <$) h+        (i, h) <- numberedHoles+        let ri x   = Ranged (getRange x) i+            rp x n = Ranged (getRange x) $+                     BoundVariablePosition+                       { holeNumber = i+                       , varNumber  = n+                       }+            hole y = HolePart noRange $ fmap (ri y <$) h+                              -- This range is filled in by mkPart.         case namedArg h of-          ExprHole y       -> [(y, normalHole y)]-          LambdaHole x y-            | "_" <- rangedThing x -> [(x, WildHole (ri x)),         (y, normalHole y)]-            | otherwise            -> [(x, BindHole noRange (ri x)), (y, normalHole y)]-                                                 -- Filled in by mkPart+          ExprHole y      -> [(y, hole y)]+          LambdaHole xs y -> [(y, hole y)] +++            zipWith+              (\ n x -> case rangedThing x of+                "_" -> (x, WildPart (rp x n))+                _   -> (x, VarPart noRange (rp x n)))+                                   -- Filled in by mkPart.+              [0..]+              (List1.toList xs)        -- Check whether all hole names are distinct.       -- The hole names are the keys of the @holeMap@.       uniqueHoleNames = distinct [ x | (x, _) <- holeMap, rangedThing x /= "_" ] -      isExprLinear   xs = List.sort [ i | x <- xs, isNormalHole x, let Just i = holeTarget x ] == holeNumbers-      isLambdaLinear xs = List.sort [ rangedThing x | BindHole _ x <- xs ] ==-                          [ i | (i, h) <- numberedHoles,-                                LambdaHole x _ <- [namedArg h], rangedThing x /= "_" ]+      isExprLinear xs =+        List.sort [ i | x <- xs, isAHole x, let Just i = holeTarget x ]+          ==+        holeNumbers -      noAdjacentHoles :: [GenPart] -> Bool-      noAdjacentHoles []       = __IMPOSSIBLE__-      noAdjacentHoles [x]      = True-      noAdjacentHoles (x:y:xs) =-        not (isAHole x && isAHole y) && noAdjacentHoles (y:xs)+      isLambdaLinear xs =+        List.sort [ rangedThing x | VarPart _ x <- xs ]+          ==+        [ BoundVariablePosition { holeNumber = i, varNumber = v }+        | (i, h) <- numberedHoles+        , LambdaHole vs _ <- [namedArg h]+        , (v, x) <- zip [0..] $ map rangedThing $ List1.toList vs+        , x /= "_"+        ] -      isSingleHole :: [GenPart] -> Bool+      noAdjacentHoles :: [NotationPart] -> Bool+      noAdjacentHoles =+        noAdj .+        filter (\h -> case h of+                   HolePart{} -> True+                   IdPart{}   -> True+                   _          -> False)+        where+        noAdj []       = __IMPOSSIBLE__+        noAdj [x]      = True+        noAdj (x:y:xs) =+          not (isAHole x && isAHole y) &&+          noAdj (y:xs)++      isSingleHole :: [NotationPart] -> Bool       isSingleHole = \case         [ IdPart{} ] -> False         [ _hole ]    -> True@@ -210,11 +236,10 @@ -- | All the notation information related to a name. data NewNotation = NewNotation   { notaName  :: QName-  , notaNames :: Set A.Name+  , notaNames :: Set1 A.Name     -- ^ The names the syntax and/or fixity belong to.     ---    -- Invariant: The set is non-empty. Every name in the list matches-    -- 'notaName'.+    -- Invariant: Every name in the list matches 'notaName'.   , notaFixity :: Fixity     -- ^ Associativity and precedence (fixity) of the names.   , notation :: Notation@@ -232,7 +257,7 @@ namesToNotation :: QName -> A.Name -> NewNotation namesToNotation q n = NewNotation   { notaName       = q-  , notaNames      = Set.singleton n+  , notaNames      = singleton n   , notaFixity     = f   , notation       = if null syn then syntaxOf (unqualify q) else syn   , notaIsOperator = null syn@@ -260,7 +285,7 @@  -- | Create a 'Notation' (without binders) from a concrete 'Name'. --   Does the obvious thing:---   'Hole's become 'NormalHole's, 'Id's become 'IdParts'.+--   'Hole's become 'HolePart's, 'Id's become 'IdParts'. --   If 'Name' has no 'Hole's, it returns 'noNotation'. syntaxOf :: Name -> Notation syntaxOf y@@ -272,7 +297,7 @@     -- Result will have no 'BindingHole's.     mkSyn :: Int -> [NamePart] -> Notation     mkSyn n []          = []-    mkSyn n (Hole : xs) = NormalHole noRange (defaultNamedArg $ unranged n) : mkSyn (1 + n) xs+    mkSyn n (Hole : xs) = HolePart noRange (defaultNamedArg $ unranged n) : mkSyn (1 + n) xs     mkSyn n (Id x : xs) = IdPart (unranged x) : mkSyn n xs  -- | Merges 'NewNotation's that have the same precedence level and@@ -293,32 +318,33 @@ -- Every 'NewNotation' must have the same 'notaName'. -- -- Postcondition: No 'A.Name' occurs in more than one list element.-mergeNotations :: [NewNotation] -> [NewNotation]-mergeNotations =-  map merge .-  concatMap groupIfLevelsMatch .-  groupOn (\n -> ( notation n-                 , notaIsOperator n-                 ))+mergeNotations :: List1 NewNotation -> List1 NewNotation+mergeNotations ns@(_ :| []) = ns+mergeNotations ns =+  fmap merge+  . List1.concatMap1 groupIfLevelsMatch+  . List1.groupOn1 (notation &&& notaIsOperator)+  $ ns   where-  groupIfLevelsMatch :: [NewNotation] -> [[NewNotation]]-  groupIfLevelsMatch []         = __IMPOSSIBLE__-  groupIfLevelsMatch ns@(n : _) =+  groupIfLevelsMatch :: List1 NewNotation -> List1 (List1 NewNotation)+  groupIfLevelsMatch ns =     if allEqual (map fixityLevel related)-    then [sameAssoc (sameLevel ns)]-    else map (: []) ns+    then singleton $ sameAssoc $ sameLevel ns+    else fmap singleton ns     where     -- Fixities of operators whose precedence level is not Unrelated.-    related = mapMaybe ((\f -> case fixityLevel f of-                                Unrelated  -> Nothing-                                Related {} -> Just f)-                              . notaFixity) ns+    related = List1.mapMaybe (maybeRelated . notaFixity) ns+      where+        maybeRelated f =+          case fixityLevel f of+            Unrelated  -> Nothing+            Related {} -> Just f      -- Precondition: All related operators have the same precedence     -- level.     --     -- Gives all unrelated operators the same level.-    sameLevel = map (set (_notaFixity . _fixityLevel) level)+    sameLevel = fmap (set (_notaFixity . _fixityLevel) level)       where       level = case related of         f : _ -> fixityLevel f@@ -327,19 +353,27 @@     -- If all related operators have the same associativity, then the     -- unrelated operators get the same associativity, and otherwise     -- all operators get the associativity NonAssoc.-    sameAssoc = map (set (_notaFixity . _fixityAssoc) assoc)+    sameAssoc = fmap (set (_notaFixity . _fixityAssoc) assoc)       where       assoc = case related of         f : _ | allEqual (map fixityAssoc related) -> fixityAssoc f         _                                          -> NonAssoc -  merge :: [NewNotation] -> NewNotation-  merge []         = __IMPOSSIBLE__-  merge ns@(n : _) = n { notaNames = Set.unions $ map notaNames ns }+  merge :: List1 NewNotation -> NewNotation+  merge ns@(n :| _) = n { notaNames = Set1.unions $ fmap notaNames ns } +-- | Check if a notation contains any lambdas (in which case it cannot be used in a pattern).+isLambdaNotation :: NewNotation -> Bool+isLambdaNotation n = any isBinder (notation n)+  where+    isBinder VarPart{}  = True+    isBinder WildPart{} = True+    isBinder IdPart{}   = False+    isBinder HolePart{} = False+ -- | Lens for 'Fixity' in 'NewNotation'. -_notaFixity :: Lens' Fixity NewNotation+_notaFixity :: Lens' NewNotation Fixity _notaFixity f r = f (notaFixity r) <&> \x -> r { notaFixity = x }  -- * Sections
src/full/Agda/Syntax/Parser.hs view
@@ -9,7 +9,7 @@       -- * Parsers     , moduleParser     , moduleNameParser-    , acceptableFileExts+    , agdaFileExtensions     , exprParser     , exprWhereParser     , holeContentParser@@ -41,6 +41,7 @@ import Agda.Syntax.Parser.Lexer import Agda.Syntax.Parser.Literate import Agda.Syntax.Concrete+import Agda.Syntax.Concrete.Attribute import Agda.Syntax.Parser.Tokens  import Agda.Utils.FileName@@ -71,23 +72,25 @@  -- | Embed a 'ParseResult' as 'PM' computation. -wrap :: ParseResult a -> PM a+wrap :: ParseResult a -> PM (a, Attributes) wrap (ParseFailed err)  = throwError err wrap (ParseOk s x)      = do   modify' (parseWarnings s ++)-  return x+  return (x, parseAttributes s) -wrapM :: IO (ParseResult a) -> PM a+wrapM :: IO (ParseResult a) -> PM (a, Attributes) wrapM m = liftIO m >>= wrap  -- | Returns the contents of the given file. -readFilePM :: AbsolutePath -> PM Text-readFilePM path = wrapIOM (ReadFileError path) (readTextFile $ filePath path)+readFilePM :: RangeFile -> PM Text+readFilePM file =+  wrapIOM (ReadFileError file) $+  readTextFile (filePath $ rangeFilePath file)  wrapIOM :: (MonadError e m, MonadIO m) => (IOError -> e) -> IO a -> m a wrapIOM f m = do-  a <- liftIO$ (Right <$> m) `catch` (\err -> return$ Left (err :: IOError))+  a <- liftIO $ (Right <$> m) `catch` (\ err -> return $ Left (err :: IOError))   case a of     Right x  -> return x     Left err -> throwError (f err)@@ -103,7 +106,8 @@   , parseLiterate  :: LiterateParser a   } -type LiterateParser a = Parser a -> [Layer] -> PM a+type LiterateParser a =+  Parser a -> SrcFile -> [Layer] -> PM (a, Attributes)  -- | Initial state for lexing. @@ -117,7 +121,7 @@  -- | Parse without top-level layout. -parse :: Parser a -> String -> PM a+parse :: Parser a -> String -> PM (a, Attributes) parse p = wrapM . return . M.parse (parseFlags p) normalLexState (parser p)  -- | Parse with top-level layout.@@ -126,72 +130,74 @@   :: SrcFile   -- ^ Name of source file.   -> Parser a  -- ^ Parser to use.   -> String    -- ^ Contents of source file.-  -> PM a+  -> PM (a, Attributes) parseFileFromString src p = wrapM . return . M.parseFromSrc (parseFlags p) layoutLexState (parser p) src  -- | Parse with top-level layout.  parseLiterateWithoutComments :: LiterateParser a-parseLiterateWithoutComments p layers = parseFileFromString (literateSrcFile layers) p $ illiterate layers+parseLiterateWithoutComments p f layers = parseFileFromString f p $ illiterate layers  -- | Parse with top-level layout.  parseLiterateWithComments :: LiterateParser [Token]-parseLiterateWithComments p layers = do-  code <- parseLiterateWithoutComments p layers+parseLiterateWithComments p f layers = do+  (code, coh) <- parseLiterateWithoutComments p f layers   let literate = filter (not . isCodeLayer) layers   let (terms, overlaps) = interleaveRanges (map Left code) (map Right literate)    forM_ (map fst overlaps) $ \c ->-    warning $ OverlappingTokensWarning { warnRange = getRange c }+    warning $ OverlappingTokensWarning { warnRange = f <$ getRangeWithoutFile c } -  return $ forMaybe terms $ \case-    Left t                           -> Just t-    Right (Layer Comment interval s) -> Just $ TokTeX    (interval, s)-    Right (Layer Markup  interval s) -> Just $ TokMarkup (interval, s)-    Right (Layer Code _ _)           -> Nothing+  return . (,coh) . forMaybe terms $ \case+      Left t                           -> Just t+      Right (Layer Comment interval s) -> Just $ TokTeX    (f <$ interval, s)+      Right (Layer Markup  interval s) -> Just $ TokMarkup (f <$ interval, s)+      Right (Layer Code _ _)           -> Nothing   parseLiterateFile   :: Processor   -> Parser a-  -> AbsolutePath-     -- ^ The path to the file.+  -> RangeFile+     -- ^ The file.   -> String      -- ^ The file contents. Note that the file is /not/ read from      -- disk.-  -> PM a-parseLiterateFile po p path = parseLiterate p p . po (startPos (Just path))+  -> PM (a, Attributes)+parseLiterateFile po p path = parseLiterate p p (pure path) . po (startPos' ()) -parsePosString :: Parser a -> Position -> String -> PM a+parsePosString :: Parser a -> Position -> String -> PM (a, Attributes) parsePosString p pos = wrapM . return . M.parsePosString pos (parseFlags p) normalLexState (parser p)  -- | Extensions supported by `parseFile`. -acceptableFileExts :: [String]-acceptableFileExts = ".agda" : (fst <$> literateProcessors)+agdaFileExtensions :: [String]+agdaFileExtensions = ".agda" : (fst <$> literateProcessors)  parseFile   :: Show a   => Parser a-  -> AbsolutePath-     -- ^ The path to the file.+  -> RangeFile+     -- ^ The file.   -> String      -- ^ The file contents. Note that the file is /not/ read from      -- disk.-  -> PM (a, FileType)+  -> PM ((a, Attributes), FileType) parseFile p file input =-  if ".agda" `List.isSuffixOf` filePath file then+  if ".agda" `List.isSuffixOf` path then     (, AgdaFileType) <$> parseFileFromString (Strict.Just file) p input   else     go literateProcessors   where+    path = filePath (rangeFilePath file)+     go [] = throwError InvalidExtensionError                    { errPath = file-                   , errValidExts = acceptableFileExts+                   , errValidExts = agdaFileExtensions                    }     go ((ext, (po, ft)) : pos)-      | ext `List.isSuffixOf` filePath file =+      | ext `List.isSuffixOf` path =           (, ft) <$> parseLiterateFile po p file input       | otherwise = go pos
src/full/Agda/Syntax/Parser/Alex.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-| This module defines the things required by Alex and some other     Alex related things. -}@@ -35,7 +37,7 @@   }  -- | A lens for 'lexInput'.-lensLexInput :: Lens' String AlexInput+lensLexInput :: Lens' AlexInput String lensLexInput f r = f (lexInput r) <&> \ s -> r { lexInput = s }  -- | Get the previously lexed character. Same as 'lexPrevChar'. Alex needs this
src/full/Agda/Syntax/Parser/Comments.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  {-| This module defines the lex action to lex nested comments. As is well-known     this cannot be done by regular expressions (which, incidently, is probably
+ src/full/Agda/Syntax/Parser/Helpers.hs view
@@ -0,0 +1,732 @@+-- | Utility functions used in the Happy parser.++module Agda.Syntax.Parser.Helpers where++import Prelude hiding (null)++import Control.Applicative ( (<|>) )+import Control.Monad.State ( modify' )++import Data.Bifunctor (first, second)+import Data.Char+import qualified Data.List as List+import Data.Maybe+import Data.Semigroup ((<>), sconcat)+import Data.Text (Text)+import qualified Data.Text as T++import Agda.Syntax.Position+import Agda.Syntax.Parser.Monad+import Agda.Syntax.Parser.Lexer+import Agda.Syntax.Parser.Tokens+import Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Attribute as CA+import Agda.Syntax.Concrete.Pattern+import Agda.Syntax.Common+import Agda.Syntax.Notation+import Agda.Syntax.Literal++import Agda.TypeChecking.Positivity.Occurrence++import Agda.Utils.Either+import Agda.Utils.Functor+import Agda.Utils.Hash+import Agda.Utils.List ( spanJust, chopWhen, initLast )+import Agda.Utils.List1 ( List1, pattern (:|), (<|) )+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Syntax.Common.Pretty hiding ((<>))+import Agda.Utils.Singleton+import qualified Agda.Utils.Maybe.Strict as Strict+import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.List2 as List2++import Agda.Utils.Impossible++-- | Grab leading OPTIONS pragmas.+takeOptionsPragmas :: [Declaration] -> Module+takeOptionsPragmas = uncurry Mod . spanJust (\ d -> case d of+  Pragma p@OptionsPragma{} -> Just p+  _                        -> Nothing)++-- | Insert a top-level module if there is none.+--   Also fix-up for the case the declarations in the top-level module+--   are not indented (this is allowed as a special case).+figureOutTopLevelModule :: [Declaration] -> [Declaration]+figureOutTopLevelModule ds =+  case spanAllowedBeforeModule ds of+    -- Andreas 2016-02-01, issue #1388.+    -- We need to distinguish two additional cases.++    -- Case 1: Regular file layout: imports followed by one module. Nothing to do.+    (ds0, [ Module{} ]) -> ds++    -- Case 2: The declarations in the module are not indented.+    -- This is allowed for the top level module, and thus rectified here.+    (ds0, Module r erased m tel [] : ds2) ->+      ds0 ++ [Module r erased m tel ds2]++    -- Case 3: There is a module with indented declarations,+    -- followed by non-indented declarations.  This should be a+    -- parse error and be reported later (see @toAbstract TopLevel{}@),+    -- thus, we do not do anything here.+    (ds0, Module r _ m tel ds1 : ds2) -> ds  -- Gives parse error in scope checker.+    -- OLD code causing issue 1388:+    -- (ds0, Module r m tel ds1 : ds2) -> ds0 ++ [Module r m tel $ ds1 ++ ds2]++    -- Case 4: a top-level module declaration is missing.+    -- Andreas, 2017-01-01, issue #2229:+    -- Put everything (except OPTIONS pragmas) into an anonymous module.+    _ -> ds0 ++ [Module r defaultErased (QName $ noName r) [] ds1]+      where+      (ds0, ds1) = (`span` ds) $ \case+        Pragma OptionsPragma{} -> True+        _ -> False+      -- Andreas, 2017-05-17, issue #2574.+      -- Since the module noName will act as jump target, it needs a range.+      -- We use the beginning of the file as beginning of the top level module.+      r = beginningOfFile $ getRange ds1++-- | Create a name from a string. The boolean indicates whether a part+-- of the name can be token 'constructor'.+mkName' :: Bool -> (Interval, String) -> Parser Name+mkName' constructor (i, s) =+  either parseError return $ mkValidName constructor (getRange i) s++-- | Create a name from a string. The boolean indicates whether a part+-- of the name can be token 'constructor'.+mkValidName :: Bool -> Range -> String -> Either String Name+mkValidName constructor' r s = do+    let+      xs = C.stringNameParts s++      -- The keyword constructor can appear as the only NamePart in the+      -- last segment of a qualified name --- Foo.constructor refers to+      -- the constructor of the record Foo.+      constructor = case xs of+        _ :| [] -> constructor'+        _       -> False+      --  The constructor' argument to mkName' determines whether this+      --  is the last segment of a QName, the local variable constructor+      --  additionally takes whether it's the only NamePart into+      --  consideration.++    mapM_ (isValidId constructor) xs+    unless (alternating xs) $ parseError $ "a name cannot contain two consecutive underscores"+    return $ Name r InScope xs+    where+        parseError = Left+        isValidId _ Hole   = return ()+        isValidId con (Id y) = do+          let x = rawNameToString y+              err = "in the name " ++ s ++ ", the part " ++ x ++ " is not valid"+          case parse defaultParseFlags [0] (lexer return) x of+            ParseOk _ TokId{}  -> return ()+            ParseFailed{}      -> parseError err+            ParseOk _ TokEOF{} -> parseError err+            ParseOk _ (TokKeyword KwConstructor _) | con -> pure ()+            ParseOk _ t   -> parseError . ((err ++ " because it is ") ++) $ case t of+              TokQId{}      -> "qualified"+              TokKeyword{}  -> "a keyword"+              TokLiteral{}  -> "a literal"+              TokSymbol s _ -> case s of+                SymDot               -> __IMPOSSIBLE__ -- "reserved"+                SymSemi              -> "used to separate declarations"+                SymVirtualSemi       -> __IMPOSSIBLE__+                SymBar               -> "used for with-arguments"+                SymColon             -> "part of declaration syntax"+                SymArrow             -> "the function arrow"+                SymEqual             -> "part of declaration syntax"+                SymLambda            -> "used for lambda-abstraction"+                SymUnderscore        -> "used for anonymous identifiers"+                SymQuestionMark      -> "a meta variable"+                SymAs                -> "used for as-patterns"+                SymOpenParen         -> "used to parenthesize expressions"+                SymCloseParen        -> "used to parenthesize expressions"+                SymOpenIdiomBracket  -> "an idiom bracket"+                SymCloseIdiomBracket -> "an idiom bracket"+                SymEmptyIdiomBracket -> "an empty idiom bracket"+                SymDoubleOpenBrace   -> "used for instance arguments"+                SymDoubleCloseBrace  -> "used for instance arguments"+                SymOpenBrace         -> "used for hidden arguments"+                SymCloseBrace        -> "used for hidden arguments"+                SymOpenVirtualBrace  -> __IMPOSSIBLE__+                SymCloseVirtualBrace -> __IMPOSSIBLE__+                SymOpenPragma        -> "used for pragmas"+                SymClosePragma       -> "used for pragmas"+                SymEllipsis          -> "used for function clauses"+                SymDotDot            -> "a modality"+                SymEndComment        -> "the end-of-comment brace"+              TokString{}   -> __IMPOSSIBLE__+              TokTeX{}      -> __IMPOSSIBLE__  -- used by the LaTeX backend only+              TokMarkup{}   -> __IMPOSSIBLE__  -- ditto+              TokComment{}  -> __IMPOSSIBLE__+              TokDummy{}    -> __IMPOSSIBLE__++        -- we know that there are no two Ids in a row+        alternating (Hole :| Hole : _) = False+        alternating (_    :| x   : xs) = alternating $ x :| xs+        alternating (_    :|       []) = True++-- | Create a name from a string+mkName :: (Interval, String) -> Parser Name+mkName = mkName' False++-- | Create a qualified name from a list of strings+mkQName :: [(Interval, String)] -> Parser QName+mkQName ss | Just (ss0, ss1) <- initLast ss = do+  xs0 <- mapM mkName ss0+  xs1 <- mkName' True ss1+  return $ foldr Qual (QName xs1) xs0+mkQName _ = __IMPOSSIBLE__ -- The lexer never gives us an empty list of parts++mkDomainFree_ :: (NamedArg Binder -> NamedArg Binder) -> Maybe Pattern -> Name -> NamedArg Binder+mkDomainFree_ f p n = f $ defaultNamedArg $ Binder p UserBinderName $ mkBoundName_ n++mkRString :: (Interval, String) -> RString+mkRString (i, s) = Ranged (getRange i) s++mkRText :: (Interval, String) -> Ranged Text+mkRText (i, s) = Ranged (getRange i) $ T.pack s++-- | Create a qualified name from a string (used in pragmas).+--   Range of each name component is range of whole string.+--   TODO: precise ranges!++pragmaQName :: (Interval, String) -> Parser QName+pragmaQName (r, s) = do+  let ss = chopWhen (== '.') s+  mkQName $ map (r,) ss++mkNamedArg :: Maybe QName -> Either QName Range -> Parser (NamedArg BoundName)+mkNamedArg x y = do+  lbl <- case x of+           Nothing        -> return $ Just $ WithOrigin UserWritten $ unranged "_"+           Just (QName x) -> return $ Just $ WithOrigin UserWritten $ Ranged (getRange x) $ prettyShow x+           _              -> parseError "expected unqualified variable name"+  var <- case y of+           Left (QName y) -> return $ mkBoundName y noFixity'+           Right r        -> return $ mkBoundName (noName r) noFixity'+           _              -> parseError "expected unqualified variable name"+  return $ defaultArg $ Named lbl var++-- | Polarity parser.+--+--- Unknown polarities are replaced with the default polarity.++parsePolarity :: (Interval, String) -> Parser (Ranged Occurrence)+parsePolarity (i, s) =+  case s of+    "_"  -> ret Unused+    "++" -> ret StrictPos+    "+"  -> ret JustPos+    "-"  -> ret JustNeg+    "*"  -> ret Mixed+    _    -> do+      parseWarning (UnknownPolarity r s)+      ret Mixed+  where+    r = getRange i+    ret = return . Ranged r++recoverLayout :: [(Interval, String)] -> String+recoverLayout [] = ""+recoverLayout xs@((i, _) : _) = go (iStart i) xs+  where+    c0 = posCol (iStart i)++    go cur [] = ""+    go cur ((i, s) : xs) = padding cur (iStart i) ++ s ++ go (iEnd i) xs++    padding Pn{ posLine = l1, posCol = c1 } Pn{ posLine = l2, posCol = c2 }+      | l1 < l2   = List.genericReplicate (l2 - l1) '\n' ++ List.genericReplicate (max 0 (c2 - c0)) ' '+      | l1 == l2  = List.genericReplicate (c2 - c1) ' '+      | otherwise = __IMPOSSIBLE__++ensureUnqual :: QName -> Parser Name+ensureUnqual (QName x) = return x+ensureUnqual q@Qual{}  = parseError' (rStart' $ getRange q) "Qualified name not allowed here"++------------------------------------------------------------------------+-- Lambinds++-- | Result of parsing @LamBinds@.+data LamBinds' a = LamBinds+  { lamBindings   :: a             -- ^ A number of domain-free or typed bindings or record patterns.+  , absurdBinding :: Maybe Hiding  -- ^ Followed by possibly a final absurd pattern.+  } deriving (Functor)++type LamBinds = LamBinds' [LamBinding]++mkAbsurdBinding :: Hiding -> LamBinds+mkAbsurdBinding = LamBinds [] . Just++mkLamBinds :: a -> LamBinds' a+mkLamBinds bs = LamBinds bs Nothing++-- | Build a forall pi (forall x y z -> ...)+forallPi :: List1 LamBinding -> Expr -> Expr+forallPi bs e = Pi (fmap addType bs) e++-- | Converts lambda bindings to typed bindings.+addType :: LamBinding -> TypedBinding+addType (DomainFull b) = b+addType (DomainFree x) = TBind r (singleton x) $ Underscore r Nothing+  where r = getRange x++-- | Returns the value of the first erasure attribute, if any, or else+-- the default value of type 'Erased'.+--+-- Raises warnings for all attributes except for erasure attributes,+-- and for multiple erasure attributes.++onlyErased+  :: [Attr]  -- ^ The attributes, in reverse order.+  -> Parser Erased+onlyErased as = do+  es <- catMaybes <$> mapM onlyErased' (reverse as)+  case es of+    []     -> return defaultErased+    [e]    -> return e+    e : es -> do+      parseWarning $ MultipleAttributes (getRange es) (Just "erasure")+      return e+  where+  onlyErased' a = case theAttr a of+    RelevanceAttribute{} -> unsup "Relevance"+    CohesionAttribute{}  -> unsup "Cohesion"+    LockAttribute{}      -> unsup "Lock"+    CA.TacticAttribute{} -> unsup "Tactic"+    PolarityAttribute{}  -> unsup "Polarity"+    QuantityAttribute q  -> maybe (unsup "Linearity") (return . Just) $ erasedFromQuantity q+    where+    unsup s = do+      parseWarning $ UnsupportedAttribute (attrRange a) (Just s)+      return Nothing++-- | Constructs extended lambdas.++extLam+  :: Range            -- ^ The range of the lambda symbol and @where@ or+                      --   the braces.+  -> [Attr]           -- ^ The attributes in reverse order.+  -> List1 LamClause  -- ^ The clauses in reverse order.+  -> Parser Expr+extLam symbolRange attrs cs = do+  e <- onlyErased attrs+  let cs' = List1.reverse cs+  return $ ExtendedLam (getRange (symbolRange, e, cs')) e cs'++-- | Constructs extended or absurd lambdas.++extOrAbsLam+  :: Range   -- ^ The range of the lambda symbol.+  -> [Attr]  -- ^ The attributes, in reverse order.+  -> Either ([LamBinding], Hiding) (List1 Expr)+  -> Parser Expr+extOrAbsLam lambdaRange attrs cs = case cs of+  Right es -> do+    -- It is of the form @\ { p1 ... () }@.+    e  <- onlyErased attrs+    cl <- mkAbsurdLamClause empty es+    return $ ExtendedLam (getRange (lambdaRange, e, es)) e $ singleton cl+  Left (bs, h) -> do+    mapM_ (\a -> parseWarning $+                   UnsupportedAttribute (attrRange a) Nothing)+          (reverse attrs)+    List1.ifNull bs+      {-then-} (return $ AbsurdLam r h)+      {-else-} $ \ bs -> return $ Lam r bs (AbsurdLam r h)+    where+    r = fuseRange lambdaRange bs++-- | Interpret an expression as a list of names and (not parsed yet) as-patterns++exprAsNamesAndPatterns :: Expr -> Maybe (List1 (Name, Maybe Expr))+exprAsNamesAndPatterns = mapM exprAsNameAndPattern . exprAsTele+  where+    exprAsTele :: Expr -> List1 Expr+    exprAsTele (RawApp _ es) = List2.toList1 es+    exprAsTele e             = singleton e++exprAsNameAndPattern :: Expr -> Maybe (Name, Maybe Expr)+exprAsNameAndPattern (Ident (QName x)) = Just (x, Nothing)+exprAsNameAndPattern (Underscore r _)  = Just (setRange r simpleHole, Nothing)+exprAsNameAndPattern (As _ n e)        = Just (n, Just e)+exprAsNameAndPattern (Paren r e)       = Just (setRange r simpleHole, Just e)+exprAsNameAndPattern _                 = Nothing++-- interpret an expression as name or list of hidden / instance names+exprAsNameOrHiddenNames :: Expr -> Maybe (List1 (NamedArg (Name, Maybe Expr)))+exprAsNameOrHiddenNames = \case+  HiddenArg _ (Named Nothing e) ->+    fmap (hide . defaultNamedArg) <$> exprAsNamesAndPatterns e+  InstanceArg _ (Named Nothing e) ->+    fmap (makeInstance . defaultNamedArg) <$> exprAsNamesAndPatterns e+  e ->+    singleton . defaultNamedArg <$> exprAsNameAndPattern e++boundNamesOrAbsurd :: List1 Expr -> Parser (Either (List1 (NamedArg Binder)) (List1 Expr))+boundNamesOrAbsurd es+  | any isAbsurd es = return $ Right es+  | otherwise       =+    case mapM exprAsNameAndPattern es of+        Nothing   -> parseError $ "expected sequence of bound identifiers"+        Just good -> fmap Left $ forM good $ \ (n, me) -> do+                       p <- traverse exprToPattern me+                       return (defaultNamedArg (Binder p UserBinderName (mkBoundName_ n)))++  where++    isAbsurd :: Expr -> Bool+    isAbsurd (Absurd _)                  = True+    isAbsurd (HiddenArg _ (Named _ e))   = isAbsurd e+    isAbsurd (InstanceArg _ (Named _ e)) = isAbsurd e+    isAbsurd (Paren _ e)                 = isAbsurd e+    isAbsurd (As _ _ e)                  = isAbsurd e+    isAbsurd (RawApp _ es)               = any isAbsurd es+    isAbsurd _                           = False++-- | Match a pattern-matching "assignment" statement @p <- e@+exprToAssignment :: Expr -> Parser (Maybe (Pattern, Range, Expr))+exprToAssignment e@(RawApp r es)+  | (es1, arr : es2) <- List2.break isLeftArrow es =+    case filter isLeftArrow es2 of+      arr : _ -> parseError' (rStart' $ getRange arr) $ "Unexpected " ++ prettyShow arr+      [] ->+        -- Andreas, 2021-05-06, issue #5365+        -- Handle pathological cases like @do <-@ and @do x <-@.+        case (es1, es2) of+          (e1:rest1, e2:rest2) -> do+            p <- exprToPattern $ rawApp $ e1 :| rest1+            pure $ Just (p, getRange arr, rawApp (e2 :| rest2))+          _ -> parseError' (rStart' $ getRange e) $ "Incomplete binding " ++ prettyShow e+  where+    isLeftArrow (Ident (QName (Name _ _ (Id arr :| [])))) =+      arr `elem` ["<-", "\x2190"]  -- \leftarrow [issue #5465, unicode might crash happy]+    isLeftArrow _ = False+exprToAssignment _ = pure Nothing++-- | Build a with-block+buildWithBlock ::+  [Either RewriteEqn (List1 (Named Name Expr))] ->+  Parser ([RewriteEqn], [Named Name Expr])+buildWithBlock rees = case groupByEither rees of+  (Left rs : rest) -> (List1.toList rs,) <$> finalWith rest+  rest             -> ([],) <$> finalWith rest++  where++    finalWith :: (HasRange a, HasRange b) =>+                 [Either (List1 a) (List1 (List1 b))] -> Parser [b]+    finalWith []             = pure $ []+    finalWith [Right ees]    = pure $ List1.toList $ sconcat ees+    finalWith (Right{} : tl) = parseError' (rStart' $ getRange tl)+      "Cannot use rewrite / pattern-matching with after a with-abstraction."+    finalWith (Left{} : _)   = __IMPOSSIBLE__++-- | Build a with-statement+buildWithStmt :: List1 (Named Name Expr) ->+                 Parser [Either RewriteEqn (List1 (Named Name Expr))]+buildWithStmt nes = do+  ws <- mapM buildSingleWithStmt (List1.toList nes)+  let rws = groupByEither ws+  pure $ map (first (Invert ())) rws++buildUsingStmt :: List1 Expr -> Parser RewriteEqn+buildUsingStmt es = do+  mpatexprs <- mapM exprToAssignment es+  case mapM (fmap $ \(pat, _, expr) -> (pat, expr)) mpatexprs of+    Nothing -> parseError' (rStart' $ getRange es) "Expected assignments"+    Just assignments -> pure $ LeftLet assignments++buildSingleWithStmt ::+  Named Name Expr ->+  Parser (Either (Named Name (Pattern, Expr)) (Named Name Expr))+buildSingleWithStmt e = do+  mpatexpr <- exprToAssignment (namedThing e)+  pure $ case mpatexpr of+    Just (pat, _, expr) -> Left ((pat, expr) <$ e)+    Nothing             -> Right e++-- | Build a do-statement+defaultBuildDoStmt :: Expr -> [LamClause] -> Parser DoStmt+defaultBuildDoStmt e (_ : _) = parseError' (rStart' $ getRange e) "Only pattern matching do-statements can have where clauses."+defaultBuildDoStmt e []      = pure $ DoThen e++buildDoStmt :: Expr -> [LamClause] -> Parser DoStmt+buildDoStmt (Let r ds Nothing) [] = return $ DoLet r ds+buildDoStmt e@(RawApp r _)    cs = do+  mpatexpr <- exprToAssignment e+  case mpatexpr of+    Just (pat, r, expr) -> pure $ DoBind r pat expr cs+    Nothing -> defaultBuildDoStmt e cs+buildDoStmt e cs = defaultBuildDoStmt e cs+++{--------------------------------------------------------------------------+    Patterns+ --------------------------------------------------------------------------}++-- | Turn an expression into a left hand side.+exprToLHS :: Expr -> Parser ([RewriteEqn] -> [WithExpr] -> LHS)+exprToLHS e = LHS <$> exprToPattern e++-- | Turn an expression into a pattern. Fails if the expression is not a+--   valid pattern.+exprToPattern :: Expr -> Parser Pattern+exprToPattern e = case C.isPattern e of+  Nothing -> parseErrorRange e $ "Not a valid pattern: " ++ prettyShow e+  Just p  -> pure p++-- | Turn an expression into a name. Fails if the expression is not a+--   valid identifier.+exprToName :: Expr -> Parser Name+exprToName (Ident (QName x)) = return x+exprToName e = parseErrorRange e $ "Not a valid identifier: " ++ prettyShow e++-- | When given expression is @e1 = e2@, turn it into a named expression.+--   Call this inside an implicit argument @{e}@ or @{{e}}@, where+--   an equality must be a named argument (rather than a cubical partial match).+maybeNamed :: Expr -> Parser (Named_ Expr)+maybeNamed e =+  case e of+    Equal _ e1 e2 -> do+      let succeed x = return $ named (WithOrigin UserWritten $ Ranged (getRange e1) x) e2+      case e1 of+        Ident (QName x) -> succeed $ nameToRawName x+        -- We could have the following, but names of arguments cannot be _.+        -- Underscore{}    -> succeed $ "_"+        _ -> parseErrorRange e $ "Not a valid named argument: " ++ prettyShow e+    _ -> return $ unnamed e++-- Andreas, 2024-02-20, issue #7136:+-- The following function has been rewritten to a defensive pattern matching style+-- to be robust against future parser changes.+patternSynArgs :: [NamedArg Binder] -> Parser [WithHiding Name]+patternSynArgs = mapM \ x -> do+  let+    abort s = parseError $+      "Illegal pattern synonym argument  " ++ prettyShow x ++ "\n" +++      "(" ++ s ++ ".)"+    noAnn s = s ++ " annotations not allowed in pattern synonym arguments"++  case x of++    -- Invariant: fixity is not used here, and neither finiteness+    Arg ai (Named mn (Binder mp _ (BName n fix mtac fin)))+      | not $ null fix -> __IMPOSSIBLE__+      | fin            -> __IMPOSSIBLE__++    -- Error cases:+    Arg _ (Named _ (Binder (Just _) _ _)) ->+      abort "Arguments to pattern synonyms cannot be patterns themselves"+    Arg _ (Named _ (Binder _ _ (BName _ _ tac _))) | not (null tac) ->+      abort $ noAnn "Tactic"++    -- Benign case:+    Arg ai (Named mn (Binder Nothing _ (BName n _ _ _)))+      -- allow {n = n} for backwards compat with Agda 2.6+      | maybe True ((C.nameToRawName n ==) . rangedThing . woThing) mn ->+        case ai of++          -- Benign case:+          ArgInfo h (Modality Relevant{} (Quantityω _) Continuous (PolarityModality { modPolarityAnn = MixedPolarity })) UserWritten UnknownFVs (Annotation IsNotLock) ->+            return $ WithHiding h n++          -- Error cases:+          ArgInfo _ _ _ _ (Annotation (IsLock _)) ->+            abort $ noAnn "Lock"++          ArgInfo h (Modality r q c p) _ _ _+            | not (isRelevant r) ->+                abort "Arguments to pattern synonyms must be relevant"+            | not (isQuantityω q) ->+                abort $ noAnn "Quantity"+            | modPolarityAnn p /= MixedPolarity ->+                abort $ noAnn "Polarity"+            | c /= Continuous ->+                abort $ noAnn "Cohesion"++          -- Invariant: origin and fvs not used.+          ArgInfo _ _ _ (KnownFVs _) _ -> __IMPOSSIBLE__+          ArgInfo _ _ o _ _ | o /= UserWritten -> __IMPOSSIBLE__++          ArgInfo _ _ _ _ _ -> __IMPOSSIBLE__++      -- Error case: other named args are unsupported (issue #7136)+      | otherwise ->+          abort "Arguments to pattern synonyms cannot be named"++mkLamClause+  :: Catchall+  -> [Expr] -- ^ Possibly empty list of patterns.+  -> RHS+  -> Parser LamClause+mkLamClause catchall es rhs = mapM exprToPattern es <&> \ ps ->+  LamClause{ lamLHS = ps, lamRHS = rhs, lamCatchall = catchall }++mkAbsurdLamClause :: Catchall -> List1 Expr -> Parser LamClause+mkAbsurdLamClause catchall es = mkLamClause catchall (List1.toList es) AbsurdRHS++{- RHS or type signature -}++data RHSOrTypeSigs+ = JustRHS RHS+ | TypeSigsRHS Expr+ deriving Show++patternToNames :: Pattern -> Parser (List1 (ArgInfo, Name))+patternToNames = \case+    IdentP _ (QName i)           -> return $ singleton (defaultArgInfo, i)+    WildP r                      -> return $ singleton (defaultArgInfo, C.noName r)+    DotP kwr _ (Ident (QName i)) -> return $ singleton (makeIrrelevant kwr defaultArgInfo, i)+    RawAppP _ ps                 -> sconcat . List2.toList1 <$> mapM patternToNames ps+    p -> parseError $+      "Illegal name in type signature: " ++ prettyShow p++funClauseOrTypeSigs :: [Attr] -> ([RewriteEqn] -> [WithExpr] -> LHS)+                    -> [Either RewriteEqn (List1 (Named Name Expr))]+                    -> RHSOrTypeSigs+                    -> WhereClause -> Parser (List1 Declaration)+funClauseOrTypeSigs attrs lhs' with mrhs wh = do+  (rs , es) <- buildWithBlock with+  let lhs = lhs' rs (map (fmap observeModifiers) es)+  -- traceShowM lhs+  case mrhs of+    JustRHS rhs   -> do+      unless (null attrs) $ parseWarning $ MisplacedAttributes (getRange attrs) "A function clause cannot have attributes"+      return $ singleton $ FunClause lhs rhs wh empty+    TypeSigsRHS e -> case wh of+      NoWhere -> case lhs of+        LHS p _ _ | hasEllipsis p -> parseError "The ellipsis ... cannot have a type signature"+        LHS _ _ (_:_) -> parseError "Illegal: with in type signature"+        LHS _ (_:_) _ -> parseError "Illegal: rewrite in type signature"+        LHS p _ _ | hasWithPatterns p -> parseError "Illegal: with patterns in type signature"+        LHS p [] [] -> forMM (patternToNames p) $ \ (info, x) -> do+          info <- applyAttrs attrs info+          return $ typeSig info (getTacticAttr attrs) x e+      _ -> parseError "A type signature cannot have a where clause"++typeSig :: ArgInfo -> TacticAttribute -> Name -> Expr -> Declaration+typeSig i tac n e = TypeSig i tac n (Generalized e)++------------------------------------------------------------------------+-- * Relevance++makeIrrelevant :: (HasRange a, LensRelevance b) => a -> b -> b+makeIrrelevant = setRelevance . Irrelevant . OIrrDot . getRange++makeShapeIrrelevant :: (HasRange a, LensRelevance b) => a -> b -> b+makeShapeIrrelevant = setRelevance . ShapeIrrelevant . OShIrrDotDot . getRange++defaultIrrelevantArg :: HasRange a => a -> b -> Arg b+defaultIrrelevantArg a = makeIrrelevant a . defaultArg++defaultShapeIrrelevantArg :: HasRange a => a -> b -> Arg b+defaultShapeIrrelevantArg a = makeShapeIrrelevant a . defaultArg++makeIrrelevantM :: (HasRange a, LensRelevance b) => a -> b -> Parser b+makeIrrelevantM r x = do+  assertPristineRelevance r x+  return $ makeIrrelevant r x++makeShapeIrrelevantM :: (HasRange a, LensRelevance b) => a -> b -> Parser b+makeShapeIrrelevantM r x = do+  assertPristineRelevance r x+  return $ makeShapeIrrelevant r x++assertPristineRelevance :: (HasRange a, LensRelevance b) => a -> b -> Parser ()+assertPristineRelevance r x = unless (null $ getRelevance x) $+  parseErrorRange r $ "Conflicting relevance information"++------------------------------------------------------------------------+-- * Attributes++-- | Parse an attribute.+toAttribute :: Range -> Expr -> Parser (Maybe Attr)+toAttribute r e = do+  case exprToAttribute r e of+    Nothing -> Nothing <$ parseWarning (UnknownAttribute r s)+    Just a -> do+      let attr = Attr r s a+      modify' \ st -> st{ parseAttributes = attr : parseAttributes st }+      return $ Just attr+  where+    s = prettyShow e++-- | Apply an attribute to thing (usually `Arg`).+--   This will fail if one of the attributes is already set+--   in the thing to something else than the default value.+applyAttr :: (LensAttribute a) => Attr -> a -> Parser a+applyAttr attr@(Attr _ _ a) = maybe failure return . setPristineAttribute a+  where+  failure = errorConflictingAttribute attr++-- | Apply attributes to thing (usually `Arg`).+--   Expects a reversed list of attributes.+--   This will fail if one of the attributes is already set+--   in the thing to something else than the default value.+applyAttrs :: LensAttribute a => [Attr] -> a -> Parser a+applyAttrs rattrs arg = do+  let attrs = reverse rattrs+  checkForUniqueAttribute (isJust . isQuantityAttribute ) attrs+  checkForUniqueAttribute (isJust . isRelevanceAttribute) attrs+  checkForUniqueAttribute (not . null . isTacticAttribute) attrs+  foldM (flip applyAttr) arg attrs++applyAttrs1 :: LensAttribute a => List1 Attr -> a -> Parser a+applyAttrs1 = applyAttrs . List1.toList++-- | Set the tactic attribute of a binder+setTacticAttr :: [Attr] -> NamedArg Binder -> NamedArg Binder+setTacticAttr [] = id+setTacticAttr as = updateNamedArg $ fmap $ \ b ->+  case getTacticAttr as of+    t | null t    -> b+      | otherwise -> b { bnameTactic = t }++-- | Get the tactic attribute if present.+getTacticAttr :: [Attr] -> TacticAttribute+getTacticAttr as = C.TacticAttribute $+  case tacticAttributes [ a | Attr _ _ a <- as ] of+    [CA.TacticAttribute e] -> Just e+    [] -> Nothing+    _  -> __IMPOSSIBLE__++-- | Report a parse error if two attributes in the list are of the same kind,+--   thus, present conflicting information.+checkForUniqueAttribute :: (Attribute -> Bool) -> [Attr] -> Parser ()+checkForUniqueAttribute p attrs = do+  let pAttrs = filter (p . theAttr) attrs+  when (length pAttrs >= 2) $+    errorConflictingAttributes pAttrs++-- | Report an attribute as conflicting (e.g., with an already set value).+errorConflictingAttribute :: Attr -> Parser a+errorConflictingAttribute a = parseErrorRange a $+  "Conflicting attribute: " ++ prettyAttr a++-- | Report attributes as conflicting (e.g., with each other).+--   Precondition: List not emtpy.+errorConflictingAttributes :: [Attr] -> Parser a+errorConflictingAttributes [a] = errorConflictingAttribute a+errorConflictingAttributes as  = parseErrorRange as $+  "Conflicting attributes: " ++ unwords (map prettyAttr as)++prettyAttr :: Attr -> String+prettyAttr = ("@" ++) . attrName++-- | Apply some attributes to some binders.+applyAttributes :: Functor f+  => [Attr]+       -- ^ Can contain @tactic@ attribute.+  -> ArgInfo+       -- ^ If the attributes to be set are not at default value here, crash.+  -> f (NamedArg Binder)+       -- ^ Binders to apply attributes to.+  -> Parser (f (NamedArg Binder))+       -- ^ Binders with attributes applied.+applyAttributes attrs ai bs = do+  applyAttrs attrs ai <&> \ ai' ->+    fmap (setTacticAttr attrs . setArgInfo ai') bs
src/full/Agda/Syntax/Parser/Layout.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  {-| This module contains the lex actions that handle the layout rules. The way     it works is that the 'Parser' monad keeps track of a stack of@@ -13,7 +14,7 @@     > [Layout 12, Layout 4, Layout 0]      The closest layout block is the one following @do@ which is-    started by token @foo@ at column 12.  The second closest block is the+    started by token @y@ at column 12.  The second closest block is the     @where@ clause started by the @x'@ token which has indentation 4.     Finally, there is a top-level layout block with indentation 0. @@ -118,8 +119,6 @@ import Agda.Syntax.Position  import Agda.Utils.Functor ((<&>))--import Agda.Utils.Impossible  {-| Executed for the first token in each line (see 'Agda.Syntax.Parser.Lexer.bol'),     except when the last token was a layout keyword.
src/full/Agda/Syntax/Parser/Layout.hs-boot view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Syntax.Parser.Layout where  import Agda.Syntax.Parser.Alex   (LexAction)
src/full/Agda/Syntax/Parser/LexActions.hs view
@@ -1,4 +1,7 @@+{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wunused-imports #-}+ {-| This module contains the building blocks used to construct the lexer. -} module Agda.Syntax.Parser.LexActions@@ -23,7 +26,9 @@  import Data.Bifunctor import Data.Char+#if !MIN_VERSION_base(4,20,0) import Data.Foldable (foldl')+#endif import Data.Maybe  import Agda.Syntax.Common (pattern Ranged)@@ -35,6 +40,8 @@ import Agda.Syntax.Literal  import Agda.Utils.List+import Agda.Utils.List1 (String1, toList)+import qualified Agda.Utils.List1 as List1  import Agda.Utils.Impossible @@ -251,15 +258,15 @@ -- | Parse an identifier. Identifiers can be qualified (see 'Name'). --   Example: @Foo.Bar.f@ identifier :: LexAction Token-identifier = qualified (either TokId TokQId)+identifier = qualified $ either (TokId . second toList) (TokQId . map (second toList))   -- | Parse a possibly qualified name.-qualified :: (Either (Interval, String) [(Interval, String)] -> a) -> LexAction a+qualified :: (Either (Interval, String1) [(Interval, String1)] -> a) -> LexAction a qualified tok =     token $ \s ->     do  i <- getParseInterval-        case mkName i $ wordsBy (=='.') s of+        case mkName i $ List1.wordsBy (== '.') s of             []  -> lexError "lex error on .."             [x] -> return $ tok $ Left  x             xs  -> return $ tok $ Right xs@@ -267,16 +274,14 @@         -- Compute the ranges for the substrings (separated by '.') of         -- a name. Dots are included: the intervals generated for         -- "A.B.x" correspond to "A.", "B." and "x".-        mkName :: Interval -> [String] -> [(Interval, String)]+        mkName :: Interval -> [String1] -> [(Interval, String1)]         mkName _ []     = []         mkName i [x]    = [(i, x)]-        mkName i (x:xs) = (i0, x) : mkName i1 xs+        mkName (Interval f p0 p1) (x:xs) = (i0, x) : mkName i1 xs             where-                p0 = iStart i-                p1 = iEnd i                 p' = movePos (movePosByString p0 x) '.'-                i0 = Interval p0 p'-                i1 = Interval p' p1+                i0 = Interval f p0 p'+                i1 = Interval f p' p1   {--------------------------------------------------------------------------
src/full/Agda/Syntax/Parser/LexActions.hs-boot view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Syntax.Parser.LexActions where  import Agda.Syntax.Literal
src/full/Agda/Syntax/Parser/Lexer.x view
@@ -88,8 +88,11 @@ <pragma_>   "ETA"                      { keyword KwETA } <pragma_>   "IMPOSSIBLE"               { keyword KwIMPOSSIBLE } <pragma_>   "INJECTIVE"                { keyword KwINJECTIVE }+<pragma_>   "INJECTIVE_FOR_INFERENCE"  { keyword KwINJECTIVE_FOR_INFERENCE } <pragma_>   "INLINE"                   { keyword KwINLINE }+<pragma_>   "INCOHERENT"               { keyword KwINCOHERENT } <pragma_>   "NOINLINE"                 { keyword KwNOINLINE }+<pragma_>   "NOT_PROJECTION_LIKE"      { keyword KwNOT_PROJECTION_LIKE } <pragma_>   "LINE"                     { keyword KwLINE } <pragma_>   "MEASURE"                  { keyword KwMEASURE } <pragma_>   "NO_POSITIVITY_CHECK"      { keyword KwNO_POSITIVITY_CHECK }@@ -99,6 +102,9 @@ <pragma_>   "NON_TERMINATING"          { keyword KwNON_TERMINATING } <pragma_>   "OPTIONS"                  { keyword KwOPTIONS } <pragma_>   "POLARITY"                 { keyword KwPOLARITY }+<pragma_>   "OVERLAPPABLE"             { keyword KwOVERLAPPABLE }+<pragma_>   "OVERLAPPING"              { keyword KwOVERLAPPING }+<pragma_>   "OVERLAPS"                 { keyword KwOVERLAPS } <pragma_>   "REWRITE"                  { keyword KwREWRITE } <pragma_>   "STATIC"                   { keyword KwSTATIC } <pragma_>   "TERMINATING"              { keyword KwTERMINATING }@@ -190,6 +196,8 @@ <0,code> variable          { keyword KwVariable } <0,code> where             { keyword KwWhere } <0,code> with              { keyword KwWith }+<0,code> opaque            { keyword KwOpaque }+<0,code> unfolding         { keyword KwUnfolding }  -- The parser is responsible to put the lexer in the imp_dir_ state when it -- expects an import directive keyword. This means that if you run the
src/full/Agda/Syntax/Parser/Literate.hs view
@@ -1,11 +1,10 @@-{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Preprocessors for literate code formats.  module Agda.Syntax.Parser.Literate   ( literateProcessors   , literateExtsShortList-  , literateSrcFile   , literateTeX   , literateRsT   , literateMd@@ -33,7 +32,9 @@ import Agda.Syntax.Position  import Agda.Utils.List+import Agda.Utils.List1 (List1) import qualified Agda.Utils.List1 as List1+import Agda.Utils.Singleton  import Agda.Utils.Impossible @@ -46,7 +47,7 @@  data Layer = Layer   { layerRole    :: LayerRole-  , interval     :: Interval+  , interval     :: IntervalWithoutFile   , layerContent :: String   } deriving Show @@ -54,17 +55,17 @@  type Layers = [Layer] -instance HasRange Layer where-  getRange = getRange . interval+instance HasRangeWithoutFile Layer where+  getRangeWithoutFile = getRangeWithoutFile . interval  -- | Annotates a tokenized string with position information. -mkLayers :: Position -> [(LayerRole, String)] -> Layers+mkLayers :: PositionWithoutFile -> [(LayerRole, String)] -> Layers mkLayers pos []            = emptyLiterate pos mkLayers pos ((_,"") : xs) = mkLayers pos xs                              -- Empty layers are ignored. mkLayers pos ((ty,s) : xs) =-  Layer ty (Interval pos next) s : mkLayers next xs+  Layer ty (Interval () pos next) s : mkLayers next xs   where   next = movePosByString pos s @@ -79,15 +80,11 @@ -- --   > f : Processor -----   prop> f pos s /= []+--   proposition> f pos s /= [] -----   prop> f pos s >>= layerContent == s--type Processor = Position -> String -> [Layer]+--   proposition> f pos s >>= layerContent == s -literateSrcFile :: [Layer] -> SrcFile-literateSrcFile []                    = __IMPOSSIBLE__-literateSrcFile (Layer{interval} : _) = getIntervalFile interval+type Processor = PositionWithoutFile -> String -> [Layer]  -- | List of valid extensions for literate Agda files, and their --   corresponding preprocessors.@@ -103,6 +100,10 @@     , (".tex", (literateTeX, TexFileType))     , (".md",  (literateMd,  MdFileType ))     , (".org", (literateOrg, OrgFileType))+    , (".tree", (literateTree, TreeFileType))+    -- For now, treat typst as markdown because they use the same+    -- syntax for code blocks.+    , (".typ", (literateMd,  TypstFileType))     ]  -- | Returns @True@ if the role corresponds to Agda code.@@ -141,8 +142,8 @@ -- | Short list of extensions for literate Agda files. --   For display purposes. -literateExtsShortList :: [String]-literateExtsShortList = [".lagda"]+literateExtsShortList :: List1 String+literateExtsShortList = singleton ".lagda"  -- | Returns a tuple consisting of the first line of the input, and the rest --   of the input.@@ -156,8 +157,8 @@  -- | Canonical decomposition of an empty literate file. -emptyLiterate :: Position -> [Layer]-emptyLiterate pos = [Layer Markup (Interval pos pos) ""]+emptyLiterate :: PositionWithoutFile -> [Layer]+emptyLiterate pos = [Layer Markup (Interval () pos pos) ""]  -- | Create a regular expression that: --   - Must match the whole string@@ -170,7 +171,7 @@  -- | Preprocessor for literate TeX. -literateTeX :: Position -> String -> [Layer]+literateTeX :: Processor literateTeX pos s = mkLayers pos (tex s)   where   tex :: String -> [(LayerRole, String)]@@ -196,7 +197,7 @@  -- | Preprocessor for Markdown. -literateMd :: Position -> String -> [Layer]+literateMd :: Processor literateMd pos s = mkLayers pos $ md s   where   md :: String -> [(LayerRole, String)]@@ -234,7 +235,7 @@  -- | Preprocessor for reStructuredText. -literateRsT :: Position -> String -> [Layer]+literateRsT :: Processor literateRsT pos s = mkLayers pos $ rst s   where   rst :: String -> [(LayerRole, String)]@@ -281,7 +282,7 @@  -- | Preprocessor for Org mode documents. -literateOrg :: Position -> String -> [Layer]+literateOrg :: Processor literateOrg pos s = mkLayers pos $ org s   where   org :: String -> [(LayerRole, String)]@@ -309,3 +310,29 @@   rex' :: String -> Regex   -- Source blocks start with `#+begin_src` but the casing does not matter.   rex' = makeRegexOpts blankCompOpt{newSyntax = True, caseSensitive = False} blankExecOpt++-- | Preprocessor for Forester documents++literateTree :: Processor+literateTree pos s = mkLayers pos (tree s)+  where+  tree :: String -> [(LayerRole, String)]+  tree = caseLine [] $ \ line rest ->+    case tree_begin `matchM` line of+      Just (getAllTextSubmatches -> [_, pre, _, markup, whitespace]) ->+        (Comment, pre) : (Markup, markup) :+        (Code, whitespace) : code rest+      Just _  -> __IMPOSSIBLE__+      Nothing -> (Comment, line) : tree rest++  tree_begin = rex "(([^\\%]|\\\\.)*)(\\\\agda\\{[^\n]*)(\n)?"++  code :: String -> [(LayerRole, String)]+  code = caseLine [] $ \ line rest ->+    case tree_end `matchM` line of+      Just (getAllTextSubmatches -> [_, code, markup, post]) ->+        (Code, code) : (Markup, markup) : (Comment, post) : tree rest+      Just _  -> __IMPOSSIBLE__+      Nothing -> (Code, line) : code rest++  tree_end = rex "([[:blank:]]*)(\\})(.*)"
src/full/Agda/Syntax/Parser/LookAhead.hs view
@@ -25,7 +25,7 @@ import Agda.Syntax.Parser.Monad  import Agda.Utils.Null (ifNull)-import Agda.Utils.Maybe (caseMaybeM, fromMaybeM)+import Agda.Utils.Maybe (fromMaybeM)  {--------------------------------------------------------------------------     The look-ahead monad
src/full/Agda/Syntax/Parser/Monad.hs view
@@ -36,19 +36,21 @@ import Control.Monad.Except import Control.Monad.State -import Data.Int-import Data.Data  ( Data ) import Data.Maybe ( listToMaybe )+import Data.Word  ( Word32)  import Agda.Interaction.Options.Warnings +import Agda.Syntax.Concrete.Attribute import Agda.Syntax.Position import Agda.Syntax.Parser.Tokens ( Keyword( KwMutual ) ) -import Agda.Utils.FileName+import Agda.TypeChecking.Positivity.Occurrence ( pattern Mixed )++import Agda.Utils.IO   ( showIOException ) import Agda.Utils.List ( tailWithDefault ) import qualified Agda.Utils.Maybe.Strict as Strict-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty  import Agda.Utils.Impossible @@ -76,6 +78,9 @@                                              --   (states can be nested so we need a stack)     , parseFlags    :: ParseFlags            -- ^ parametrization of the parser     , parseWarnings :: ![ParseWarning]       -- ^ In reverse order.+    , parseAttributes+                    :: !Attributes+      -- ^ Every encountered attribute.     }     deriving Show @@ -101,7 +106,7 @@     deriving Show  -- | A (layout) column.-type Column = Int32+type Column = Word32  -- | Status of a layout column (see #1145). --   A layout column is 'Tentative' until we encounter a new line.@@ -151,37 +156,57 @@    -- | Parse errors that concern a whole file.   | InvalidExtensionError-    { errPath      :: !AbsolutePath+    { errPath      :: !RangeFile                       -- ^ The file which the error concerns.     , errValidExts :: [String]     }   | ReadFileError-    { errPath      :: !AbsolutePath+    { errPath      :: !RangeFile     , errIOError   :: IOError     }   deriving Show +instance NFData ParseError where+  rnf = \case+    ParseError _f _r inp tok msg  -> rnf inp `seq` rnf tok `seq` rnf msg+    OverlappingTokensError _r     -> ()+    InvalidExtensionError _r exts -> rnf exts+    ReadFileError _r _err         -> ()+ -- | Warnings for parsing. data ParseWarning   -- | Parse errors that concern a range in a file.   = OverlappingTokensWarning-    { warnRange    :: !(Range' SrcFile)-                      -- ^ The range of the bigger overlapping token+    { warnRange :: !(Range' SrcFile)+        -- ^ The range of the bigger overlapping token.     }+  | MisplacedAttributes Range String+      -- ^ The 'String' is the error message.+  | UnknownPolarity Range String+      -- ^ Unknown polarity, ignored.+  | UnknownAttribute Range String+      -- ^ Unknown attribute, ignored.+      --   The 'Range' includes the "@", the 'String' not.   | UnsupportedAttribute Range !(Maybe String)-    -- ^ Unsupported attribute.+      -- ^ Unsupported attribute.   | MultipleAttributes Range !(Maybe String)-    -- ^ Multiple attributes.-  deriving (Data, Show)+      -- ^ Multiple attributes.+  deriving Show  instance NFData ParseWarning where   rnf (OverlappingTokensWarning _) = ()+  rnf (MisplacedAttributes _ s)    = rnf s+  rnf (UnknownPolarity _ s)        = rnf s+  rnf (UnknownAttribute _ s)       = rnf s   rnf (UnsupportedAttribute _ s)   = rnf s   rnf (MultipleAttributes _ s)     = rnf s  parseWarningName :: ParseWarning -> WarningName parseWarningName = \case   OverlappingTokensWarning{} -> OverlappingTokensWarning_+  MisplacedAttributes{}      -> MisplacedAttributes_+  UnknownPolarity{}          -> UnknownPolarity_+  UnknownAttribute{}         -> UnknownAttribute_   UnsupportedAttribute{}     -> UnsupportedAttribute_   MultipleAttributes{}       -> MultipleAttributes_ @@ -221,23 +246,25 @@  instance Pretty ParseError where   pretty ParseError{errPos,errSrcFile,errMsg,errPrevToken,errInput} = vcat-      [ (pretty (errPos { srcFile = errSrcFile }) <> colon) <+>-        text errMsg-      , text $ errPrevToken ++ "<ERROR>"-      , text $ take 30 errInput ++ "..."+      [ (pretty errPos{ srcFile = errSrcFile } <> colon) <+> "error: [ParseError]"+      , if not $ null errMsg then text errMsg else sep+          -- Happy errors have no message, so we print the context instead+          [ text $ errPrevToken ++ "<ERROR>"+          , text $ take 30 errInput ++ "..."+          ]       ]   pretty OverlappingTokensError{errRange} = vcat-      [ (pretty errRange <> colon) <+>-        "Multi-line comment spans one or more literate text blocks."+      [ (pretty errRange <> colon) <+> "error: [OverlappingTokensError]"+      , "Multi-line comment spans one or more literate text blocks."       ]   pretty InvalidExtensionError{errPath,errValidExts} = vcat-      [ (pretty errPath <> colon) <+>-        "Unsupported extension."+      [ (pretty errPath <> colon) <+> "error: [InvalidExtensionError]"+      , "Unsupported extension."       , "Supported extensions are:" <+> prettyList_ errValidExts       ]   pretty ReadFileError{errPath,errIOError} = vcat       [ "Cannot read file" <+> pretty errPath-      , "Error:" <+> text (displayException errIOError)+      , "Error:" <+> text (showIOException errIOError)       ]  instance HasRange ParseError where@@ -250,26 +277,38 @@     errPathRange = posToRange p p       where p = startPos $ Just $ errPath err +-- | Does not include printing of the range.+-- instance Pretty ParseWarning where-  pretty OverlappingTokensWarning{warnRange} = vcat-      [ (pretty warnRange <> colon) <+>-        "Multi-line comment spans one or more literate text blocks."+  pretty = \case++    OverlappingTokensWarning _r ->+      "Multi-line comment spans one or more literate text blocks."++    MisplacedAttributes _r s -> text s++    UnknownPolarity _r s ->+      "Replacing unknown polarity" <+> text s <+> "by" <+> pretty Mixed++    UnknownAttribute _r s ->+      "Ignoring unknown attribute:" <+> ("@" <> text s)++    UnsupportedAttribute _r ms -> hsep+      [ case ms of+          Nothing -> "Attributes"+          Just s  -> text s <+> "attributes"+      , "are not supported here."       ]-  pretty (UnsupportedAttribute r s) = vcat-    [ (pretty r <> colon) <+>-      (case s of-         Nothing -> "Attributes"-         Just s  -> text s <+> "attributes") <+>-      "are not supported here."-    ]-  pretty (MultipleAttributes r s) = vcat-    [ (pretty r <> colon) <+>-      "Multiple" <+>-      maybe id (\s -> (text s <+>)) s "attributes (ignored)."-    ] +    MultipleAttributes _r ms -> hsep+      [ "Multiple", pretty ms, "attributes (ignored)." ]++ instance HasRange ParseWarning where   getRange OverlappingTokensWarning{warnRange} = warnRange+  getRange (MisplacedAttributes r _)           = r+  getRange (UnknownPolarity r _)               = r+  getRange (UnknownAttribute r _)              = r   getRange (UnsupportedAttribute r _)          = r   getRange (MultipleAttributes r _)            = r @@ -293,6 +332,7 @@                                                 -- Just for better errors on stray @constructor@ decls.                 , parseFlags        = flags                 , parseWarnings     = []+                , parseAttributes   = []                 }   where   pos' = pos { srcFile = () }@@ -300,8 +340,8 @@ -- | Constructs the initial state of the parser. The string argument --   is the input string, the file path is only there because it's part --   of a position.-initState :: Maybe AbsolutePath -> ParseFlags -> String -> [LexState]-          -> ParseState+initState ::+  Maybe RangeFile -> ParseFlags -> String -> [LexState] -> ParseState initState file = initStatePos (startPos file)  -- | The default flags.
src/full/Agda/Syntax/Parser/Parser.y view
@@ -24,2416 +24,1908 @@     , exprWhereParser     , tokensParser     , holeContentParser-    , splitOnDots  -- only used by the internal test-suite-    ) where--import Prelude hiding ( null )--import Control.Applicative ( (<|>) )-import Control.Monad--import Data.Bifunctor (first, second)-import Data.Char-import qualified Data.List as List-import Data.Maybe-import Data.Semigroup ((<>), sconcat)-import qualified Data.Traversable as T--import Agda.Syntax.Position hiding (tests)-import Agda.Syntax.Parser.Monad-import Agda.Syntax.Parser.Lexer-import Agda.Syntax.Parser.Tokens-import Agda.Syntax.Concrete as C-import Agda.Syntax.Concrete.Attribute-import Agda.Syntax.Concrete.Pattern-import Agda.Syntax.Common-import Agda.Syntax.Notation-import Agda.Syntax.Literal--import Agda.TypeChecking.Positivity.Occurrence hiding (tests)--import Agda.Utils.Either hiding (tests)-import Agda.Utils.Functor-import Agda.Utils.Hash-import Agda.Utils.List ( spanJust, chopWhen )-import Agda.Utils.List1 ( List1, pattern (:|), (<|) )-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Pretty hiding ((<>))-import Agda.Utils.Singleton-import qualified Agda.Utils.Maybe.Strict as Strict-import qualified Agda.Utils.List1 as List1-import qualified Agda.Utils.List2 as List2--import Agda.Utils.Impossible--}--%name tokensParser Tokens-%name exprParser Expr-%name exprWhereParser ExprWhere-%name moduleParser File-%name moduleNameParser ModuleName-%name funclauseParser FunClause-%name holeContentParser HoleContent--%tokentype { Token }-%monad { Parser }-%lexer { lexer } { TokEOF{} }--%expect 8--- * shift/reduce for \ x y z -> foo = bar---   shifting means it'll parse as \ x y z -> (foo = bar) rather than---   (\ x y z -> foo) = bar------ * Telescope let and do-notation let.---      Expr2 -> 'let' Declarations . LetBody---      TypedBinding -> '(' 'let' Declarations . ')'---        ')'   shift, and enter state 486---              (reduce using rule 189)---   A do-block cannot end in a 'let' so committing to TypedBinding with a---   shift is the right thing to do here.------ * Named implicits in TypedBinding {x = y}. When encountering the '=' shift---   treats this as a named implicit and reducing would fail later.---- This is a trick to get rid of shift/reduce conflicts arising because we want--- to parse things like "m >>= \x -> k x". See the Expr rule for more--- information.-%nonassoc LOWEST-%nonassoc '->'--%token-    'abstract'                { TokKeyword KwAbstract $$ }-    'codata'                  { TokKeyword KwCoData $$ }-    'coinductive'             { TokKeyword KwCoInductive $$ }-    'constructor'             { TokKeyword KwConstructor $$ }-    'data'                    { TokKeyword KwData $$ }-    'eta-equality'            { TokKeyword KwEta $$ }-    'field'                   { TokKeyword KwField $$ }-    'forall'                  { TokKeyword KwForall $$ }-    'variable'                { TokKeyword KwVariable $$ }-    'hiding'                  { TokKeyword KwHiding $$ }-    'import'                  { TokKeyword KwImport $$ }-    'in'                      { TokKeyword KwIn $$ }-    'inductive'               { TokKeyword KwInductive $$ }-    'infix'                   { TokKeyword KwInfix $$ }-    'infixl'                  { TokKeyword KwInfixL $$ }-    'infixr'                  { TokKeyword KwInfixR $$ }-    'instance'                { TokKeyword KwInstance $$ }-    'overlap'                 { TokKeyword KwOverlap $$ }-    'let'                     { TokKeyword KwLet $$ }-    'macro'                   { TokKeyword KwMacro $$ }-    'module'                  { TokKeyword KwModule $$ }-    'interleaved'             { TokKeyword KwInterleaved $$ }-    'mutual'                  { TokKeyword KwMutual $$ }-    'no-eta-equality'         { TokKeyword KwNoEta $$ }-    'open'                    { TokKeyword KwOpen $$ }-    'pattern'                 { TokKeyword KwPatternSyn $$ }-    'postulate'               { TokKeyword KwPostulate $$ }-    'primitive'               { TokKeyword KwPrimitive $$ }-    'private'                 { TokKeyword KwPrivate $$ }-    'public'                  { TokKeyword KwPublic $$ }-    'quote'                   { TokKeyword KwQuote $$ }-    'quoteTerm'               { TokKeyword KwQuoteTerm $$ }-    'record'                  { TokKeyword KwRecord $$ }-    'renaming'                { TokKeyword KwRenaming $$ }-    'rewrite'                 { TokKeyword KwRewrite $$ }-    'syntax'                  { TokKeyword KwSyntax $$ }-    'tactic'                  { TokKeyword KwTactic $$ }-    'to'                      { TokKeyword KwTo $$ }-    'unquote'                 { TokKeyword KwUnquote $$ }-    'unquoteDecl'             { TokKeyword KwUnquoteDecl $$ }-    'unquoteDef'              { TokKeyword KwUnquoteDef $$ }-    'using'                   { TokKeyword KwUsing $$ }-    'where'                   { TokKeyword KwWhere $$ }-    'do'                      { TokKeyword KwDo $$ }-    'with'                    { TokKeyword KwWith $$ }--    'BUILTIN'                 { TokKeyword KwBUILTIN $$ }-    'CATCHALL'                { TokKeyword KwCATCHALL $$ }-    'DISPLAY'                 { TokKeyword KwDISPLAY $$ }-    'ETA'                     { TokKeyword KwETA $$ }-    'FOREIGN'                 { TokKeyword KwFOREIGN $$ }-    'COMPILE'                 { TokKeyword KwCOMPILE $$ }-    'IMPOSSIBLE'              { TokKeyword KwIMPOSSIBLE $$ }-    'INJECTIVE'               { TokKeyword KwINJECTIVE $$ }-    'INLINE'                  { TokKeyword KwINLINE $$ }-    'NOINLINE'                { TokKeyword KwNOINLINE $$ }-    'MEASURE'                 { TokKeyword KwMEASURE $$ }-    'NO_TERMINATION_CHECK'    { TokKeyword KwNO_TERMINATION_CHECK $$ }-    'NO_POSITIVITY_CHECK'     { TokKeyword KwNO_POSITIVITY_CHECK $$ }-    'NO_UNIVERSE_CHECK'       { TokKeyword KwNO_UNIVERSE_CHECK $$ }-    'NON_TERMINATING'         { TokKeyword KwNON_TERMINATING $$ }-    'NON_COVERING'            { TokKeyword KwNON_COVERING $$ }-    'OPTIONS'                 { TokKeyword KwOPTIONS $$ }-    'POLARITY'                { TokKeyword KwPOLARITY $$ }-    'WARNING_ON_USAGE'        { TokKeyword KwWARNING_ON_USAGE $$ }-    'WARNING_ON_IMPORT'       { TokKeyword KwWARNING_ON_IMPORT $$ }-    'REWRITE'                 { TokKeyword KwREWRITE $$ }-    'STATIC'                  { TokKeyword KwSTATIC $$ }-    'TERMINATING'             { TokKeyword KwTERMINATING $$ }--    tex                       { TokTeX $$ }-    comment                   { TokComment $$ }--    '...'                     { TokSymbol SymEllipsis $$ }-    '..'                      { TokSymbol SymDotDot $$ }-    '.'                       { TokSymbol SymDot $$ }-    ';'                       { TokSymbol SymSemi $$ }-    ':'                       { TokSymbol SymColon $$ }-    '='                       { TokSymbol SymEqual $$ }-    '_'                       { TokSymbol SymUnderscore $$ }-    '?'                       { TokSymbol SymQuestionMark $$ }-    '->'                      { TokSymbol SymArrow $$ }-    '\\'                      { TokSymbol SymLambda $$ }-    '@'                       { TokSymbol SymAs $$ }-    '|'                       { TokSymbol SymBar $$ }-    '('                       { TokSymbol SymOpenParen $$ }-    ')'                       { TokSymbol SymCloseParen $$ }-    '(|'                      { TokSymbol SymOpenIdiomBracket $$ }-    '|)'                      { TokSymbol SymCloseIdiomBracket $$ }-    '(|)'                     { TokSymbol SymEmptyIdiomBracket $$ }-    '{{'                      { TokSymbol SymDoubleOpenBrace $$ }-    '}}'                      { TokSymbol SymDoubleCloseBrace $$ }-    '{'                       { TokSymbol SymOpenBrace $$ }-    '}'                       { TokSymbol SymCloseBrace $$ }---    ':{'                      { TokSymbol SymColonBrace $$ }-    vopen                     { TokSymbol SymOpenVirtualBrace $$ }-    vclose                    { TokSymbol SymCloseVirtualBrace $$ }-    vsemi                     { TokSymbol SymVirtualSemi $$ }-    '{-#'                     { TokSymbol SymOpenPragma $$ }-    '#-}'                     { TokSymbol SymClosePragma $$ }--    id                        { TokId $$ }-    q_id                      { TokQId $$ }--    string                    { TokString $$ }-    literal                   { TokLiteral $$ }--%%--{---------------------------------------------------------------------------    Parsing the token stream. Used by the TeX compiler.- --------------------------------------------------------------------------}---- Parse a list of tokens.-Tokens :: { [Token] }-Tokens : TokensR        { reverse $1 }---- Happy is much better at parsing left recursive grammars (constant--- stack size vs. linear stack size for right recursive).-TokensR :: { [Token] }-TokensR : TokensR Token { $2 : $1 }-        |               { [] }---- Parse single token.-Token :: { Token }-Token-      -- Please keep these keywords in alphabetical order!-    : 'abstract'                { TokKeyword KwAbstract $1 }-    | 'codata'                  { TokKeyword KwCoData $1 }-    | 'coinductive'             { TokKeyword KwCoInductive $1 }-    | 'constructor'             { TokKeyword KwConstructor $1 }-    | 'data'                    { TokKeyword KwData $1 }-    | 'do'                      { TokKeyword KwDo $1 }-    | 'eta-equality'            { TokKeyword KwEta $1 }-    | 'field'                   { TokKeyword KwField $1 }-    | 'forall'                  { TokKeyword KwForall $1 }-    | 'hiding'                  { TokKeyword KwHiding $1 }-    | 'import'                  { TokKeyword KwImport $1 }-    | 'in'                      { TokKeyword KwIn $1 }-    | 'inductive'               { TokKeyword KwInductive $1 }-    | 'infix'                   { TokKeyword KwInfix $1 }-    | 'infixl'                  { TokKeyword KwInfixL $1 }-    | 'infixr'                  { TokKeyword KwInfixR $1 }-    | 'instance'                { TokKeyword KwInstance $1 }-    | 'let'                     { TokKeyword KwLet $1 }-    | 'macro'                   { TokKeyword KwMacro $1 }-    | 'module'                  { TokKeyword KwModule $1 }-    | 'interleaved'             { TokKeyword KwInterleaved $1 }-    | 'mutual'                  { TokKeyword KwMutual $1 }-    | 'no-eta-equality'         { TokKeyword KwNoEta $1 }-    | 'open'                    { TokKeyword KwOpen $1 }-    | 'overlap'                 { TokKeyword KwOverlap $1 }-    | 'pattern'                 { TokKeyword KwPatternSyn $1 }-    | 'postulate'               { TokKeyword KwPostulate $1 }-    | 'primitive'               { TokKeyword KwPrimitive $1 }-    | 'private'                 { TokKeyword KwPrivate $1 }-    | 'public'                  { TokKeyword KwPublic $1 }-    | 'quote'                   { TokKeyword KwQuote $1 }-    | 'quoteTerm'               { TokKeyword KwQuoteTerm $1 }-    | 'record'                  { TokKeyword KwRecord $1 }-    | 'renaming'                { TokKeyword KwRenaming $1 }-    | 'rewrite'                 { TokKeyword KwRewrite $1 }-    | 'syntax'                  { TokKeyword KwSyntax $1 }-    | 'tactic'                  { TokKeyword KwTactic $1 }-    | 'to'                      { TokKeyword KwTo $1 }-    | 'unquote'                 { TokKeyword KwUnquote $1 }-    | 'unquoteDecl'             { TokKeyword KwUnquoteDecl $1 }-    | 'unquoteDef'              { TokKeyword KwUnquoteDef $1 }-    | 'using'                   { TokKeyword KwUsing $1 }-    | 'variable'                { TokKeyword KwVariable $1 }-    | 'where'                   { TokKeyword KwWhere $1 }-    | 'with'                    { TokKeyword KwWith $1 }--      -- Please keep these pragmas in alphabetical order!-    | 'BUILTIN'                 { TokKeyword KwBUILTIN $1 }-    | 'CATCHALL'                { TokKeyword KwCATCHALL $1 }-    | 'COMPILE'                 { TokKeyword KwCOMPILE $1 }-    | 'DISPLAY'                 { TokKeyword KwDISPLAY $1 }-    | 'ETA'                     { TokKeyword KwETA $1 }-    | 'FOREIGN'                 { TokKeyword KwFOREIGN $1 }-    | 'IMPOSSIBLE'              { TokKeyword KwIMPOSSIBLE $1 }-    | 'INJECTIVE'               { TokKeyword KwINJECTIVE $1 }-    | 'INLINE'                  { TokKeyword KwINLINE $1 }-    | 'MEASURE'                 { TokKeyword KwMEASURE $1 }-    | 'NOINLINE'                { TokKeyword KwNOINLINE $1 }-    | 'NO_POSITIVITY_CHECK'     { TokKeyword KwNO_POSITIVITY_CHECK $1 }-    | 'NO_TERMINATION_CHECK'    { TokKeyword KwNO_TERMINATION_CHECK $1 }-    | 'NO_UNIVERSE_CHECK'       { TokKeyword KwNO_UNIVERSE_CHECK $1 }-    | 'NON_TERMINATING'         { TokKeyword KwNON_TERMINATING $1 }-    | 'NON_COVERING'            { TokKeyword KwNON_COVERING $1 }-    | 'OPTIONS'                 { TokKeyword KwOPTIONS $1 }-    | 'POLARITY'                { TokKeyword KwPOLARITY $1 }-    | 'REWRITE'                 { TokKeyword KwREWRITE $1 }-    | 'STATIC'                  { TokKeyword KwSTATIC $1 }-    | 'TERMINATING'             { TokKeyword KwTERMINATING $1 }-    | 'WARNING_ON_IMPORT'       { TokKeyword KwWARNING_ON_IMPORT $1 }-    | 'WARNING_ON_USAGE'        { TokKeyword KwWARNING_ON_USAGE $1 }--    | tex                       { TokTeX $1 }-    | comment                   { TokComment $1 }--    | '...'                     { TokSymbol SymEllipsis $1 }-    | '..'                      { TokSymbol SymDotDot $1 }-    | '.'                       { TokSymbol SymDot $1 }-    | ';'                       { TokSymbol SymSemi $1 }-    | ':'                       { TokSymbol SymColon $1 }-    | '='                       { TokSymbol SymEqual $1 }-    | '_'                       { TokSymbol SymUnderscore $1 }-    | '?'                       { TokSymbol SymQuestionMark $1 }-    | '->'                      { TokSymbol SymArrow $1 }-    | '\\'                      { TokSymbol SymLambda $1 }-    | '@'                       { TokSymbol SymAs $1 }-    | '|'                       { TokSymbol SymBar $1 }-    | '('                       { TokSymbol SymOpenParen $1 }-    | ')'                       { TokSymbol SymCloseParen $1 }-    | '(|'                      { TokSymbol SymOpenIdiomBracket $1 }-    | '|)'                      { TokSymbol SymCloseIdiomBracket $1 }-    | '(|)'                     { TokSymbol SymEmptyIdiomBracket $1 }-    | '{{'                      { TokSymbol SymDoubleOpenBrace $1 }-    | '}}'                      { TokSymbol SymDoubleCloseBrace $1 }-    | '{'                       { TokSymbol SymOpenBrace $1 }-    | '}'                       { TokSymbol SymCloseBrace $1 }-    | vopen                     { TokSymbol SymOpenVirtualBrace $1 }-    | vclose                    { TokSymbol SymCloseVirtualBrace $1 }-    | vsemi                     { TokSymbol SymVirtualSemi $1 }-    | '{-#'                     { TokSymbol SymOpenPragma $1 }-    | '#-}'                     { TokSymbol SymClosePragma $1 }--    | id                        { TokId $1 }-    | q_id                      { TokQId $1 }-    | string                    { TokString $1 }--    | literal                   { TokLiteral $1 }--{---------------------------------------------------------------------------    Top level- --------------------------------------------------------------------------}--File :: { Module }-File : vopen TopLevel maybe_vclose { takeOptionsPragmas $2 }--maybe_vclose :: { () }-maybe_vclose : {- empty -} { () }-             | vclose      { () }--{---------------------------------------------------------------------------    Meta rules- --------------------------------------------------------------------------}--{-  A layout block might have to be closed by a parse error. Example:-        let x = e in e'-    Here the 'let' starts a layout block which should end before the 'in'.  The-    problem is that the lexer doesn't know this, so there is no virtual close-    brace. However when the parser sees the 'in' there will be a parse error.-    This is our cue to close the layout block.--}-close :: { () }-close : vclose  { () }-      | error   {% popBlock }----- You can use concrete semi colons in a layout block started with a virtual--- brace, so we don't have to distinguish between the two semi colons. You can't--- use a virtual semi colon in a block started by a concrete brace, but this is--- simply because the lexer will not generate virtual semis in this case.-semi :: { Interval }-semi : ';'    { $1 }-     | vsemi  { $1 }----- Enter the 'imp_dir' lex state, where we can parse the keyword 'to'.-beginImpDir :: { () }-beginImpDir : {- empty -}   {% pushLexState imp_dir }--{---------------------------------------------------------------------------    Helper rules- --------------------------------------------------------------------------}---- A float. Used in fixity declarations.-Float :: { Ranged Double }-Float : literal {% forM $1 $ \case-                   { LitNat   i -> return $ fromInteger i-                   ; LitFloat d -> return d-                   ; _          -> parseError $ "Expected floating point number"-                   }-                }---{---------------------------------------------------------------------------    Names- --------------------------------------------------------------------------}---- A name is really a sequence of parts, but the lexer just sees it as a--- string, so we have to do the translation here.-Id :: { Name }-Id : id     {% mkName $1 }---- Space separated list of one or more identifiers.-SpaceIds :: { List1 Name }-SpaceIds-    : Id SpaceIds { $1 <| $2 }-    | Id          { singleton $1 }---- When looking for a double closed brace, we accept either a single token '}}'--- (which is what the unicode character "RIGHT WHITE CURLY BRACKET" is--- postprocessed into in LexActions.hs), but also two consecutive tokens '}'--- (which a string '}}' is lexed to).  This small hack allows us to keep--- "record { a = record { }}" working. In the second case, we check that the two--- tokens '}' are immediately consecutive.-DoubleCloseBrace :: { Range }-DoubleCloseBrace-  : '}}' { getRange $1 }-  | '}' '}' {%-      if posPos (fromJust (rEnd' (getRange $2))) --         posPos (fromJust (rStart' (getRange $1))) > 2-      then parseErrorRange $2 "Expecting '}}', found separated '}'s."-      else return $ getRange ($1, $2)-    }---- A possibly dotted identifier.-MaybeDottedId :: { Arg Name }-MaybeDottedId-  : '..' Id { setRelevance NonStrict $ defaultArg $2 }-  | '.'  Id { setRelevance Irrelevant $ defaultArg $2 }-  | Id      { defaultArg $1 }---- Space separated list of one or more possibly dotted identifiers.-MaybeDottedIds :: { List1 (Arg Name) }-MaybeDottedIds-    : MaybeDottedId MaybeDottedIds { $1 <| $2 }-    | MaybeDottedId                { singleton $1 }---- Space separated list of one or more identifiers, some of which may--- be surrounded by braces or dotted.-ArgIds :: { List1 (Arg Name) }-ArgIds-    : MaybeDottedId ArgIds            { $1 <| $2 }-    | MaybeDottedId                   { singleton $1 }-    | '{{' MaybeDottedIds DoubleCloseBrace ArgIds { fmap makeInstance $2 <> $4 }-    | '{{' MaybeDottedIds DoubleCloseBrace        { fmap makeInstance $2 }-    | '{' MaybeDottedIds '}' ArgIds   { fmap hide $2 <> $4 }-    | '{' MaybeDottedIds '}'          { fmap hide $2 }-    | '.' '{' SpaceIds '}' ArgIds     { fmap (hide . setRelevance Irrelevant . defaultArg) $3 <> $5 }-    | '.' '{' SpaceIds '}'            { fmap (hide . setRelevance Irrelevant . defaultArg) $3 }-    | '.' '{{' SpaceIds DoubleCloseBrace ArgIds   { fmap (makeInstance . setRelevance Irrelevant . defaultArg) $3 <> $5 }-    | '.' '{{' SpaceIds DoubleCloseBrace          { fmap (makeInstance . setRelevance Irrelevant . defaultArg) $3 }-    | '..' '{' SpaceIds '}' ArgIds    { fmap (hide . setRelevance NonStrict . defaultArg) $3 <> $5 }-    | '..' '{' SpaceIds '}'           { fmap (hide . setRelevance NonStrict . defaultArg) $3 }-    | '..' '{{' SpaceIds DoubleCloseBrace ArgIds  { fmap (makeInstance . setRelevance NonStrict . defaultArg) $3 <> $5 }-    | '..' '{{' SpaceIds DoubleCloseBrace         { fmap (makeInstance . setRelevance NonStrict . defaultArg) $3 }---- Modalities preceeding identifiers--ModalArgIds :: { ([Attr], List1 (Arg Name)) }-ModalArgIds : Attributes ArgIds  {% ($1,) `fmap` mapM (applyAttrs $1) $2 }---- Attributes are parsed as '@' followed by an atomic expression.--Attribute :: { Attr }-Attribute : '@' ExprOrAttr  {% setRange (getRange ($1,$2)) `fmap` toAttribute $2 }---- Parse a reverse list of modalities--Attributes :: { [Attr] }-Attributes : {- empty -}  { [] }-  | Attributes Attribute { $2 : $1 }--Attributes1 :: { List1 Attr }-Attributes1 : Attribute  { singleton $1 }-  | Attributes1 Attribute { $2 <| $1 }--QId :: { QName }-QId : q_id  {% mkQName $1 }-    | Id    { QName $1 }----- A module name is just a qualified name-ModuleName :: { QName }-ModuleName : QId { $1 }----- A binding variable. Can be '_'-BId :: { Name }-BId : Id    { $1 }-    | '_'   { setRange (getRange $1) simpleHole }--{- UNUSED--- A binding variable. Can be '_'-MaybeDottedBId :: { (Relevance, Name) }-MaybeDottedBId-    : BId        { (Relevant  , $1) }-    | '.' BId    { (Irrelevant, $2) }-    | '..' BId   { (NonStrict, $2) }--}----- Space separated list of binding identifiers. Used in fixity--- declarations infixl 100 + --SpaceBIds :: { List1 Name }-SpaceBIds-    : BId SpaceBIds { $1 <| $2 }-    | BId           { singleton $1 }--{- DOES PRODUCE REDUCE/REDUCE CONFLICTS!--- Space-separated list of binding identifiers. Used in dependent--- function spaces: (x y z : Nat) -> ...--- (Used to be comma-separated; hence the name)--- QUESTION: Should this be replaced by SpaceBIds above?---CommaBIds :: { [(Relevance,Name)] }-CommaBIds :: { [Name] }-CommaBIds-    : CommaBIds BId { $1 ++ [$2] }  -- SWITCHING DOES NOT HELP-    | BId           { [$1] }--}---- Space-separated list of binding identifiers. Used in dependent--- function spaces: (x y z : Nat) -> ...--- (Used to be comma-separated; hence the name)--- QUESTION: Should this be replaced by SpaceBIds above?--- Andreas, 2011-04-07 the trick avoids reduce/reduce conflicts--- when parsing  (x y z : A) -> B--- at point (x y  it is not clear whether x y is an application or--- a variable list. We could be parsing (x y z) -> B--- with ((x y) z) being a type.-CommaBIds :: { List1 (NamedArg Binder) }-CommaBIds : CommaBIdAndAbsurds {%-    case $1 of-      Left ns -> return ns-      Right _ -> parseError $ "expected sequence of bound identifiers, not absurd pattern"-    }--CommaBIdAndAbsurds :: { Either (List1 (NamedArg Binder)) (List1 Expr) }-CommaBIdAndAbsurds-  : Application {% boundNamesOrAbsurd $1 }-  | QId '=' QId {% (Left . singleton . updateNamedArg mkBinder) `fmap` mkNamedArg (Just $1) (Left $3) }-  | '_' '=' QId {% (Left . singleton . updateNamedArg mkBinder) `fmap` mkNamedArg Nothing   (Left $3) }-  | QId '=' '_' {% (Left . singleton . updateNamedArg mkBinder) `fmap` mkNamedArg (Just $1) (Right $ getRange $3) }-  | '_' '=' '_' {% (Left . singleton . updateNamedArg mkBinder) `fmap` mkNamedArg Nothing   (Right $ getRange $3) }---- Parse a sequence of identifiers, including hiding info.--- Does not include instance arguments.--- E.g. x {y z} _ {v}--- To be used in typed bindings, like (x {y z} _ {v} : Nat).-BIdsWithHiding :: { List1 (NamedArg Binder) }-BIdsWithHiding : Application {%-  -- interpret an expression as a name and maybe a pattern-  case mapM exprAsNameOrHiddenNames $1 of-    Nothing   -> parseError "Expected sequence of possibly hidden bound identifiers"-    Just good -> forM (sconcat good) $ updateNamedArgA $ \ (n, me) -> do-                   p <- traverse exprToPattern me-                   pure $ Binder p (mkBoundName_ n)-    }----- Space separated list of strings in a pragma.-PragmaStrings :: { [String] }-PragmaStrings-    : {- empty -}           { [] }-    | string PragmaStrings  { snd $1 : $2 }-{- Unused-PragmaString :: { String }-PragmaString-    : string { snd $1 }--}-Strings :: { [(Interval, String)] }-Strings : {- empty -}    { [] }-        | string Strings { $1 : $2 }--ForeignCode :: { [(Interval, String)] }-ForeignCode-  : {- empty -} { [] }-  | string ForeignCode { $1 : $2 }-  | '{-#' ForeignCode '#-}' ForeignCode { [($1, "{-#")] ++ $2 ++ [($3, "#-}")] ++ $4 }--PragmaName :: { Name }-PragmaName : string {% mkName $1 }--PragmaQName :: { QName }-PragmaQName : string {% pragmaQName $1 }  -- Issue 2125. WAS: string {% fmap QName (mkName $1) }--PragmaQNames :: { [QName] }-PragmaQNames : Strings {% mapM pragmaQName $1 }--{---------------------------------------------------------------------------    Expressions (terms and types)- --------------------------------------------------------------------------}--{-  Expressions. You might expect lambdas and lets to appear in the first-    expression category (lowest precedence). The reason they don't is that we-    want to parse things like--        m >>= \x -> k x--    This will leads to a conflict in the following case--        m >>= \x -> k x >>= \y -> k' y--    At the second '>>=' we can either shift or reduce. We solve this problem-    using Happy's precedence directives. The rule 'Expr -> Expr1' (which is the-    rule you shouldn't use to reduce when seeing '>>=') is given LOWEST-    precedence.  The terminals '->' and op (which is what you should shift)-    is given higher precedence.--}---- Top level: Function types.-Expr :: { Expr }-Expr-  : TeleArrow Expr                      { Pi $1 $2 }-  | Application3 '->' Expr              { Fun (getRange ($1,$2,$3))-                                              (defaultArg $ rawApp $1)-                                              $3 }-  | Attributes1 Application3 '->' Expr  {% applyAttrs1 $1 (defaultArg $ rawApp $2) <&> \ dom ->-                                             Fun (getRange ($1,$2,$3,$4)) dom $4 }-  | Expr1 %prec LOWEST                  { $1 }---- Level 1: Application-Expr1 :: { Expr }-Expr1-  : UnnamedWithExprs-      {% case $1 of-           { e :| [] -> return e-           ; e :| es -> return $ WithApp (fuseRange e es) e es-           }-      }--WithExprs :: { List1 (Named Name Expr) }-WithExprs-  : Application3 'in' Id     '|' WithExprs { named $3  (rawApp $1) <| $5 }-  | Application3 {- empty -} '|' WithExprs { unnamed   (rawApp $1) <| $3 }-  | Application3 'in' Id                   { singleton (named $3 (rawApp $1)) }-  | Application3 {- empty -}               { singleton (unnamed  (rawApp $1)) }--UnnamedWithExprs :: { List1 Expr }-UnnamedWithExprs-  :  Application3 '|' UnnamedWithExprs { (rawApp $1) <| $3 }-  | {- empty -} Application            { singleton (rawApp $1) }--Application :: { List1 Expr }-Application-    : Expr2             { singleton $1 }-    | Expr3 Application { $1 <| $2 }---- Level 2: Lambdas and lets-Expr2 :: { Expr }-Expr2-    : '\\' LamBindings Expr        { Lam (getRange ($1,$2,$3)) $2 $3 }-    | ExtendedOrAbsurdLam          { $1 }-    | 'forall' ForallBindings Expr { forallPi $2 $3 }-    | 'let' Declarations LetBody   { Let (getRange ($1,$2,$3)) $2 $3 }-    | 'do' vopen DoStmts close     { DoBlock (getRange ($1, $3)) $3 }-    | Expr3                        { $1 }-    | 'tactic' Application3        { Tactic (getRange ($1, $2)) (rawApp $2) }--LetBody :: { Maybe Expr }-LetBody : 'in' Expr   { Just $2 }-        | {- empty -} { Nothing }--ExtendedOrAbsurdLam :: { Expr }-ExtendedOrAbsurdLam-    : '\\'             '{' LamClauses '}'                  {% extLam (getRange ($1, $2, $4))     []                $3 }-    | '\\' Attributes1 '{' LamClauses '}'                  {% extLam (getRange ($1, $3, $5))     (List1.toList $2) $4 }-    | '\\'             'where' vopen LamWhereClauses close {% extLam (getRange ($1, $2, $3, $5)) []                $4 }-    | '\\' Attributes1 'where' vopen LamWhereClauses close {% extLam (getRange ($1, $3, $4, $6)) (List1.toList $2) $5 }-    | '\\'             AbsurdLamBindings                   {% extOrAbsLam (getRange $1) []                $2 }-    | '\\' Attributes1 AbsurdLamBindings                   {% extOrAbsLam (getRange $1) (List1.toList $2) $3 }--Application3 :: { List1 Expr }-Application3-    : Expr3              { singleton $1 }-    | Expr3 Application3 { $1 <| $2 }---- Christian Sattler, 2017-08-04, issue #2671--- We allow empty lists of expressions for the LHS of extended lambda clauses.--- I am not sure what Application3 is otherwise used for, so I keep the--- original type and create this copy solely for extended lambda clauses.-Application3PossiblyEmpty :: { [Expr] }-Application3PossiblyEmpty-    :                                 { [] }-    | Expr3 Application3PossiblyEmpty { $1 : $2 }---- Level 3: Atoms-Expr3Curly :: { Expr }-Expr3Curly-    : '{' Expr4 '}'               {% HiddenArg (getRange ($1,$2,$3)) `fmap` maybeNamed $2 }-    | '{' '}'                     { let r = fuseRange $1 $2 in HiddenArg r $ unnamed $ Absurd r }-    | '{{' Expr4 DoubleCloseBrace {% InstanceArg (getRange ($1,$2,$3)) `fmap` maybeNamed $2 }-    | '{{' DoubleCloseBrace       { let r = fuseRange $1 $2 in InstanceArg r $ unnamed $ Absurd r }--Expr3NoCurly :: { Expr }-Expr3NoCurly-    : '?'                               { QuestionMark (getRange $1) Nothing }-    | '_'                               { Underscore (getRange $1) Nothing }-    | 'quote'                           { Quote (getRange $1) }-    | 'quoteTerm'                       { QuoteTerm (getRange $1) }-    | 'unquote'                         { Unquote (getRange $1) }-    | '(|' UnnamedWithExprs '|)'        { IdiomBrackets (getRange ($1,$2,$3)) (List1.toList $2) }-    | '(|)'                             { IdiomBrackets (getRange $1) [] }-    | '(' ')'                           { Absurd (fuseRange $1 $2) }-    | Id '@' Expr3                      { As (getRange ($1,$2,$3)) $1 $3 }-    | '.' Expr3                         { Dot (fuseRange $1 $2) $2 }-    | '..' Expr3                        { DoubleDot (fuseRange $1 $2) $2 }-    | 'record' '{' RecordAssignments '}' { Rec (getRange ($1,$2,$3,$4)) $3 }-    | 'record' Expr3NoCurly '{' FieldAssignments '}' { RecUpdate (getRange ($1,$2,$3,$4,$5)) $2 $4 }-    | '...'                             { Ellipsis (getRange $1) }-    | ExprOrAttr                       { $1 }---- Level 4: Maybe named, or cubical faces-Expr4 :: { Expr }-Expr4 : Expr1 '=' Expr { Equal (getRange ($1, $2, $3)) $1 $3 }-      | Expr           { $1 }--ExprOrAttr :: { Expr }-ExprOrAttr-    : QId           { Ident $1 }-    | literal       { Lit (getRange $1) (rangedThing $1) }-    | '(' Expr4 ')' { Paren (getRange ($1,$2,$3)) $2 }-    -- ^ this is needed for cubical stuff--Expr3 :: { Expr }-Expr3-    : Expr3Curly   { $1 }-    | Expr3NoCurly { $1 }--RecordAssignments :: { RecordAssignments }-RecordAssignments-  : {- empty -}        { [] }-  | RecordAssignments1 { List1.toList $1 }--RecordAssignments1 :: { List1 RecordAssignment }-RecordAssignments1-  : RecordAssignment                        { singleton $1 }-  | RecordAssignment ';' RecordAssignments1 { $1 <| $3 }--RecordAssignment :: { RecordAssignment }-RecordAssignment-  : FieldAssignment  { Left  $1 }-  | ModuleAssignment { Right $1 }--ModuleAssignment :: { ModuleAssignment }-ModuleAssignment-  : ModuleName OpenArgs ImportDirective  { ModuleAssignment $1 $2 $3 }--FieldAssignments :: { [FieldAssignment] }-FieldAssignments-  : {- empty -}       { [] }-  | FieldAssignments1 { List1.toList $1 }--FieldAssignments1 :: { List1 FieldAssignment }-FieldAssignments1-  : FieldAssignment                       { singleton $1 }-  | FieldAssignment ';' FieldAssignments1 { $1 <| $3 }--FieldAssignment :: { FieldAssignment }-FieldAssignment-  : Id '=' Expr   { FieldAssignment $1 $3 }--{---------------------------------------------------------------------------    Bindings- --------------------------------------------------------------------------}---- "Delta ->" to avoid conflict between Delta -> Gamma and Delta -> A.-TeleArrow :: { Telescope1 }-TeleArrow : Telescope1 '->' { $1 }--Telescope1 :: { Telescope1 }-Telescope1 : TypedBindings { $1 }--TypedBindings :: { List1 TypedBinding }-TypedBindings-    : TypedBinding TypedBindings { $1 <| $2 }-    | TypedBinding               { singleton $1 }----- A typed binding is either (x1 .. xn : A) or   {y1 .. ym : B}--- Andreas, 2011-04-07: or  .(x1 .. xn : A) or  .{y1 .. ym : B}--- Andreas, 2011-04-27: or ..(x1 .. xn : A) or ..{y1 .. ym : B}-TypedBinding :: { TypedBinding }-TypedBinding-    : '.' '(' TBindWithHiding ')'    { setRange (getRange ($2,$3,$4)) $-                             setRelevance Irrelevant $3 }-    | '.' '{' TBind '}'    { setRange (getRange ($2,$3,$4)) $-                             setHiding Hidden $-                             setRelevance Irrelevant $3 }-    | '.' '{{' TBind DoubleCloseBrace-                           { setRange (getRange ($2,$3,$4)) $-                             makeInstance $-                             setRelevance Irrelevant $3 }-    | '..' '(' TBindWithHiding ')'   { setRange (getRange ($2,$3,$4)) $-                             setRelevance NonStrict $3 }-    | '..' '{' TBind '}'   { setRange (getRange ($2,$3,$4)) $-                             setHiding Hidden $-                             setRelevance NonStrict $3 }-    | '..' '{{' TBind DoubleCloseBrace-                           { setRange (getRange ($2,$3,$4)) $-                             makeInstance $-                             setRelevance NonStrict $3 }-    | '(' TBindWithHiding ')'        { setRange (getRange ($1,$2,$3)) $2 }-    | '(' ModalTBindWithHiding ')'        { setRange (getRange ($1,$2,$3)) $2 }-    | '{{' TBind DoubleCloseBrace-                           { setRange (getRange ($1,$2,$3)) $-                             makeInstance $2 }-    | '{{' ModalTBind DoubleCloseBrace-                           { setRange (getRange ($1,$2,$3)) $-                             makeInstance $2 }-    | '{' TBind '}'        { setRange (getRange ($1,$2,$3)) $-                             setHiding Hidden $2 }-    | '{' ModalTBind '}'   { setRange (getRange ($1,$2,$3)) $-                             setHiding Hidden $2 }-    | '(' Open ')'               { TLet (getRange ($1,$3)) $2 }-    | '(' 'let' Declarations ')' { TLet (getRange ($1,$4)) $3 }----- x1 .. xn : A--- x1 .. xn :{i1 i2 ..} A-TBind :: { TypedBinding }-TBind : CommaBIds ':' Expr  {-    let r = getRange ($1,$2,$3) -- the range is approximate only for TypedBindings-    in TBind r $1 $3-  }--ModalTBind :: { TypedBinding }-ModalTBind : Attributes1 CommaBIds ':' Expr  {% do-    let r = getRange ($1,$2,$3,$4) -- the range is approximate only for TypedBindings-    xs <- mapM (applyAttrs1 $1 . setTacticAttr $1) $2-    return $ TBind r xs $4-  }---- x {y z} _ {v} : A-TBindWithHiding :: { TypedBinding }-TBindWithHiding : BIdsWithHiding ':' Expr  {-    let r = getRange ($1,$2,$3) -- the range is approximate only for TypedBindings-    in TBind r $1 $3-  }--ModalTBindWithHiding :: { TypedBinding }-ModalTBindWithHiding : Attributes1 BIdsWithHiding ':' Expr  {% do-    let r = getRange ($1,$2,$3,$4) -- the range is approximate only for TypedBindings-    xs <- mapM (applyAttrs1 $1 . setTacticAttr $1) $2-    return $ TBind r xs $4-  }---- A non-empty sequence of lambda bindings.-LamBindings :: { List1 LamBinding }-LamBindings-  : LamBinds '->' {%-      case absurdBinding $1 of-        Just{}  -> parseError "Absurd lambda cannot have a body."-        Nothing -> return $ List1.fromList $ lamBindings $1-      }--AbsurdLamBindings :: { Either ([LamBinding], Hiding) (List1 Expr) }-AbsurdLamBindings-  : LamBindsAbsurd {%-    case $1 of-      Left lb -> case absurdBinding lb of-                   Nothing -> parseError "Missing body for lambda"-                   Just h  -> return $ Left (lamBindings lb, h)-      Right es -> return $ Right es-    }---- absurd lambda is represented by @Left hiding@-LamBinds :: { LamBinds }-LamBinds-  : DomainFreeBinding LamBinds  { fmap (map DomainFree (List1.toList $1) ++) $2 }-  | TypedBinding LamBinds       { fmap (DomainFull $1 :) $2 }-  | DomainFreeBinding           { mkLamBinds $ map DomainFree $ List1.toList $1 }-  | TypedBinding                { mkLamBinds [DomainFull $1] }-  | '(' ')'                     { mkAbsurdBinding NotHidden }-  | '{' '}'                     { mkAbsurdBinding Hidden }-  | '{{' DoubleCloseBrace       { mkAbsurdBinding (Instance NoOverlap) }---- Like LamBinds, but could also parse an absurd LHS of an extended lambda @{ p1 ... () }@-LamBindsAbsurd :: { Either LamBinds (List1 Expr) }-LamBindsAbsurd-  : DomainFreeBinding LamBinds  { Left $ fmap (map DomainFree (List1.toList $1) ++) $2 }-  | TypedBinding LamBinds       { Left $ fmap (DomainFull $1 :) $2 }-  | DomainFreeBindingAbsurd     { case $1 of-                                    Left lb -> Left $ mkLamBinds (map DomainFree $ List1.toList lb)-                                    Right es -> Right es }-  | TypedBinding                { Left $ mkLamBinds [DomainFull $1] }-  | '(' ')'                     { Left $ mkAbsurdBinding NotHidden }-  | '{' '}'                     { Left $ mkAbsurdBinding Hidden }-  | '{{' DoubleCloseBrace       { Left $ mkAbsurdBinding (Instance NoOverlap) }---- FNF, 2011-05-05: No where-clauses in extended lambdas for now.--- Andreas, 2020-03-28: And also not in sight either nine years later.-NonAbsurdLamClause :: { LamClause }-NonAbsurdLamClause-  : Application3PossiblyEmpty '->' Expr {% mkLamClause False $1 (RHS $3) }-  | CatchallPragma-    Application3PossiblyEmpty '->' Expr {% mkLamClause True  $2 (RHS $4) }--AbsurdLamClause :: { LamClause }-AbsurdLamClause--- FNF, 2011-05-09: By being more liberal here, we avoid shift/reduce and reduce/reduce errors.--- Later stages such as scope checking will complain if we let something through which we should not-  : Application                {% mkAbsurdLamClause False $1 }-  | CatchallPragma Application {% mkAbsurdLamClause True  $2 }--LamClause :: { LamClause }-LamClause-  : NonAbsurdLamClause { $1 }-  | AbsurdLamClause { $1 }---- Parses all extended lambda clauses except for a single absurd clause, which is taken care of--- in AbsurdLambda-LamClauses :: { List1 LamClause }-LamClauses-   : LamClauses semi LamClause { $3 <| $1 }-   | AbsurdLamClause semi LamClause { $3 <| singleton $1 }-   | NonAbsurdLamClause { singleton $1 }---- Parses all extended lambda clauses including a single absurd clause.--- For lambda-where this is not[sic!, now?] taken care of in AbsurdLambda.-LamWhereClauses :: { List1 LamClause }-LamWhereClauses-   : LamWhereClauses semi LamClause { $3 <| $1 }-   | LamClause { singleton $1 }--ForallBindings :: { List1 LamBinding }-ForallBindings-  : TypedUntypedBindings1 '->' { $1 }---- A non-empty sequence of possibly untyped bindings.-TypedUntypedBindings1 :: { List1 LamBinding }-TypedUntypedBindings1-  : DomainFreeBinding TypedUntypedBindings1 { fmap DomainFree $1 <> $2 }-  | TypedBinding TypedUntypedBindings1      { DomainFull $1 <| $2 }-  | DomainFreeBinding                       { fmap DomainFree $1 }-  | TypedBinding                            { singleton $ DomainFull $1 }---- A possibly empty sequence of possibly untyped bindings.--- This is used as telescope in data and record decls.-TypedUntypedBindings :: { [LamBinding] }-TypedUntypedBindings-  : DomainFreeBinding TypedUntypedBindings { map DomainFree (List1.toList $1) ++ $2 }-  | TypedBinding TypedUntypedBindings      { DomainFull $1 : $2 }-  |                                        { [] }--DomainFreeBindings :: { [NamedArg Binder] }-DomainFreeBindings-  : {- empty -}                          { [] }-  | DomainFreeBinding DomainFreeBindings { List1.toList $1 ++ $2 }---- A domain free binding is either x or {x1 .. xn}-DomainFreeBinding :: { List1 (NamedArg Binder) }-DomainFreeBinding-  : DomainFreeBindingAbsurd {% case $1 of-                             Left lbs -> return lbs-                             Right _ -> parseError "expected sequence of bound identifiers, not absurd pattern"-                          }--MaybeAsPattern :: { Maybe Pattern }-MaybeAsPattern-  : '@' Expr3   {% fmap Just (exprToPattern $2) }-  | {- empty -} { Nothing }---- A domain free binding is either x or {x1 .. xn}-DomainFreeBindingAbsurd :: { Either (List1 (NamedArg Binder)) (List1 Expr)}-DomainFreeBindingAbsurd-    : BId      MaybeAsPattern { Left . singleton $ mkDomainFree_ id $2 $1 }-    | '.' BId  MaybeAsPattern { Left . singleton $ mkDomainFree_ (setRelevance Irrelevant) $3 $2 }-    | '..' BId MaybeAsPattern { Left . singleton $ mkDomainFree_ (setRelevance NonStrict) $3 $2 }-    | '(' Application ')'     {% exprToPattern (rawApp $2) >>= \ p ->-                                 pure . Left . singleton $ mkDomainFree_ id (Just p) $ simpleHole }-    | '(' Attributes1 CommaBIdAndAbsurds ')'-         {% applyAttrs1 $2 defaultArgInfo <&> \ ai ->-              first (fmap (setTacticAttr $2 . setArgInfo ai)) $3 }-    | '{' CommaBIdAndAbsurds '}'-         { first (fmap hide) $2 }-    | '{' Attributes1 CommaBIdAndAbsurds '}'-         {% applyAttrs1 $2 defaultArgInfo <&> \ ai ->-              first (fmap (hide . setTacticAttr $2 . setArgInfo ai)) $3 }-    | '{{' CommaBIds DoubleCloseBrace { Left $ fmap makeInstance $2 }-    | '{{' Attributes1 CommaBIds DoubleCloseBrace-         {% applyAttrs1 $2 defaultArgInfo <&> \ ai ->-              Left $ fmap (makeInstance . setTacticAttr $2 . setArgInfo ai) $3 }-    | '.' '{' CommaBIds '}' { Left $ fmap (hide . setRelevance Irrelevant) $3 }-    | '.' '{{' CommaBIds DoubleCloseBrace { Left $ fmap (makeInstance . setRelevance Irrelevant) $3 }-    | '..' '{' CommaBIds '}' { Left $ fmap (hide . setRelevance NonStrict) $3 }-    | '..' '{{' CommaBIds DoubleCloseBrace { Left $ fmap (makeInstance . setRelevance NonStrict) $3 }---{---------------------------------------------------------------------------    Do-notation- --------------------------------------------------------------------------}--DoStmts :: { List1 DoStmt }-DoStmts : DoStmt              { singleton $1 }-        | DoStmt vsemi        { singleton $1 }    -- #3046-        | DoStmt semi DoStmts { $1 <| $3 }--DoStmt :: { DoStmt }-DoStmt : Expr DoWhere {% buildDoStmt $1 $2 }--DoWhere :: { [LamClause] }-DoWhere-  : {- empty -} { [] }-  | 'where' vopen LamWhereClauses close { reverse (List1.toList $3) }--{---------------------------------------------------------------------------    Modules and imports- --------------------------------------------------------------------------}---- Import directives-ImportDirective :: { ImportDirective }-ImportDirective-  : ImportDirective1 ImportDirective { $1 <> $2 }-  | {- empty -}                      { mempty }--ImportDirective1 :: { ImportDirective }-  : 'public'      { defaultImportDir { importDirRange = getRange $1, publicOpen = Just (getRange $1) } }-  | Using         { defaultImportDir { importDirRange = snd $1, using    = fst $1 } }-  | Hiding        { defaultImportDir { importDirRange = snd $1, hiding   = fst $1 } }-  | RenamingDir   { defaultImportDir { importDirRange = snd $1, impRenaming = fst $1 } }--Using :: { (Using, Range) }-Using-    : 'using' '(' CommaImportNames ')'   { (Using $3 , getRange ($1,$2,$3,$4)) }-        -- using can have an empty list--Hiding :: { ([ImportedName], Range) }-Hiding-    : 'hiding' '(' CommaImportNames ')'  { ($3 , getRange ($1,$2,$3,$4)) }-        -- if you want to hide nothing that's fine, isn't it?--RenamingDir :: { ([Renaming] , Range) }-RenamingDir-    : 'renaming' '(' Renamings ')'      { ($3 , getRange ($1,$2,$3,$4)) }-    | 'renaming' '(' ')'                { ([] , getRange ($1,$2,$3)) }---- Renamings of the form 'x to y'-Renamings :: { [Renaming] }-Renamings-    : Renaming ';' Renamings    { $1 : $3 }-    | Renaming                  { [$1] }--Renaming :: { Renaming }-Renaming-    : ImportName_ 'to' RenamingTarget { Renaming $1 (setImportedName $1 (snd $3)) (fst $3) (getRange $2) }--RenamingTarget :: { (Maybe Fixity, Name) }-RenamingTarget-    : Id                 { (Nothing, $1) }-    | 'infix'  Float Id  { (Just (Fixity (getRange ($1,$2)) (Related $ rangedThing $2) NonAssoc)  , $3) }-    | 'infixl' Float Id  { (Just (Fixity (getRange ($1,$2)) (Related $ rangedThing $2) LeftAssoc) , $3) }-    | 'infixr' Float Id  { (Just (Fixity (getRange ($1,$2)) (Related $ rangedThing $2) RightAssoc), $3) }---- We need a special imported name here, since we have to trigger--- the imp_dir state exactly one token before the 'to'-ImportName_ :: { ImportedName }-ImportName_-    : beginImpDir Id          { ImportedName $2 }-    | 'module' beginImpDir Id { ImportedModule $3 }--ImportName :: { ImportedName }-ImportName : Id          { ImportedName $1 }-           | 'module' Id { ImportedModule $2 }---- Actually semi-colon separated, possibly empty list of ImportName.-CommaImportNames :: { [ImportedName] }-CommaImportNames-    : {- empty -}       { [] }-    | CommaImportNames1 { List1.toList $1 }--CommaImportNames1 :: { List1 ImportedName }-CommaImportNames1-    : ImportName                        { singleton $1 }-    | ImportName ';' CommaImportNames1  { $1 <| $3 }--{---------------------------------------------------------------------------    Function clauses- --------------------------------------------------------------------------}---- A left hand side of a function clause. We parse it as an expression, and--- then check that it is a valid left hand side.-LHS :: { [RewriteEqn] -> [WithExpr] -> LHS }-LHS : Expr1 {% exprToLHS $1 }--WithClause :: { [Either RewriteEqn (List1 (Named Name Expr))] }-WithClause-  : 'with' WithExprs WithClause-    {% fmap (++ $3) (buildWithStmt $2)  }-  | 'rewrite' UnnamedWithExprs WithClause-    { Left (Rewrite $ fmap ((),) $2) : $3 }-  | {- empty -} { [] }---- Parsing either an expression @e@ or a @(rewrite | with p <-) e1 | ... | en@.-HoleContent :: { HoleContent }-HoleContent-  : Expr                   {  HoleContentExpr    $1 }-  | WithClause-    {% fmap HoleContentRewrite $ forM $1 $ \case-         Left r  -> pure r-         Right{} -> parseError "Cannot declare a 'with' abstraction from inside a hole."-      }---- Where clauses are optional.-WhereClause :: { WhereClause }-WhereClause-    : {- empty -}                               { NoWhere }-    |                     'where' Declarations0 { AnyWhere  (getRange $1) $2 }-    | 'module' Id         'where' Declarations0 { SomeWhere (getRange ($1,$3)) $2 PublicAccess $4 }-    | 'module' Underscore 'where' Declarations0 { SomeWhere (getRange ($1,$3)) $2 PublicAccess $4 }-  -- Note: The access modifier is a dummy, it is computed in the nicifier.--ExprWhere :: { ExprWhere }-ExprWhere : Expr WhereClause { ExprWhere $1 $2 }--{---------------------------------------------------------------------------    Different kinds of declarations- --------------------------------------------------------------------------}---- Top-level definitions.-Declaration :: { List1 Declaration }-Declaration-    : Fields          { singleton $1 }-    | FunClause       { $1 }            -- includes type signatures-    | Data            { singleton $1 }-    | DataSig         { singleton $1 }  -- lone data type signature in mutual block-    | Record          { singleton $1 }-    | RecordSig       { singleton $1 }  -- lone record signature in mutual block-    | Infix           { singleton $1 }-    | Generalize      { singleton $1 }-    | Mutual          { singleton $1 }-    | Abstract        { singleton $1 }-    | Private         { singleton $1 }-    | Instance        { singleton $1 }-    | Macro           { singleton $1 }-    | Postulate       { singleton $1 }-    | Primitive       { singleton $1 }-    | Open            { $1 }-    | ModuleMacro     { singleton $1 }-    | Module          { singleton $1 }-    | Pragma          { singleton $1 }-    | Syntax          { singleton $1 }-    | PatternSyn      { singleton $1 }-    | UnquoteDecl     { singleton $1 }-    | Constructor     { singleton $1 }--{---------------------------------------------------------------------------    Individual declarations- --------------------------------------------------------------------------}---- Type signatures of the form "n1 n2 n3 ... : Type", with at least--- one bound name.-TypeSigs :: { List1 Declaration }-TypeSigs : SpaceIds ':' Expr { fmap (\ x -> typeSig defaultArgInfo Nothing x $3) $1 }---- A variant of TypeSigs where any sub-sequence of names can be marked--- as hidden or irrelevant using braces and dots:--- {n1 .n2} n3 .n4 {n5} .{n6 n7} ... : Type.-ArgTypeSigs :: { List1 (Arg Declaration) }-ArgTypeSigs-  : ModalArgIds ':' Expr { let (attrs, xs) = $1 in-                           fmap (fmap (\ x -> typeSig defaultArgInfo (getTacticAttr attrs) x $3)) xs }-  | 'overlap' ModalArgIds ':' Expr {%-      let (attrs, xs) = $2-          setOverlap x =-            case getHiding x of-              Instance _ -> return $ makeInstance' YesOverlap x-              _          -> parseErrorRange $1-                             "The 'overlap' keyword only applies to instance fields (fields marked with {{ }})"-      in T.traverse (setOverlap . fmap (\ x -> typeSig defaultArgInfo (getTacticAttr attrs) x $4)) xs }-  | 'instance' ArgTypeSignatures {-    let-      setInstance (TypeSig info tac x t) = TypeSig (makeInstance info) tac x t-      setInstance _ = __IMPOSSIBLE__ in-    fmap (fmap setInstance) $2 }---- Function declarations. The left hand side is parsed as an expression to allow--- declarations like 'x::xs ++ ys = e', when '::' has higher precedence than '++'.--- FunClause also handle possibly dotted type signatures.-FunClause :: { List1 Declaration }-FunClause-  : {- emptyb -} LHS WHS RHS WhereClause {% funClauseOrTypeSigs [] $1 $2 $3 $4 }-  | Attributes1  LHS WHS RHS WhereClause {% funClauseOrTypeSigs (List1.toList $1) $2 $3 $4 $5 }---- "With Hand Side", in between the Left & the Right hand ones-WHS :: { [Either RewriteEqn (List1 (Named Name Expr))] }-WHS-  : {- empty -}                           { [] }-  | 'with'    WithExprs        WithClause {% fmap (++ $3) (buildWithStmt $2) }-  | 'rewrite' UnnamedWithExprs WithClause { Left (Rewrite $ fmap ((),) $2) : $3 }--RHS :: { RHSOrTypeSigs }-RHS-  : {- empty -}    { JustRHS AbsurdRHS }-  | '='       Expr { JustRHS (RHS $2) }-  | ':'       Expr { TypeSigsRHS $2 }---- Data declaration. Can be local.-Data :: { Declaration }-Data : 'data' Id TypedUntypedBindings ':' Expr 'where'-            Declarations0       { Data (getRange ($1,$2,$3,$4,$5,$6,$7)) $2 $3 $5 $7 }--  -- New cases when we already had a DataSig.  Then one can omit the sort.-     | 'data' Id TypedUntypedBindings 'where'-            Declarations0       { DataDef (getRange ($1,$2,$3,$4,$5)) $2 $3 $5 }---- Data type signature. Found in mutual blocks.-DataSig :: { Declaration }-DataSig : 'data' Id TypedUntypedBindings ':' Expr-  { DataSig (getRange ($1,$2,$3,$4,$5)) $2 $3 $5 }---- Andreas, 2012-03-16:  The Expr3NoCurly instead of Id in everything--- following 'record' is to remove the (harmless) shift/reduce conflict--- introduced by record update expressions.---- Record declarations.-Record :: { Declaration }-Record : 'record' Expr3NoCurly TypedUntypedBindings ':' Expr 'where'-            RecordDeclarations-         {% exprToName $2 >>= \ n -> let (dir, ds) = $7 in return $ Record (getRange ($1,$2,$3,$4,$5,$6,$7)) n dir $3 $5 ds }-       | 'record' Expr3NoCurly TypedUntypedBindings 'where'-            RecordDeclarations-         {% exprToName $2 >>= \ n -> let (dir, ds) = $5 in return $ RecordDef (getRange ($1,$2,$3,$4,$5)) n dir $3 ds }---- Record type signature. In mutual blocks.-RecordSig :: { Declaration }-RecordSig : 'record' Expr3NoCurly TypedUntypedBindings ':' Expr-  {% exprToName $2 >>= \ n -> return $ RecordSig (getRange ($1,$2,$3,$4,$5)) n $3 $5 }--Constructor :: { Declaration }-Constructor : 'data' '_' 'where' Declarations0-  { LoneConstructor (getRange ($1,$4)) $4 }---- Declaration of record constructor name.-RecordConstructorName :: { (Name, IsInstance) }-RecordConstructorName :                  'constructor' Id       { ($2, NotInstanceDef) }-                      | 'instance' vopen 'constructor' Id close { ($4, InstanceDef (getRange $1)) }----- Fixity declarations.-Infix :: { Declaration }-Infix : 'infix'  Float SpaceBIds  { Infix (Fixity (getRange ($1,$2,$3)) (Related $ rangedThing $2) NonAssoc)   $3 }-      | 'infixl' Float SpaceBIds  { Infix (Fixity (getRange ($1,$2,$3)) (Related $ rangedThing $2) LeftAssoc)  $3 }-      | 'infixr' Float SpaceBIds  { Infix (Fixity (getRange ($1,$2,$3)) (Related $ rangedThing $2) RightAssoc) $3 }---- Field declarations.-Fields :: { Declaration }-Fields : 'field' ArgTypeSignaturesOrEmpty-            { let-                inst i = case getHiding i of-                           Instance _ -> InstanceDef noRange  -- no @instance@ keyword here-                           _          -> NotInstanceDef-                toField (Arg info (TypeSig info' tac x t)) = FieldSig (inst info') tac x (Arg info t)-              in Field (fuseRange $1 $2) $ map toField $2 }-  -- | 'field' ModalArgTypeSignatures-  --           { let-  --               inst i = case getHiding i of-  --                          Instance _ -> InstanceDef-  --                          _          -> NotInstanceDef-  --               toField (Arg info (TypeSig info' x t)) = FieldSig (inst info') x (Arg info t)-  --             in Field (fuseRange $1 $2) $ map toField $2 }---- Variable declarations for automatic generalization-Generalize :: { Declaration }-Generalize : 'variable' ArgTypeSignaturesOrEmpty-            { let-                toGeneralize (Arg info (TypeSig _ tac x t)) = TypeSig info tac x t-              in Generalize (fuseRange $1 $2) (map toGeneralize $2) }---- Mutually recursive declarations.-Mutual :: { Declaration }-Mutual : 'mutual' Declarations0  { Mutual (fuseRange $1 $2) $2 }-       | 'interleaved' 'mutual' Declarations0 { InterleavedMutual (getRange ($1,$2,$3)) $3 }---- Abstract declarations.-Abstract :: { Declaration }-Abstract : 'abstract' Declarations0  { Abstract (fuseRange $1 $2) $2 }----- Private can only appear on the top-level (or rather the module level).-Private :: { Declaration }-Private : 'private' Declarations0        { Private (fuseRange $1 $2) UserWritten $2 }----- Instance declarations.-Instance :: { Declaration }-Instance : 'instance' Declarations0  { InstanceB (getRange $1) $2 }----- Macro declarations.-Macro :: { Declaration }-Macro : 'macro' Declarations0 { Macro (fuseRange $1 $2) $2 }----- Postulates.-Postulate :: { Declaration }-Postulate : 'postulate' Declarations0 { Postulate (fuseRange $1 $2) $2 }---- Primitives. Can only contain type signatures.-Primitive :: { Declaration }-Primitive : 'primitive' ArgTypeSignaturesOrEmpty  {-  let { setArg (Arg info (TypeSig _ tac x t)) = TypeSig info tac x t-      ; setArg _ = __IMPOSSIBLE__ } in-  Primitive (fuseRange $1 $2) (map setArg $2) }---- Unquoting declarations.-UnquoteDecl :: { Declaration }-UnquoteDecl-  : 'unquoteDecl' '=' Expr { UnquoteDecl (fuseRange $1 $3) [] $3 }-  | 'unquoteDecl' SpaceIds '=' Expr { UnquoteDecl (fuseRange $1 $4) (List1.toList $2) $4 }-  | 'unquoteDef'  SpaceIds '=' Expr { UnquoteDef (fuseRange $1 $4) (List1.toList $2) $4 }---- Syntax declaration (To declare eg. mixfix binders)-Syntax :: { Declaration }-Syntax : 'syntax' Id HoleNames '=' SimpleIds  {%-  case $2 of-    Name _ _ (_ :| []) -> case mkNotation $3 $5 of-      Left err -> parseError $ "Malformed syntax declaration: " ++ err-      Right n -> return $ Syntax $2 n-    _ -> parseError "Syntax declarations are allowed only for simple names (without holes)"-}---- Pattern synonyms.-PatternSyn :: { Declaration }-PatternSyn : 'pattern' Id PatternSynArgs '=' Expr {% do-  p <- exprToPattern $5-  return (PatternSyn (getRange ($1,$2,$3,$4,$5)) $2 $3 p)-  }--PatternSynArgs :: { [Arg Name] }-PatternSynArgs : DomainFreeBindings    {% patternSynArgs $1 }--SimpleIds :: { [RString] }-SimpleIds : SimpleId { [$1] }-          | SimpleIds SimpleId {$1 ++ [$2]}--HoleNames :: { [NamedArg HoleName] }-HoleNames :                    { [] }-          | HoleNames HoleName {$1 ++ [$2]}--HoleName :: { NamedArg HoleName }-HoleName-  : SimpleTopHole { defaultNamedArg $1 }-  | '{'  SimpleHole '}'  { hide         $ defaultNamedArg $2 }-  | '{{' SimpleHole '}}' { makeInstance $ defaultNamedArg $2 }-  | '{'  SimpleId '=' SimpleHole '}'  { hide         $ defaultArg $ userNamed $2 $4 }-  | '{{' SimpleId '=' SimpleHole '}}' { makeInstance $ defaultArg $ userNamed $2 $4 }--SimpleTopHole :: { HoleName }-SimpleTopHole-  : SimpleId { ExprHole $1 }-  | '(' '\\' SimpleId '->' SimpleId ')' { LambdaHole $3 $5 }-  | '(' '\\' '_'      '->' SimpleId ')' { LambdaHole (Ranged (getRange $3) "_") $5 }--SimpleHole :: { HoleName }-SimpleHole-  : SimpleId { ExprHole $1 }-  | '\\' SimpleId '->' SimpleId { LambdaHole $2 $4 }-  | '\\' '_'      '->' SimpleId { LambdaHole (Ranged (getRange $3) "_") $4 }--- Variable name hole to be implemented later.---- Discard the interval.-SimpleId :: { RString }-SimpleId : id  { Ranged (getRange $ fst $1) (stringToRawName $ snd $1) }--MaybeOpen :: { Maybe Range }-MaybeOpen : 'open'      { Just (getRange $1) }-          | {- empty -} { Nothing }---- Open-Open :: { List1 Declaration }-Open : MaybeOpen 'import' ModuleName OpenArgs ImportDirective {%-    let-    { doOpen = maybe DontOpen (const DoOpen) $1-    ; m   = $3-    ; es  = $4-    ; dir = $5-    ; r   = getRange ($1, $2, m, es, dir)-    ; mr  = getRange m-    ; unique = hashString $ prettyShow $ (Strict.Nothing :: Strict.Maybe ()) <$ r-         -- turn range into unique id, but delete file path-         -- which is absolute and messes up suite of failing tests-         -- (different hashs on different installations)-         -- TODO: Don't use (insecure) hashes in this way.-    ; fresh  = Name mr NotInScope $ singleton $ Id $ stringToRawName $ ".#" ++ prettyShow m ++ "-" ++ show unique-    ; fresh' = Name mr NotInScope $ singleton $ Id $ stringToRawName $ ".#" ++ prettyShow m ++ "-" ++ show (unique + 1)-    ; impStm asR = Import noRange m (Just (AsName (Right fresh) asR)) DontOpen defaultImportDir-    ; appStm m' es =-        Private r Inserted-          [ ModuleMacro r m'-             (SectionApp (getRange es) []-               (rawApp (Ident (QName fresh) :| es)))-             doOpen dir-          ]-    ; (initArgs, last2Args) = splitAt (length es - 2) es-    ; parseAsClause = case last2Args of-      { [ Ident (QName (Name asR InScope (Id x :| [])))-        , e-          -- Andreas, 2018-11-03, issue #3364, accept anything after 'as'-          -- but require it to be a 'Name' in the scope checker.-        ] | rawNameToString x == "as" -> Just . (asR,) $-          if | Ident (QName m') <- e -> Right m'-             | otherwise             -> Left e-      ; _ -> Nothing-      }-    } in-    case es of-      { [] -> return $ singleton $ Import r m Nothing doOpen dir-      ; _ | Just (asR, m') <- parseAsClause -> return $-              if null initArgs then singleton-                 ( Import (getRange (m, asR, m', dir)) m-                     (Just (AsName m' asR)) doOpen dir-                 )-              else impStm asR :| [ appStm (fromRight (const fresh') m') initArgs ]-          -- Andreas, 2017-05-13, issue #2579-          -- Nisse reports that importing with instantation but without open-          -- could be usefule for bringing instances into scope.-          -- Ulf, 2018-12-6: Not since fixes of #1913 and #2489 which require-          -- instances to be in scope.-          | DontOpen <- doOpen -> parseErrorRange $2 "An import statement with module instantiation is useless without either an `open' keyword or an `as` binding giving a name to the instantiated module."-          | otherwise -> return $-              impStm noRange :|-              appStm (noName $ beginningOf $ getRange m) es :-              []-      }-  }-  |'open' ModuleName OpenArgs ImportDirective {-    let-    { m   = $2-    ; es  = $3-    ; dir = $4-    ; r   = getRange ($1, m, es, dir)-    } in singleton $-      case es of-      { []  -> Open r m dir-      ; _   -> Private r Inserted-                 [ ModuleMacro r (noName $ beginningOf $ getRange m)-                             (SectionApp (getRange (m , es)) [] (rawApp (Ident m :| es)))-                             DoOpen dir-                 ]-      }-  }-  | 'open' ModuleName '{{' '...' DoubleCloseBrace ImportDirective {-    let r = getRange $2 in singleton $-      Private r Inserted-      [ ModuleMacro r (noName $ beginningOf $ getRange $2) (RecordModuleInstance r $2) DoOpen $6-      ]-  }--OpenArgs :: { [Expr] }-OpenArgs : {- empty -}    { [] }-         | Expr3 OpenArgs { $1 : $2 }--ModuleApplication :: { Telescope -> Parser ModuleApplication }-ModuleApplication : ModuleName '{{' '...' DoubleCloseBrace { (\ts ->-                    if null ts then return $ RecordModuleInstance (getRange ($1,$2,$3,$4)) $1-                    else parseError "No bindings allowed for record module with non-canonical implicits" )-                    }-                  | ModuleName OpenArgs {-                    (\ts -> return $ SectionApp (getRange ($1, $2)) ts (rawApp (Ident $1 :| $2)) ) }----- Module instantiation-ModuleMacro :: { Declaration }-ModuleMacro : 'module' ModuleName TypedUntypedBindings '=' ModuleApplication ImportDirective-                    {% do { ma <- $5 (map addType $3)-                          ; name <- ensureUnqual $2-                          ; return $ ModuleMacro (getRange ($1, $2, ma, $6)) name ma DontOpen $6 } }-            | 'open' 'module' Id TypedUntypedBindings '=' ModuleApplication ImportDirective-                    {% do {ma <- $6 (map addType $4); return $ ModuleMacro (getRange ($1, $2, $3, ma, $7)) $3 ma DoOpen $7 } }---- Module-Module :: { Declaration }-Module : 'module' ModuleName TypedUntypedBindings 'where' Declarations0-                    { Module (getRange ($1,$2,$3,$4,$5)) $2 (map addType $3) $5 }-       | 'module' Underscore TypedUntypedBindings 'where' Declarations0-                    { Module (getRange ($1,$2,$3,$4,$5)) (QName $2) (map addType $3) $5 }--Underscore :: { Name }-Underscore : '_' { noName (getRange $1) }--TopLevel :: { [Declaration] }-TopLevel : TopDeclarations { figureOutTopLevelModule $1 }--Pragma :: { Declaration }-Pragma : DeclarationPragma  { Pragma $1 }--DeclarationPragma :: { Pragma }-DeclarationPragma-  : BuiltinPragma            { $1 }-  | RewritePragma            { $1 }-  | CompilePragma            { $1 }-  | ForeignPragma            { $1 }-  | StaticPragma             { $1 }-  | InjectivePragma          { $1 }-  | InlinePragma             { $1 }-  | NoInlinePragma           { $1 }-  | ImpossiblePragma         { $1 }-  | TerminatingPragma        { $1 }-  | NonTerminatingPragma     { $1 }-  | NoTerminationCheckPragma { $1 }-  | NonCoveringPragma        { $1 }-  | WarningOnUsagePragma     { $1 }-  | WarningOnImportPragma    { $1 }-  | MeasurePragma            { $1 }-  | CatchallPragma           { $1 }-  | DisplayPragma            { $1 }-  | EtaPragma                { $1 }-  | NoPositivityCheckPragma  { $1 }-  | NoUniverseCheckPragma    { $1 }-  | PolarityPragma           { $1 }-  | OptionsPragma            { $1 }-    -- Andreas, 2014-03-06-    -- OPTIONS pragma not allowed everywhere, but don't give parse error.-    -- Give better error during type checking instead.--OptionsPragma :: { Pragma }-OptionsPragma : '{-#' 'OPTIONS' PragmaStrings '#-}' { OptionsPragma (getRange ($1,$2,$4)) $3 }--BuiltinPragma :: { Pragma }-BuiltinPragma-    : '{-#' 'BUILTIN' string PragmaQName '#-}'-      { BuiltinPragma (getRange ($1,$2,fst $3,$4,$5)) (mkRString $3) $4 }-    -- Extra rule to accept keyword REWRITE also as built-in:-    | '{-#' 'BUILTIN' 'REWRITE' PragmaQName '#-}'-      { BuiltinPragma (getRange ($1,$2,$3,$4,$5)) (Ranged (getRange $3) "REWRITE") $4 }--RewritePragma :: { Pragma }-RewritePragma-    : '{-#' 'REWRITE' PragmaQNames '#-}'-      { RewritePragma (getRange ($1,$2,$3,$4)) (getRange $2) $3 }--ForeignPragma :: { Pragma }-ForeignPragma-  : '{-#' 'FOREIGN' string ForeignCode '#-}' { ForeignPragma (getRange ($1, $2, fst $3, $5)) (mkRString $3) (recoverLayout $4) }--CompilePragma :: { Pragma }-CompilePragma-  : '{-#' 'COMPILE' string PragmaQName PragmaStrings '#-}'-    { CompilePragma (getRange ($1,$2,fst $3,$4,$6)) (mkRString $3) $4 (unwords $5) }--StaticPragma :: { Pragma }-StaticPragma-  : '{-#' 'STATIC' PragmaQName '#-}'-    { StaticPragma (getRange ($1,$2,$3,$4)) $3 }--InlinePragma :: { Pragma }-InlinePragma-  : '{-#' 'INLINE' PragmaQName '#-}'-    { InlinePragma (getRange ($1,$2,$3,$4)) True $3 }--NoInlinePragma :: { Pragma }-NoInlinePragma-  : '{-#' 'NOINLINE' PragmaQName '#-}'-    { InlinePragma (getRange ($1,$2,$3,$4)) False $3 }--InjectivePragma :: { Pragma }-InjectivePragma-  : '{-#' 'INJECTIVE' PragmaQName '#-}'-    { InjectivePragma (getRange ($1,$2,$3,$4)) $3 }--DisplayPragma :: { Pragma }-DisplayPragma-  : '{-#' 'DISPLAY' string PragmaStrings '#-}' {%-      let (r, s) = $3 in-      parseDisplayPragma (fuseRange $1 $5) (iStart r) (unwords (s : $4)) }--EtaPragma :: { Pragma }-EtaPragma-  : '{-#' 'ETA' PragmaQName '#-}'-    { EtaPragma (getRange ($1,$2,$3,$4)) $3 }--NoTerminationCheckPragma :: { Pragma }-NoTerminationCheckPragma-  : '{-#' 'NO_TERMINATION_CHECK' '#-}'-    { TerminationCheckPragma (getRange ($1,$2,$3)) NoTerminationCheck }--NonTerminatingPragma :: { Pragma }-NonTerminatingPragma-  : '{-#' 'NON_TERMINATING' '#-}'-    { TerminationCheckPragma (getRange ($1,$2,$3)) NonTerminating }--TerminatingPragma :: { Pragma }-TerminatingPragma-  : '{-#' 'TERMINATING' '#-}'-    { TerminationCheckPragma (getRange ($1,$2,$3)) Terminating }--NonCoveringPragma :: { Pragma }-NonCoveringPragma-  : '{-#' 'NON_COVERING' '#-}'-    { NoCoverageCheckPragma (getRange ($1,$2,$3)) }--MeasurePragma :: { Pragma }-MeasurePragma-  : '{-#' 'MEASURE' PragmaName '#-}'-    { let r = getRange ($1, $2, $3, $4) in-      TerminationCheckPragma r (TerminationMeasure r $3) }--CatchallPragma :: { Pragma }-CatchallPragma-  : '{-#' 'CATCHALL' '#-}'-    { CatchallPragma (getRange ($1,$2,$3)) }--ImpossiblePragma :: { Pragma }-ImpossiblePragma-  : '{-#' 'IMPOSSIBLE' PragmaStrings '#-}'-    { ImpossiblePragma (getRange ($1,$2,$4)) $3 }--NoPositivityCheckPragma :: { Pragma }-NoPositivityCheckPragma-  : '{-#' 'NO_POSITIVITY_CHECK' '#-}'-    { NoPositivityCheckPragma (getRange ($1,$2,$3)) }--NoUniverseCheckPragma :: { Pragma }-NoUniverseCheckPragma-  : '{-#' 'NO_UNIVERSE_CHECK' '#-}'-    { NoUniverseCheckPragma (getRange ($1,$2,$3)) }--PolarityPragma :: { Pragma }-PolarityPragma-  : '{-#' 'POLARITY' PragmaName Polarities '#-}'-    { let (rs, occs) = unzip (reverse $4) in-      PolarityPragma (getRange ($1,$2,$3,rs,$5)) $3 occs }--WarningOnUsagePragma :: { Pragma }-WarningOnUsagePragma-  : '{-#' 'WARNING_ON_USAGE' PragmaQName literal '#-}'-  {%  case $4 of-        { Ranged r (LitString str) -> return $ WarningOnUsage (getRange ($1,$2,$3,r,$5)) $3 str-        ; _ -> parseError "Expected string literal"-        }-  }--WarningOnImportPragma :: { Pragma }-WarningOnImportPragma-  : '{-#' 'WARNING_ON_IMPORT' literal '#-}'-  {%  case $3 of-        { Ranged r (LitString str) -> return $ WarningOnImport (getRange ($1,$2,r,$4)) str-        ; _ -> parseError "Expected string literal"-        }-  }---- Possibly empty list of polarities. Reversed.-Polarities :: { [(Range, Occurrence)] }-Polarities : {- empty -}          { [] }-           | Polarities Polarity  { $2 : $1 }--Polarity :: { (Range, Occurrence) }-Polarity : string {% polarity $1 }--{---------------------------------------------------------------------------    Sequences of declarations- --------------------------------------------------------------------------}---- Possibly empty list of type signatures, with several identifiers allowed--- for every signature.-TypeSignatures0 :: { [TypeSignature] }-TypeSignatures-    : vopen close    { [] }-    | TypeSignatures { List1.toList $1 }---- Non-empty list of type signatures, with several identifiers allowed--- for every signature.-TypeSignatures :: { List1 TypeSignature }-TypeSignatures-    : vopen TypeSignatures1 close   { List1.reverse $2 }---- Inside the layout block.-TypeSignatures1 :: { List1 TypeSignature }-TypeSignatures1-    : TypeSignatures1 semi TypeSigs { List1.reverse $3 <> $1 }-    | TypeSigs                      { List1.reverse $1 }---- A variant of TypeSignatures which uses ArgTypeSigs instead of--- TypeSigs.-ArgTypeSignatures :: { List1 (Arg TypeSignature) }-ArgTypeSignatures-    : vopen ArgTypeSignatures1 close   { List1.reverse $2 }---- Inside the layout block.-ArgTypeSignatures1 :: { List1 (Arg TypeSignature) }-ArgTypeSignatures1-    : ArgTypeSignatures1 semi ArgTypeSigs { List1.reverse $3 <> $1 }-    | ArgTypeSigs                         { List1.reverse $1 }---- A variant of TypeSignatures which uses ArgTypeSigs instead of--- TypeSigs.-ArgTypeSignaturesOrEmpty :: { [Arg TypeSignature] }-ArgTypeSignaturesOrEmpty-    : vopen ArgTypeSignatures0 close   { reverse $2 }---- Inside the layout block.-ArgTypeSignatures0 :: { [Arg TypeSignature] }-ArgTypeSignatures0-    : ArgTypeSignatures0 semi ArgTypeSigs { reverse (List1.toList $3) ++ $1 }-    | ArgTypeSigs                         { reverse (List1.toList $1) }-    | {- empty -}                         { [] }---- Record declarations, including an optional record constructor name.-RecordDeclarations :: { (RecordDirectives, [Declaration]) }-RecordDeclarations-    : vopen RecordDirectives close                    {% verifyRecordDirectives $2 <&> (,[]) }-    | vopen RecordDirectives semi Declarations1 close {% verifyRecordDirectives $2 <&> (, List1.toList $4) }-    | vopen Declarations1 close                       { (emptyRecordDirectives, List1.toList $2) }---RecordDirectives :: { [RecordDirective] }-RecordDirectives-    : {- empty -}                           { [] }-    | RecordDirectives semi RecordDirective { $3 : $1 }-    | RecordDirective                       { [$1] }--RecordDirective :: { RecordDirective }-RecordDirective-    : RecordConstructorName { uncurry Constructor $1 }-    | RecordInduction       { Induction $1 }-    | RecordEta             { Eta $1 }-    | RecordPatternMatching { PatternOrCopattern $1 }--RecordEta :: { Ranged HasEta0 }-RecordEta-    : 'eta-equality'    { Ranged (getRange $1) YesEta }-    | 'no-eta-equality' { Ranged (getRange $1) (NoEta ()) }---- Directive 'pattern' if a decision between matching on constructor/record pattern--- or copattern matching is needed.--- Such decision is only needed for 'no-eta-equality' records.--- But eta could be turned off automatically, thus, we do not bundle this--- with the 'no-eta-equality' declaration.--- Nor with the 'constructor' declaration, since it applies also to--- the record pattern.-RecordPatternMatching :: { Range }-RecordPatternMatching-    : 'pattern'     { getRange $1 }---- Declaration of record as 'inductive' or 'coinductive'.-RecordInduction :: { Ranged Induction }-RecordInduction-    : 'inductive'   { Ranged (getRange $1) Inductive   }-    | 'coinductive' { Ranged (getRange $1) CoInductive }---- Arbitrary declarations-Declarations :: { List1 Declaration }-Declarations-    : vopen Declarations1 close { $2 }---- Arbitrary declarations (possibly empty)-Declarations0 :: { [Declaration] }-Declarations0-    : vopen close  { [] }-    | Declarations { List1.toList $1 }--Declarations1 :: { List1 Declaration }-Declarations1-    : Declaration semi Declarations1 { $1 <> $3 }-    | Declaration vsemi              { $1 } -- #3046-    | Declaration                    { $1 }--TopDeclarations :: { [Declaration] }-TopDeclarations-  : {- empty -}   { [] }-  | Declarations1 { List1.toList $1 }--{--{---------------------------------------------------------------------------    Parsers- --------------------------------------------------------------------------}---- | Parse the token stream. Used by the TeX compiler.-tokensParser :: Parser [Token]---- | Parse an expression. Could be used in interactions.-exprParser :: Parser Expr---- | Parse an expression followed by a where clause. Could be used in interactions.-exprWhereParser :: Parser ExprWhere---- | Parse a module.-moduleParser :: Parser Module---{---------------------------------------------------------------------------    Happy stuff- --------------------------------------------------------------------------}---- | Required by Happy.-happyError :: Parser a-happyError = parseError "Parse error"---{---------------------------------------------------------------------------    Utility functions- --------------------------------------------------------------------------}---- | Grab leading OPTIONS pragmas.-takeOptionsPragmas :: [Declaration] -> Module-takeOptionsPragmas = uncurry Mod . spanJust (\ d -> case d of-  Pragma p@OptionsPragma{} -> Just p-  _                        -> Nothing)---- | Insert a top-level module if there is none.---   Also fix-up for the case the declarations in the top-level module---   are not indented (this is allowed as a special case).-figureOutTopLevelModule :: [Declaration] -> [Declaration]-figureOutTopLevelModule ds =-  case spanAllowedBeforeModule ds of-    -- Andreas 2016-02-01, issue #1388.-    -- We need to distinguish two additional cases.--    -- Case 1: Regular file layout: imports followed by one module. Nothing to do.-    (ds0, [ Module{} ]) -> ds--    -- Case 2: The declarations in the module are not indented.-    -- This is allowed for the top level module, and thus rectified here.-    (ds0, Module r m tel [] : ds2) -> ds0 ++ [Module r m tel ds2]--    -- Case 3: There is a module with indented declarations,-    -- followed by non-indented declarations.  This should be a-    -- parse error and be reported later (see @toAbstract TopLevel{}@),-    -- thus, we do not do anything here.-    (ds0, Module r m tel ds1 : ds2) -> ds  -- Gives parse error in scope checker.-    -- OLD code causing issue 1388:-    -- (ds0, Module r m tel ds1 : ds2) -> ds0 ++ [Module r m tel $ ds1 ++ ds2]--    -- Case 4: a top-level module declaration is missing.-    -- Andreas, 2017-01-01, issue #2229:-    -- Put everything (except OPTIONS pragmas) into an anonymous module.-    _ -> ds0 ++ [Module r (QName $ noName r) [] ds1]-      where-      (ds0, ds1) = (`span` ds) $ \case-        Pragma OptionsPragma{} -> True-        _ -> False-      -- Andreas, 2017-05-17, issue #2574.-      -- Since the module noName will act as jump target, it needs a range.-      -- We use the beginning of the file as beginning of the top level module.-      r = beginningOfFile $ getRange ds1---- | Create a name from a string.--mkName :: (Interval, String) -> Parser Name-mkName (i, s) = do-    let xs = C.stringNameParts s-    mapM_ isValidId xs-    unless (alternating xs) $ parseError $ "a name cannot contain two consecutive underscores"-    return $ Name (getRange i) InScope xs-    where-        isValidId Hole   = return ()-        isValidId (Id y) = do-          let x = rawNameToString y-              err = "in the name " ++ s ++ ", the part " ++ x ++ " is not valid"-          case parse defaultParseFlags [0] (lexer return) x of-            ParseOk _ TokId{}  -> return ()-            ParseFailed{}      -> parseError err-            ParseOk _ TokEOF{} -> parseError err-            ParseOk _ t   -> parseError . ((err ++ " because it is ") ++) $ case t of-              TokId{}       -> __IMPOSSIBLE__-              TokQId{}      -> __IMPOSSIBLE__ -- "qualified"-              TokKeyword{}  -> "a keyword"-              TokLiteral{}  -> "a literal"-              TokSymbol s _ -> case s of-                SymDot               -> __IMPOSSIBLE__ -- "reserved"-                SymSemi              -> "used to separate declarations"-                SymVirtualSemi       -> __IMPOSSIBLE__-                SymBar               -> "used for with-arguments"-                SymColon             -> "part of declaration syntax"-                SymArrow             -> "the function arrow"-                SymEqual             -> "part of declaration syntax"-                SymLambda            -> "used for lambda-abstraction"-                SymUnderscore        -> "used for anonymous identifiers"-                SymQuestionMark      -> "a meta variable"-                SymAs                -> "used for as-patterns"-                SymOpenParen         -> "used to parenthesize expressions"-                SymCloseParen        -> "used to parenthesize expressions"-                SymOpenIdiomBracket  -> "an idiom bracket"-                SymCloseIdiomBracket -> "an idiom bracket"-                SymDoubleOpenBrace   -> "used for instance arguments"-                SymDoubleCloseBrace  -> "used for instance arguments"-                SymOpenBrace         -> "used for hidden arguments"-                SymCloseBrace        -> "used for hidden arguments"-                SymOpenVirtualBrace  -> __IMPOSSIBLE__-                SymCloseVirtualBrace -> __IMPOSSIBLE__-                SymOpenPragma        -> __IMPOSSIBLE__ -- "used for pragmas"-                SymClosePragma       -> __IMPOSSIBLE__ -- "used for pragmas"-                SymEllipsis          -> "used for function clauses"-                SymDotDot            -> __IMPOSSIBLE__ -- "a modality"-                SymEndComment        -> "the end-of-comment brace"-              TokString{}   -> __IMPOSSIBLE__-              TokTeX{}      -> __IMPOSSIBLE__  -- used by the LaTeX backend only-              TokMarkup{}   -> __IMPOSSIBLE__  -- ditto-              TokComment{}  -> __IMPOSSIBLE__-              TokDummy{}    -> __IMPOSSIBLE__-              TokEOF{}      -> __IMPOSSIBLE__--        -- we know that there are no two Ids in a row-        alternating (Hole :| Hole : _) = False-        alternating (_    :| x   : xs) = alternating $ x :| xs-        alternating (_    :|       []) = True---- | Create a qualified name from a list of strings-mkQName :: [(Interval, String)] -> Parser QName-mkQName ss = do-    xs <- mapM mkName ss-    return $ foldr Qual (QName $ last xs) (init xs)--mkDomainFree_ :: (NamedArg Binder -> NamedArg Binder) -> Maybe Pattern -> Name -> NamedArg Binder-mkDomainFree_ f p n = f $ defaultNamedArg $ Binder p $ mkBoundName_ n--mkRString :: (Interval, String) -> RString-mkRString (i, s) = Ranged (getRange i) s---- | Create a qualified name from a string (used in pragmas).---   Range of each name component is range of whole string.---   TODO: precise ranges!--pragmaQName :: (Interval, String) -> Parser QName-pragmaQName (r, s) = do-  let ss = chopWhen (== '.') s-  mkQName $ map (r,) ss--mkNamedArg :: Maybe QName -> Either QName Range -> Parser (NamedArg BoundName)-mkNamedArg x y = do-  lbl <- case x of-           Nothing        -> return $ Just $ WithOrigin UserWritten $ unranged "_"-           Just (QName x) -> return $ Just $ WithOrigin UserWritten $ Ranged (getRange x) $ prettyShow x-           _              -> parseError "expected unqualified variable name"-  var <- case y of-           Left (QName y) -> return $ mkBoundName y noFixity'-           Right r        -> return $ mkBoundName (noName r) noFixity'-           _              -> parseError "expected unqualified variable name"-  return $ defaultArg $ Named lbl var---- | Polarity parser.--polarity :: (Interval, String) -> Parser (Range, Occurrence)-polarity (i, s) =-  case s of-    "_"  -> ret Unused-    "++" -> ret StrictPos-    "+"  -> ret JustPos-    "-"  -> ret JustNeg-    "*"  -> ret Mixed-    _    -> parseError $ "Not a valid polarity: " ++ s-  where-  ret x = return (getRange i, x)--recoverLayout :: [(Interval, String)] -> String-recoverLayout [] = ""-recoverLayout xs@((i, _) : _) = go (iStart i) xs-  where-    c0 = posCol (iStart i)--    go cur [] = ""-    go cur ((i, s) : xs) = padding cur (iStart i) ++ s ++ go (iEnd i) xs--    padding Pn{ posLine = l1, posCol = c1 } Pn{ posLine = l2, posCol = c2 }-      | l1 < l2  = List.genericReplicate (l2 - l1) '\n' ++ List.genericReplicate (max 0 (c2 - c0)) ' '-      | l1 == l2 = List.genericReplicate (c2 - c1) ' '--ensureUnqual :: QName -> Parser Name-ensureUnqual (QName x) = return x-ensureUnqual q@Qual{}  = parseError' (rStart' $ getRange q) "Qualified name not allowed here"---- | Match a particular name.-isName :: String -> (Interval, String) -> Parser ()-isName s (_,s')-    | s == s'   = return ()-    | otherwise = parseError $ "expected " ++ s ++ ", found " ++ s'---- Lambinds---- | Result of parsing @LamBinds@.-data LamBinds' a = LamBinds-  { lamBindings   :: a             -- ^ A number of domain-free or typed bindings or record patterns.-  , absurdBinding :: Maybe Hiding  -- ^ Followed by possibly a final absurd pattern.-  } deriving (Functor)-type LamBinds = LamBinds' [LamBinding]--mkAbsurdBinding :: Hiding -> LamBinds-mkAbsurdBinding = LamBinds [] . Just--mkLamBinds :: a -> LamBinds' a-mkLamBinds bs = LamBinds bs Nothing---- | Build a forall pi (forall x y z -> ...)-forallPi :: List1 LamBinding -> Expr -> Expr-forallPi bs e = Pi (fmap addType bs) e---- | Converts lambda bindings to typed bindings.-addType :: LamBinding -> TypedBinding-addType (DomainFull b) = b-addType (DomainFree x) = TBind r (singleton x) $ Underscore r Nothing-  where r = getRange x---- | Returns the value of the first erasure attribute, if any, or else--- the default value of type 'Erased'.------ Raises warnings for all attributes except for erasure attributes,--- and for multiple erasure attributes.--onlyErased-  :: [Attr]  -- ^ The attributes, in reverse order.-  -> Parser Erased-onlyErased as = do-  es <- catMaybes <$> mapM onlyErased' (reverse as)-  case es of-    []     -> return defaultErased-    [e]    -> return e-    e : es -> do-      parseWarning $ MultipleAttributes (getRange es) (Just "erasure")-      return e-  where-  onlyErased' a = case theAttr a of-    RelevanceAttribute{} -> unsup "Relevance"-    CohesionAttribute{}  -> unsup "Cohesion"-    LockAttribute{}      -> unsup "Lock"-    TacticAttribute{}    -> unsup "Tactic"-    QuantityAttribute q  -> maybe (unsup "Linearity") (return . Just) $ erasedFromQuantity q-    where-    unsup s = do-      parseWarning $ UnsupportedAttribute (attrRange a) (Just s)-      return Nothing---- | Constructs extended lambdas.--extLam-  :: Range            -- ^ The range of the lambda symbol and @where@ or-                      --   the braces.-  -> [Attr]           -- ^ The attributes in reverse order.-  -> List1 LamClause  -- ^ The clauses in reverse order.-  -> Parser Expr-extLam symbolRange attrs cs = do-  e <- onlyErased attrs-  let cs' = List1.reverse cs-  return $ ExtendedLam (getRange (symbolRange, e, cs')) e cs'---- | Constructs extended or absurd lambdas.--extOrAbsLam-  :: Range   -- ^ The range of the lambda symbol.-  -> [Attr]  -- ^ The attributes, in reverse order.-  -> Either ([LamBinding], Hiding) (List1 Expr)-  -> Parser Expr-extOrAbsLam lambdaRange attrs cs = case cs of-  Right es -> do-    -- It is of the form @\ { p1 ... () }@.-    e  <- onlyErased attrs-    cl <- mkAbsurdLamClause False es-    return $ ExtendedLam (getRange (lambdaRange, e, es)) e $ singleton cl-  Left (bs, h) -> do-    mapM_ (\a -> parseWarning $-                   UnsupportedAttribute (attrRange a) Nothing)-          (reverse attrs)-    List1.ifNull bs-      {-then-} (return $ AbsurdLam r h)-      {-else-} $ \ bs -> return $ Lam r bs (AbsurdLam r h)-    where-    r = fuseRange lambdaRange bs---- | Interpret an expression as a list of names and (not parsed yet) as-patterns--exprAsTele :: Expr -> List1 Expr-exprAsTele (RawApp _ es) = List2.toList1 es-exprAsTele e             = singleton e--exprAsNamesAndPatterns :: Expr -> Maybe (List1 (Name, Maybe Expr))-exprAsNamesAndPatterns = mapM exprAsNameAndPattern . exprAsTele--exprAsNameAndPattern :: Expr -> Maybe (Name, Maybe Expr)-exprAsNameAndPattern (Ident (QName x)) = Just (x, Nothing)-exprAsNameAndPattern (Underscore r _)  = Just (setRange r simpleHole, Nothing)-exprAsNameAndPattern (As _ n e)        = Just (n, Just e)-exprAsNameAndPattern (Paren r e)       = Just (setRange r simpleHole, Just e)-exprAsNameAndPattern _                 = Nothing---- interpret an expression as name or list of hidden / instance names-exprAsNameOrHiddenNames :: Expr -> Maybe (List1 (NamedArg (Name, Maybe Expr)))-exprAsNameOrHiddenNames = \case-  HiddenArg _ (Named Nothing e) ->-    fmap (hide . defaultNamedArg) <$> exprAsNamesAndPatterns e-  InstanceArg _ (Named Nothing e) ->-    fmap (makeInstance . defaultNamedArg) <$> exprAsNamesAndPatterns e-  e ->-    singleton . defaultNamedArg <$> exprAsNameAndPattern e--boundNamesOrAbsurd :: List1 Expr -> Parser (Either (List1 (NamedArg Binder)) (List1 Expr))-boundNamesOrAbsurd es-  | any isAbsurd es = return $ Right es-  | otherwise       =-    case mapM exprAsNameAndPattern es of-        Nothing   -> parseError $ "expected sequence of bound identifiers"-        Just good -> fmap Left $ forM good $ \ (n, me) -> do-                       p <- traverse exprToPattern me-                       return (defaultNamedArg (Binder p (mkBoundName_ n)))--  where--    isAbsurd :: Expr -> Bool-    isAbsurd (Absurd _)                  = True-    isAbsurd (HiddenArg _ (Named _ e))   = isAbsurd e-    isAbsurd (InstanceArg _ (Named _ e)) = isAbsurd e-    isAbsurd (Paren _ e)                 = isAbsurd e-    isAbsurd (As _ _ e)                  = isAbsurd e-    isAbsurd (RawApp _ es)               = any isAbsurd es-    isAbsurd _                           = False---- | Match a pattern-matching "assignment" statement @p <- e@-exprToAssignment :: Expr -> Parser (Maybe (Pattern, Range, Expr))-exprToAssignment e@(RawApp r es)-  | (es1, arr : es2) <- List2.break isLeftArrow es =-    case filter isLeftArrow es2 of-      arr : _ -> parseError' (rStart' $ getRange arr) $ "Unexpected " ++ prettyShow arr-      [] ->-        -- Andreas, 2021-05-06, issue #5365-        -- Handle pathological cases like @do <-@ and @do x <-@.-        case (es1, es2) of-          (e1:rest1, e2:rest2) -> do-            p <- exprToPattern $ rawApp $ e1 :| rest1-            pure $ Just (p, getRange arr, rawApp (e2 :| rest2))-          _ -> parseError' (rStart' $ getRange e) $ "Incomplete binding " ++ prettyShow e-  where-    isLeftArrow (Ident (QName (Name _ _ (Id arr :| [])))) =-      arr `elem` ["<-", "\x2190"]  -- \leftarrow [issue #5465, unicode might crash happy]-    isLeftArrow _ = False-exprToAssignment _ = pure Nothing---- | Build a with-block-buildWithBlock ::-  [Either RewriteEqn (List1 (Named Name Expr))] ->-  Parser ([RewriteEqn], [Named Name Expr])-buildWithBlock rees = case groupByEither rees of-  (Left rs : rest) -> (List1.toList rs,) <$> finalWith rest-  rest             -> ([],) <$> finalWith rest--  where--    finalWith :: (HasRange a, HasRange b) =>-                 [Either (List1 a) (List1 (List1 b))] -> Parser [b]-    finalWith []             = pure $ []-    finalWith [Right ees]    = pure $ List1.toList $ sconcat ees-    finalWith (Right{} : tl) = parseError' (rStart' $ getRange tl)-      "Cannot use rewrite / pattern-matching with after a with-abstraction."---- | Build a with-statement-buildWithStmt :: List1 (Named Name Expr) ->-                 Parser [Either RewriteEqn (List1 (Named Name Expr))]-buildWithStmt nes = do-  ws <- mapM buildSingleWithStmt (List1.toList nes)-  let rws = groupByEither ws-  pure $ map (first (Invert ())) rws--buildSingleWithStmt ::-  Named Name Expr ->-  Parser (Either (Named Name (Pattern, Expr)) (Named Name Expr))-buildSingleWithStmt e = do-  mpatexpr <- exprToAssignment (namedThing e)-  pure $ case mpatexpr of-    Just (pat, _, expr) -> Left ((pat, expr) <$ e)-    Nothing             -> Right e--fromWithApp :: Expr -> List1 Expr-fromWithApp = \case-  WithApp _ e es -> e :| es-  e              -> singleton e---- | Build a do-statement-defaultBuildDoStmt :: Expr -> [LamClause] -> Parser DoStmt-defaultBuildDoStmt e (_ : _) = parseError' (rStart' $ getRange e) "Only pattern matching do-statements can have where clauses."-defaultBuildDoStmt e []      = pure $ DoThen e--buildDoStmt :: Expr -> [LamClause] -> Parser DoStmt-buildDoStmt (Let r ds Nothing) [] = return $ DoLet r ds-buildDoStmt e@(RawApp r _)    cs = do-  mpatexpr <- exprToAssignment e-  case mpatexpr of-    Just (pat, r, expr) -> pure $ DoBind r pat expr cs-    Nothing -> defaultBuildDoStmt e cs-buildDoStmt e cs = defaultBuildDoStmt e cs----- | Extract record directives-extractRecordDirectives :: [Declaration] -> Parser (RecordDirectives, [Declaration])-extractRecordDirectives ds = do-  let (dirs, rest) = spanJust isRecordDirective ds-  dir <- verifyRecordDirectives dirs-  pure (dir, rest)---- | Check for duplicate record directives.-verifyRecordDirectives :: [RecordDirective] -> Parser RecordDirectives-verifyRecordDirectives ds-  | null rs   = return (RecordDirectives (listToMaybe is) (listToMaybe es) (listToMaybe ps) (listToMaybe cs))-      -- Here, all the lists is, es, cs, ps are at most singletons.-  | otherwise = parseErrorRange (head rs) $ unlines $ "Repeated record directives at:" : map prettyShow rs-  where-  errorFromList []  = []-  errorFromList [x] = []-  errorFromList xs  = map getRange xs-  rs  = List.sort $ concat [ errorFromList is, errorFromList es', errorFromList cs, errorFromList ps ]-  es  = map rangedThing es'-  is  = [ i      | Induction i          <- ds ]-  es' = [ e      | Eta e                <- ds ]-  cs  = [ (c, i) | Constructor c i      <- ds ]-  ps  = [ r      | PatternOrCopattern r <- ds ]----- | Breaks up a string into substrings. Returns every maximal--- subsequence of zero or more characters distinct from @'.'@.------ > splitOnDots ""         == [""]--- > splitOnDots "foo.bar"  == ["foo", "bar"]--- > splitOnDots ".foo.bar" == ["", "foo", "bar"]--- > splitOnDots "foo.bar." == ["foo", "bar", ""]--- > splitOnDots "foo..bar" == ["foo", "", "bar"]-splitOnDots :: String -> [String]-splitOnDots ""        = [""]-splitOnDots ('.' : s) = [] : splitOnDots s-splitOnDots (c   : s) = case splitOnDots s of-  p : ps -> (c : p) : ps----- | Returns 'True' iff the name is a valid Haskell (hierarchical)--- module name.-validHaskellModuleName :: String -> Bool-validHaskellModuleName = all ok . splitOnDots-  where-  -- Checks if a dot-less module name is well-formed.-  ok :: String -> Bool-  ok []      = False-  ok (c : s) =-    isUpper c &&-    all (\c -> isLower c || c == '_' ||-               isUpper c ||-               generalCategory c == DecimalNumber ||-               c == '\'')-        s--{---------------------------------------------------------------------------    Patterns- --------------------------------------------------------------------------}---- | Turn an expression into a left hand side.-exprToLHS :: Expr -> Parser ([RewriteEqn] -> [WithExpr] -> LHS)-exprToLHS e = LHS <$> exprToPattern e---- | Turn an expression into a pattern. Fails if the expression is not a---   valid pattern.-exprToPattern :: Expr -> Parser Pattern-exprToPattern e = case C.isPattern e of-  Nothing -> parseErrorRange e $ "Not a valid pattern: " ++ prettyShow e-  Just p  -> pure p--opAppExprToPattern :: OpApp Expr -> Parser Pattern-opAppExprToPattern (SyntaxBindingLambda _ _ _) = parseError "Syntax binding lambda cannot appear in a pattern"-opAppExprToPattern (Ordinary e) = exprToPattern e---- | Turn an expression into a name. Fails if the expression is not a---   valid identifier.-exprToName :: Expr -> Parser Name-exprToName (Ident (QName x)) = return x-exprToName e = parseErrorRange e $ "Not a valid identifier: " ++ prettyShow e--isEqual :: Expr -> Maybe (Expr, Expr)-isEqual = \case-    Equal _ a b -> Just (a, b)-    _           -> Nothing---- | When given expression is @e1 = e2@, turn it into a named expression.---   Call this inside an implicit argument @{e}@ or @{{e}}@, where---   an equality must be a named argument (rather than a cubical partial match).-maybeNamed :: Expr -> Parser (Named_ Expr)-maybeNamed e =-  case isEqual e of-    Nothing       -> return $ unnamed e-    Just (e1, e2) -> do-      let succeed x = return $ named (WithOrigin UserWritten $ Ranged (getRange e1) x) e2-      case e1 of-        Ident (QName x) -> succeed $ nameToRawName x-        -- We could have the following, but names of arguments cannot be _.-        -- Underscore{}    -> succeed $ "_"-        _ -> parseErrorRange e $ "Not a valid named argument: " ++ prettyShow e--patternSynArgs :: [NamedArg Binder] -> Parser [Arg Name]-patternSynArgs = mapM pSynArg-  where-    pSynArg x-      | let h = getHiding x, h `notElem` [Hidden, NotHidden] =-          abort $ prettyShow h ++ " arguments not allowed to pattern synonyms"-      | not (isRelevant x) =-          abort "Arguments to pattern synonyms must be relevant"-      | Just p <- binderPattern (namedArg x) =-          abort "Arguments to pattern synonyms cannot be patterns themselves"-      | otherwise = return $ fmap (boundName . binderName . namedThing) x-      where-      abort s = parseError $-        "Illegal pattern synonym argument  " ++ prettyShow x ++ "\n" ++-        "(" ++ s ++ ".)"--mkLamClause-  :: Bool   -- ^ Catch-all?-  -> [Expr] -- ^ Possibly empty list of patterns.-  -> RHS-  -> Parser LamClause-mkLamClause catchAll es rhs = mapM exprToPattern es <&> \ ps ->-  LamClause{ lamLHS = ps, lamRHS = rhs, lamCatchAll = catchAll }--mkAbsurdLamClause :: Bool -> List1 Expr -> Parser LamClause-mkAbsurdLamClause catchAll es = mkLamClause catchAll (List1.toList es) AbsurdRHS--parsePanic s = parseError $ "Internal parser error: " ++ s ++ ". Please report this as a bug."--{- RHS or type signature -}--data RHSOrTypeSigs- = JustRHS RHS- | TypeSigsRHS Expr- deriving Show--patternToNames :: Pattern -> Parser (List1 (ArgInfo, Name))-patternToNames = \case-    IdentP (QName i)         -> return $ singleton $ (defaultArgInfo, i)-    WildP r                  -> return $ singleton $ (defaultArgInfo, C.noName r)-    DotP _ (Ident (QName i)) -> return $ singleton $ (setRelevance Irrelevant defaultArgInfo, i)-    RawAppP _ ps             -> sconcat . List2.toList1 <$> mapM patternToNames ps-    p                        -> parseError $-      "Illegal name in type signature: " ++ prettyShow p--funClauseOrTypeSigs :: [Attr] -> ([RewriteEqn] -> [WithExpr] -> LHS)-                    -> [Either RewriteEqn (List1 (Named Name Expr))]-                    -> RHSOrTypeSigs-                    -> WhereClause -> Parser (List1 Declaration)-funClauseOrTypeSigs attrs lhs' with mrhs wh = do-  (rs , es) <- buildWithBlock with-  let lhs = lhs' rs (map (fmap observeModifiers) es)-  -- traceShowM lhs-  case mrhs of-    JustRHS rhs   -> do-      unless (null attrs) $ parseErrorRange attrs $ "A function clause cannot have attributes"-      return $ singleton $ FunClause lhs rhs wh False-    TypeSigsRHS e -> case wh of-      NoWhere -> case lhs of-        LHS p _ _ | hasEllipsis p -> parseError "The ellipsis ... cannot have a type signature"-        LHS _ _ (_:_) -> parseError "Illegal: with in type signature"-        LHS _ (_:_) _ -> parseError "Illegal: rewrite in type signature"-        LHS p _ _ | hasWithPatterns p -> parseError "Illegal: with patterns in type signature"-        LHS p [] [] -> forMM (patternToNames p) $ \ (info, x) -> do-          info <- applyAttrs attrs info-          return $ typeSig info (getTacticAttr attrs) x e-      _ -> parseError "A type signature cannot have a where clause"--parseDisplayPragma :: Range -> Position -> String -> Parser Pragma-parseDisplayPragma r pos s =-  case parsePosString pos defaultParseFlags [normal] funclauseParser s of-    ParseOk s (FunClause (LHS lhs [] []) (RHS rhs) NoWhere ca :| []) | null (parseInp s) ->-      return $ DisplayPragma r lhs rhs-    _ -> parseError "Invalid DISPLAY pragma. Should have form {-# DISPLAY LHS = RHS #-}."--typeSig :: ArgInfo -> TacticAttribute -> Name -> Expr -> Declaration-typeSig i tac n e = TypeSig i tac n (Generalized e)---- * Attributes---- | Parsed attribute.--data Attr = Attr-  { attrRange :: Range       -- ^ Range includes the @.-  , attrName  :: String      -- ^ Concrete, user written attribute for error reporting.-  , theAttr   :: Attribute   -- ^ Parsed attribute.-  }--instance HasRange Attr where-  getRange = attrRange--instance SetRange Attr where-  setRange r (Attr _ x a) = Attr r x a---- | Parse an attribute.-toAttribute :: Expr -> Parser Attr-toAttribute x = maybe failure (return . Attr (getRange x) y) $ exprToAttribute x-  where-  y = prettyShow x-  failure = parseErrorRange x $ "Unknown attribute: " ++ y---- | Apply an attribute to thing (usually `Arg`).---   This will fail if one of the attributes is already set---   in the thing to something else than the default value.-applyAttr :: (LensAttribute a) => Attr -> a -> Parser a-applyAttr attr@(Attr r x a) = maybe failure return . setPristineAttribute a-  where-  failure = errorConflictingAttribute attr---- | Apply attributes to thing (usually `Arg`).---   Expects a reversed list of attributes.---   This will fail if one of the attributes is already set---   in the thing to something else than the default value.-applyAttrs :: LensAttribute a => [Attr] -> a -> Parser a-applyAttrs rattrs arg = do-  let attrs = reverse rattrs-  checkForUniqueAttribute (isJust . isQuantityAttribute ) attrs-  checkForUniqueAttribute (isJust . isRelevanceAttribute) attrs-  checkForUniqueAttribute (isJust . isTacticAttribute)    attrs-  foldM (flip applyAttr) arg attrs--applyAttrs1 :: LensAttribute a => List1 Attr -> a -> Parser a-applyAttrs1 = applyAttrs . List1.toList---- | Set the tactic attribute of a binder-setTacticAttr :: List1 Attr -> NamedArg Binder -> NamedArg Binder-setTacticAttr as = updateNamedArg $ fmap $ \ b ->-  case getTacticAttr $ List1.toList as of-    Just t  -> b { bnameTactic = Just t }-    Nothing -> b---- | Get the tactic attribute if present.-getTacticAttr :: [Attr] -> TacticAttribute-getTacticAttr as =-  case tacticAttributes [ a | Attr _ _ a <- as ] of-    [TacticAttribute e] -> Just e-    []                  -> Nothing-    _                   -> __IMPOSSIBLE__---- | Report a parse error if two attributes in the list are of the same kind,---   thus, present conflicting information.-checkForUniqueAttribute :: (Attribute -> Bool) -> [Attr] -> Parser ()-checkForUniqueAttribute p attrs = do-  let pAttrs = filter (p . theAttr) attrs-  when (length pAttrs >= 2) $-    errorConflictingAttributes pAttrs---- | Report an attribute as conflicting (e.g., with an already set value).-errorConflictingAttribute :: Attr -> Parser a-errorConflictingAttribute a = parseErrorRange a $ "Conflicting attribute: " ++ attrName a---- | Report attributes as conflicting (e.g., with each other).---   Precondition: List not emtpy.-errorConflictingAttributes :: [Attr] -> Parser a-errorConflictingAttributes [a] = errorConflictingAttribute a-errorConflictingAttributes as  = parseErrorRange as $-  "Conflicting attributes: " ++ unwords (map attrName as)+    ) where++import Prelude hiding ( null )+import qualified Prelude++import Control.Applicative ( (<|>) )+import Control.Monad+import Control.Monad.State++import Data.Bifunctor (first, second)+import Data.Char+import Data.DList (DList)+import qualified Data.DList as DL+import qualified Data.List as List+import Data.Maybe+import Data.Semigroup ((<>), sconcat)+import qualified Data.Traversable as T++import Agda.Syntax.Position hiding (tests)+import Agda.Syntax.Parser.Helpers+import Agda.Syntax.Parser.Monad+import Agda.Syntax.Parser.Lexer+import Agda.Syntax.Parser.Tokens+import Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Attribute+import Agda.Syntax.Concrete.Pattern+import Agda.Syntax.Common+import Agda.Syntax.Notation+import Agda.Syntax.Literal++import Agda.TypeChecking.Positivity.Occurrence hiding (tests)++import Agda.Utils.Either hiding (tests)+import Agda.Utils.Functor+import Agda.Utils.Hash+import Agda.Utils.List ( spanJust, chopWhen )+import Agda.Utils.List1 ( List1, pattern (:|), (<|) )+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Syntax.Common.Pretty hiding ((<>))+import Agda.Utils.Singleton+import qualified Agda.Utils.Maybe.Strict as Strict+import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.List2 as List2++import Agda.Utils.Impossible++}++%name tokensParser Tokens+%name exprParser Expr+%name exprWhereParser ExprWhere+%name moduleParser File+%name moduleNameParser ModuleName+%name funclauseParser FunClause+%name holeContentParser HoleContent++%tokentype { Token }+%monad { Parser }+%lexer { lexer } { TokEOF{} }++%expect 8+-- * shift/reduce for \ x y z -> foo = bar+--   shifting means it'll parse as \ x y z -> (foo = bar) rather than+--   (\ x y z -> foo) = bar+--+-- * Telescope let and do-notation let.+--      Expr2 -> 'let' Declarations . LetBody+--      TypedBinding -> '(' 'let' Declarations . ')'+--        ')'   shift, and enter state 486+--              (reduce using rule 189)+--   A do-block cannot end in a 'let' so committing to TypedBinding with a+--   shift is the right thing to do here.+--+-- * Named implicits in TypedBinding {x = y}. When encountering the '=' shift+--   treats this as a named implicit and reducing would fail later.++-- This is a trick to get rid of shift/reduce conflicts arising because we want+-- to parse things like "m >>= \x -> k x". See the Expr rule for more+-- information.+%nonassoc LOWEST+%nonassoc '->'++%token+    'abstract'                { TokKeyword KwAbstract $$ }+    'codata'                  { TokKeyword KwCoData $$ }+    'coinductive'             { TokKeyword KwCoInductive $$ }+    'constructor'             { TokKeyword KwConstructor $$ }+    'data'                    { TokKeyword KwData $$ }+    'eta-equality'            { TokKeyword KwEta $$ }+    'field'                   { TokKeyword KwField $$ }+    'forall'                  { TokKeyword KwForall $$ }+    'variable'                { TokKeyword KwVariable $$ }+    'hiding'                  { TokKeyword KwHiding $$ }+    'import'                  { TokKeyword KwImport $$ }+    'in'                      { TokKeyword KwIn $$ }+    'inductive'               { TokKeyword KwInductive $$ }+    'infix'                   { TokKeyword KwInfix $$ }+    'infixl'                  { TokKeyword KwInfixL $$ }+    'infixr'                  { TokKeyword KwInfixR $$ }+    'instance'                { TokKeyword KwInstance $$ }+    'overlap'                 { TokKeyword KwOverlap $$ }+    'let'                     { TokKeyword KwLet $$ }+    'macro'                   { TokKeyword KwMacro $$ }+    'module'                  { TokKeyword KwModule $$ }+    'interleaved'             { TokKeyword KwInterleaved $$ }+    'mutual'                  { TokKeyword KwMutual $$ }+    'no-eta-equality'         { TokKeyword KwNoEta $$ }+    'open'                    { TokKeyword KwOpen $$ }+    'pattern'                 { TokKeyword KwPatternSyn $$ }+    'postulate'               { TokKeyword KwPostulate $$ }+    'primitive'               { TokKeyword KwPrimitive $$ }+    'private'                 { TokKeyword KwPrivate $$ }+    'public'                  { TokKeyword KwPublic $$ }+    'quote'                   { TokKeyword KwQuote $$ }+    'quoteTerm'               { TokKeyword KwQuoteTerm $$ }+    'record'                  { TokKeyword KwRecord $$ }+    'renaming'                { TokKeyword KwRenaming $$ }+    'rewrite'                 { TokKeyword KwRewrite $$ }+    'syntax'                  { TokKeyword KwSyntax $$ }+    'tactic'                  { TokKeyword KwTactic $$ }+    'to'                      { TokKeyword KwTo $$ }+    'unquote'                 { TokKeyword KwUnquote $$ }+    'unquoteDecl'             { TokKeyword KwUnquoteDecl $$ }+    'unquoteDef'              { TokKeyword KwUnquoteDef $$ }+    'using'                   { TokKeyword KwUsing $$ }+    'where'                   { TokKeyword KwWhere $$ }+    'do'                      { TokKeyword KwDo $$ }+    'with'                    { TokKeyword KwWith $$ }+    'opaque'                  { TokKeyword KwOpaque $$ }+    'unfolding'               { TokKeyword KwUnfolding $$ }++    'BUILTIN'                 { TokKeyword KwBUILTIN $$ }+    'CATCHALL'                { TokKeyword KwCATCHALL $$ }+    'DISPLAY'                 { TokKeyword KwDISPLAY $$ }+    'ETA'                     { TokKeyword KwETA $$ }+    'FOREIGN'                 { TokKeyword KwFOREIGN $$ }+    'COMPILE'                 { TokKeyword KwCOMPILE $$ }+    'IMPOSSIBLE'              { TokKeyword KwIMPOSSIBLE $$ }+    'INCOHERENT'              { TokKeyword KwINCOHERENT $$ }+    'INJECTIVE'               { TokKeyword KwINJECTIVE $$ }+    'INJECTIVE_FOR_INFERENCE' { TokKeyword KwINJECTIVE_FOR_INFERENCE $$ }+    'INLINE'                  { TokKeyword KwINLINE $$ }+    'NOINLINE'                { TokKeyword KwNOINLINE $$ }+    'MEASURE'                 { TokKeyword KwMEASURE $$ }+    'NO_TERMINATION_CHECK'    { TokKeyword KwNO_TERMINATION_CHECK $$ }+    'NO_POSITIVITY_CHECK'     { TokKeyword KwNO_POSITIVITY_CHECK $$ }+    'NO_UNIVERSE_CHECK'       { TokKeyword KwNO_UNIVERSE_CHECK $$ }+    'NON_TERMINATING'         { TokKeyword KwNON_TERMINATING $$ }+    'NON_COVERING'            { TokKeyword KwNON_COVERING $$ }+    'NOT_PROJECTION_LIKE'     { TokKeyword KwNOT_PROJECTION_LIKE $$ }+    'OPTIONS'                 { TokKeyword KwOPTIONS $$ }+    'POLARITY'                { TokKeyword KwPOLARITY $$ }+    'OVERLAPPABLE'            { TokKeyword KwOVERLAPPABLE $$ }+    'OVERLAPPING'             { TokKeyword KwOVERLAPPING $$ }+    'OVERLAPS'                { TokKeyword KwOVERLAPS $$ }+    'WARNING_ON_USAGE'        { TokKeyword KwWARNING_ON_USAGE $$ }+    'WARNING_ON_IMPORT'       { TokKeyword KwWARNING_ON_IMPORT $$ }+    'REWRITE'                 { TokKeyword KwREWRITE $$ }+    'STATIC'                  { TokKeyword KwSTATIC $$ }+    'TERMINATING'             { TokKeyword KwTERMINATING $$ }++    tex                       { TokTeX $$ }+    comment                   { TokComment $$ }++    '...'                     { TokSymbol SymEllipsis $$ }+    '..'                      { TokSymbol SymDotDot $$ }+    '.'                       { TokSymbol SymDot $$ }+    ';'                       { TokSymbol SymSemi $$ }+    ':'                       { TokSymbol SymColon $$ }+    '='                       { TokSymbol SymEqual $$ }+    '_'                       { TokSymbol SymUnderscore $$ }+    '?'                       { TokSymbol SymQuestionMark $$ }+    '->'                      { TokSymbol SymArrow $$ }+    '\\'                      { TokSymbol SymLambda $$ }+    '@'                       { TokSymbol SymAs $$ }+    '|'                       { TokSymbol SymBar $$ }+    '('                       { TokSymbol SymOpenParen $$ }+    ')'                       { TokSymbol SymCloseParen $$ }+    '(|'                      { TokSymbol SymOpenIdiomBracket $$ }+    '|)'                      { TokSymbol SymCloseIdiomBracket $$ }+    '(|)'                     { TokSymbol SymEmptyIdiomBracket $$ }+    '{{'                      { TokSymbol SymDoubleOpenBrace $$ }+    '}}'                      { TokSymbol SymDoubleCloseBrace $$ }+    '{'                       { TokSymbol SymOpenBrace $$ }+    '}'                       { TokSymbol SymCloseBrace $$ }+--    ':{'                      { TokSymbol SymColonBrace $$ }+    vopen                     { TokSymbol SymOpenVirtualBrace $$ }+    vclose                    { TokSymbol SymCloseVirtualBrace $$ }+    vsemi                     { TokSymbol SymVirtualSemi $$ }+    '{-#'                     { TokSymbol SymOpenPragma $$ }+    '#-}'                     { TokSymbol SymClosePragma $$ }++    id                        { TokId $$ }+    q_id                      { TokQId $$ }++    string                    { TokString $$ }+    literal                   { TokLiteral $$ }++%%++{--------------------------------------------------------------------------+    Parsing the token stream. Used by the TeX compiler.+ --------------------------------------------------------------------------}++-- Parse a list of tokens.+Tokens :: { [Token] }+Tokens : TokensR        { reverse $1 }++-- Happy is much better at parsing left recursive grammars (constant+-- stack size vs. linear stack size for right recursive).+TokensR :: { [Token] }+TokensR : TokensR Token { $2 : $1 }+        |               { [] }++-- Parse single token.+Token :: { Token }+Token+      -- Please keep these keywords in alphabetical order!+    : 'abstract'                { TokKeyword KwAbstract $1 }+    | 'codata'                  { TokKeyword KwCoData $1 }+    | 'coinductive'             { TokKeyword KwCoInductive $1 }+    | 'constructor'             { TokKeyword KwConstructor $1 }+    | 'data'                    { TokKeyword KwData $1 }+    | 'do'                      { TokKeyword KwDo $1 }+    | 'eta-equality'            { TokKeyword KwEta $1 }+    | 'field'                   { TokKeyword KwField $1 }+    | 'forall'                  { TokKeyword KwForall $1 }+    | 'hiding'                  { TokKeyword KwHiding $1 }+    | 'import'                  { TokKeyword KwImport $1 }+    | 'in'                      { TokKeyword KwIn $1 }+    | 'inductive'               { TokKeyword KwInductive $1 }+    | 'infix'                   { TokKeyword KwInfix $1 }+    | 'infixl'                  { TokKeyword KwInfixL $1 }+    | 'infixr'                  { TokKeyword KwInfixR $1 }+    | 'instance'                { TokKeyword KwInstance $1 }+    | 'let'                     { TokKeyword KwLet $1 }+    | 'macro'                   { TokKeyword KwMacro $1 }+    | 'module'                  { TokKeyword KwModule $1 }+    | 'interleaved'             { TokKeyword KwInterleaved $1 }+    | 'mutual'                  { TokKeyword KwMutual $1 }+    | 'no-eta-equality'         { TokKeyword KwNoEta $1 }+    | 'opaque'                  { TokKeyword KwOpaque $1 }+    | 'open'                    { TokKeyword KwOpen $1 }+    | 'overlap'                 { TokKeyword KwOverlap $1 }+    | 'pattern'                 { TokKeyword KwPatternSyn $1 }+    | 'postulate'               { TokKeyword KwPostulate $1 }+    | 'primitive'               { TokKeyword KwPrimitive $1 }+    | 'private'                 { TokKeyword KwPrivate $1 }+    | 'public'                  { TokKeyword KwPublic $1 }+    | 'quote'                   { TokKeyword KwQuote $1 }+    | 'quoteTerm'               { TokKeyword KwQuoteTerm $1 }+    | 'record'                  { TokKeyword KwRecord $1 }+    | 'renaming'                { TokKeyword KwRenaming $1 }+    | 'rewrite'                 { TokKeyword KwRewrite $1 }+    | 'syntax'                  { TokKeyword KwSyntax $1 }+    | 'tactic'                  { TokKeyword KwTactic $1 }+    | 'to'                      { TokKeyword KwTo $1 }+    | 'unfolding'               { TokKeyword KwUnfolding $1 }+    | 'unquote'                 { TokKeyword KwUnquote $1 }+    | 'unquoteDecl'             { TokKeyword KwUnquoteDecl $1 }+    | 'unquoteDef'              { TokKeyword KwUnquoteDef $1 }+    | 'using'                   { TokKeyword KwUsing $1 }+    | 'variable'                { TokKeyword KwVariable $1 }+    | 'where'                   { TokKeyword KwWhere $1 }+    | 'with'                    { TokKeyword KwWith $1 }++      -- Please keep these pragmas in alphabetical order!+    | 'BUILTIN'                 { TokKeyword KwBUILTIN $1 }+    | 'CATCHALL'                { TokKeyword KwCATCHALL $1 }+    | 'COMPILE'                 { TokKeyword KwCOMPILE $1 }+    | 'DISPLAY'                 { TokKeyword KwDISPLAY $1 }+    | 'ETA'                     { TokKeyword KwETA $1 }+    | 'FOREIGN'                 { TokKeyword KwFOREIGN $1 }+    | 'IMPOSSIBLE'              { TokKeyword KwIMPOSSIBLE $1 }+    | 'INCOHERENT'              { TokKeyword KwINCOHERENT $1 }+    | 'INJECTIVE'               { TokKeyword KwINJECTIVE $1 }+    | 'INJECTIVE_FOR_INFERENCE' { TokKeyword KwINJECTIVE_FOR_INFERENCE $1 }+    | 'INLINE'                  { TokKeyword KwINLINE $1 }+    | 'MEASURE'                 { TokKeyword KwMEASURE $1 }+    | 'NOINLINE'                { TokKeyword KwNOINLINE $1 }+    | 'NO_POSITIVITY_CHECK'     { TokKeyword KwNO_POSITIVITY_CHECK $1 }+    | 'NO_TERMINATION_CHECK'    { TokKeyword KwNO_TERMINATION_CHECK $1 }+    | 'NO_UNIVERSE_CHECK'       { TokKeyword KwNO_UNIVERSE_CHECK $1 }+    | 'NON_TERMINATING'         { TokKeyword KwNON_TERMINATING $1 }+    | 'NON_COVERING'            { TokKeyword KwNON_COVERING $1 }+    | 'NOT_PROJECTION_LIKE'     { TokKeyword KwNOT_PROJECTION_LIKE $1 }+    | 'OPTIONS'                 { TokKeyword KwOPTIONS $1 }+    | 'OVERLAPPABLE'            { TokKeyword KwOVERLAPPABLE $1 }+    | 'OVERLAPPING'             { TokKeyword KwOVERLAPPING $1 }+    | 'OVERLAPS'                { TokKeyword KwOVERLAPS $1 }+    | 'POLARITY'                { TokKeyword KwPOLARITY $1 }+    | 'REWRITE'                 { TokKeyword KwREWRITE $1 }+    | 'STATIC'                  { TokKeyword KwSTATIC $1 }+    | 'TERMINATING'             { TokKeyword KwTERMINATING $1 }+    | 'WARNING_ON_IMPORT'       { TokKeyword KwWARNING_ON_IMPORT $1 }+    | 'WARNING_ON_USAGE'        { TokKeyword KwWARNING_ON_USAGE $1 }++    | tex                       { TokTeX $1 }+    | comment                   { TokComment $1 }++    | '...'                     { TokSymbol SymEllipsis $1 }+    | '..'                      { TokSymbol SymDotDot $1 }+    | '.'                       { TokSymbol SymDot $1 }+    | ';'                       { TokSymbol SymSemi $1 }+    | ':'                       { TokSymbol SymColon $1 }+    | '='                       { TokSymbol SymEqual $1 }+    | '_'                       { TokSymbol SymUnderscore $1 }+    | '?'                       { TokSymbol SymQuestionMark $1 }+    | '->'                      { TokSymbol SymArrow $1 }+    | '\\'                      { TokSymbol SymLambda $1 }+    | '@'                       { TokSymbol SymAs $1 }+    | '|'                       { TokSymbol SymBar $1 }+    | '('                       { TokSymbol SymOpenParen $1 }+    | ')'                       { TokSymbol SymCloseParen $1 }+    | '(|'                      { TokSymbol SymOpenIdiomBracket $1 }+    | '|)'                      { TokSymbol SymCloseIdiomBracket $1 }+    | '(|)'                     { TokSymbol SymEmptyIdiomBracket $1 }+    | '{{'                      { TokSymbol SymDoubleOpenBrace $1 }+    | '}}'                      { TokSymbol SymDoubleCloseBrace $1 }+    | '{'                       { TokSymbol SymOpenBrace $1 }+    | '}'                       { TokSymbol SymCloseBrace $1 }+    | vopen                     { TokSymbol SymOpenVirtualBrace $1 }+    | vclose                    { TokSymbol SymCloseVirtualBrace $1 }+    | vsemi                     { TokSymbol SymVirtualSemi $1 }+    | '{-#'                     { TokSymbol SymOpenPragma $1 }+    | '#-}'                     { TokSymbol SymClosePragma $1 }++    | id                        { TokId $1 }+    | q_id                      { TokQId $1 }+    | string                    { TokString $1 }++    | literal                   { TokLiteral $1 }++{--------------------------------------------------------------------------+    Top level+ --------------------------------------------------------------------------}++File :: { Module }+File : vopen TopLevel maybe_vclose { takeOptionsPragmas $2 }++maybe_vclose :: { () }+maybe_vclose : {- empty -} { () }+             | vclose      { () }++{--------------------------------------------------------------------------+    Meta rules+ --------------------------------------------------------------------------}++{-  A layout block might have to be closed by a parse error. Example:+        let x = e in e'+    Here the 'let' starts a layout block which should end before the 'in'.  The+    problem is that the lexer doesn't know this, so there is no virtual close+    brace. However when the parser sees the 'in' there will be a parse error.+    This is our cue to close the layout block.+-}+close :: { () }+close : vclose  { () }+      | error   {% popBlock }+++-- You can use concrete semi colons in a layout block started with a virtual+-- brace, so we don't have to distinguish between the two semi colons. You can't+-- use a virtual semi colon in a block started by a concrete brace, but this is+-- simply because the lexer will not generate virtual semis in this case.+semi :: { Interval }+semi : ';'    { $1 }+     | vsemi  { $1 }+++-- Enter the 'imp_dir' lex state, where we can parse the keyword 'to'.+beginImpDir :: { () }+beginImpDir : {- empty -}   {% pushLexState imp_dir }++{--------------------------------------------------------------------------+    Helper rules+ --------------------------------------------------------------------------}++-- A float. Used in fixity declarations.+Float :: { Ranged Double }+Float : literal {% forM $1 $ \case+                   { LitNat   i -> return $ fromInteger i+                   ; LitFloat d -> return d+                   ; _          -> parseError $ "Expected floating point number"+                   }+                }++{--------------------------------------------------------------------------+    Names+ --------------------------------------------------------------------------}++-- A name is really a sequence of parts, but the lexer just sees it as a+-- string, so we have to do the translation here.+Id :: { Name }+Id : id     {% mkName $1 }++-- Space separated list of one or more identifiers.+SpaceIds :: { List1 Name }+SpaceIds+    : Id SpaceIds { $1 <| $2 }+    | Id          { singleton $1 }++-- When looking for a double closed brace, we accept either a single token '}}'+-- (which is what the unicode character "RIGHT WHITE CURLY BRACKET" is+-- postprocessed into in LexActions.hs), but also two consecutive tokens '}'+-- (which a string '}}' is lexed to).  This small hack allows us to keep+-- "record { a = record { }}" working. In the second case, we check that the two+-- tokens '}' are immediately consecutive.+DoubleCloseBrace :: { Range }+DoubleCloseBrace+  : '}}' { getRange $1 }+  | '}' '}' {%+      if posPos (fromJust (rEnd' (getRange $2))) -+         posPos (fromJust (rStart' (getRange $1))) > 2+      then parseErrorRange $2 "Expecting '}}', found separated '}'s."+      else return $ getRange ($1, $2)+    }++-- A possibly dotted identifier.+MaybeDottedId :: { Arg Name }+MaybeDottedId+  : '..' Id { defaultShapeIrrelevantArg $1 $2 }+  | '.'  Id { defaultIrrelevantArg $1 $2 }+  | Id      { defaultArg $1 }++-- Space separated list of one or more possibly dotted identifiers.+MaybeDottedIds :: { List1 (Arg Name) }+MaybeDottedIds+    : MaybeDottedId MaybeDottedIds { $1 <| $2 }+    | MaybeDottedId                { singleton $1 }++-- Space separated list of one or more identifiers, some of which may+-- be surrounded by braces or dotted.+ArgIds :: { List1 (Arg Name) }+ArgIds+    : MaybeDottedId ArgIds            { $1 <| $2 }+    | MaybeDottedId                   { singleton $1 }+    | '{{' MaybeDottedIds DoubleCloseBrace ArgIds { fmap makeInstance $2 <> $4 }+    | '{{' MaybeDottedIds DoubleCloseBrace        { fmap makeInstance $2 }+    | '{' MaybeDottedIds '}' ArgIds   { fmap hide $2 <> $4 }+    | '{' MaybeDottedIds '}'          { fmap hide $2 }+    | '.' '{' SpaceIds '}' ArgIds     { fmap (hide . defaultIrrelevantArg $1) $3 <> $5 }+    | '.' '{' SpaceIds '}'            { fmap (hide . defaultIrrelevantArg $1) $3 }+    | '.' '{{' SpaceIds DoubleCloseBrace ArgIds   { fmap (makeInstance . defaultIrrelevantArg $1) $3 <> $5 }+    | '.' '{{' SpaceIds DoubleCloseBrace          { fmap (makeInstance . defaultIrrelevantArg $1) $3 }+    | '..' '{' SpaceIds '}' ArgIds    { fmap (hide . defaultShapeIrrelevantArg $1) $3 <> $5 }+    | '..' '{' SpaceIds '}'           { fmap (hide . defaultShapeIrrelevantArg $1) $3 }+    | '..' '{{' SpaceIds DoubleCloseBrace ArgIds  { fmap (makeInstance . defaultShapeIrrelevantArg $1) $3 <> $5 }+    | '..' '{{' SpaceIds DoubleCloseBrace         { fmap (makeInstance . defaultShapeIrrelevantArg $1) $3 }++-- Modalities preceeding identifiers++ModalArgIds :: { ([Attr], List1 (Arg Name)) }+ModalArgIds : Attributes ArgIds  {% ($1,) `fmap` mapM (applyAttrs $1) $2 }++-- Attributes are parsed as '@' followed by an atomic expression.+-- Unknown attributes cast a warning and are ignored.++Attribute :: { Maybe Attr }+Attribute : '@' ExprOrAttr  {% toAttribute (getRange ($1,$2)) $2 }++-- Parse a reverse list of modalities++Attributes :: { [Attr] }+Attributes : {- empty -}  { [] }+  | Attributes Attribute { maybe $1 (: $1) $2 }++Attributes1 :: { [Attr] }+Attributes1 : Attribute  { maybeToList $1 }+  | Attributes1 Attribute { maybe $1 (: $1) $2 }++QId :: { QName }+QId : q_id  {% mkQName $1 }+    | Id    { QName $1 }+++-- A module name is just a qualified name+ModuleName :: { QName }+ModuleName : QId { $1 }+++-- A binding variable. Can be '_'+BId :: { Name }+BId : Id    { $1 }+    | '_'   { setRange (getRange $1) simpleHole }++{- UNUSED+-- A binding variable. Can be '_'+MaybeDottedBId :: { (Relevance, Name) }+MaybeDottedBId+    : BId        { (Relevant empty , $1) }+    | '.' BId    { (Irrelevant (OIrrDot $ getRange $1), $2) }+    | '..' BId   { (ShapeIrrelevant (OShIrrDotDot $ getRange $1), $2) }+-}+++-- Space separated list of binding identifiers. Used in fixity+-- declarations infixl 100 + -+SpaceBIds :: { List1 Name }+SpaceBIds+    : BId SpaceBIds { $1 <| $2 }+    | BId           { singleton $1 }++-- Space-separated list of binding identifiers. Used in dependent+-- function spaces: (x y z : Nat) -> ...+-- (Used to be comma-separated; hence the name)+-- QUESTION: Should this be replaced by SpaceBIds above?+-- Andreas, 2011-04-07 the trick avoids reduce/reduce conflicts+-- when parsing  (x y z : A) -> B+-- at point (x y  it is not clear whether x y is an application or+-- a variable list. We could be parsing (x y z) -> B+-- with ((x y) z) being a type.+CommaBIds :: { List1 (NamedArg Binder) }+CommaBIds : CommaBIdAndAbsurds {%+    case $1 of+      Left ns -> return ns+      Right _ -> parseError $ "expected sequence of bound identifiers, not absurd pattern"+    }++CommaBIdAndAbsurds :: { Either (List1 (NamedArg Binder)) (List1 Expr) }+CommaBIdAndAbsurds+  : Application {% boundNamesOrAbsurd $1 }+  | QId '=' QId {% (Left . singleton . updateNamedArg mkBinder) `fmap` mkNamedArg (Just $1) (Left $3) }+  | '_' '=' QId {% (Left . singleton . updateNamedArg mkBinder) `fmap` mkNamedArg Nothing   (Left $3) }+  | QId '=' '_' {% (Left . singleton . updateNamedArg mkBinder) `fmap` mkNamedArg (Just $1) (Right $ getRange $3) }+  | '_' '=' '_' {% (Left . singleton . updateNamedArg mkBinder) `fmap` mkNamedArg Nothing   (Right $ getRange $3) }++-- Parse a sequence of identifiers, including hiding info.+-- Does not include instance arguments.+-- E.g. x {y z} _ {v}+-- To be used in typed bindings, like (x {y z} _ {v} : Nat).+BIdsWithHiding :: { List1 (NamedArg Binder) }+BIdsWithHiding : Application {%+  -- interpret an expression as a name and maybe a pattern+  case mapM exprAsNameOrHiddenNames $1 of+    Nothing   -> parseError "Expected sequence of possibly hidden bound identifiers"+    Just good -> forM (sconcat good) $ updateNamedArgA $ \ (n, me) -> do+                   p <- traverse exprToPattern me+                   pure $ Binder p UserBinderName (mkBoundName_ n)+    }+++-- Space separated list of strings in a pragma.+PragmaStrings :: { [(Interval, String)] }+PragmaStrings+    : {- empty -}           { [] }+    | string PragmaStrings  { $1 : $2 }+{- Unused+PragmaString :: { String }+PragmaString+    : string { snd $1 }+-}+Strings :: { [(Interval, String)] }+Strings : {- empty -}    { [] }+        | string Strings { $1 : $2 }++ForeignCode :: { DList (Interval, String) }+ForeignCode+  : {- empty -} { mempty }+  | string ForeignCode { $1 `DL.cons` $2 }+  | '{-#' ForeignCode '#-}' ForeignCode+    { (($1, "{-#") `DL.cons` $2) <> (($3, "#-}") `DL.cons` $4) }++PragmaName :: { Name }+PragmaName : string {% mkName $1 }++PragmaQName :: { QName }+PragmaQName : string {% pragmaQName $1 }  -- Issue 2125. WAS: string {% fmap QName (mkName $1) }++PragmaQNames :: { [QName] }+PragmaQNames : Strings {% mapM pragmaQName $1 }++PragmaQNames1 :: { [QName] }+PragmaQNames1 : PragmaQName PragmaQNames { $1:$2 }++{--------------------------------------------------------------------------+    Expressions (terms and types)+ --------------------------------------------------------------------------}++{-  Expressions. You might expect lambdas and lets to appear in the first+    expression category (lowest precedence). The reason they don't is that we+    want to parse things like++        m >>= \x -> k x++    This will leads to a conflict in the following case++        m >>= \x -> k x >>= \y -> k' y++    At the second '>>=' we can either shift or reduce. We solve this problem+    using Happy's precedence directives. The rule 'Expr -> Expr1' (which is the+    rule you shouldn't use to reduce when seeing '>>=') is given LOWEST+    precedence.  The terminals '->' and op (which is what you should shift)+    is given higher precedence.+-}++-- Top level: Function types.+Expr :: { Expr }+Expr+  : TeleArrow Expr                      { Pi $1 $2 }+  | Application3 '->' Expr              { Fun (getRange ($1,$2,$3))+                                              (defaultArg $ rawApp $1)+                                              $3 }+  | Attributes1 Application3 '->' Expr  {% applyAttrs $1 (defaultArg $ rawApp $2) <&> \ dom ->+                                             Fun (getRange ($1,$2,$3,$4)) dom $4 }+  | Expr1 %prec LOWEST                  { $1 }++-- Level 1: Application+Expr1 :: { Expr }+Expr1+  : UnnamedWithExprs+      {% case $1 of+           { e :| []      -> return e+           ; e :| e1 : es -> return $ WithApp (getRange (e, e1, es)) e (e1 :| es)+           }+      }++WithExprs :: { List1 (Named Name Expr) }+WithExprs+  : Application3 'in' Id     '|' WithExprs { named $3  (rawApp $1) <| $5 }+  | Application3 {- empty -} '|' WithExprs { unnamed   (rawApp $1) <| $3 }+  | Application3 'in' Id                   { singleton (named $3 (rawApp $1)) }+  | Application3 {- empty -}               { singleton (unnamed  (rawApp $1)) }++UnnamedWithExprs :: { List1 Expr }+UnnamedWithExprs+  :  Application3 '|' UnnamedWithExprs { (rawApp $1) <| $3 }+  | {- empty -} Application            { singleton (rawApp $1) }++Application :: { List1 Expr }+Application+    : Expr2             { singleton $1 }+    | Expr3 Application { $1 <| $2 }++-- Level 2: Lambdas and lets+Expr2 :: { Expr }+Expr2+    : '\\' LamBindings Expr        { Lam (getRange ($1,$2,$3)) $2 $3 }+    | ExtendedOrAbsurdLam          { $1 }+    | 'forall' ForallBindings Expr { forallPi $2 $3 }+    | 'let' Declarations LetBody   { Let (getRange ($1,$2,$3)) $2 $3 }+    | 'do' vopen DoStmts close     { DoBlock (getRange ($1, $3)) $3 }+    | Expr3                        { $1 }+    | 'tactic' Application3        { Tactic (getRange ($1, $2)) (rawApp $2) }++LetBody :: { Maybe Expr }+LetBody : 'in' Expr   { Just $2 }+        | {- empty -} { Nothing }++ExtendedOrAbsurdLam :: { Expr }+ExtendedOrAbsurdLam+    : '\\'             '{' LamClauses '}'                  {% extLam (getRange ($1, $2, $4))     [] $3 }+    | '\\' Attributes1 '{' LamClauses '}'                  {% extLam (getRange ($1, $3, $5))     $2 $4 }+    | '\\'             'where' vopen LamWhereClauses close {% extLam (getRange ($1, $2, $3, $5)) [] $4 }+    | '\\' Attributes1 'where' vopen LamWhereClauses close {% extLam (getRange ($1, $3, $4, $6)) $2 $5 }+    | '\\'             AbsurdLamBindings                   {% extOrAbsLam (getRange $1) [] $2 }+    | '\\' Attributes1 AbsurdLamBindings                   {% extOrAbsLam (getRange $1) $2 $3 }++Application3 :: { List1 Expr }+Application3+    : Expr3              { singleton $1 }+    | Expr3 Application3 { $1 <| $2 }++-- Christian Sattler, 2017-08-04, issue #2671+-- We allow empty lists of expressions for the LHS of extended lambda clauses.+-- I am not sure what Application3 is otherwise used for, so I keep the+-- original type and create this copy solely for extended lambda clauses.+Application3PossiblyEmpty :: { [Expr] }+Application3PossiblyEmpty+    : {- empty -}                     { [] }+    | Expr3 Application3PossiblyEmpty { $1 : $2 }++-- Level 3: Atoms+Expr3Curly :: { Expr }+Expr3Curly+    : '{' Expr4 '}'               {% HiddenArg (getRange ($1,$2,$3)) `fmap` maybeNamed $2 }+    | '{' '}'                     { let r = fuseRange $1 $2 in HiddenArg r $ unnamed $ Absurd r }+    | '{{' Expr4 DoubleCloseBrace {% InstanceArg (getRange ($1,$2,$3)) `fmap` maybeNamed $2 }+    | '{{' DoubleCloseBrace       { let r = fuseRange $1 $2 in InstanceArg r $ unnamed $ Absurd r }++Expr3NoCurly :: { Expr }+Expr3NoCurly+    : '?'                               { QuestionMark (getRange $1) Nothing }+    | '_'                               { Underscore (getRange $1) Nothing }+    | 'quote'                           { Quote (getRange $1) }+    | 'quoteTerm'                       { QuoteTerm (getRange $1) }+    | 'unquote'                         { Unquote (getRange $1) }+    | '(|' UnnamedWithExprs '|)'        { IdiomBrackets (getRange ($1,$2,$3)) (List1.toList $2) }+    | '(|)'                             { IdiomBrackets (getRange $1) [] }+    | '(' ')'                           { Absurd (fuseRange $1 $2) }+    | Id '@' Expr3                      { As (getRange ($1,$2,$3)) $1 $3 }+    | '.' Expr3                         { Dot (kwRange $1) $2 }+    | '..' Expr3                        { DoubleDot (kwRange $1) $2 }+    | 'record' '{' RecordAssignments '}' { Rec (kwRange $1) (getRange ($1,$2,$3,$4)) $3 }+    | 'record' Expr3NoCurly '{' FieldAssignments '}' { RecUpdate (kwRange $1) (getRange ($1,$2,$3,$4,$5)) $2 $4 }+    | '...'                             { Ellipsis (getRange $1) }+    | ExprOrAttr                       { $1 }++-- Level 4: Maybe named, or cubical faces+Expr4 :: { Expr }+Expr4 : Expr1 '=' Expr { Equal (getRange ($1, $2, $3)) $1 $3 }+      | Expr           { $1 }++ExprOrAttr :: { Expr }+ExprOrAttr+    : QId           { Ident $1 }+    | literal       { Lit (getRange $1) (rangedThing $1) }+    | '(' Expr4 ')' { Paren (getRange ($1,$2,$3)) $2 }+    -- ^ this is needed for cubical stuff++Expr3 :: { Expr }+Expr3+    : Expr3Curly   { $1 }+    | Expr3NoCurly { $1 }++RecordAssignments :: { RecordAssignments }+RecordAssignments+  : {- empty -}        { [] }+  | RecordAssignments1 { List1.toList $1 }++RecordAssignments1 :: { List1 RecordAssignment }+RecordAssignments1+  : RecordAssignment                        { singleton $1 }+  | RecordAssignment ';' RecordAssignments1 { $1 <| $3 }++RecordAssignment :: { RecordAssignment }+RecordAssignment+  : FieldAssignment  { Left  $1 }+  | ModuleAssignment { Right $1 }++ModuleAssignment :: { ModuleAssignment }+ModuleAssignment+  : ModuleName OpenArgs ImportDirective  { ModuleAssignment $1 $2 $3 }++FieldAssignments :: { [FieldAssignment] }+FieldAssignments+  : {- empty -}       { [] }+  | FieldAssignments1 { List1.toList $1 }++FieldAssignments1 :: { List1 FieldAssignment }+FieldAssignments1+  : FieldAssignment                       { singleton $1 }+  | FieldAssignment ';' FieldAssignments1 { $1 <| $3 }++FieldAssignment :: { FieldAssignment }+FieldAssignment+  : Id '=' Expr   { FieldAssignment $1 $3 }++{--------------------------------------------------------------------------+    Bindings+ --------------------------------------------------------------------------}++-- "Delta ->" to avoid conflict between Delta -> Gamma and Delta -> A.+TeleArrow :: { Telescope1 }+TeleArrow : Telescope1 '->' { $1 }++Telescope1 :: { Telescope1 }+Telescope1 : TypedBindings { $1 }++TypedBindings :: { List1 TypedBinding }+TypedBindings+    : TypedBinding TypedBindings { $1 <| $2 }+    | TypedBinding               { singleton $1 }+++-- A typed binding is either (x1 .. xn : A) or   {y1 .. ym : B}+-- Andreas, 2011-04-07: or  .(x1 .. xn : A) or  .{y1 .. ym : B}+-- Andreas, 2011-04-27: or ..(x1 .. xn : A) or ..{y1 .. ym : B}+TypedBinding :: { TypedBinding }+TypedBinding+    : '(' Open ')'               { TLet (getRange ($1,$3)) $2 }+    | '(' 'let' Declarations ')' { TLet (getRange ($1,$4)) $3 }+-- relevant+    | '(' TBindWithHiding ')'                { setRange (getRange ($1,$2,$3)) $+                                               $2 }+    | '{' TBind '}'                          { setRange (getRange ($1,$2,$3)) $+                                               hide $2 }+    | '{{' TBind DoubleCloseBrace            { setRange (getRange ($1,$2,$3)) $+                                               makeInstance $2 }+-- irrelevant+    | '.' '(' TBindWithHiding ')'            { setRange (getRange ($2,$3,$4)) $+                                               makeIrrelevant $1 $3 }+    | '.' '{' TBind '}'                      { setRange (getRange ($2,$3,$4)) $+                                               hide $+                                               makeIrrelevant $1 $3 }+    | '.' '{{' TBind DoubleCloseBrace        { setRange (getRange ($2,$3,$4)) $+                                               makeInstance $+                                               makeIrrelevant $1 $3 }+-- shape-irrelevant+    | '..' '(' TBindWithHiding ')'           { setRange (getRange ($2,$3,$4)) $+                                               makeShapeIrrelevant $1 $3 }+    | '..' '{' TBind '}'                     { setRange (getRange ($2,$3,$4)) $+                                               hide $+                                               makeShapeIrrelevant $1 $3 }+    | '..' '{{' TBind DoubleCloseBrace       { setRange (getRange ($2,$3,$4)) $+                                               makeInstance $+                                               makeShapeIrrelevant $1 $3 }+-- attributes, relevant+    | '(' ModalTBindWithHiding ')'           { setRange (getRange ($1,$2,$3)) $+                                               $2 }+    | '{{' ModalTBind DoubleCloseBrace       { setRange (getRange ($1,$2,$3)) $+                                               makeInstance $2 }+    | '{' ModalTBind '}'                     { setRange (getRange ($1,$2,$3)) $+                                               hide $2 }+-- attributes, irrelevant+    | '.' '(' ModalTBindWithHiding ')'       {% setRange (getRange ($2,$3,$4)) <\$>+                                                makeIrrelevantM $1 $3 }+    | '.' '{' ModalTBind '}'                 {% setRange (getRange ($2,$3,$4)) . hide <\$>+                                                makeIrrelevantM $1 $3 }+    | '.' '{{' ModalTBind DoubleCloseBrace   {% setRange (getRange ($2,$3,$4)) . makeInstance <\$>+                                                makeIrrelevantM $1 $3 }+-- attributes, shape-irrelevant+    | '..' '(' ModalTBindWithHiding ')'      {% setRange (getRange ($2,$3,$4)) <\$>+                                                makeShapeIrrelevantM $1 $3 }+    | '..' '{' ModalTBind '}'                {% setRange (getRange ($2,$3,$4)) . hide <\$>+                                                makeShapeIrrelevantM $1 $3 }+    | '..' '{{' ModalTBind DoubleCloseBrace  {% setRange (getRange ($2,$3,$4)) . makeInstance <\$>+                                                makeShapeIrrelevantM $1 $3 }+++-- x1 .. xn : A+-- x1 .. xn :{i1 i2 ..} A+TBind :: { TypedBinding }+TBind : CommaBIds ':' Expr  {+    let r = getRange ($1,$2,$3) -- the range is approximate only for TypedBindings+    in TBind r $1 $3+  }++ModalTBind :: { TypedBinding }+ModalTBind : Attributes1 CommaBIds ':' Expr  {% do+    let r = getRange ($1,$2,$3,$4) -- the range is approximate only for TypedBindings+    xs <- mapM (applyAttrs $1 . setTacticAttr $1) $2+    return $ TBind r xs $4+  }++-- x {y z} _ {v} : A+TBindWithHiding :: { TypedBinding }+TBindWithHiding : BIdsWithHiding ':' Expr  {+    let r = getRange ($1,$2,$3) -- the range is approximate only for TypedBindings+    in TBind r $1 $3+  }++ModalTBindWithHiding :: { TypedBinding }+ModalTBindWithHiding : Attributes1 BIdsWithHiding ':' Expr  {% do+    let r = getRange ($1,$2,$3,$4) -- the range is approximate only for TypedBindings+    xs <- mapM (applyAttrs $1 . setTacticAttr $1) $2+    return $ TBind r xs $4+  }++-- A non-empty sequence of lambda bindings.+LamBindings :: { List1 LamBinding }+LamBindings+  : LamBinds '->' {%+      case absurdBinding $1 of+        Just{}  -> parseError "Absurd lambda cannot have a body."+        Nothing -> return $ List1.fromListSafe __IMPOSSIBLE__ $ lamBindings $1+      }++AbsurdLamBindings :: { Either ([LamBinding], Hiding) (List1 Expr) }+AbsurdLamBindings+  : LamBindsAbsurd {%+    case $1 of+      Left lb -> case absurdBinding lb of+                   Nothing -> parseError "Missing body for lambda"+                   Just h  -> return $ Left (lamBindings lb, h)+      Right es -> return $ Right es+    }++-- absurd lambda is represented by @Left hiding@+LamBinds :: { LamBinds }+LamBinds+  : DomainFreeBinding LamBinds  { fmap (map DomainFree (List1.toList $1) ++) $2 }+  | TypedBinding LamBinds       { fmap (DomainFull $1 :) $2 }+  | DomainFreeBinding           { mkLamBinds $ map DomainFree $ List1.toList $1 }+  | TypedBinding                { mkLamBinds [DomainFull $1] }+  | '(' ')'                     { mkAbsurdBinding NotHidden }+  | '{' '}'                     { mkAbsurdBinding Hidden }+  | '{{' DoubleCloseBrace       { mkAbsurdBinding (Instance NoOverlap) }++-- Like LamBinds, but could also parse an absurd LHS of an extended lambda @{ p1 ... () }@+LamBindsAbsurd :: { Either LamBinds (List1 Expr) }+LamBindsAbsurd+  : DomainFreeBinding LamBinds  { Left $ fmap (map DomainFree (List1.toList $1) ++) $2 }+  | TypedBinding LamBinds       { Left $ fmap (DomainFull $1 :) $2 }+  | DomainFreeBindingAbsurd     { case $1 of+                                    Left lb -> Left $ mkLamBinds (map DomainFree $ List1.toList lb)+                                    Right es -> Right es }+  | TypedBinding                { Left $ mkLamBinds [DomainFull $1] }+  | '(' ')'                     { Left $ mkAbsurdBinding NotHidden }+  | '{' '}'                     { Left $ mkAbsurdBinding Hidden }+  | '{{' DoubleCloseBrace       { Left $ mkAbsurdBinding (Instance NoOverlap) }++-- FNF, 2011-05-05: No where-clauses in extended lambdas for now.+-- Andreas, 2020-03-28: And also not in sight either nine years later.+NonAbsurdLamClause :: { LamClause }+NonAbsurdLamClause+  : Application3PossiblyEmpty '->' Expr {% mkLamClause empty $1 (RHS $3) }+  | CatchallPragma+    Application3PossiblyEmpty '->' Expr {% mkLamClause (YesCatchall (getRange $1))  $2 (RHS $4) }++AbsurdLamClause :: { LamClause }+AbsurdLamClause+-- FNF, 2011-05-09: By being more liberal here, we avoid shift/reduce and reduce/reduce errors.+-- Later stages such as scope checking will complain if we let something through which we should not+  : Application                {% mkAbsurdLamClause empty $1 }+  | CatchallPragma Application {% mkAbsurdLamClause (YesCatchall (getRange $1))  $2 }++LamClause :: { LamClause }+LamClause+  : NonAbsurdLamClause { $1 }+  | AbsurdLamClause { $1 }++-- Parses all extended lambda clauses except for a single absurd clause, which is taken care of+-- in AbsurdLambda+LamClauses :: { List1 LamClause }+LamClauses+   : LamClauses semi LamClause { $3 <| $1 }+   | AbsurdLamClause semi LamClause { $3 <| singleton $1 }+   | NonAbsurdLamClause { singleton $1 }++-- Parses all extended lambda clauses including a single absurd clause.+-- For lambda-where this is not[sic!, now?] taken care of in AbsurdLambda.+LamWhereClauses :: { List1 LamClause }+LamWhereClauses+   : LamWhereClauses semi LamClause { $3 <| $1 }+   | LamClause { singleton $1 }++ForallBindings :: { List1 LamBinding }+ForallBindings+  : TypedUntypedBindings1 '->' { $1 }++-- A non-empty sequence of possibly untyped bindings.+TypedUntypedBindings1 :: { List1 LamBinding }+TypedUntypedBindings1+  : DomainFreeBinding TypedUntypedBindings1 { fmap DomainFree $1 <> $2 }+  | TypedBinding TypedUntypedBindings1      { DomainFull $1 <| $2 }+  | DomainFreeBinding                       { fmap DomainFree $1 }+  | TypedBinding                            { singleton $ DomainFull $1 }++-- A possibly empty sequence of possibly untyped bindings.+-- This is used as telescope in data and record decls.+TypedUntypedBindings :: { [LamBinding] }+TypedUntypedBindings+  : DomainFreeBinding TypedUntypedBindings { map DomainFree (List1.toList $1) ++ $2 }+  | TypedBinding TypedUntypedBindings      { DomainFull $1 : $2 }+  |                                        { [] }++DomainFreeBindings :: { [NamedArg Binder] }+DomainFreeBindings+  : {- empty -}                          { [] }+  | DomainFreeBinding DomainFreeBindings { List1.toList $1 ++ $2 }++-- A domain free binding is either x or {x1 .. xn}+DomainFreeBinding :: { List1 (NamedArg Binder) }+DomainFreeBinding+  : DomainFreeBindingAbsurd {% case $1 of+                             Left lbs -> return lbs+                             Right _ -> parseError "expected sequence of bound identifiers, not absurd pattern"+                          }++MaybeAsPattern :: { Maybe Pattern }+MaybeAsPattern+  : '@' Expr3   {% fmap Just (exprToPattern $2) }+  | {- empty -} { Nothing }++-- A domain free binding is either x or {x1 .. xn}+DomainFreeBindingAbsurd :: { Either (List1 (NamedArg Binder)) (List1 Expr)}+DomainFreeBindingAbsurd+-- no parentheses+    : BId      MaybeAsPattern { Left . singleton $ mkDomainFree_ id $2 $1 }+    | '.' BId  MaybeAsPattern { Left . singleton $ mkDomainFree_ (makeIrrelevant $1) $3 $2 }+    | '..' BId MaybeAsPattern { Left . singleton $ mkDomainFree_ (makeShapeIrrelevant $1) $3 $2 }+-- just parentheses+    | '(' Application ')'     {% exprToPattern (rawApp $2) >>= \ p ->+                                 pure . Left . singleton $ mkDomainFree_ id (Just p) $ simpleHole }+    | '{' CommaBIdAndAbsurds '}'+         { first (fmap hide) $2 }+    | '{{' CommaBIds DoubleCloseBrace { Left $ fmap makeInstance $2 }+-- additonal attributes, e.g. @tactic+    | '(' Attributes1 CommaBIdAndAbsurds ')'+         {% applyAttrs $2 defaultArgInfo <&> \ ai ->+              first (fmap (setTacticAttr $2 . setArgInfo ai)) $3 }+    | '{' Attributes1 CommaBIdAndAbsurds '}'+         {% applyAttrs $2 defaultArgInfo <&> \ ai ->+              first (fmap (hide . setTacticAttr $2 . setArgInfo ai)) $3 }+    | '{{' Attributes1 CommaBIds DoubleCloseBrace+         {% Left <\$> applyAttributes $2 (makeInstance defaultArgInfo) $3 }+-- additional irrelevance+    | '.'  '('  CommaBIds ')'              { Left $ fmap (makeIrrelevant $1) $3 }+    | '.'  '{'  CommaBIds '}'              { Left $ fmap (hide . makeIrrelevant $1) $3 }+    | '.'  '{{' CommaBIds DoubleCloseBrace { Left $ fmap (makeInstance . makeIrrelevant $1) $3 }+-- additional shape-irrelevance+    | '..' '('  CommaBIds ')'              { Left $ fmap (makeShapeIrrelevant $1) $3 }+    | '..' '{'  CommaBIds '}'              { Left $ fmap (hide . makeShapeIrrelevant $1) $3 }+    | '..' '{{' CommaBIds DoubleCloseBrace { Left $ fmap (makeInstance . makeShapeIrrelevant $1) $3 }+-- additional irrelevance and attributes+    | '.' '(' Attributes1 CommaBIds ')'+         {% Left <\$> applyAttributes $3 (makeIrrelevant $1 defaultArgInfo) $4 }+    | '.' '{' Attributes1 CommaBIds '}'+         {% Left <\$> applyAttributes $3 (makeIrrelevant $1 $ hide defaultArgInfo) $4 }+    | '.' '{{' Attributes1 CommaBIds DoubleCloseBrace+         {% Left <\$> applyAttributes $3 (makeIrrelevant $1 $ makeInstance defaultArgInfo) $4 }+-- additional shape-irrelevance and attributes+    | '..' '(' Attributes1 CommaBIds ')'+         {% Left <\$> applyAttributes $3 (makeShapeIrrelevant $1 defaultArgInfo) $4 }+    | '..' '{' Attributes1 CommaBIds '}'+         {% Left <\$> applyAttributes $3 (makeShapeIrrelevant $1 $ hide defaultArgInfo) $4 }+    | '..' '{{' Attributes1 CommaBIds DoubleCloseBrace+         {% Left <\$> applyAttributes $3 (makeShapeIrrelevant $1 $ makeInstance defaultArgInfo) $4 }+++{--------------------------------------------------------------------------+    Do-notation+ --------------------------------------------------------------------------}++DoStmts :: { List1 DoStmt }+DoStmts : DoStmt              { singleton $1 }+        | DoStmt vsemi        { singleton $1 }    -- #3046+        | DoStmt semi DoStmts { $1 <| $3 }++DoStmt :: { DoStmt }+DoStmt : Expr DoWhere {% buildDoStmt $1 $2 }++DoWhere :: { [LamClause] }+DoWhere+  : {- empty -} { [] }+  | 'where' vopen LamWhereClauses close { reverse (List1.toList $3) }++{--------------------------------------------------------------------------+    Modules and imports+ --------------------------------------------------------------------------}++-- Import directives+ImportDirective :: { ImportDirective }+ImportDirective+  : ImportDirective1 ImportDirective { $1 <> $2 }+  | {- empty -}                      { mempty }++ImportDirective1 :: { ImportDirective }+  : 'public'      { defaultImportDir { importDirRange = getRange $1, publicOpen = Just (kwRange $1) } }+  | Using         { defaultImportDir { importDirRange = snd $1, using    = fst $1 } }+  | Hiding        { defaultImportDir { importDirRange = snd $1, hiding   = fst $1 } }+  | RenamingDir   { defaultImportDir { importDirRange = snd $1, impRenaming = fst $1 } }++Using :: { (Using, Range) }+Using+    : 'using' '(' CommaImportNames ')'   { (Using $3 , getRange ($1,$2,$3,$4)) }+        -- using can have an empty list++Hiding :: { ([ImportedName], Range) }+Hiding+    : 'hiding' '(' CommaImportNames ')'  { ($3 , getRange ($1,$2,$3,$4)) }+        -- if you want to hide nothing that's fine, isn't it?++RenamingDir :: { ([Renaming] , Range) }+RenamingDir+    : 'renaming' '(' Renamings ')'      { ($3 , getRange ($1,$2,$3,$4)) }+    | 'renaming' '(' ')'                { ([] , getRange ($1,$2,$3)) }++-- Renamings of the form 'x to y'+Renamings :: { [Renaming] }+Renamings+    : Renaming ';' Renamings    { $1 : $3 }+    | Renaming                  { [$1] }++Renaming :: { Renaming }+Renaming+    : ImportName_ 'to' RenamingTarget { Renaming $1 (setImportedName $1 (snd $3)) (fst $3) (getRange $2) }++RenamingTarget :: { (Maybe Fixity, Name) }+RenamingTarget+    : Id                 { (Nothing, $1) }+    | 'infix'  Float Id  { (Just (Fixity (getRange ($1,$2)) (Related $ rangedThing $2) NonAssoc)  , $3) }+    | 'infixl' Float Id  { (Just (Fixity (getRange ($1,$2)) (Related $ rangedThing $2) LeftAssoc) , $3) }+    | 'infixr' Float Id  { (Just (Fixity (getRange ($1,$2)) (Related $ rangedThing $2) RightAssoc), $3) }++-- We need a special imported name here, since we have to trigger+-- the imp_dir state exactly one token before the 'to'+ImportName_ :: { ImportedName }+ImportName_+    : beginImpDir Id          { ImportedName $2 }+    | 'module' beginImpDir Id { ImportedModule $3 }++ImportName :: { ImportedName }+ImportName : Id          { ImportedName $1 }+           | 'module' Id { ImportedModule $2 }++-- Actually semi-colon separated, possibly empty list of ImportName.+CommaImportNames :: { [ImportedName] }+CommaImportNames+    : {- empty -}       { [] }+    | CommaImportNames1 { List1.toList $1 }++CommaImportNames1 :: { List1 ImportedName }+CommaImportNames1+    : ImportName                        { singleton $1 }+    | ImportName ';' CommaImportNames1  { $1 <| $3 }++{--------------------------------------------------------------------------+    Function clauses+ --------------------------------------------------------------------------}++-- A left hand side of a function clause. We parse it as an expression, and+-- then check that it is a valid left hand side.+LHS :: { [RewriteEqn] -> [WithExpr] -> LHS }+LHS : Expr1 {% exprToLHS $1 }++-- Parsing either an expression @e@ or a @(rewrite | with p <-) e1 | ... | en@.+HoleContent :: { HoleContent }+HoleContent+  : Expr                   {  HoleContentExpr    $1 }+  | WHS+    {% fmap HoleContentRewrite $ forM $1 $ \case+         Left r  -> pure r+         Right{} -> parseError "Cannot declare a 'with' abstraction from inside a hole."+      }++-- Where clauses are optional.+WhereClause :: { WhereClause }+WhereClause+    : {- empty -} { NoWhere }+    |                                'where' Declarations0+        { AnyWhere  (getRange $1) $2 }+    | 'module' Attributes Id         'where' Declarations0+         {% onlyErased $2 >>= \erased ->+            return $ SomeWhere (getRange ($1,$4)) erased+                       $3 PublicAccess $5 }+    | 'module' Attributes Underscore 'where' Declarations0+         {% onlyErased $2 >>= \erased ->+            return $ SomeWhere (getRange ($1,$4)) erased+                       $3 PublicAccess $5 }+  -- Note: The access modifier is a dummy, it is computed in the nicifier.++ExprWhere :: { ExprWhere }+ExprWhere : Expr WhereClause { ExprWhere $1 $2 }++{--------------------------------------------------------------------------+    Different kinds of declarations+ --------------------------------------------------------------------------}++-- Top-level definitions.+Declaration :: { List1 Declaration }+Declaration+    : Fields          { singleton $1 }+    | FunClause       { $1 }            -- includes type signatures+    | Data            { singleton $1 }+    | DataSig         { singleton $1 }  -- lone data type signature in mutual block+    | Record          { singleton $1 }+    | RecordSig       { singleton $1 }  -- lone record signature in mutual block+    | Infix           { singleton $1 }+    | Generalize      { singleton $1 }+    | Mutual          { singleton $1 }+    | Abstract        { singleton $1 }+    | Private         { singleton $1 }+    | Instance        { singleton $1 }+    | Macro           { singleton $1 }+    | Postulate       { singleton $1 }+    | Primitive       { singleton $1 }+    | Open            { $1 }+    | ModuleMacro     { singleton $1 }+    | Module          { singleton $1 }+    | Pragma          { singleton $1 }+    | Syntax          { singleton $1 }+    | PatternSyn      { singleton $1 }+    | UnquoteDecl     { singleton $1 }+    | Constructor     { singleton $1 }+    | Opaque          { singleton $1 }+    | Unfolding       { singleton $1 }++{--------------------------------------------------------------------------+    Individual declarations+ --------------------------------------------------------------------------}++-- A variant of TypeSigs where any sub-sequence of names can be marked+-- as hidden or irrelevant using braces and dots:+-- {n1 .n2} n3 .n4 {n5} .{n6 n7} ... : Type.+ArgTypeSigs :: { List1 (Arg Declaration) }+ArgTypeSigs+  : ModalArgIds ':' Expr { let (attrs, xs) = $1 in+                           fmap (fmap (\ x -> typeSig defaultArgInfo (getTacticAttr attrs) x $3)) xs }+  | 'overlap' ModalArgIds ':' Expr {%+      let (attrs, xs) = $2+          setOverlap x =+            case getHiding x of+              Instance _ -> return $ makeInstance' YesOverlap x+              _          -> parseErrorRange $1+                             "The 'overlap' keyword only applies to instance fields (fields marked with {{ }})"+      in T.traverse (setOverlap . fmap (\ x -> typeSig defaultArgInfo (getTacticAttr attrs) x $4)) xs }+  | 'instance' ArgTypeSignatures {+    let+      setInstance (TypeSig info tac x t) = TypeSig (makeInstance info) tac x t+      setInstance _ = __IMPOSSIBLE__ in+    fmap (fmap setInstance) $2 }++-- Function declarations. The left hand side is parsed as an expression to allow+-- declarations like 'x::xs ++ ys = e', when '::' has higher precedence than '++'.+-- FunClause also handle possibly dotted type signatures.+FunClause :: { List1 Declaration }+FunClause+  : {- emptyb -} LHS WHS RHS WhereClause {% funClauseOrTypeSigs [] $1 $2 $3 $4 }+  | Attributes1  LHS WHS RHS WhereClause {% funClauseOrTypeSigs $1 $2 $3 $4 $5 }++-- "With Hand Side", in between the Left & the Right hand ones+WHS :: { [Either RewriteEqn (List1 (Named Name Expr))] }+WHS+  : {- empty -}                           { [] }+  | 'with'    WithExprs        WHS {% fmap (++ $3) (buildWithStmt $2) }+  | 'rewrite' UnnamedWithExprs WHS { Left (Rewrite $ fmap ((),) $2) : $3 }+  | 'using'   UnnamedWithExprs WHS {% do+      eqn <- buildUsingStmt $2+      pure $ Left eqn : $3 }++RHS :: { RHSOrTypeSigs }+RHS+  : {- empty -}    { JustRHS AbsurdRHS }+  | '='       Expr { JustRHS (RHS $2) }+  | ':'       Expr { TypeSigsRHS $2 }++-- Data declaration. Can be local.+Data :: { Declaration }+Data : 'data' Id TypedUntypedBindings ':' Expr 'where'+            Declarations0+       { Data (getRange ($1,$2,$3,$4,$5,$6,$7))+           defaultErased $2 $3 $5 $7 }+     | 'data' Attributes1 Id TypedUntypedBindings ':' Expr 'where'+            Declarations0+       {% onlyErased $2 >>= \e ->+          return $ Data (getRange (($1,$2,$3,$4),($5,$6,$7,$8)))+                     e $3 $4 $6 $8 }++  -- New cases when we already had a DataSig.  Then one can omit the sort.+     | 'data' Id TypedUntypedBindings 'where'+            Declarations0       { DataDef (getRange ($1,$2,$3,$4,$5)) $2 $3 $5 }++-- Data type signature. Found in mutual blocks.+DataSig :: { Declaration }+DataSig+  : 'data' Id TypedUntypedBindings ':' Expr+    { DataSig (getRange ($1,$2,$3,$4,$5)) defaultErased $2 $3 $5 }+  | 'data' Attributes1 Id TypedUntypedBindings ':' Expr+    {% onlyErased $2 >>= \e ->+       return $ DataSig (getRange ($1,$2,$3,$4,$5,$6)) e $3 $4 $6 }++-- Andreas, 2012-03-16:  The Expr3NoCurly instead of Id in everything+-- following 'record' is to remove the (harmless) shift/reduce conflict+-- introduced by record update expressions.++-- Record declarations.+Record :: { Declaration }+Record : 'record' Expr3NoCurly TypedUntypedBindings ':' Expr 'where'+            RecordDeclarations+         {% exprToName $2 >>= \ n -> let (dir, ds) = $7 in+            return $ Record (getRange ($1,$2,$3,$4,$5,$6,$7))+                       defaultErased n dir $3 $5 ds }+       | 'record' Attributes1 Expr3NoCurly TypedUntypedBindings ':' Expr+            'where'+            RecordDeclarations+         {% onlyErased $2 >>= \e ->+            exprToName $3 >>= \n ->+            let (dir, ds) = $8 in+            return $ Record (getRange (($1,$2,$3,$4),($5,$6,$7,$8)))+                       e n dir $4 $6 ds }+       | 'record' Expr3NoCurly TypedUntypedBindings 'where'+            RecordDeclarations+         {% exprToName $2 >>= \ n -> let (dir, ds) = $5 in return $ RecordDef (getRange ($1,$2,$3,$4,$5)) n dir $3 ds }++-- Record type signature. In mutual blocks.+RecordSig :: { Declaration }+RecordSig+  : 'record' Expr3NoCurly TypedUntypedBindings ':' Expr+    {% exprToName $2 >>= \n ->+       return $ RecordSig (getRange ($1,$2,$3,$4,$5))+                  defaultErased n $3 $5 }+  | 'record' Attributes1 Expr3NoCurly TypedUntypedBindings ':' Expr+    {% onlyErased $2 >>= \e ->+       exprToName $3 >>= \n ->+       return $ RecordSig (getRange ($1,$2,$3,$4,$5,$6)) e n $4 $6 }++Constructor :: { Declaration }+Constructor : 'data' '_' 'where' Declarations0+  { LoneConstructor (kwRange ($1,$2,$3)) $4 }++-- Declaration of record constructor name.+RecordConstructorName :: { (Name, IsInstance) }+RecordConstructorName :                  'constructor' Id       { ($2, NotInstanceDef) }+                      | 'instance' vopen 'constructor' Id close { ($4, InstanceDef (kwRange $1)) }+++-- Fixity declarations.+Infix :: { Declaration }+Infix : 'infix'  Float SpaceBIds  { Infix (Fixity (getRange ($1,$2,$3)) (Related $ rangedThing $2) NonAssoc)   $3 }+      | 'infixl' Float SpaceBIds  { Infix (Fixity (getRange ($1,$2,$3)) (Related $ rangedThing $2) LeftAssoc)  $3 }+      | 'infixr' Float SpaceBIds  { Infix (Fixity (getRange ($1,$2,$3)) (Related $ rangedThing $2) RightAssoc) $3 }++-- Field declarations.+Fields :: { Declaration }+Fields : 'field' ArgTypeSignaturesOrEmpty+            { let+                inst i = case getHiding i of+                           Instance _ -> InstanceDef empty  -- no @instance@ keyword here+                           _          -> NotInstanceDef+                toField (Arg info (TypeSig info' tac x t)) = FieldSig (inst info') tac x (Arg info t)+              in Field (kwRange $1) $ map toField $2 }++-- Variable declarations for automatic generalization+Generalize :: { Declaration }+Generalize : 'variable' ArgTypeSignaturesOrEmpty+            { let+                toGeneralize (Arg info (TypeSig _ tac x t)) = TypeSig info tac x t+              in Generalize (kwRange $1) (map toGeneralize $2) }++-- Mutually recursive declarations.+Mutual :: { Declaration }+Mutual : 'mutual' Declarations0  { Mutual (kwRange $1) $2 }+       | 'interleaved' 'mutual' Declarations0 { InterleavedMutual (kwRange ($1,$2)) $3 }++-- Abstract declarations.+Abstract :: { Declaration }+Abstract : 'abstract' Declarations0  { Abstract (kwRange $1) $2 }+++-- Private can only appear on the top-level (or rather the module level).+Private :: { Declaration }+Private : 'private' Declarations0        { Private (kwRange $1) UserWritten $2 }+++-- Instance declarations.+Instance :: { Declaration }+Instance : 'instance' Declarations0  { InstanceB (kwRange $1) $2 }+++-- Macro declarations.+Macro :: { Declaration }+Macro : 'macro' Declarations0 { Macro (kwRange $1) $2 }+++-- Postulates.+Postulate :: { Declaration }+Postulate : 'postulate' Declarations0 { Postulate (kwRange $1) $2 }++-- Primitives. Can only contain type signatures.+Primitive :: { Declaration }+Primitive : 'primitive' ArgTypeSignaturesOrEmpty  {+  let { setArg (Arg info (TypeSig _ tac x t)) = TypeSig info tac x t+      ; setArg _ = __IMPOSSIBLE__ } in+  Primitive (kwRange $1) (map setArg $2) }++-- Unquoting declarations.+UnquoteDecl :: { Declaration }+UnquoteDecl+  : 'unquoteDecl' '=' Expr { UnquoteDecl (fuseRange $1 $3) [] $3 }+  | 'unquoteDecl' 'data' Id '=' Expr { UnquoteData (getRange($1, $2, $5)) $3 [] $5 }+  | 'unquoteDecl' 'data' Id 'constructor' SpaceIds '=' Expr { UnquoteData (getRange($1, $2, $4, $7)) $3 (List1.toList $5) $7 }+  | 'unquoteDecl' SpaceIds '=' Expr { UnquoteDecl (fuseRange $1 $4) (List1.toList $2) $4 }+  | 'unquoteDef'  SpaceIds '=' Expr { UnquoteDef (fuseRange $1 $4) (List1.toList $2) $4 }++-- Syntax declaration (To declare eg. mixfix binders)+Syntax :: { Declaration }+Syntax : 'syntax' Id HoleNames '=' SimpleIds  {%+  case $2 of+    Name _ _ (_ :| []) -> case mkNotation (DL.toList $3) (reverse $5) of+      Left err -> parseError $ "Malformed syntax declaration: " ++ err+      Right n -> return $ Syntax $2 n+    _ -> parseError "Syntax declarations are allowed only for simple names (without holes)"+}++-- Pattern synonyms.+PatternSyn :: { Declaration }+PatternSyn : 'pattern' Id PatternSynArgs '=' Expr {% do+  p <- exprToPattern $5+  return (PatternSyn (getRange ($1,$2,$3,$4,$5)) $2 $3 p)+  }++PatternSynArgs :: { [WithHiding Name] }+PatternSynArgs : DomainFreeBindings    {% patternSynArgs $1 }++-- The list should be reversed.++SimpleIds :: { [RString] }+SimpleIds : SimpleId           { [$1] }+          | SimpleIds SimpleId { $2 : $1 }++-- The list should be reversed.++SimpleIdsOrWildcards :: { List1 RString }+SimpleIdsOrWildcards+  : SimpleIdOrWildcard                      { List1.singleton $1 }+  | SimpleIdsOrWildcards SimpleIdOrWildcard { $2 <| $1 }++HoleNames :: { DList (NamedArg HoleName) }+HoleNames :                    { mempty }+          | HoleNames HoleName { $1 `DL.snoc` $2 }++HoleName :: { NamedArg HoleName }+HoleName+  : SimpleTopHole { defaultNamedArg $1 }+  | '{'  SimpleHole '}'  { hide         $ defaultNamedArg $2 }+  | '{{' SimpleHole '}}' { makeInstance $ defaultNamedArg $2 }+  | '{'  SimpleId '=' SimpleHole '}'  { hide         $ defaultArg $ userNamed $2 $4 }+  | '{{' SimpleId '=' SimpleHole '}}' { makeInstance $ defaultArg $ userNamed $2 $4 }++SimpleTopHole :: { HoleName }+SimpleTopHole+  : SimpleId { ExprHole $1 }+  | '(' '\\' SimpleIdsOrWildcards '->' SimpleId ')'+    { LambdaHole (List1.reverse $3) $5 }++SimpleHole :: { HoleName }+SimpleHole+  : SimpleId { ExprHole $1 }+  | '\\' SimpleIdsOrWildcards '->' SimpleId+    { LambdaHole (List1.reverse $2) $4 }++-- Discard the interval.+SimpleId :: { RString }+SimpleId : id  { Ranged (getRange $ fst $1) (stringToRawName $ snd $1) }++SimpleIdOrWildcard :: { RString }+SimpleIdOrWildcard+  : SimpleId { $1 }+  | '_'      { Ranged (getRange $1) "_" }++MaybeOpen :: { Maybe Range }+MaybeOpen : 'open'      { Just (getRange $1) }+          | {- empty -} { Nothing }++-- Open+Open :: { List1 Declaration }+Open : MaybeOpen 'import' ModuleName OpenArgs ImportDirective {%+    let+    { doOpen = maybe DontOpen (const DoOpen) $1+    ; m   = $3+    ; es  = $4+    ; dir = $5+    ; r   = getRange ($1, $2, m, es, dir)+    ; mr  = getRange m+    ; unique = hashString $ prettyShow $ (Strict.Nothing :: Strict.Maybe ()) <$ r+         -- turn range into unique id, but delete file path+         -- which is absolute and messes up suite of failing tests+         -- (different hashs on different installations)+         -- TODO: Don't use (insecure) hashes in this way.+    ; fresh  = Name mr NotInScope $ singleton $ Id $ stringToRawName $ ".#" ++ prettyShow m ++ "-" ++ show unique+    ; fresh' = Name mr NotInScope $ singleton $ Id $ stringToRawName $ ".#" ++ prettyShow m ++ "-" ++ show (unique + 1)+    ; impStm asR = Import (getRange ($2, $3)) m (Just (AsName (Right fresh) asR)) DontOpen defaultImportDir+    ; appStm m' es =+        Private empty Inserted+          [ ModuleMacro r defaultErased m'+             (SectionApp (getRange es) [] (QName fresh) es)+             doOpen dir+          ]+    ; (initArgs, last2Args) = splitAt (length es - 2) es+    ; parseAsClause = case last2Args of+      { [ Ident (QName (Name asR InScope (Id x :| [])))+        , e+          -- Andreas, 2018-11-03, issue #3364, accept anything after 'as'+          -- but require it to be a 'Name' in the scope checker.+        ] | rawNameToString x == "as" -> Just . (asR,) $+          if | Ident (QName m') <- e -> Right m'+             | otherwise             -> Left e+      ; _ -> Nothing+      }+    } in+    case es of+      { [] -> return $ singleton $ Import r m Nothing doOpen dir+      ; _ | Just (asR, m') <- parseAsClause -> return $+              if null initArgs then singleton+                 ( Import (getRange (m, asR, m', dir)) m+                     (Just (AsName m' asR)) doOpen dir+                 )+              else impStm asR :| [ appStm (fromRight (const fresh') m') initArgs ]+          -- Andreas, 2017-05-13, issue #2579+          -- Nisse reports that importing with instantation but without open+          -- could be usefule for bringing instances into scope.+          -- Ulf, 2018-12-6: Not since fixes of #1913 and #2489 which require+          -- instances to be in scope.+          | DontOpen <- doOpen -> parseErrorRange $2 "An import statement with module instantiation is useless without either an `open' keyword or an `as` binding giving a name to the instantiated module."+          | otherwise -> return $+              impStm noRange :|+              appStm (noName $ beginningOf $ getRange m) es :+              []+      }+  }+  |'open' ModuleName OpenArgs ImportDirective {+    let+    { m   = $2+    ; es  = $3+    ; dir = $4+    ; r   = getRange ($1, m, es, dir)+    } in singleton $+      case es of+      { []  -> Open r m dir+      ; _   -> Private empty Inserted+                 [ ModuleMacro r defaultErased+                     (noName $ beginningOf $ getRange m)+                     (SectionApp (getRange (m , es)) [] m es)+                     DoOpen dir+                 ]+      }+  }+  | 'open' ModuleName '{{' '...' DoubleCloseBrace ImportDirective {+    let r = getRange $2 in singleton $+      Private empty Inserted+      [ ModuleMacro r defaultErased (noName $ beginningOf $ getRange $2)+          (RecordModuleInstance r $2) DoOpen $6+      ]+  }++OpenArgs :: { [Expr] }+OpenArgs : {- empty -}    { [] }+         | Expr3 OpenArgs { $1 : $2 }++ModuleApplication :: { Telescope -> Parser ModuleApplication }+ModuleApplication : ModuleName '{{' '...' DoubleCloseBrace { (\ts ->+                    if null ts then return $ RecordModuleInstance (getRange ($1,$2,$3,$4)) $1+                    else parseError "No bindings allowed for record module with non-canonical implicits" )+                    }+                  | ModuleName OpenArgs {+                    (\ts -> return $ SectionApp (getRange ($1, $2)) ts $1 $2) }+++-- Module instantiation+ModuleMacro :: { Declaration }+ModuleMacro+  : 'module' Attributes ModuleName TypedUntypedBindings '='+      ModuleApplication ImportDirective+    {% do { ma     <- $6 (map addType $4)+          ; erased <- onlyErased $2+          ; name   <- ensureUnqual $3+          ; return $ ModuleMacro (getRange ($1, $2, $3, ma, $7))+                       erased name ma DontOpen $7+          }+    }+  | 'open' 'module' Attributes Id TypedUntypedBindings '='+      ModuleApplication ImportDirective+    {% do { ma     <- $7 (map addType $5)+          ; erased <- onlyErased $3+          ; return $ ModuleMacro (getRange ($1, $2, $3, $4, ma, $8))+                       erased $4 ma DoOpen $8+          } }++-- Module+Module :: { Declaration }+Module+  : 'module' Attributes ModuleName TypedUntypedBindings 'where'+      Declarations0+    {% onlyErased $2 >>= \erased ->+       return $ Module (getRange ($1,$2,$3,$4,$5,$6)) erased+                  $3 (map addType $4) $6 }+  | 'module' Attributes Underscore TypedUntypedBindings 'where'+      Declarations0+    {% onlyErased $2 >>= \erased ->+       return $ Module (getRange ($1,$2,$3,$4,$5,$6)) erased+                  (QName $3) (map addType $4) $6 }++Underscore :: { Name }+Underscore : '_' { noName (getRange $1) }++TopLevel :: { [Declaration] }+TopLevel : TopDeclarations { figureOutTopLevelModule $1 }++Pragma :: { Declaration }+Pragma : DeclarationPragma  { Pragma $1 }++DeclarationPragma :: { Pragma }+DeclarationPragma+  : BuiltinPragma            { $1 }+  | RewritePragma            { $1 }+  | CompilePragma            { $1 }+  | ForeignPragma            { $1 }+  | StaticPragma             { $1 }+  | InjectivePragma          { $1 }+  | InjectiveForInferencePragma { $1 }+  | InlinePragma             { $1 }+  | NoInlinePragma           { $1 }+  | ImpossiblePragma         { $1 }+  | TerminatingPragma        { $1 }+  | NonTerminatingPragma     { $1 }+  | NoTerminationCheckPragma { $1 }+  | NonCoveringPragma        { $1 }+  | NotProjectionLikePragma  { $1 }+  | WarningOnUsagePragma     { $1 }+  | WarningOnImportPragma    { $1 }+  | MeasurePragma            { $1 }+  | CatchallPragma           { $1 }+  | DisplayPragma            { $1 }+  | EtaPragma                { $1 }+  | NoPositivityCheckPragma  { $1 }+  | NoUniverseCheckPragma    { $1 }+  | PolarityPragma           { $1 }+  | OverlapPragma            { $1 }+  | OptionsPragma            { $1 }+    -- Andreas, 2014-03-06+    -- OPTIONS pragma not allowed everywhere, but don't give parse error.+    -- Give better error during type checking instead.++OptionsPragma :: { Pragma }+OptionsPragma :+  '{-#' 'OPTIONS' PragmaStrings '#-}'+  { OptionsPragma (getRange ($1, $2, map fst $3, $4)) (map snd $3) }++BuiltinPragma :: { Pragma }+BuiltinPragma+    : '{-#' 'BUILTIN' string PragmaQName '#-}'+      { BuiltinPragma (getRange ($1,$2,fst $3,$4,$5)) (mkRString $3) $4 }+    -- Extra rule to accept keyword REWRITE also as built-in:+    | '{-#' 'BUILTIN' 'REWRITE' PragmaQName '#-}'+      { BuiltinPragma (getRange ($1,$2,$3,$4,$5)) (Ranged (getRange $3) "REWRITE") $4 }++RewritePragma :: { Pragma }+RewritePragma+    : '{-#' 'REWRITE' PragmaQNames '#-}'+      { RewritePragma (getRange ($1,$2,$3,$4)) (getRange $2) $3 }++ForeignPragma :: { Pragma }+ForeignPragma+  : '{-#' 'FOREIGN' string ForeignCode '#-}'+    { ForeignPragma (getRange ($1, $2, fst $3, $5))+        (mkRText $3) (recoverLayout (DL.toList $4)) }++CompilePragma :: { Pragma }+CompilePragma+  : '{-#' 'COMPILE' string PragmaQName PragmaStrings '#-}'+    { CompilePragma (getRange ($1, $2, fst $3, $4, map fst $5, $6))+        (mkRText $3) $4 (unwords (map snd $5)) }++StaticPragma :: { Pragma }+StaticPragma+  : '{-#' 'STATIC' PragmaQName '#-}'+    { StaticPragma (getRange ($1,$2,$3,$4)) $3 }++InlinePragma :: { Pragma }+InlinePragma+  : '{-#' 'INLINE' PragmaQName '#-}'+    { InlinePragma (getRange ($1,$2,$3,$4)) True $3 }++NoInlinePragma :: { Pragma }+NoInlinePragma+  : '{-#' 'NOINLINE' PragmaQName '#-}'+    { InlinePragma (getRange ($1,$2,$3,$4)) False $3 }++NotProjectionLikePragma :: { Pragma }+NotProjectionLikePragma+  : '{-#' 'NOT_PROJECTION_LIKE' PragmaQName '#-}'+    { NotProjectionLikePragma (getRange ($1,$2,$3,$4)) $3 }++OverlapPragma :: { Pragma }+OverlapPragma+  : '{-#' 'OVERLAPPABLE' PragmaQNames1 '#-}' { OverlapPragma (getRange ($1,$2,$3,$4)) $3 Overlappable }+  | '{-#' 'OVERLAPPING'  PragmaQNames1 '#-}' { OverlapPragma (getRange ($1,$2,$3,$4)) $3 Overlapping }+  | '{-#' 'OVERLAPS'     PragmaQNames1 '#-}' { OverlapPragma (getRange ($1,$2,$3,$4)) $3 Overlaps }+  | '{-#' 'INCOHERENT'   PragmaQNames1 '#-}' { OverlapPragma (getRange ($1,$2,$3,$4)) $3 Incoherent }++InjectivePragma :: { Pragma }+InjectivePragma+  : '{-#' 'INJECTIVE' PragmaQName '#-}'+    { InjectivePragma (getRange ($1,$2,$3,$4)) $3 }++InjectiveForInferencePragma :: { Pragma }+InjectiveForInferencePragma+  : '{-#' 'INJECTIVE_FOR_INFERENCE' PragmaQName '#-}'+    { InjectiveForInferencePragma (getRange ($1,$2,$3,$4)) $3 }++DisplayPragma :: { Pragma }+DisplayPragma+  : '{-#' 'DISPLAY' string PragmaStrings '#-}'+    {% let (r, s) = $3 in+       parseDisplayPragma (getRange ($1, $2, r, map fst $4, $5))+         (iStart r) (unwords (s : map snd $4)) }++EtaPragma :: { Pragma }+EtaPragma+  : '{-#' 'ETA' PragmaQName '#-}'+    { EtaPragma (getRange ($1,$2,$3,$4)) $3 }++NoTerminationCheckPragma :: { Pragma }+NoTerminationCheckPragma+  : '{-#' 'NO_TERMINATION_CHECK' '#-}'+    { TerminationCheckPragma (getRange ($1,$2,$3)) NoTerminationCheck }++NonTerminatingPragma :: { Pragma }+NonTerminatingPragma+  : '{-#' 'NON_TERMINATING' '#-}'+    { TerminationCheckPragma (getRange ($1,$2,$3)) NonTerminating }++TerminatingPragma :: { Pragma }+TerminatingPragma+  : '{-#' 'TERMINATING' '#-}'+    { TerminationCheckPragma (getRange ($1,$2,$3)) Terminating }++NonCoveringPragma :: { Pragma }+NonCoveringPragma+  : '{-#' 'NON_COVERING' '#-}'+    { NoCoverageCheckPragma (getRange ($1,$2,$3)) }++MeasurePragma :: { Pragma }+MeasurePragma+  : '{-#' 'MEASURE' PragmaName '#-}'+    { let r = getRange ($1, $2, $3, $4) in+      TerminationCheckPragma r (TerminationMeasure r $3) }++CatchallPragma :: { Pragma }+CatchallPragma+  : '{-#' 'CATCHALL' '#-}'+    { CatchallPragma (getRange ($1,$2,$3)) }++ImpossiblePragma :: { Pragma }+ImpossiblePragma+  : '{-#' 'IMPOSSIBLE' PragmaStrings '#-}'+    { ImpossiblePragma (getRange ($1, $2, map fst $3, $4))+        (map snd $3) }++NoPositivityCheckPragma :: { Pragma }+NoPositivityCheckPragma+  : '{-#' 'NO_POSITIVITY_CHECK' '#-}'+    { NoPositivityCheckPragma (getRange ($1,$2,$3)) }++NoUniverseCheckPragma :: { Pragma }+NoUniverseCheckPragma+  : '{-#' 'NO_UNIVERSE_CHECK' '#-}'+    { NoUniverseCheckPragma (getRange ($1,$2,$3)) }++PolarityPragma :: { Pragma }+PolarityPragma+  : '{-#' 'POLARITY' PragmaName Polarities '#-}'+    { let occs = reverse $4 in+      PolarityPragma (getRange ($1,$2,$3,occs,$5)) $3 occs }++WarningOnUsagePragma :: { Pragma }+WarningOnUsagePragma+  : '{-#' 'WARNING_ON_USAGE' PragmaQName literal '#-}'+  {%  case $4 of+        { Ranged r (LitString str) -> return $ WarningOnUsage (getRange ($1,$2,$3,r,$5)) $3 str+        ; _ -> parseError "Expected string literal"+        }+  }++WarningOnImportPragma :: { Pragma }+WarningOnImportPragma+  : '{-#' 'WARNING_ON_IMPORT' literal '#-}'+  {%  case $3 of+        { Ranged r (LitString str) -> return $ WarningOnImport (getRange ($1,$2,r,$4)) str+        ; _ -> parseError "Expected string literal"+        }+  }++-- Possibly empty list of polarities. Reversed.+Polarities :: { [Ranged Occurrence] }+Polarities : {- empty -}          { [] }+           | Polarities Polarity  { $2 : $1 }++Polarity :: { Ranged Occurrence }+Polarity : string {% parsePolarity $1 }++{--------------------------------------------------------------------------+    Sequences of declarations+ --------------------------------------------------------------------------}++-- A variant of TypeSignatures which uses ArgTypeSigs instead of+-- TypeSigs.+ArgTypeSignatures :: { List1 (Arg TypeSignature) }+ArgTypeSignatures+    : vopen ArgTypeSignatures1 close   { List1.reverse $2 }++-- Inside the layout block.+ArgTypeSignatures1 :: { List1 (Arg TypeSignature) }+ArgTypeSignatures1+    : ArgTypeSignatures1 semi ArgTypeSigs { List1.reverse $3 <> $1 }+    | ArgTypeSigs                         { List1.reverse $1 }++-- A variant of TypeSignatures which uses ArgTypeSigs instead of+-- TypeSigs.+ArgTypeSignaturesOrEmpty :: { [Arg TypeSignature] }+ArgTypeSignaturesOrEmpty+    : vopen ArgTypeSignatures0 close   { reverse $2 }++-- Inside the layout block.+ArgTypeSignatures0 :: { [Arg TypeSignature] }+ArgTypeSignatures0+    : ArgTypeSignatures0 semi ArgTypeSigs { reverse (List1.toList $3) ++ $1 }+    | ArgTypeSigs                         { reverse (List1.toList $1) }+    | {- empty -}                         { [] }++-- Record declarations, including an optional record constructor name.+RecordDeclarations :: { ([RecordDirective], [Declaration]) }+RecordDeclarations+    : vopen RecordDirectives close                    { (reverse $2, []) }+    | vopen RecordDirectives semi Declarations1 close { (reverse $2, List1.toList $4) }+    | vopen Declarations1 close                       { ([], List1.toList $2) }++RecordDirectives :: { [RecordDirective] }+RecordDirectives+    : {- empty -}                           { [] }+    | RecordDirectives semi RecordDirective { $3 : $1 }+    | RecordDirective                       { [$1] }++RecordDirective :: { RecordDirective }+RecordDirective+    : RecordConstructorName { uncurry Constructor $1 }+    | RecordInduction       { Induction $1 }+    | RecordEta             { Eta $1 }+    | RecordPatternMatching { PatternOrCopattern $1 }++RecordEta :: { Ranged HasEta0 }+RecordEta+    : 'eta-equality'    { Ranged (getRange $1) YesEta }+    | 'no-eta-equality' { Ranged (getRange $1) (NoEta ()) }++-- Directive 'pattern' if a decision between matching on constructor/record pattern+-- or copattern matching is needed.+-- Such decision is only needed for 'no-eta-equality' records.+-- But eta could be turned off automatically, thus, we do not bundle this+-- with the 'no-eta-equality' declaration.+-- Nor with the 'constructor' declaration, since it applies also to+-- the record pattern.+RecordPatternMatching :: { Range }+RecordPatternMatching+    : 'pattern'     { getRange $1 }++-- Declaration of record as 'inductive' or 'coinductive'.+RecordInduction :: { Ranged Induction }+RecordInduction+    : 'inductive'   { Ranged (getRange $1) Inductive   }+    | 'coinductive' { Ranged (getRange $1) CoInductive }++Opaque :: { Declaration }+  : 'opaque' Declarations0     { Opaque (kwRange $1) $2 }++Unfolding :: { Declaration }+  : 'unfolding' UnfoldingNames { Unfolding (kwRange $1) $2 }++UnfoldingNames :: { [QName] }+UnfoldingNames+    : QId UnfoldingNames { $1:$2 }+    | {- empty -}        { [] }++-- Arbitrary declarations+Declarations :: { List1 Declaration }+Declarations+    : vopen Declarations1 close { $2 }++-- Arbitrary declarations (possibly empty)+Declarations0 :: { [Declaration] }+Declarations0+    : vopen close  { [] }+    | Declarations { List1.toList $1 }++Declarations1 :: { List1 Declaration }+Declarations1+    : Declaration semi Declarations1 { $1 <> $3 }+    | Declaration vsemi              { $1 } -- #3046+    | Declaration                    { $1 }++TopDeclarations :: { [Declaration] }+TopDeclarations+  : {- empty -}   { [] }+  | Declarations1 { List1.toList $1 }++{++{--------------------------------------------------------------------------+    Parsers+ --------------------------------------------------------------------------}++-- | Parse the token stream. Used by the TeX compiler.+tokensParser :: Parser [Token]++-- | Parse an expression. Could be used in interactions.+exprParser :: Parser Expr++-- | Parse an expression followed by a where clause. Could be used in interactions.+exprWhereParser :: Parser ExprWhere++-- | Parse a module.+moduleParser :: Parser Module++-- | Parse a display pragma.+parseDisplayPragma ::+      Range     -- ^ Range of the whole DISPLAY pragma.+   -> Position  -- ^ Start of the name the thing we want to display.+   -> String    -- ^ The DISPLAY pragma content.+   -> Parser Pragma+parseDisplayPragma r pos s =+  case parsePosString pos defaultParseFlags [normal] funclauseParser s of+    ParseOk s (FunClause (LHS lhs [] []) (RHS rhs) NoWhere ca :| []) | null (parseInp s) ->+      return $ DisplayPragma r lhs rhs+    _ -> parseError "Invalid DISPLAY pragma. Should have form {-# DISPLAY LHS = RHS #-}."++{--------------------------------------------------------------------------+    Happy stuff+ --------------------------------------------------------------------------}++-- | Required by Happy.+happyError :: Parser a+happyError = parseError ""+++{--------------------------------------------------------------------------+    Utility functions+ --------------------------------------------------------------------------}++-- Utilites have been moved to Agda.Syntax.Parser.Helpers.+--+-- Add Haskell functions used in the parser there, not here.+ }
src/full/Agda/Syntax/Parser/StringLiterals.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-| The code to lex string and character literals. Basically the same code     as in GHC. -}
src/full/Agda/Syntax/Parser/Tokens.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.Syntax.Parser.Tokens     ( Token(..)     , Keyword(..)@@ -5,6 +7,8 @@     , Symbol(..)     ) where +import Data.Functor (void)+ import Agda.Syntax.Literal (RLiteral) import Agda.Syntax.Position @@ -19,15 +23,18 @@         | KwInductive | KwCoInductive         | KwEta | KwNoEta         | KwHiding | KwUsing | KwRenaming | KwTo | KwPublic+        | KwOpaque | KwUnfolding         | KwOPTIONS | KwBUILTIN | KwLINE         | KwFOREIGN | KwCOMPILE-        | KwIMPOSSIBLE | KwSTATIC | KwINJECTIVE | KwINLINE | KwNOINLINE+        | KwIMPOSSIBLE | KwSTATIC | KwINJECTIVE | KwINJECTIVE_FOR_INFERENCE | KwINLINE | KwNOINLINE         | KwETA         | KwNO_TERMINATION_CHECK | KwTERMINATING | KwNON_TERMINATING+        | KwNOT_PROJECTION_LIKE         | KwNON_COVERING         | KwWARNING_ON_USAGE | KwWARNING_ON_IMPORT         | KwMEASURE | KwDISPLAY         | KwREWRITE+        | KwOVERLAPPABLE | KwOVERLAPPING | KwOVERLAPS | KwINCOHERENT         | KwQuote | KwQuoteTerm         | KwUnquote | KwUnquoteDecl | KwUnquoteDef         | KwSyntax@@ -56,6 +63,7 @@     , KwPrivate     , KwVariable     , KwWhere+    , KwOpaque     ]  data Symbol@@ -106,3 +114,6 @@   getRange (TokComment (i, _)) = getRange i   getRange TokDummy            = noRange   getRange (TokEOF i)          = getRange i++instance HasRangeWithoutFile Token where+  getRangeWithoutFile = void . getRange
src/full/Agda/Syntax/Position.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE UndecidableInstances #-} -- Due to KILLRANGE vararg typeclass+ {-| Position information for syntax. Crucial for giving good error messages. -} @@ -7,33 +10,40 @@   , PositionWithoutFile   , Position'(..)   , SrcFile+  , RangeFile(..)+  , mkRangeFile   , positionInvariant   , startPos+  , startPos'   , movePos   , movePosByString   , backupPos-  , startPos'      -- * Intervals   , Interval   , IntervalWithoutFile-  , Interval'(..)+  , Interval'(Interval, iStart', iEnd')   , intervalInvariant+  , iStart+  , iEnd   , posToInterval   , getIntervalFile   , iLength   , fuseIntervals-  , setIntervalFile      -- * Ranges   , Range+  , RangeWithoutFile   , Range'(..)   , rangeInvariant   , consecutiveAndSeparated   , intervalsToRange   , intervalToRange+  , rangeFromAbsolutePath   , rangeIntervals   , rangeFile+  , rangeModule'+  , rangeModule   , rightMargin   , noRange   , posToRange, posToRange'@@ -45,13 +55,12 @@   , continuousPerLine   , PrintRange(..)   , HasRange(..)+  , HasRangeWithoutFile(..)   , SetRange(..)   , KillRange(..)   , KillRangeT   , killRangeMap-  , killRange1, killRange2, killRange3, killRange4, killRange5, killRange6, killRange7-  , killRange8, killRange9, killRange10, killRange11, killRange12, killRange13, killRange14-  , killRange15, killRange16, killRange17, killRange18, killRange19+  , KILLRANGE(..)   , withRangeOf   , fuseRange   , fuseRanges@@ -63,24 +72,26 @@ import Prelude hiding ( null )  import Control.DeepSeq+import Control.Monad import Control.Monad.Writer (runWriter, tell)  import qualified Data.Foldable as Fold-import Data.Function-import Data.Int-import Data.List hiding (null)+import Data.Function (on)+import Data.List (sort) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set-import Data.Data (Data) import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Semigroup (Semigroup(..)) import Data.Void+import Data.Word (Word32)  import GHC.Generics (Generic) +import Agda.Syntax.TopLevelModuleName.Boot (TopLevelModuleName'(..))+ import Agda.Utils.FileName import Agda.Utils.List import Agda.Utils.List1 (List1)@@ -88,7 +99,10 @@ import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Null import Agda.Utils.Permutation-import Agda.Utils.Pretty+import Agda.Utils.Set1 (Set1)+import qualified Agda.Utils.Set1 as Set1+import Agda.Utils.TypeLevel (IsBase, All, Domains)+import Agda.Utils.Tuple (sortPair)  import Agda.Utils.Impossible @@ -108,20 +122,20 @@ data Position' a = Pn   { srcFile :: !a     -- ^ File.-  , posPos  :: !Int32+  , posPos  :: !Word32     -- ^ Position, counting from 1.-  , posLine :: !Int32+  , posLine :: !Word32     -- ^ Line number, counting from 1.-  , posCol  :: !Int32+  , posCol  :: !Word32     -- ^ Column number, counting from 1.   }-  deriving (Show, Data, Functor, Foldable, Traversable, Generic)+  deriving (Show, Functor, Foldable, Traversable, Generic)  positionInvariant :: Position' a -> Bool positionInvariant p =   posPos p > 0 && posLine p > 0 && posCol p > 0 -importantPart :: Position' a -> (a, Int32)+importantPart :: Position' a -> (a, Word32) importantPart p = (srcFile p, posPos p)  instance Eq a => Eq (Position' a) where@@ -130,8 +144,50 @@ instance Ord a => Ord (Position' a) where   compare = compare `on` importantPart -type SrcFile = Strict.Maybe AbsolutePath+type SrcFile = Strict.Maybe RangeFile +-- | File information used in the 'Position', 'Interval' and 'Range'+-- types.+data RangeFile = RangeFile+  { rangeFilePath :: !AbsolutePath+    -- ^ The file's path.+  , rangeFileName :: !(Maybe (TopLevelModuleName' Range))+    -- ^ The file's top-level module name (if applicable).+    --+    -- This field is optional, but some things may break if the field+    -- is not instantiated with an actual top-level module name. For+    -- instance, the 'Eq' and 'Ord' instances only make use of this+    -- field.+    --+    -- The field uses 'Maybe' rather than 'Strict.Maybe' because it+    -- should be possible to instantiate it with something that is not+    -- yet defined (see 'Agda.Interaction.Imports.parseSource').+    --+    -- This '(TopLevelModuleName' Range)' should not contain a range.+  }+  deriving (Show, Generic)++-- | A smart constructor for 'RangeFile'.++mkRangeFile :: AbsolutePath -> Maybe (TopLevelModuleName' Range) -> RangeFile+mkRangeFile f top = RangeFile+  { rangeFilePath = f+  , rangeFileName = killRange top+  }++-- | Only the 'rangeFileName' component is compared.++instance Eq RangeFile where+  (==) = (==) `on` rangeFileName++-- | Only the 'rangeFileName' component is compared.++instance Ord RangeFile where+  compare = compare `on` rangeFileName++instance NFData RangeFile where+  rnf (RangeFile _ n) = rnf n+ type Position            = Position' SrcFile type PositionWithoutFile = Position' () @@ -144,8 +200,12 @@ -- | An interval. The @iEnd@ position is not included in the interval. -- -- Note the invariant which intervals have to satisfy: 'intervalInvariant'.-data Interval' a = Interval { iStart, iEnd :: !(Position' a) }-  deriving (Show, Data, Eq, Ord, Functor, Foldable, Traversable, Generic)+data Interval' a = Interval+  { getIntervalFile :: a+  , iStart' :: !PositionWithoutFile+  , iEnd'   :: !PositionWithoutFile+  }+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)  type Interval            = Interval' SrcFile type IntervalWithoutFile = Interval' ()@@ -157,34 +217,26 @@   rnf = (`seq` ())  intervalInvariant :: Ord a => Interval' a -> Bool-intervalInvariant i =-  all positionInvariant [iStart i, iEnd i]-    &&-  iStart i <= iEnd i-    &&-  srcFile (iStart i) == srcFile (iEnd i)---- | Sets the 'srcFile' components of the interval.+intervalInvariant i = and+  [ positionInvariant $ iStart i+  , positionInvariant $ iEnd i+  , iStart i <= iEnd i+  ] -setIntervalFile :: a -> Interval' b -> Interval' a-setIntervalFile f (Interval p1 p2) =-  Interval (p1 { srcFile = f }) (p2 { srcFile = f })+iStart :: Interval' a -> Position' a+iStart (Interval f s _) = f <$ s --- | Gets the 'srcFile' component of the interval. Because of the invariant,---   they are both the same.-getIntervalFile :: Interval' a -> a-getIntervalFile = srcFile . iStart+iEnd   :: Interval' a -> Position' a+iEnd   (Interval f _ e) = f <$ e  -- | Converts a file name and two positions to an interval.+--   Sort the positions ascendingly. posToInterval ::   a -> PositionWithoutFile -> PositionWithoutFile -> Interval' a-posToInterval f p1 p2 = setIntervalFile f $-  if p1 < p2-  then Interval p1 p2-  else Interval p2 p1+posToInterval f p1 p2 = uncurry (Interval f) $ sortPair (p1, p2)  -- | The length of an interval.-iLength :: Interval' a -> Int32+iLength :: Interval' a -> Word32 iLength i = posPos (iEnd i) - posPos (iStart i)  -- | A range is a file name, plus a sequence of intervals, assumed to@@ -196,9 +248,10 @@   = NoRange   | Range !a (Seq IntervalWithoutFile)   deriving-    (Show, Data, Eq, Ord, Functor, Foldable, Traversable, Generic)+    (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)  type Range = Range' SrcFile+type RangeWithoutFile = Range' ()  instance NFData a => NFData (Range' a) @@ -208,19 +261,17 @@    empty = NoRange -instance Semigroup a => Semigroup (Range' a) where+instance Eq a => Semigroup (Range' a) where   NoRange <> r = r   r <> NoRange = r-  Range f is <> Range f' is' = Range (f <> f') (is <> is')+  Range f is <> Range f' is'+    | f /= f'   = __IMPOSSIBLE__+    | otherwise = Range f (is <> is') -instance Semigroup a => Monoid (Range' a) where+instance Eq a => Monoid (Range' a) where   mempty  = empty   mappend = (<>) --- | To get @'Semigroup' 'Range'@, we need a semigroup instance for 'AbsolutePath'.-instance Semigroup AbsolutePath where-  f <> f' = if f == f' then f else __IMPOSSIBLE__- -- | The intervals that make up the range. The intervals are -- consecutive and separated ('consecutiveAndSeparated'). rangeIntervals :: Range' a -> [IntervalWithoutFile]@@ -242,10 +293,7 @@     &&   allEqual (map (srcFile . iStart) is)     &&-  (null is-     ||-   and (zipWith (<) (map iEnd   (init is))-                    (map iStart (tail is))))+  allConsecutive (\ i j -> iEnd i < iStart j) is  -- | Range invariant. rangeInvariant :: Ord a => Range' a -> Bool@@ -261,12 +309,26 @@ rangeFile NoRange     = Strict.Nothing rangeFile (Range f _) = f +-- | The range's top-level module name, if any.+--+-- If there is no range, then 'Nothing' is returned. If there is a+-- range without a module name, then @'Just' 'Nothing'@ is returned.+rangeModule' :: Range -> Maybe (Maybe (TopLevelModuleName' Range))+rangeModule' NoRange     = Nothing+rangeModule' (Range f _) = Just $ case f of+  Strict.Nothing -> Nothing+  Strict.Just f  -> rangeFileName f++-- | The range's top-level module name, if any.+rangeModule :: Range -> Maybe (TopLevelModuleName' Range)+rangeModule = join . rangeModule'+ -- | Conflate a range to its right margin. rightMargin :: Range -> Range rightMargin r@NoRange      = r rightMargin r@(Range f is) = case Seq.viewr is of   Seq.EmptyR -> __IMPOSSIBLE__-  _ Seq.:> i -> intervalToRange f (i { iStart = iEnd i })+  _ Seq.:> Interval () s e -> intervalToRange f (Interval () e e)  -- | Wrapper to indicate that range should be printed. newtype PrintRange a = PrintRange a@@ -278,11 +340,10 @@    default getRange :: (Foldable t, HasRange b, t b ~ a) => a -> Range   getRange = Fold.foldr fuseRange noRange+  {-# INLINABLE getRange #-}  instance HasRange Interval where-    getRange i =-      intervalToRange (srcFile (iStart i))-                      (setIntervalFile () i)+  getRange (Interval f p1 p2) = intervalToRange f (Interval () p1 p2)  instance HasRange Range where     getRange = id@@ -293,6 +354,15 @@ instance HasRange Bool where     getRange _ = noRange +instance HasRange (TopLevelModuleName' Range) where+  getRange = moduleNameRange++instance SetRange (TopLevelModuleName' Range) where+  setRange r (TopLevelModuleName _ h x z) = TopLevelModuleName r h x z++instance KillRange (TopLevelModuleName' Range) where+  killRange (TopLevelModuleName _ h x z) = TopLevelModuleName noRange h x z+ -- | Precondition: The ranges of the list elements must point to the -- same file (or be empty). instance HasRange a => HasRange [a]@@ -302,6 +372,7 @@ instance HasRange a => HasRange (List1 a) instance HasRange a => HasRange (List2 a) instance HasRange a => HasRange (Maybe a)+instance HasRange a => HasRange (Set1 a)  -- | Precondition: The ranges of the tuple elements must point to the -- same file (or be empty).@@ -336,6 +407,58 @@ instance (HasRange a, HasRange b) => HasRange (Either a b) where     getRange = either getRange getRange +-- | Things that have a 'RangeWithoutFile' are instances of this class.++class HasRangeWithoutFile a where+  getRangeWithoutFile :: a -> RangeWithoutFile++  default getRangeWithoutFile :: (Foldable t, HasRangeWithoutFile b, t b ~ a) => a -> RangeWithoutFile+  getRangeWithoutFile = Fold.foldr fuseRangeWithoutFile noRange+  {-# INLINABLE getRangeWithoutFile #-}++instance HasRangeWithoutFile IntervalWithoutFile where+  getRangeWithoutFile = intervalToRange ()++instance HasRangeWithoutFile RangeWithoutFile where+    getRangeWithoutFile = id++instance HasRangeWithoutFile () where+  getRangeWithoutFile _ = noRange++instance HasRangeWithoutFile Bool where+    getRangeWithoutFile _ = noRange++-- UNUSED:+-- instance HasRangeWithoutFile (TopLevelModuleName' RangeWithoutFile) where+--   getRangeWithoutFile = moduleNameRange++instance HasRangeWithoutFile a => HasRangeWithoutFile [a]+instance HasRangeWithoutFile a => HasRangeWithoutFile (List1 a)+instance HasRangeWithoutFile a => HasRangeWithoutFile (List2 a)+instance HasRangeWithoutFile a => HasRangeWithoutFile (Maybe a)+instance HasRangeWithoutFile a => HasRangeWithoutFile (Set1 a)++instance (HasRangeWithoutFile a, HasRangeWithoutFile b) => HasRangeWithoutFile (a,b) where+    getRangeWithoutFile = uncurry fuseRangeWithoutFile++instance (HasRangeWithoutFile a, HasRangeWithoutFile b, HasRangeWithoutFile c) => HasRangeWithoutFile (a,b,c) where+    getRangeWithoutFile (x,y,z) = getRangeWithoutFile (x,(y,z))++instance (HasRangeWithoutFile a, HasRangeWithoutFile b, HasRangeWithoutFile c, HasRangeWithoutFile d) => HasRangeWithoutFile (a,b,c,d) where+    getRangeWithoutFile (x,y,z,w) = getRangeWithoutFile (x,(y,(z,w)))++instance (HasRangeWithoutFile a, HasRangeWithoutFile b, HasRangeWithoutFile c, HasRangeWithoutFile d, HasRangeWithoutFile e) => HasRangeWithoutFile (a,b,c,d,e) where+    getRangeWithoutFile (x,y,z,w,v) = getRangeWithoutFile (x,(y,(z,(w,v))))++instance (HasRangeWithoutFile a, HasRangeWithoutFile b, HasRangeWithoutFile c, HasRangeWithoutFile d, HasRangeWithoutFile e, HasRangeWithoutFile f) => HasRangeWithoutFile (a,b,c,d,e,f) where+    getRangeWithoutFile (x,y,z,w,v,u) = getRangeWithoutFile (x,(y,(z,(w,(v,u)))))++instance (HasRangeWithoutFile a, HasRangeWithoutFile b, HasRangeWithoutFile c, HasRangeWithoutFile d, HasRangeWithoutFile e, HasRangeWithoutFile f, HasRangeWithoutFile g) => HasRangeWithoutFile (a,b,c,d,e,f,g) where+    getRangeWithoutFile (x,y,z,w,v,u,t) = getRangeWithoutFile (x,(y,(z,(w,(v,(u,t))))))++instance (HasRangeWithoutFile a, HasRangeWithoutFile b) => HasRangeWithoutFile (Either a b) where+    getRangeWithoutFile = either getRangeWithoutFile getRangeWithoutFile+ -- | If it is also possible to set the range, this is the class. -- --   Instances should satisfy @'getRange' ('setRange' r x) == r@.@@ -360,132 +483,21 @@  type KillRangeT a = a -> a --- | Remove ranges in keys and values of a map.-killRangeMap :: (KillRange k, KillRange v) => KillRangeT (Map k v)-killRangeMap = Map.mapKeysMonotonic killRange . Map.map killRange--killRange1 :: KillRange a => (a -> b) -> a -> b--killRange2 :: (KillRange a, KillRange b) => (a -> b -> c) -> a -> b -> c--killRange3 :: (KillRange a, KillRange b, KillRange c) =>-              (a -> b -> c -> d) -> a -> b -> c -> d--killRange4 :: (KillRange a, KillRange b, KillRange c, KillRange d) =>-              (a -> b -> c -> d -> e) -> a -> b -> c -> d -> e--killRange5 :: ( KillRange a, KillRange b, KillRange c, KillRange d-              , KillRange e ) =>-              (a -> b -> c -> d -> e -> f) -> a -> b -> c -> d -> e -> f--killRange6 :: ( KillRange a, KillRange b, KillRange c, KillRange d-              , KillRange e, KillRange f ) =>-              (a -> b -> c -> d -> e -> f -> g) -> a -> b -> c -> d -> e -> f -> g--killRange7 :: ( KillRange a, KillRange b, KillRange c, KillRange d-              , KillRange e, KillRange f, KillRange g ) =>-              (a -> b -> c -> d -> e -> f -> g -> h) -> a -> b -> c -> d -> e -> f -> g -> h--killRange8 :: ( KillRange a, KillRange b, KillRange c, KillRange d-              , KillRange e, KillRange f, KillRange g, KillRange h ) =>-              (a -> b -> c -> d -> e -> f -> g -> h -> i) ->-              a -> b -> c -> d -> e -> f -> g -> h -> i--killRange9 :: ( KillRange a, KillRange b, KillRange c, KillRange d-              , KillRange e, KillRange f, KillRange g, KillRange h-              , KillRange i ) =>-              (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) ->-              a -> b -> c -> d -> e -> f -> g -> h -> i -> j--killRange10 :: ( KillRange a, KillRange b, KillRange c, KillRange d-               , KillRange e, KillRange f, KillRange g, KillRange h-               , KillRange i, KillRange j ) =>-               (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) ->-               a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k--killRange11 :: ( KillRange a, KillRange b, KillRange c, KillRange d-               , KillRange e, KillRange f, KillRange g, KillRange h-               , KillRange i, KillRange j, KillRange k ) =>-               (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l) ->-               a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l--killRange12 :: ( KillRange a, KillRange b, KillRange c, KillRange d-               , KillRange e, KillRange f, KillRange g, KillRange h-               , KillRange i, KillRange j, KillRange k, KillRange l ) =>-               (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m) ->-               a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m--killRange13 :: ( KillRange a, KillRange b, KillRange c, KillRange d-               , KillRange e, KillRange f, KillRange g, KillRange h-               , KillRange i, KillRange j, KillRange k, KillRange l-               , KillRange m ) =>-               (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n) ->-               a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n--killRange14 :: ( KillRange a, KillRange b, KillRange c, KillRange d-               , KillRange e, KillRange f, KillRange g, KillRange h-               , KillRange i, KillRange j, KillRange k, KillRange l-               , KillRange m, KillRange n ) =>-               (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o) ->-               a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o--killRange15 :: ( KillRange a, KillRange b, KillRange c, KillRange d-               , KillRange e, KillRange f, KillRange g, KillRange h-               , KillRange i, KillRange j, KillRange k, KillRange l-               , KillRange m, KillRange n, KillRange o ) =>-               (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p) ->-               a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p--killRange16 :: ( KillRange a, KillRange b, KillRange c, KillRange d-               , KillRange e, KillRange f, KillRange g, KillRange h-               , KillRange i, KillRange j, KillRange k, KillRange l-               , KillRange m, KillRange n, KillRange o, KillRange p ) =>-               (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q) ->-               a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q--killRange17 :: ( KillRange a, KillRange b, KillRange c, KillRange d-               , KillRange e, KillRange f, KillRange g, KillRange h-               , KillRange i, KillRange j, KillRange k, KillRange l-               , KillRange m, KillRange n, KillRange o, KillRange p-               , KillRange q ) =>-               (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r) ->-               a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r+class KILLRANGE t b where+  killRangeN :: IsBase t ~ b => All KillRange (Domains t) =>+                t -> t -killRange18 :: ( KillRange a, KillRange b, KillRange c, KillRange d-               , KillRange e, KillRange f, KillRange g, KillRange h-               , KillRange i, KillRange j, KillRange k, KillRange l-               , KillRange m, KillRange n, KillRange o, KillRange p-               , KillRange q, KillRange r ) =>-               (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r -> s) ->-               a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r -> s+instance IsBase t ~ 'True => KILLRANGE t 'True where+  {-# INLINE killRangeN #-}+  killRangeN v = v -killRange19 :: ( KillRange a, KillRange b, KillRange c, KillRange d-               , KillRange e, KillRange f, KillRange g, KillRange h-               , KillRange i, KillRange j, KillRange k, KillRange l-               , KillRange m, KillRange n, KillRange o, KillRange p-               , KillRange q, KillRange r, KillRange s ) =>-               (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r -> s -> t) ->-               a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r -> s -> t+instance KILLRANGE t (IsBase t) => KILLRANGE (a -> t) 'False where+  {-# INLINE killRangeN #-}+  killRangeN f a = killRangeN (f (killRange a)) -killRange1  f a = f (killRange a)-killRange2  f a = killRange1 (f $ killRange a)-killRange3  f a = killRange2 (f $ killRange a)-killRange4  f a = killRange3 (f $ killRange a)-killRange5  f a = killRange4 (f $ killRange a)-killRange6  f a = killRange5 (f $ killRange a)-killRange7  f a = killRange6 (f $ killRange a)-killRange8  f a = killRange7 (f $ killRange a)-killRange9  f a = killRange8 (f $ killRange a)-killRange10 f a = killRange9 (f $ killRange a)-killRange11 f a = killRange10 (f $ killRange a)-killRange12 f a = killRange11 (f $ killRange a)-killRange13 f a = killRange12 (f $ killRange a)-killRange14 f a = killRange13 (f $ killRange a)-killRange15 f a = killRange14 (f $ killRange a)-killRange16 f a = killRange15 (f $ killRange a)-killRange17 f a = killRange16 (f $ killRange a)-killRange18 f a = killRange17 (f $ killRange a)-killRange19 f a = killRange18 (f $ killRange a)+-- | Remove ranges in keys and values of a map.+killRangeMap :: (KillRange k, KillRange v) => KillRangeT (Map k v)+killRangeMap = Map.mapKeysMonotonic killRange . Map.map killRange  instance KillRange Range where   killRange _ = noRange@@ -524,62 +536,24 @@ instance {-# OVERLAPPABLE #-} (Ord a, KillRange a) => KillRange (Set a) where   killRange = Set.map killRange +instance (Ord a, KillRange a) => KillRange (Set1 a) where+  killRange = Set1.map killRange+ instance (KillRange a, KillRange b) => KillRange (a, b) where   killRange (x, y) = (killRange x, killRange y)  instance (KillRange a, KillRange b, KillRange c) =>          KillRange (a, b, c) where-  killRange (x, y, z) = killRange3 (,,) x y z+  killRange (x, y, z) = killRangeN (,,) x y z  instance (KillRange a, KillRange b, KillRange c, KillRange d) =>          KillRange (a, b, c, d) where-  killRange (x, y, z, u) = killRange4 (,,,) x y z u+  killRange (x, y, z, u) = killRangeN (,,,) x y z u  instance (KillRange a, KillRange b) => KillRange (Either a b) where   killRange (Left  x) = Left  $ killRange x   killRange (Right x) = Right $ killRange x ---------------------------------------------------------------------------- Printing---------------------------------------------------------------------------instance Pretty a => Pretty (Position' (Strict.Maybe a)) where-  pretty (Pn Strict.Nothing  _ l c) = pretty l <> "," <> pretty c-  pretty (Pn (Strict.Just f) _ l c) =-    pretty f <> ":" <> pretty l <> "," <> pretty c--instance Pretty PositionWithoutFile where-  pretty p = pretty (p { srcFile = Strict.Nothing } :: Position)--instance Pretty IntervalWithoutFile where-  pretty (Interval s e) = start <> "-" <> end-    where-      sl = posLine s-      el = posLine e-      sc = posCol s-      ec = posCol e--      start :: Doc-      start = pretty sl <> comma <> pretty sc--      end :: Doc-        | sl == el  = pretty ec-        | otherwise = pretty el <> comma <> pretty ec--instance Pretty a => Pretty (Interval' (Strict.Maybe a)) where-  pretty i@(Interval s _) = file <> pretty (setIntervalFile () i)-    where-      file :: Doc-      file = case srcFile s of-               Strict.Nothing -> empty-               Strict.Just f  -> pretty f <> colon--instance Pretty a => Pretty (Range' (Strict.Maybe a)) where-  pretty r = maybe empty pretty (rangeToIntervalWithFile r)--instance (Pretty a, HasRange a) => Pretty (PrintRange a) where-  pretty (PrintRange a) = pretty a <+> parens ("at" <+> pretty (getRange a))- {--------------------------------------------------------------------------     Functions on positions and ranges  --------------------------------------------------------------------------}@@ -594,9 +568,16 @@   }  -- | The first position in a file: position 1, line 1, column 1.-startPos :: Maybe AbsolutePath -> Position+startPos :: Maybe RangeFile -> Position startPos = startPos' . Strict.toStrict +-- | Range pointing to the first position in the given file.+rangeFromAbsolutePath :: AbsolutePath -> Range+rangeFromAbsolutePath f = posToRange' src p0 p0+  where+    src = Strict.Just $ mkRangeFile f Nothing+    p0  = startPos' ()+ -- | Ranges between two unknown positions noRange :: Range' a noRange = NoRange@@ -612,8 +593,8 @@ -- | Advance the position by a string. -- --   > movePosByString = foldl' movePos-movePosByString :: Position' a -> String -> Position' a-movePosByString = foldl' movePos+movePosByString :: Foldable t => Position' a -> t Char -> Position' a+movePosByString = Fold.foldl' movePos  -- | Backup the position by one character. --@@ -640,30 +621,21 @@ -- | Converts a range to an interval, if possible. rangeToIntervalWithFile :: Range' a -> Maybe (Interval' a) rangeToIntervalWithFile NoRange      = Nothing-rangeToIntervalWithFile (Range f is) = case (Seq.viewl is, Seq.viewr is) of-  (head Seq.:< _, _ Seq.:> last) -> Just $ setIntervalFile f $-                                      Interval { iStart = iStart head-                                               , iEnd   = iEnd   last-                                               }-  _                              -> __IMPOSSIBLE__+rangeToIntervalWithFile (Range f is) =+  case (Seq.viewl is, Seq.viewr is) of+    (head Seq.:< _, _ Seq.:> last) -> Just $ Interval f (iStart head) (iEnd last)+    _ -> __IMPOSSIBLE__ --- | Converts a range to an interval, if possible. Note that the--- information about the source file is lost.+-- | Converts a range to an interval, if possible.+-- Note that the information about the source file is lost. rangeToInterval :: Range' a -> Maybe IntervalWithoutFile-rangeToInterval NoRange      = Nothing-rangeToInterval (Range _ is) = case (Seq.viewl is, Seq.viewr is) of-  (head Seq.:< _, _ Seq.:> last) -> Just $-                                      Interval { iStart = iStart head-                                               , iEnd   = iEnd   last-                                               }-  _                              -> __IMPOSSIBLE__+rangeToInterval = rangeToIntervalWithFile . void  -- | Returns the shortest continuous range containing the given one. continuous :: Range' a -> Range' a continuous NoRange = NoRange-continuous r@(Range f _) = case rangeToInterval r of-  Nothing -> __IMPOSSIBLE__-  Just i  -> intervalToRange f i+continuous r@(Range f _) =+  maybe __IMPOSSIBLE__ (intervalToRange f) $ rangeToInterval r  -- | Removes gaps between intervals on the same line. continuousPerLine :: Ord a => Range' a -> Range' a@@ -699,12 +671,8 @@  -- | Finds the least interval which covers the arguments. ----- Precondition: The intervals must point to the same file.-fuseIntervals :: Ord a => Interval' a -> Interval' a -> Interval' a-fuseIntervals x y = Interval { iStart = s, iEnd = e }-    where-    s = headWithDefault __IMPOSSIBLE__ $ sort [iStart x, iStart y]-    e = lastWithDefault __IMPOSSIBLE__ $ sort [iEnd   x, iEnd   y]+fuseIntervals :: IntervalWithoutFile -> IntervalWithoutFile -> IntervalWithoutFile+fuseIntervals (Interval () s1 e1) (Interval () s2 e2) = Interval () (min s1 s2) (max e1 e2)  -- | @fuseRanges r r'@ unions the ranges @r@ and @r'@. --@@ -735,7 +703,7 @@    mergeTouching l e s r = l Seq.>< i Seq.<| r     where-    i = Interval { iStart = iStart e, iEnd = iEnd s }+    i = Interval () (iStart e) (iEnd s)    -- The following two functions could use binary search instead of   -- linear.@@ -748,11 +716,18 @@     where     r1' = Seq.dropWhileL (\s -> iEnd s <= iEnd s2) r1 +{-# INLINE fuseRange #-} -- | Precondition: The ranges must point to the same file (or be -- empty). fuseRange :: (HasRange u, HasRange t) => u -> t -> Range fuseRange x y = fuseRanges (getRange x) (getRange y) +{-# INLINE fuseRangeWithoutFile #-}+-- | Precondition: The ranges must point to the same file (or be+-- empty).+fuseRangeWithoutFile :: (HasRangeWithoutFile u, HasRangeWithoutFile t) => u -> t -> RangeWithoutFile+fuseRangeWithoutFile x y = fuseRanges (getRangeWithoutFile x) (getRangeWithoutFile y)+ -- | @beginningOf r@ is an empty range (a single, empty interval) -- positioned at the beginning of @r@. If @r@ does not have a -- beginning, then 'noRange' is returned.@@ -762,13 +737,28 @@   Nothing  -> __IMPOSSIBLE__   Just pos -> posToRange' f pos pos +class BeginningOfFile a where+  -- | Return an empty range (a single, empty interval) at the beginning of the file.+  beginningOfFile :: a -> Range++instance BeginningOfFile SrcFile where+  beginningOfFile f = posToRange' f p p+    where p = startPos' ()++instance BeginningOfFile RangeFile where+  beginningOfFile = beginningOfFile . Strict.Just++instance BeginningOfFile AbsolutePath where+  beginningOfFile f = beginningOfFile $ mkRangeFile f Nothing+ -- | @beginningOfFile r@ is an empty range (a single, empty interval) -- at the beginning of @r@'s starting position's file. If there is no -- such position, then an empty range is returned.-beginningOfFile :: Range -> Range-beginningOfFile NoRange     = NoRange-beginningOfFile (Range f _) = posToRange' f p p-  where p = startPos' ()+instance BeginningOfFile Range where+  beginningOfFile :: Range -> Range+  beginningOfFile NoRange     = NoRange+  beginningOfFile (Range f _) = posToRange' f p p+    where p = startPos' ()  -- | @x \`withRangeOf\` y@ sets the range of @x@ to the range of @y@. withRangeOf :: (SetRange t, HasRange u) => t -> u -> t@@ -781,14 +771,14 @@ --   is placed first. In case of a tie, the element with the earliest --   ending position is placed first. If both tie, the element from the --   first list is placed first.-interleaveRanges :: (HasRange a) => [a] -> [a] -> ([a], [(a,a)])-interleaveRanges as bs = runWriter$ go as bs+interleaveRanges :: forall a. (HasRangeWithoutFile a) => [a] -> [a] -> ([a], [(a,a)])+interleaveRanges as bs = runWriter $ go as bs   where     go []         as = return as     go as         [] = return as     go as@(a:as') bs@(b:bs') =-      let ra = getRange a-          rb = getRange b+      let ra = getRangeWithoutFile a+          rb = getRangeWithoutFile b            ra0 = rStart ra           rb0 = rStart rb
+ src/full/Agda/Syntax/Position.hs-boot view
@@ -0,0 +1,3 @@+module Agda.Syntax.Position where++class KillRange a
src/full/Agda/Syntax/Scope/Base.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE GADTs              #-}  {-| This module defines the notion of a scope and operations on scopes. -}@@ -12,7 +11,7 @@  import Data.Either (partitionEithers) import Data.Foldable ( length, toList )-import Data.Function+import Data.Function (on) import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map@@ -21,8 +20,6 @@ import Data.Maybe import Data.Semigroup ( Semigroup(..) ) -import Data.Data (Data)- import GHC.Generics (Generic)  import Agda.Benchmarking@@ -41,11 +38,14 @@ import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.List1 ( List1, pattern (:|) )+import Agda.Utils.List2 ( List2 ) import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe (filterMaybe) import Agda.Utils.Null-import Agda.Utils.Pretty hiding ((<>))-import qualified Agda.Utils.Pretty as P+import Agda.Syntax.Common.Pretty hiding ((<>))+import qualified Agda.Syntax.Common.Pretty as P+import Agda.Utils.Set1 ( Set1 ) import Agda.Utils.Singleton import qualified Agda.Utils.Map as Map @@ -62,19 +62,19 @@       , scopeImports        :: Map C.QName A.ModuleName       , scopeDatatypeModule :: Maybe DataOrRecordModule       }-  deriving (Data, Eq, Show, Generic)+  deriving (Eq, Show, Generic)  data DataOrRecordModule   = IsDataModule   | IsRecordModule-  deriving (Data, Show, Eq, Enum, Bounded, Generic)+  deriving (Show, Eq, Enum, Bounded, Generic)  -- | See 'Agda.Syntax.Common.Access'. data NameSpaceId   = PrivateNS        -- ^ Things not exported by this module.   | PublicNS         -- ^ Things defined and exported by this module.   | ImportedNS       -- ^ Things from open public, exported by this module.-  deriving (Data, Eq, Bounded, Enum, Show, Generic)+  deriving (Eq, Bounded, Enum, Show, Generic)  allNameSpaces :: [NameSpaceId] allNameSpaces = [minBound..maxBound]@@ -86,7 +86,7 @@ localNameSpace PrivateAccess{} = PrivateNS  nameSpaceAccess :: NameSpaceId -> Access-nameSpaceAccess PrivateNS = PrivateAccess Inserted+nameSpaceAccess PrivateNS = privateAccessInserted nameSpaceAccess _         = PublicAccess  -- | Get a 'NameSpace' from 'Scope'.@@ -120,8 +120,10 @@       , _scopeInScope       :: InScopeSet       , _scopeFixities      :: C.Fixities    -- ^ Maps concrete names C.Name to fixities       , _scopePolarities    :: C.Polarities  -- ^ Maps concrete names C.Name to polarities+      , _scopeRecords       :: Map A.QName (A.QName, Maybe Induction)+        -- ^ Maps the name of a record to the name of its (co)constructor.       }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  -- | For the sake of highlighting, the '_scopeInverseName' map also stores --   the 'KindOfName' of an @A.QName@.@@ -129,7 +131,7 @@   { qnameKind     :: KindOfName     -- ^ The 'anameKind'.   , qnameConcrete :: List1 C.QName  -- ^ Possible renderings of the abstract name.   }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  -- | Invariant: the 'KindOfName' components should be equal --   whenever we have to concrete renderings of an abstract name.@@ -141,7 +143,7 @@ -- type ModuleMap = Map A.ModuleName (List1 C.QName)  instance Eq ScopeInfo where-  ScopeInfo c1 m1 v1 l1 p1 _ _ _ _ _ == ScopeInfo c2 m2 v2 l2 p2 _ _ _ _ _ =+  ScopeInfo c1 m1 v1 l1 p1 _ _ _ _ _ _ == ScopeInfo c2 m2 v2 l2 p2 _ _ _ _ _ _ =     c1 == c2 && m1 == m2 && v1 == v2 && l1 == l2 && p1 == p2  -- | Local variables.@@ -150,19 +152,28 @@ -- | For each bound variable, we want to know whether it was bound by a --   λ, Π, module telescope, pattern, or @let@. data BindingSource-  = LambdaBound  -- ^ @λ@ (currently also used for @Π@ and module parameters)-  | PatternBound -- ^ @f ... =@-  | LetBound     -- ^ @let ... in@-  | WithBound    -- ^ @| ... in q@-  deriving (Data, Show, Eq, Generic)+  = LambdaBound+      -- ^ @λ@ (currently also used for @Π@ and module parameters)+  | PatternBound Hiding+      -- ^ @f ... =@.+      --   Remember 'Hiding' for pattern variables @{x}@ and @{{x}}@.+      --   This information is only used for checking pattern synonyms.+      --   It is not serialized.+  | LetBound+      -- ^ @let ... in@+  | WithBound+      -- ^ @| ... in q@+  | MacroBound+      -- ^ Binding added to scope by one of context-manipulating reflection primitives+  deriving (Show, Eq, Generic)  instance Pretty BindingSource where   pretty = \case     LambdaBound  -> "local"-    PatternBound -> "pattern"+    PatternBound _ -> "pattern"     LetBound     -> "let-bound"     WithBound    -> "with-bound"-+    MacroBound   -> "macro-bound" -- | A local variable can be shadowed by an import. --   In case of reference to a shadowed variable, we want to report --   a scope error.@@ -175,7 +186,7 @@      -- ^ If this list is not empty, the local variable is      --   shadowed by one or more imports.   }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  instance Eq LocalVar where   (==) = (==) `on` localVar@@ -189,14 +200,13 @@   pretty (LocalVar x _ xs) = "." P.<> pretty x  -- | Shadow a local name by a non-empty list of imports.-shadowLocal :: [AbstractName] -> LocalVar -> LocalVar-shadowLocal [] _ = __IMPOSSIBLE__-shadowLocal ys (LocalVar x b zs) = LocalVar x b (ys ++ zs)+shadowLocal :: List1 AbstractName -> LocalVar -> LocalVar+shadowLocal ys (LocalVar x b zs) = LocalVar x b (List1.toList ys ++ zs)  -- | Treat patternBound variable as a module parameter patternToModuleBound :: LocalVar -> LocalVar patternToModuleBound x- | localBindingSource x == PatternBound =+ | PatternBound _ <- localBindingSource x =    x { localBindingSource = LambdaBound }  | otherwise                     = x @@ -210,57 +220,62 @@ notShadowedLocals = mapMaybe $ \ (c,x) -> (c,) <$> notShadowedLocal x  -- | Lenses for ScopeInfo components-scopeCurrent :: Lens' A.ModuleName ScopeInfo+scopeCurrent :: Lens' ScopeInfo A.ModuleName scopeCurrent f s =   f (_scopeCurrent s) <&>   \x -> s { _scopeCurrent = x } -scopeModules :: Lens' (Map A.ModuleName Scope) ScopeInfo+scopeModules :: Lens' ScopeInfo (Map A.ModuleName Scope) scopeModules f s =   f (_scopeModules s) <&>   \x -> s { _scopeModules = x } -scopeVarsToBind :: Lens' LocalVars ScopeInfo+scopeVarsToBind :: Lens' ScopeInfo LocalVars scopeVarsToBind f s =   f (_scopeVarsToBind s) <&>   \x -> s { _scopeVarsToBind = x } -scopeLocals :: Lens' LocalVars ScopeInfo+scopeLocals :: Lens' ScopeInfo LocalVars scopeLocals f s =   f (_scopeLocals s) <&>   \x -> s { _scopeLocals = x } -scopePrecedence :: Lens' PrecedenceStack ScopeInfo+scopePrecedence :: Lens' ScopeInfo PrecedenceStack scopePrecedence f s =   f (_scopePrecedence s) <&>   \x -> s { _scopePrecedence = x } -scopeInverseName :: Lens' NameMap ScopeInfo+scopeInverseName :: Lens' ScopeInfo NameMap scopeInverseName f s =   f (_scopeInverseName s) <&>   \x -> s { _scopeInverseName = x } -scopeInverseModule :: Lens' ModuleMap ScopeInfo+scopeInverseModule :: Lens' ScopeInfo ModuleMap scopeInverseModule f s =   f (_scopeInverseModule s) <&>   \x -> s { _scopeInverseModule = x } -scopeInScope :: Lens' InScopeSet ScopeInfo+scopeInScope :: Lens' ScopeInfo InScopeSet scopeInScope f s =   f (_scopeInScope s) <&>   \x -> s { _scopeInScope = x } -scopeFixities :: Lens' C.Fixities ScopeInfo+scopeFixities :: Lens' ScopeInfo C.Fixities scopeFixities f s =   f (_scopeFixities s) <&>   \x -> s { _scopeFixities = x } -scopePolarities :: Lens' C.Polarities ScopeInfo+scopePolarities :: Lens' ScopeInfo C.Polarities scopePolarities f s =   f (_scopePolarities s) <&>   \x -> s { _scopePolarities = x } -scopeFixitiesAndPolarities :: Lens' (C.Fixities, C.Polarities) ScopeInfo+scopeRecords :: Lens' ScopeInfo (Map A.QName (A.QName, Maybe Induction))+scopeRecords f s =+  f (_scopeRecords s) <&>+  \x -> s { _scopeRecords = x }++scopeFixitiesAndPolarities :: Lens' ScopeInfo (C.Fixities, C.Polarities) scopeFixitiesAndPolarities f s =   f' (_scopeFixities s) (_scopePolarities s) <&>   \ (fixs, pols) -> s { _scopeFixities = fixs, _scopePolarities = pols }@@ -310,9 +325,9 @@         -- ^ All abstract names targeted by a concrete name in scope.         --   Computed by 'recomputeInScopeSets'.       }-  deriving (Data, Eq, Show, Generic)+  deriving (Eq, Show, Generic) -type ThingsInScope a = Map C.Name [a]+type ThingsInScope a = Map C.Name (List1 a) type NamesInScope    = ThingsInScope AbstractName type ModulesInScope  = ThingsInScope AbstractModule type InScopeSet      = Set A.QName@@ -344,7 +359,7 @@  -- | Non-dependent tag for name or module. data NameOrModule = NameNotModule | ModuleNotName-  deriving (Data, Eq, Ord, Show, Enum, Bounded, Generic)+  deriving (Eq, Ord, Show, Enum, Bounded, Generic)  ------------------------------------------------------------------------ -- * Decorated names@@ -375,11 +390,19 @@   | PrimName                 -- ^ Name of a @primitive@.   | OtherDefName             -- ^ A @DefName@, but either other kind or don't know which kind.   -- End @DefName@.  Keep these together in sequence, for sake of @isDefName@!-  deriving (Eq, Ord, Show, Data, Enum, Bounded, Generic)+  deriving (Eq, Ord, Show, Enum, Bounded, Generic) +-- | All kinds of regular definitions.+defNameKinds :: [KindOfName]+defNameKinds = [DataName .. OtherDefName]+ isDefName :: KindOfName -> Bool isDefName = (>= DataName) +-- | Constructor and pattern synonyms.+conLikeNameKinds :: [KindOfName]+conLikeNameKinds = [ConName, CoConName, PatternSynName]+ isConName :: KindOfName -> Maybe Induction isConName = \case   ConName   -> Just Inductive@@ -437,7 +460,7 @@ data WithKind a = WithKind   { theKind     :: KindOfName   , kindedThing :: a-  } deriving (Data, Show, Eq, Ord, Functor, Foldable, Traversable)+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable)  -- | Where does a name come from? --@@ -450,7 +473,7 @@     -- ^ Imported from another module.   | Applied C.QName WhyInScope     -- ^ Imported by a module application.-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  -- | A decoration of 'Agda.Syntax.Abstract.Name.QName'. data AbstractName = AbsName@@ -464,11 +487,11 @@     -- ^ Additional information needed during scope checking. Currently used     --   for generalized data/record params.   }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  data NameMetadata = NoMetadata                   | GeneralizedVarsMetadata (Map A.QName A.Name)-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  -- | A decoration of abstract syntax module names. data AbstractModule = AbsModule@@ -477,7 +500,7 @@   , amodLineage :: WhyInScope     -- ^ Explanation where this name came from.   }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  instance Eq AbstractName where   (==) = (==) `on` anameName@@ -489,7 +512,7 @@   lensFixity = lensAnameName . lensFixity  -- | Van Laarhoven lens on 'anameName'.-lensAnameName :: Lens' A.QName AbstractName+lensAnameName :: Lens' AbstractName A.QName lensAnameName f am = f (anameName am) <&> \ m -> am { anameName = m }  instance Eq AbstractModule where@@ -499,7 +522,7 @@   compare = compare `on` amodName  -- | Van Laarhoven lens on 'amodName'.-lensAmodName :: Lens' A.ModuleName AbstractModule+lensAmodName :: Lens' AbstractModule A.ModuleName lensAmodName f am = f (amodName am) <&> \ m -> am { amodName = m }  @@ -517,14 +540,16 @@     FieldName (List1 AbstractName)       -- ^ @('FldName' ==) . 'anameKind'@ for all names.    | -- | Data or record constructor name.-    ConstructorName (Set Induction) (List1 AbstractName) -- ^ @isJust . 'isConName' . 'anameKind'@ for all names.+    ConstructorName+      (Set1 Induction)      -- ^ 'Inductive' or 'CoInductive' or both.+      (List1 AbstractName)  -- ^ @isJust . 'isConName' . 'anameKind'@ for all names.    | -- | Name of pattern synonym.     PatternSynResName (List1 AbstractName) -- ^ @('PatternSynName' ==) . 'anameKind'@ for all names.    | -- | Unbound name.     UnknownName-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  instance Pretty ResolvedName where   pretty = \case@@ -539,13 +564,57 @@   pretty NoSuffix   = mempty   pretty (Suffix i) = text (show i) +-- | Why is a resolved name ambiguous?  What did it resolve to?+--+--   Invariant (statically enforced): At least two resolvents in total.+data AmbiguousNameReason+  = AmbiguousLocalVar LocalVar (List1 AbstractName)+      -- ^ The name resolves both to a local variable and some declared names.+  | AmbiguousDeclName (List2 AbstractName)+      -- ^ The name resolves to at least 2 declared names.+  deriving (Show, Generic)++-- | A failure in name resolution, indicating the reason that a name+-- which /is/ in scope could not be returned from @tryResolveName@.+data NameResolutionError+  = IllegalAmbiguity  AmbiguousNameReason+  -- ^ Ambiguous names are not supported in this situation.+  | ConstrOfNonRecord C.QName ResolvedName+  -- ^ The name was @Foo.constructor@, and @Foo@ is in scope, but it is+  -- not a record.+  deriving (Show, Generic)++-- | The flat list of ambiguous names in 'AmbiguousNameReason'.+ambiguousNamesInReason :: AmbiguousNameReason -> List2 (A.QName)+ambiguousNamesInReason = \case+  AmbiguousLocalVar (LocalVar y _ _) xs -> List2.cons (A.qualify_ y) $ fmap anameName xs+  AmbiguousDeclName xs -> fmap anameName xs++data WhyInScopeData+  = WhyInScopeData+      C.QName+        -- ^ The name @x@ this explanation is about.+      FilePath+        -- ^ The directory in which the current module resides.+      (Maybe LocalVar)+        -- ^ The local variable that @x@ could denote, if any.+      [AbstractName]+        -- ^ The defined names that @x@ could denote.+      [AbstractModule]+        -- ^ The modules that @x@ could denote.++whyInScopeDataFromAmbiguousNameReason :: C.QName -> AmbiguousNameReason -> WhyInScopeData+whyInScopeDataFromAmbiguousNameReason q = \case+  AmbiguousLocalVar x ys -> WhyInScopeData q empty (Just x) (toList ys) empty+  AmbiguousDeclName ys   -> WhyInScopeData q empty Nothing  (toList ys) empty+ -- * Operations on name and module maps.  mergeNames :: Eq a => ThingsInScope a -> ThingsInScope a -> ThingsInScope a-mergeNames = Map.unionWith List.union+mergeNames = Map.unionWith List1.union  mergeNamesMany :: Eq a => [ThingsInScope a] -> ThingsInScope a-mergeNamesMany = Map.unionsWith List.union+mergeNamesMany = Map.unionsWith List1.union  ------------------------------------------------------------------------ -- * Operations on name spaces@@ -594,13 +663,41 @@  instance Null Scope where   empty = emptyScope-  null  = __IMPOSSIBLE__-    -- TODO: define when needed, careful about scopeNameSpaces!+  -- -- Use default implementation of null+  -- null Scope{ scopeName, scopeParents, scopeNameSpaces, scopeImports, scopeDatatypeModule } = and+  --   [ null scopeName+  --   , null scopeParents+  --   , null scopeNameSpaces || all (null . snd) scopeNameSpaces+  --   , null scopeImports+  --   , null scopeDatatypeModule+  --   ]  instance Null ScopeInfo where   empty = emptyScopeInfo-  null  = __IMPOSSIBLE__-    -- TODO: define when needed, careful about _scopeModules!+  -- -- Use default implementation of null+  -- null ScopeInfo+  --   { _scopeCurrent+  --   , _scopeModules+  --   , _scopeVarsToBind+  --   , _scopeLocals+  --   , _scopePrecendence+  --   , _scopeInverseName+  --   , _scopeInverseModule+  --   , _scopeInScope+  --   , _scopeFixities+  --   , _scopePolarities+  --   } = and+  --   [ null _scopeCurrent+  --   , null _scopeModules || all null (Map.values _scopeModules)+  --   , null _scopeVarsToBind+  --   , null _scopeLocals+  --   , null _scopePrecendence+  --   , null _scopeInverseName+  --   , null _scopeInverseModule+  --   , null _scopeInScope+  --   , null _scopeFixities+  --   , null _scopePolarities+  --   ]  -- | The empty scope. emptyScope :: Scope@@ -627,6 +724,7 @@   , _scopeInScope       = Set.empty   , _scopeFixities      = Map.empty   , _scopePolarities    = Map.empty+  , _scopeRecords       = Map.empty   }  -- | Map functions over the names and modules in a scope.@@ -707,7 +805,7 @@   where     recomputeInScope ns = ns { nsInScope = allANames $ nsNames ns }     allANames :: NamesInScope -> InScopeSet-    allANames = Set.fromList . map anameName . concat . Map.elems+    allANames = Set.fromList . map anameName . List1.concat . Map.elems  -- | Filter a scope keeping only concrete names matching the predicates. --   The first predicate is applied to the names and the second to the modules.@@ -722,9 +820,20 @@  allNamesInScope' :: InScope a => Scope -> ThingsInScope (a, Access) allNamesInScope' s =-  mergeNamesMany [ map (, nameSpaceAccess nsId) <$> inNameSpace ns+  mergeNamesMany [ fmap (, nameSpaceAccess nsId) <$> inNameSpace ns                  | (nsId, ns) <- scopeNameSpaces s ] +-- | Look up a single name in the current scope.+--+-- This is equivalent to @Map.lookup n . allNamesInScope'@, but more efficient+-- when only a single name needs to be looked up.+findNameInScope :: InScope a => C.Name -> Scope -> [(a, Access)]+findNameInScope n s =+  [ (name, nameSpaceAccess nsId)+  | (nsId, ns) <- scopeNameSpaces s+  , name <- List1.toList' $ Map.lookup n $ inNameSpace ns+  ]+ -- | Returns the scope's non-private names. exportedNamesInScope :: InScope a => Scope -> ThingsInScope a exportedNamesInScope = namesInScope [PublicNS, ImportedNS]@@ -787,7 +896,7 @@ addNameToScope :: NameSpaceId -> C.Name -> AbstractName -> Scope -> Scope addNameToScope nsid x y =   mapScopeNS nsid-    (Map.insertWith (flip List.union) x [y])  -- bind name x ↦ y+    (Map.insertWith (flip List1.union) x $ singleton y)  -- bind name x ↦ y     id                                        -- no change to modules     (Set.insert $ anameName y)                -- y is in scope now @@ -800,7 +909,7 @@ -- | Add a module to a scope. addModuleToScope :: NameSpaceId -> C.Name -> AbstractModule -> Scope -> Scope addModuleToScope nsid x m = mapScopeNS nsid id addM id-  where addM = Map.insertWith (flip List.union) x [m]+  where addM = Map.insertWith (flip List1.union) x (singleton m)  -- | When we get here we cannot have both @using@ and @hiding@. data UsingOrHiding@@ -919,7 +1028,7 @@         updateFxs m = foldl upd m fixities           where           -- Update fixity of all abstract names targeted by concrete name y.-          upd m (y, fx) = Map.adjust (map $ set lensFixity fx) y m+          upd m (y, fx) = Map.adjust (fmap $ set lensFixity fx) y m          updateThingsInScope           :: forall a. SetBindingSite a@@ -927,7 +1036,7 @@           -> ThingsInScope a -> ThingsInScope a         updateThingsInScope f = Map.fromListWith __IMPOSSIBLE__ . mapMaybe upd . Map.toAscList           where-          upd :: (C.Name, [a]) -> Maybe (C.Name, [a])+          upd :: (C.Name, List1 a) -> Maybe (C.Name, List1 a)           upd (x, ys) = f x <&> \ x' -> (x', setBindingSite (getRange x') ys)  -- | Rename the abstract names in a scope.@@ -938,8 +1047,8 @@     newName x = Map.findWithDefault x x renD     newMod  x = Map.findWithDefault x x renM -    renameD = Map.map $ map $ over lensAnameName newName-    renameM = Map.map $ map $ over lensAmodName  newMod+    renameD = Map.map $ fmap $ over lensAnameName newName+    renameM = Map.map $ fmap $ over lensAmodName  newMod  -- | Remove private name space of a scope. --@@ -957,8 +1066,8 @@     (Map.mapMaybe rMod)     (Set.filter (not . (`isInModule` m)))   where-    rName as = filterMaybe (not . null) $ filter (not . (`isInModule`        m) . anameName) as-    rMod  as = filterMaybe (not . null) $ filter (not . (`isLtChildModuleOf` m) . amodName)  as+    rName as = List1.nonEmpty $ List1.filter (not . (`isInModule`        m) . anameName) as+    rMod  as = List1.nonEmpty $ List1.filter (not . (`isLtChildModuleOf` m) . amodName)  as  -- | Filter privates out of a `ScopeInfo` withoutPrivates :: ScopeInfo -> ScopeInfo@@ -968,7 +1077,7 @@  -- | Disallow using generalized variables from the scope disallowGeneralizedVars :: Scope -> Scope-disallowGeneralizedVars = mapScope_ ((fmap . map) disallow) id id+disallowGeneralizedVars = mapScope_ ((fmap . fmap) disallow) id id   where     disallow a = a { anameKind = disallowGen (anameKind a) }     disallowGen GeneralizeName = DisallowedGeneralizeName@@ -978,8 +1087,8 @@ inScopeBecause :: (WhyInScope -> WhyInScope) -> Scope -> Scope inScopeBecause f = mapScope_ mapName mapMod id   where-    mapName = fmap . map $ \a -> a { anameLineage = f $ anameLineage a }-    mapMod  = fmap . map $ \a -> a { amodLineage  = f $ amodLineage a  }+    mapName = fmap . fmap $ \a -> a { anameLineage = f $ anameLineage a }+    mapMod  = fmap . fmap $ \a -> a { amodLineage  = f $ amodLineage a  }  -- | Get the public parts of the public modules of a scope publicModules :: ScopeInfo -> Map A.ModuleName Scope@@ -989,7 +1098,7 @@     allMods   = Map.map restrictPrivate $ scope ^. scopeModules     root      = scope ^. scopeCurrent -    modules s = map amodName $ concat $ Map.elems $ allNamesInScope s+    modules s = map amodName $ List1.concat $ Map.elems $ allNamesInScope s      chase m = m : concatMap chase ms       where ms = maybe __IMPOSSIBLE__ modules $ Map.lookup m allMods@@ -998,9 +1107,12 @@  publicNames :: ScopeInfo -> Set AbstractName publicNames scope =-  Set.fromList $ concat $ Map.elems $+  Set.fromList $ List1.concat $ Map.elems $   exportedNamesInScope $ mergeScopes $ Map.elems $ publicModules scope +publicNamesOfModules :: Map A.ModuleName Scope -> [AbstractName]+publicNamesOfModules = List1.concat . Map.elems . exportedNamesInScope . mergeScopes . Map.elems+ everythingInScope :: ScopeInfo -> NameSpace everythingInScope scope = allThingsInScope $ mergeScopes $     (s0 :) $ map look $ scopeParents s0@@ -1029,47 +1141,12 @@         inscope x _ = isInScope x == InScope         name    = scopeName s         imports = map lookP $ Map.elems $ scopeImports s-        submods = map (lookP . amodName) $ concat $ Map.elems $ Map.filterWithKey inscope $ allNamesInScope s---- | Compute a flattened scope. Only include unqualified names or names--- qualified by modules in the first argument.-flattenScope :: [[C.Name]] -> ScopeInfo -> Map C.QName [AbstractName]-flattenScope ms scope =-  Map.unionWith (++)-    (build ms allNamesInScope root)-    imported-  where-    current = moduleScope $ scope ^. scopeCurrent-    root    = mergeScopes $ current : map moduleScope (scopeParents current)--    imported = Map.unionsWith (++)-               [ qual c (build ms' exportedNamesInScope $ moduleScope a)-               | (c, a) <- Map.toList $ scopeImports root-               , let -- get the suffixes of c in ms-                     ms' = mapMaybe (List.stripPrefix $ List1.toList $ C.qnameParts c) ms-               , not $ null ms' ]-    qual c = Map.mapKeys (q c)-      where-        q (C.QName x)  = C.Qual x-        q (C.Qual m x) = C.Qual m . q x--    build :: [[C.Name]] -> (forall a. InScope a => Scope -> ThingsInScope a) -> Scope -> Map C.QName [AbstractName]-    build ms getNames s = Map.unionsWith (++) $-        Map.mapKeysMonotonic C.QName (getNames s) :-          [ Map.mapKeysMonotonic (\ y -> C.Qual x y) $-              build ms' exportedNamesInScope $ moduleScope m-          | (x, mods) <- Map.toList (getNames s)-          , let ms' = [ tl | hd:tl <- ms, hd == x ]-          , not $ null ms'-          , AbsModule m _ <- mods ]--    moduleScope :: A.ModuleName -> Scope-    moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules+        submods = map (lookP . amodName) $ List1.concat $ Map.elems $ Map.filterWithKey inscope $ allNamesInScope s  -- | Get all concrete names in scope. Includes bound variables. concreteNamesInScope :: ScopeInfo -> Set C.QName concreteNamesInScope scope =-  Set.unions [ build allNamesInScope root, imported, locals ]+  Set.unions [ build id allNamesInScope root, imported, locals ]   where     current = moduleScope $ scope ^. scopeCurrent     root    = mergeScopes $ current : map moduleScope (scopeParents current)@@ -1077,21 +1154,22 @@     locals  = Set.fromList [ C.QName x | (x, _) <- scope ^. scopeLocals ]      imported = Set.unions-               [ qual c (build exportedNamesInScope $ moduleScope a)-               | (c, a) <- Map.toList $ scopeImports root ]-    qual c = Set.map (q c)+               [ build (qual c) exportedNamesInScope $ moduleScope a+               | (c, a) <- Map.toList $ scopeImports root+               ]       where-        q (C.QName x)  = C.Qual x-        q (C.Qual m x) = C.Qual m . q x+        qual (C.QName x)  = C.Qual x+        qual (C.Qual m x) = C.Qual m . qual x -    build :: (forall a. InScope a => Scope -> ThingsInScope a) -> Scope -> Set C.QName-    build getNames s = Set.unions $-        Set.fromList (map C.QName $ Map.keys (getNames s :: ThingsInScope AbstractName)) :-          [ Set.mapMonotonic (\ y -> C.Qual x y) $-              build exportedNamesInScope $ moduleScope m-          | (x, mods) <- Map.toList (getNames s)-          , prettyShow x /= "_"-          , AbsModule m _ <- mods ]+    build :: (C.QName -> C.QName) -> (forall a. InScope a => Scope -> ThingsInScope a) -> Scope -> Set C.QName+    build qual getNames s = Set.unions $+        Set.mapMonotonic (qual . C.QName) (Map.keysSet (getNames s :: ThingsInScope AbstractName))+        :+        [ build (qual . C.Qual x) exportedNamesInScope $ moduleScope m+        | (x, mods) <- Map.toList (getNames s)+        , not $ isNoName x+        , AbsModule m _ <- List1.toList mods+        ]      moduleScope :: A.ModuleName -> Scope     moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules@@ -1101,35 +1179,60 @@ scopeLookup q scope = map fst $ scopeLookup' q scope  scopeLookup' :: forall a. InScope a => C.QName -> ScopeInfo -> [(a, Access)]-scopeLookup' q scope =-  nubOn fst $-    findName q root ++ maybeToList topImports ++ imports+scopeLookup' q scope = nubOn fst $ inAllScopes ++ topImports ++ imports   where-     -- 1. Finding a name in the current scope and its parents.+    inAllScopes :: [(a, Access)]+    inAllScopes = concatMap (findName q) allScopes +    -- 2. Finding a name in the top imports.+    topImports :: [(a, Access)]+    topImports = case (inScopeTag :: InScopeTag a) of+      NameTag   -> []+      ModuleTag -> first (`AbsModule` Defined) <$> imported q++    -- 3. Finding a name in the imports belonging to an initial part of the qualifier.+    imports :: [(a, Access)]+    imports = do+      let -- return all possible splittings, e.g.+          -- splitName X.Y.Z = [(X, Y.Z), (X.Y, Z)]+          splitName :: C.QName -> [(C.QName, C.QName)]+          splitName (C.QName x)  = []+          splitName (C.Qual x q) =+            (C.QName x, q) : [ (C.Qual x m, r) | (m, r) <- splitName q ]++      (m, x) <- splitName q+      m <- fst <$> imported m+      findName x $ restrictPrivate $ moduleScope m++    --------------------------------------------------------------------------------+     moduleScope :: A.ModuleName -> Scope     moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules -    current :: Scope-    current = moduleScope $ scope ^. scopeCurrent+    allScopes :: [Scope]+    allScopes = current : map moduleScope (scopeParents current) where+      current = moduleScope $ scope ^. scopeCurrent -    root    :: Scope-    root    = mergeScopes $ current : map moduleScope (scopeParents current)+    imported :: C.QName -> [(A.ModuleName, Access)]+    imported q = do+      s <- allScopes+      m <- maybeToList $ Map.lookup q $ scopeImports s+      return (m, PublicAccess)      -- Find a concrete, possibly qualified name in scope @s@.     findName :: forall a. InScope a => C.QName -> Scope -> [(a, Access)]     findName q0 s = case q0 of-      C.QName x  -> lookupName x s+      C.QName x  -> findNameInScope x s       C.Qual x q -> do         let -- Get the modules named @x@ in scope @s@.             mods :: [A.ModuleName]-            mods = amodName . fst <$> lookupName x s+            mods = amodName . fst <$> findNameInScope x s             -- Get the definitions named @x@ in scope @s@ and interpret them as modules.             -- Andreas, 2013-05-01: Issue 836 debates this feature:             -- Qualified constructors are qualified by their datatype rather than a module             defs :: [A.ModuleName] -- NB:: Defined but not used-            defs = qnameToMName . anameName . fst <$> lookupName x s+            defs = qnameToMName . anameName . fst <$> findNameInScope x s         -- Andreas, 2013-05-01:  Issue 836 complains about the feature         -- that constructors can also be qualified by their datatype         -- and projections by their record type.  This feature is off@@ -1145,36 +1248,8 @@         -- trace ("ss' = " ++ show ss') $ do         s' <- maybeToList ss'         findName q s'-      where-        lookupName :: forall a. InScope a => C.Name -> Scope -> [(a, Access)]-        lookupName x s = fromMaybe [] $ Map.lookup x $ allNamesInScope' s -    -- 2. Finding a name in the top imports. -    topImports :: Maybe (a, Access)-    topImports = case (inScopeTag :: InScopeTag a) of-      NameTag   -> Nothing-      ModuleTag -> first (`AbsModule` Defined) <$> imported q--    imported :: C.QName -> Maybe (A.ModuleName, Access)-    imported q = fmap (,PublicAccess) $ Map.lookup q $ scopeImports root--    -- 3. Finding a name in the imports belonging to an initial part of the qualifier.--    imports :: [(a, Access)]-    imports = do-      (m, x) <- splitName q-      m <- maybeToList $ fst <$> imported m-      findName x $ restrictPrivate $ moduleScope m--    -- return all possible splittings, e.g.-    -- splitName X.Y.Z = [(X, Y.Z), (X.Y, Z)]-    splitName :: C.QName -> [(C.QName, C.QName)]-    splitName (C.QName x)  = []-    splitName (C.Qual x q) =-      (C.QName x, q) : [ (C.Qual x m, r) | (m, r) <- splitName q ]-- -- * Inverse look-up  data AllowAmbiguousNames@@ -1303,14 +1378,14 @@     moduleMap = Map.fromListWith (++) $ do       (m, s)  <- scopes       (x, ms) <- Map.toList (allNamesInScope s)-      q       <- amodName <$> ms+      q       <- amodName <$> List1.toList ms       return (q, singleton (m, x))      nameMap :: NameMap     nameMap = Map.fromListWith (<>) $ do       (m, s)  <- scopes       (x, ms) <- Map.toList (allNamesInScope s)-      (q, k)  <- (anameName &&& anameKind) <$> ms+      (q, k)  <- (anameName &&& anameKind) <$> List1.toList ms       let ret z = return (q, NameMapEntry k $ singleton z)       if m `elem` current         then ret $ C.QName x@@ -1334,6 +1409,7 @@   setBindingSite = fmap . setBindingSite  instance SetBindingSite a => SetBindingSite [a]+instance SetBindingSite a => SetBindingSite (List1 a)  instance SetBindingSite A.Name where   setBindingSite r x = x { nameBindingSite = r }@@ -1398,7 +1474,7 @@ blockOfLines hd ss = hd : map (nest 2) ss  instance Pretty ScopeInfo where-  pretty (ScopeInfo this mods toBind locals ctx _ _ _ _ _) = vcat $ concat+  pretty (ScopeInfo this mods toBind locals ctx _ _ _ _ _ _) = vcat $ concat     [ [ "ScopeInfo"       , nest 2 $ "current =" <+> pretty this       ]@@ -1438,3 +1514,4 @@ instance NFData NameMetadata instance NFData AbstractModule instance NFData ResolvedName+instance NFData AmbiguousNameReason
+ src/full/Agda/Syntax/Scope/Flat.hs view
@@ -0,0 +1,141 @@+{-# OPTIONS_GHC -Wunused-imports #-}++-- | Flattened scopes.+module Agda.Syntax.Scope.Flat+  ( FlatScope+  , flattenScope+  , getDefinedNames+  , localNames+  ) where++import Prelude hiding ( (||) )++import Data.Bifunctor+import Data.Either (partitionEithers)+import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map++import qualified Agda.Syntax.Abstract.Name as A++import Agda.Syntax.Common (ExprKind(..))+import Agda.Syntax.Common.Pretty+import Agda.Syntax.Concrete+import Agda.Syntax.Notation+import Agda.Syntax.Scope.Base+import Agda.Syntax.Scope.Monad++import Agda.TypeChecking.Monad.Debug++import Agda.Utils.Boolean ( (||) )+import Agda.Utils.Function ( applyWhenJust )+import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.List1 (List1)+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Maybe++import Agda.Utils.Impossible++-- | Flattened scopes.+newtype FlatScope = Flat (Map QName (List1 AbstractName))+  deriving Pretty++-- | Compute a flattened scope. Only include unqualified names or names+-- qualified by modules in the first argument.+flattenScope :: [[Name]] -> ScopeInfo -> FlatScope+flattenScope ms scope =+  Flat $+  Map.unionWith (<>)+    (build ms allNamesInScope root)+    imported+  where+    current = moduleScope $ scope ^. scopeCurrent+    root    = mergeScopes $ current : map moduleScope (scopeParents current)++    imported = Map.unionsWith (<>)+               [ qual c (build ms' exportedNamesInScope $ moduleScope a)+               | (c, a) <- Map.toList $ scopeImports root+               , let -- get the suffixes of c in ms+                     ms' = mapMaybe (List.stripPrefix $ List1.toList $ qnameParts c) ms+               , not $ null ms' ]+    qual c = Map.mapKeysMonotonic (q c)+      where+        q (QName x)  = Qual x+        q (Qual m x) = Qual m . q x++    build :: [[Name]] -> (forall a. InScope a => Scope -> ThingsInScope a) -> Scope -> Map QName (List1 AbstractName)+    build ms getNames s = Map.unionsWith (<>) $+        Map.mapKeysMonotonic QName (getNames s) :+          [ Map.mapKeysMonotonic (\ y -> Qual x y) $+              build ms' exportedNamesInScope $ moduleScope m+          | (x, mods) <- Map.toList (getNames s)+          , let ms' = [ tl | hd:tl <- ms, hd == x ]+          , not $ null ms'+          , AbsModule m _ <- List1.toList mods+          ]++    moduleScope :: A.ModuleName -> Scope+    moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules++-- | Compute all defined names in scope and their fixities/notations.+-- Note that overloaded names (constructors) can have several+-- fixities/notations. Then we 'mergeNotations'. (See issue 1194.)+getDefinedNames' :: (AbstractName -> Bool) -> FlatScope -> [List1 NewNotation]+getDefinedNames' f (Flat names) =+  [ mergeNotations $ fmap (namesToNotation x . A.qnameName . anameName) ds+  | (x, ds) <- Map.toList names+  , any f ds+  ]+  -- Andreas, 2013-03-21 see Issue 822+  -- Names can have different kinds, i.e., 'defined' and 'constructor'.+  -- We need to consider all names that have *any* matching kind,+  -- not only those whose first appearing kind is matching.++getDefinedNames :: KindsOfNames -> FlatScope -> [List1 NewNotation]+getDefinedNames kinds = getDefinedNames' (filterByKind kinds)++filterByKind :: KindsOfNames -> AbstractName -> Bool+filterByKind kinds = (`elemKindsOfNames` kinds) . anameKind++-- | Compute all names (first component) and operators/notations+--   (second component) in scope.+--+--   For 'IsPattern', only constructor-like names are returned.+--+localNames :: ExprKind -> Maybe QName -> FlatScope -> ScopeM ([QName], [NewNotation])+localNames k top flat = do+  -- Construct a filter for the names we consider.+  let+    f = case k of+      IsExpr    -> const True+      IsPattern -> let+          -- Andreas, 2025-02-28, issue #7722+          -- Filter by kind.+          -- Just return the constructor-like operators,+          -- otherwise the pattern parser blows up.+          fk = filterByKind (someKindsOfNames $ FldName : conLikeNameKinds)+          -- Filter by name, keeping @top@ in.+          ft = top <&> \ y -> (unqualify y ==) . A.nameConcrete . A.qnameName . anameName+        in applyWhenJust ft (||) fk++  -- Retrieve the names of interest from the flat scope.+  let defs = getDefinedNames' f flat++  locals <- nubOn fst . notShadowedLocals <$> getLocalVars+  -- Note: Debug printout aligned with the one in+  -- Agda.Syntax.Concrete.Operators.buildParsers.+  reportS "scope.operators" 50+    [ "flat  = " ++ prettyShow flat+    , "defs  = " ++ prettyShow defs+    , "locals= " ++ prettyShow locals+    ]+  let localNots  = map localOp locals+      notLocal   = not . hasElem (map notaName localNots) . notaName+      otherNots  = concatMap (List1.filter notLocal) defs+  return $ second (map useDefaultFixity) $ split $ localNots ++ otherNots+  where+    localOp (x, y) = namesToNotation (QName x) y+    split          = partitionEithers . concatMap opOrNot+    opOrNot n      = Left (notaName n) :+                     [Right n | not (null (notation n))]
src/full/Agda/Syntax/Scope/Monad.hs view
@@ -8,14 +8,18 @@ import Prelude hiding (null)  import Control.Arrow ((***))-import Control.Monad-import Control.Monad.Except-import Control.Monad.State+import Control.Monad.Except       ( MonadError, throwError, runExceptT )+import Control.Monad.State        ( StateT, runStateT, gets, modify )+import Control.Monad.Trans        ( MonadTrans, lift )+import Control.Monad.Trans.Maybe  ( MaybeT(MaybeT), runMaybeT )+import Control.Applicative  import Data.Either ( partitionEithers ) import Data.Foldable (all, traverse_) import qualified Data.List as List import Data.Map (Map)+import qualified Data.HashMap.Strict as HMap+import qualified Data.HashSet as HSet import qualified Data.Map as Map import Data.Maybe import Data.Set (Set)@@ -26,6 +30,7 @@ import Agda.Interaction.Options.Warnings  import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty import Agda.Syntax.Position import Agda.Syntax.Fixity import Agda.Syntax.Notation@@ -38,12 +43,14 @@   -- TODO: move the relevant warnings out of there import Agda.Syntax.Scope.Base as A -import Agda.TypeChecking.Monad.Base-import Agda.TypeChecking.Monad.Builtin ( HasBuiltins , getBuiltinName' , builtinSet , builtinProp , builtinSetOmega, builtinSSetOmega )+import Agda.TypeChecking.Monad.Base as I+import Agda.TypeChecking.Monad.Builtin+  ( HasBuiltins, getBuiltinName'+  , builtinProp, builtinSet, builtinStrictSet, builtinPropOmega, builtinSetOmega, builtinSSetOmega ) import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.State import Agda.TypeChecking.Monad.Trace-import Agda.TypeChecking.Positivity.Occurrence (Occurrence)+import Agda.TypeChecking.Positivity.Occurrence ( PragmaPolarities, Occurrence ) import Agda.TypeChecking.Warnings ( warning, warning' )  import qualified Agda.Utils.AssocList as AssocList@@ -51,14 +58,15 @@ import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List-import Agda.Utils.List1 (List1, pattern (:|), nonEmpty)-import Agda.Utils.List2 (List2(List2))+import Agda.Utils.List1 (List1, pattern (:|), nonEmpty, toList)+import Agda.Utils.List2 (List2(List2), toList) import qualified Agda.Utils.List1 as List1 import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Pretty+import Agda.Utils.Set1 ( Set1 )+import qualified Agda.Utils.Set1 as Set1 import Agda.Utils.Singleton import Agda.Utils.Suffix as C @@ -133,7 +141,7 @@ --   (@Just@ if it is a datatype or record module.) createModule :: Maybe DataOrRecordModule -> A.ModuleName -> ScopeM () createModule b m = do-  reportSLn "scope.createModule" 10 $ "createModule " ++ prettyShow m+  reportSLn "scope.createModule" 30 $ "createModule " ++ prettyShow m   s <- getCurrentScope   let parents = scopeName s : scopeParents s       sm = emptyScope { scopeName           = m@@ -248,8 +256,8 @@ bindVarsToBind :: ScopeM () bindVarsToBind = do   vars <- getVarsToBind-  modifyLocalVars (vars++)-  printLocals 10 "bound variables:"+  modifyLocalVars (vars ++)+  printLocals 30 "bound variables:"   modifyScope_ $ setVarsToBind []  annotateDecls :: ReadTCState m => m [A.Declaration] -> m A.Declaration@@ -309,7 +317,7 @@   let cname = C.Name r C.NotInScope $ singleton $ Id $ stringToRawName $ s ++ show i   resolveName (C.QName cname) >>= \case     UnknownName -> return cname-    _           -> freshConcreteName r (i+1) s+    _           -> freshConcreteName r (i + 1) s  --------------------------------------------------------------------------- -- * Resolving names@@ -326,28 +334,43 @@ --   Then, we can ignore conflicting definitions of that name --   of a different kind. (See issue 822.) resolveName' ::-  KindsOfNames -> Maybe (Set A.Name) -> C.QName -> ScopeM ResolvedName+  KindsOfNames -> Maybe (Set1 A.Name) -> C.QName -> ScopeM ResolvedName resolveName' kinds names x = runExceptT (tryResolveName kinds names x) >>= \case-  Left ys  -> traceCall (SetRange $ getRange x) $ typeError $ AmbiguousName x ys+  Left (IllegalAmbiguity reason)  -> do+    reportS "scope.resolve" 60 $ unlines $+      "resolveName': ambiguous name" :+      map (show . qnameName) (toList $ ambiguousNamesInReason reason)+    setCurrentRange x $ typeError $ AmbiguousName x reason++  Left (ConstrOfNonRecord q r) -> case r of+    UnknownName -> setCurrentRange x $ typeError $ I.NotInScope q+    _ -> setCurrentRange x $ typeError $ ConstructorNameOfNonRecord r+   Right x' -> return x' -tryResolveName-  :: (ReadTCState m, HasBuiltins m, MonadError (List1 A.QName) m)-  => KindsOfNames       -- ^ Restrict search to these kinds of names.-  -> Maybe (Set A.Name) -- ^ Unless 'Nothing', restrict search to match any of these names.-  -> C.QName            -- ^ Name to be resolved-  -> m ResolvedName     -- ^ If illegally ambiguous, throw error with the ambiguous name.+tryResolveName :: forall m. (ReadTCState m, HasBuiltins m, MonadError NameResolutionError m)+  => KindsOfNames+       -- ^ Restrict search to these kinds of names.+  -> Maybe (Set1 A.Name)+       -- ^ Unless 'Nothing', restrict search to match any of these names.+  -> C.QName+       -- ^ Name to be resolved+  -> m ResolvedName+       -- ^ If illegally ambiguous, throw error with the ambiguous name. tryResolveName kinds names x = do   scope <- getScope-  let vars     = AssocList.mapKeysMonotonic C.QName $ scope ^. scopeLocals+  let+    vars = AssocList.mapKeysMonotonic C.QName $ scope ^. scopeLocals+    throwAmb = throwError . IllegalAmbiguity   case lookup x vars of+     -- Case: we have a local variable x, but is (perhaps) shadowed by some imports ys.-    Just (LocalVar y b ys) ->+    Just var@(LocalVar y b ys) ->       -- We may ignore the imports filtered out by the @names@ filter.-      ifNull (filterNames id ys)-        {-then-} (return $ VarName y{ nameConcrete = unqualify x } b)-        {-else-} $ \ ys' ->-          throwError $ A.qualify_ y :| map anameName ys'+      case nonEmpty $ filterNames id ys of+        Nothing  -> return $ VarName y{ nameConcrete = unqualify x } b+        Just ys' -> throwAmb $ AmbiguousLocalVar var ys'+     -- Case: we do not have a local variable x.     Nothing -> do       -- Consider only names that are in the given set of names and@@ -361,10 +384,10 @@           possibleBaseNames = filter (canHaveSuffix . anameName . fst) $ possibleNames xbase           suffixedNames = (,) <$> fromConcreteSuffix xsuffix <*> nonEmpty possibleBaseNames       case (nonEmpty $ possibleNames x) of-        Just ds  | let ks = fmap (isConName . anameKind . fst) ds-                 , all isJust ks+        Just ds  | Just ks <- traverse (isConName . anameKind . fst) ds+                     -- all names resolve to a constructor name                  , isNothing suffixedNames ->-          return $ ConstructorName (Set.fromList $ List1.catMaybes ks) $ fmap (upd . fst) ds+          return $ ConstructorName (Set1.fromList ks) $ fmap (upd . fst) ds          Just ds  | all ((FldName ==) . anameKind . fst) ds , isNothing suffixedNames ->           return $ FieldName $ fmap (upd . fst) ds@@ -372,15 +395,33 @@         Just ds  | all ((PatternSynName ==) . anameKind . fst) ds , isNothing suffixedNames ->           return $ PatternSynResName $ fmap (upd . fst) ds -        Just ((d, a) :| []) | isNothing suffixedNames ->-          return $ DefinedName a (upd d) A.NoSuffix+        Just ((d, a) :| ds) -> case (suffixedNames, ds) of+          (Nothing, []) ->+            return $ DefinedName a (upd d) A.NoSuffix+          (Nothing, (d',_) : ds') ->+            throwAmb $ AmbiguousDeclName $ List2 d d' $ map fst ds'+          (Just (_, ss), _) ->+            throwAmb $ AmbiguousDeclName $ List2.append (d :| map fst ds) (fmap fst ss) -        Just ds -> throwError $ fmap (anameName . fst) $ caseMaybe suffixedNames id ((<>) . snd) ds+        -- Name is of the form r.constructor+        Nothing | Just r <- isRecordConstructor x -> do+          -- We resolve the record name r with no filter, that way we+          -- can know when printing an error message whether r is not in+          -- scope, or whether it's some other type of name, etc.+          recd <- tryResolveName AllKindsOfNames Nothing r +          case recd of+            DefinedName acc abs suf -> getRecordConstructor (anameName abs) >>= \case+              Just (qn, ind) -> pure $ ConstructorName (Set1.singleton $ fromMaybe Inductive ind) $+                List1.singleton $ upd abs { anameName = qn, anameKind = ConName }+              Nothing -> throwError $ ConstrOfNonRecord r recd+            _ -> throwError $ ConstrOfNonRecord r recd+         Nothing -> case suffixedNames of           Nothing -> return UnknownName           Just (suffix , (d, a) :| []) -> return $ DefinedName a (upd d) suffix-          Just (suffix , sds) -> throwError $ fmap (anameName . fst) sds+          Just (suffix , (d1,_) :| (d2,_) : sds) ->+            throwAmb $ AmbiguousDeclName $ List2 d1 d2 $ map fst sds    where   -- @names@ intended semantics: a filter on names.@@ -389,7 +430,7 @@   filterNames :: forall a. (a -> AbstractName) -> [a] -> [a]   filterNames = case names of     Nothing -> \ f -> id-    Just ns -> \ f -> filter $ (`Set.member` ns) . A.qnameName . anameName . f+    Just ns -> \ f -> filter $ (`Set1.member` ns) . A.qnameName . anameName . f     -- lambda-dropped style by intention   upd d = updateConcreteName d $ unqualify x   updateConcreteName :: AbstractName -> C.Name -> AbstractName@@ -402,14 +443,16 @@     Just (C.Subscript i) -> Just $ A.Suffix i  -- | Test if a given abstract name can appear with a suffix. Currently---   only true for the names of builtin sorts @Set@ and @Prop@.+--   only true for the names of builtin sorts. canHaveSuffixTest :: HasBuiltins m => m (A.QName -> Bool) canHaveSuffixTest = do-  builtinSet  <- getBuiltinName' builtinSet   builtinProp <- getBuiltinName' builtinProp+  builtinSet  <- getBuiltinName' builtinSet+  builtinSSet <- getBuiltinName' builtinStrictSet+  builtinPropOmega <- getBuiltinName' builtinPropOmega   builtinSetOmega <- getBuiltinName' builtinSetOmega   builtinSSetOmega <- getBuiltinName' builtinSSetOmega-  return $ \x -> Just x `elem` [builtinSet, builtinProp, builtinSetOmega, builtinSSetOmega]+  return $ \x -> Just x `elem` [builtinProp, builtinSet, builtinSSet, builtinPropOmega, builtinSetOmega, builtinSSetOmega]  -- | Look up a module in the scope. resolveModule :: C.QName -> ScopeM AbstractModule@@ -424,20 +467,19 @@ getConcreteFixity x = Map.findWithDefault noFixity' x <$> useScope scopeFixities  -- | Get the polarities of a not yet bound name.-getConcretePolarity :: C.Name -> ScopeM (Maybe [Occurrence])+getConcretePolarity :: C.Name -> ScopeM (Maybe PragmaPolarities) getConcretePolarity x = Map.lookup x <$> useScope scopePolarities  instance MonadFixityError ScopeM where   throwMultipleFixityDecls xs         = case xs of-    (x, _) : _ -> setCurrentRange (getRange x) $ typeError $ MultipleFixityDecls xs-    []         -> __IMPOSSIBLE__+    (x, _) :| _ -> setCurrentRange (getRange x) $ typeError $ MultipleFixityDecls xs   throwMultiplePolarityPragmas xs     = case xs of-    x : _ -> setCurrentRange (getRange x) $ typeError $ MultiplePolarityPragmas xs-    []    -> __IMPOSSIBLE__+    x :| _ -> setCurrentRange (getRange x) $ typeError $ MultiplePolarityPragmas xs   warnUnknownNamesInFixityDecl        = scopeWarning . UnknownNamesInFixityDecl   warnUnknownNamesInPolarityPragmas   = scopeWarning . UnknownNamesInPolarityPragmas   warnUnknownFixityInMixfixDecl       = scopeWarning . UnknownFixityInMixfixDecl   warnPolarityPragmasButNotPostulates = scopeWarning . PolarityPragmasButNotPostulates+  warnEmptyPolarityPragma             = scopeWarning . EmptyPolarityPragma  -- | Collect the fixity/syntax declarations and polarity pragmas from the list --   of declarations and store them in the scope.@@ -454,7 +496,7 @@ -- | Get the notation of a name. The name is assumed to be in scope. getNotation   :: C.QName-  -> Set A.Name+  -> Set1 A.Name      -- ^ The name must correspond to one of the names in this set.   -> ScopeM NewNotation getNotation x ns = do@@ -468,10 +510,7 @@     UnknownName         -> __IMPOSSIBLE__   where     notation = namesToNotation x . qnameName . anameName-    oneNotation ds =-      case mergeNotations $ map notation $ List1.toList ds of-        [n] -> n-        _   -> __IMPOSSIBLE__+    oneNotation = List1.head . mergeNotations . fmap notation  --------------------------------------------------------------------------- -- * Binding names@@ -529,7 +568,13 @@ --   later on. rebindName :: Access -> KindOfName -> C.Name -> A.QName -> ScopeM () rebindName acc kind x y = do-  modifyCurrentScope $ removeNameFromScope (localNameSpace acc) x+  if kind == ConName+    then modifyCurrentScope $+           mapScopeNS (localNameSpace acc)+                      (Map.update (nonEmpty . List1.filter ((ConName ==) . anameKind)) x)+                      id+                      id+    else modifyCurrentScope $ removeNameFromScope (localNameSpace acc) x   bindName acc kind x y  -- | Bind a module name.@@ -542,6 +587,48 @@ bindQModule acc q m = modifyCurrentScope $ \s ->   s { scopeImports = Map.insert q m (scopeImports s) } +---------------------------------------------------+-- * Operations to do with record constructor names+---------------------------------------------------++-- | Record (ha) that a given record has the specified constructor name.+setRecordConstructor :: A.QName -> (A.QName, Maybe Induction) -> ScopeM ()+setRecordConstructor recr con = modifyScope_ $ over scopeRecords $ Map.insert recr con++-- | Get the internal 'QName' for the  name of a record constructor. If+-- the name does not refer to a record type, 'Nothing' is returned.+getRecordConstructor :: ReadTCState m => A.QName -> m (Maybe (A.QName, Maybe Induction))+getRecordConstructor recr = runMaybeT $ local <|> imported where+  local = do+    recs <- useScope scopeRecords+    MaybeT $ pure $ Map.lookup recr recs+  imported = do+    idefs <- useTC (stImports . sigDefinitions)+    case theDef <$> HMap.lookup recr idefs of+      Just def@I.Record{} -> pure (I.recCon def, I.recInduction def)+      _ -> MaybeT $ pure Nothing+++-- | Is this the qualified name which refers to the constructor of an+-- anonymous record (like @Foo.constructor@)?+--+-- If so, return the part of the name referring to the record (@Foo@).+isRecordConstructor :: C.QName -> Maybe C.QName+isRecordConstructor = fmap to . toplevel where+  toplevel, is :: C.QName -> Maybe [C.Name]+  toplevel (Qual r n) = (r:) <$> is n+  toplevel _          = Nothing++  is (C.Qual r n) = (r:) <$> is n+  is (C.QName n)  = case n of+    C.Name _ _ (Id w :| [])+      | w == "constructor" -> pure []+    _ -> Nothing++  to []     = __IMPOSSIBLE__+  to [x]    = C.QName x+  to (x:xs) = C.Qual x (to xs)+ --------------------------------------------------------------------------- -- * Module manipulation operations ---------------------------------------------------------------------------@@ -567,6 +654,16 @@   ScopeCopyInfo { renNames   = names                 , renModules = Map.map (pure . fst) mods } +-- | Mark a name as being a copy in the TC state.+copyName :: A.QName -> A.QName -> ScopeM ()+copyName from to = do+  from <- fromMaybe from . HMap.lookup from <$> useTC stCopiedNames+  modifyTCLens stCopiedNames $ HMap.insert to from+  let+    k Nothing  = Just (HSet.singleton to)+    k (Just s) = Just (HSet.insert to s)+  modifyTCLens stNameCopies $ HMap.alter k from+ -- | Create a new scope with the given name from an old scope. Renames --   public names in the old scope to match the new name and returns the --   renamings.@@ -616,6 +713,13 @@           i <- lift fresh           return $ x { A.nameId = i } +        copyRecordConstr :: A.QName -> A.QName -> WSM ()+        copyRecordConstr from to = getRecordConstructor from >>= \case+          Just (con, ind) -> do+            con' <- renName con+            lift $ setRecordConstructor to (con', ind)+          Nothing  -> pure ()+         -- Change a binding M.x -> old.M'.y to M.x -> new.M'.y         renName :: A.QName -> WSM A.QName         renName x = do@@ -651,6 +755,8 @@           y <- setRange rnew . A.qualify m <$> refresh (qnameName x)           lift $ reportSLn "scope.copy" 50 $ "  Copying " ++ prettyShow x ++ " to " ++ prettyShow y           addName x y+          lift (copyName x y)+          copyRecordConstr x y           return y          -- Change a binding M.x -> old.M'.y to M.x -> new.M'.y@@ -714,25 +820,12 @@     Renaming ImportedModule{} _ mfx _ -> getRange <$> mfx     _ -> Nothing --- Moved here carefully from Parser.y to preserve the archaeological artefact--- dating from Oct 2005 (5ba14b647b9bd175733f9563e744176425c39126). -- | Check that an import directive doesn't contain repeated names. verifyImportDirective :: [C.ImportedName] -> C.HidingDirective -> C.RenamingDirective -> ScopeM () verifyImportDirective usn hdn ren =-    case filter ((>1) . length)-         $ List.group-         $ List.sort xs-    of-        []  -> return ()-        yss -> setCurrentRange yss $ genericError $-                "Repeated name" ++ s ++ " in import directive: " ++-                concat (List.intersperse ", " $ map (prettyShow . head) yss)-            where-                s = case yss of-                        [_] -> ""-                        _   -> "s"-    where-        xs = usn ++ hdn ++ map renFrom ren+  List1.unlessNull+    (mapMaybe List2.fromList1Maybe . List1.group . List.sort $ usn ++ hdn ++ map renFrom ren)+    \ yss -> setCurrentRange yss $ typeError $ RepeatedNamesInImportDirective yss  -- | Apply an import directive and check that all the names mentioned actually --   exist.@@ -762,9 +855,9 @@     -- We start by checking that all of the names talked about in the import     -- directive do exist.  If some do not then we remove them and raise a warning.     let (missingExports, namesA) = checkExist $ usingList ++ hdn' ++ map renFrom ren'-    unless (null missingExports) $ setCurrentRange rng $ do-      reportSLn "scope.import.apply" 20 $ "non existing names: " ++ prettyShow missingExports-      warning $ ModuleDoesntExport m (Map.keys namesInScope) (Map.keys modulesInScope) missingExports+    () <- List1.unlessNull missingExports \ missingExports1 -> setCurrentRange rng do+      reportSLn "scope.import.apply" 30 $ "non existing names: " ++ prettyShow missingExports+      warning $ ModuleDoesntExport m (Map.keys namesInScope) (Map.keys modulesInScope) missingExports1      -- We can now define a cleaned-up version of the import directive.     let notMissing = not . (missingExports `hasElem`)  -- #3997, efficient lookup in missingExports@@ -793,7 +886,7 @@      -- Check for duplicate imports in a single import directive.     -- @dup@ : To be imported names that are mentioned more than once.-    unlessNull (allDuplicates targetNames) $ \ dup ->+    () <- List1.unlessNull (allDuplicates targetNames) $ \ dup ->       typeError $ DuplicateImports m dup      -- Apply the import directive.@@ -801,15 +894,15 @@      -- Andreas, 2019-11-08, issue #4154, report clashes     -- introduced by the @renaming@.-    unless (null nameClashes) $-      warning $ ClashesViaRenaming NameNotModule $ Set.toList nameClashes-    unless (null moduleClashes) $-      warning $ ClashesViaRenaming ModuleNotName $ Set.toList moduleClashes+    Set1.unlessNull nameClashes \ nameClashes ->+      warning $ ClashesViaRenaming NameNotModule nameClashes+    Set1.unlessNull moduleClashes \ moduleClashes ->+      warning $ ClashesViaRenaming ModuleNotName moduleClashes      -- Look up the defined names in the new scope.     let namesInScope'   = (allNamesInScope scope' :: ThingsInScope AbstractName)     let modulesInScope' = (allNamesInScope scope' :: ThingsInScope AbstractModule)-    let look x = headWithDefault __IMPOSSIBLE__ . Map.findWithDefault __IMPOSSIBLE__ x+    let look x = List1.head . Map.findWithDefault __IMPOSSIBLE__ x     -- We set the ranges to the ranges of the concrete names in order to get     -- highlighting for the names in the import directive.     let definedA = for definedNames $ \case@@ -851,7 +944,7 @@           let useless = \case                 ImportedName{}   -> True                 ImportedModule y -> notMentioned (ImportedName y)-          unlessNull (filter useless ys) $ warning . UselessHiding+          () <- List1.unlessNull (filter useless ys) $ warning . UselessHiding           -- We can empty @hiding@ now, since there is an explicit @using@ directive           -- and @hiding@ served its purpose to prevent modules to enter the @Using@ list.           return dir{ hiding = [] }@@ -884,9 +977,9 @@     checkExist xs = partitionEithers $ for xs $ \ name -> case name of       ImportedName x   -> ImportedName   . (x,) . setRange (getRange x) . anameName <$> resolve name x namesInScope       ImportedModule x -> ImportedModule . (x,) . setRange (getRange x) . amodName  <$> resolve name x modulesInScope--      where resolve :: Ord a => err -> a -> Map a [b] -> Either err b-            resolve err x m = maybe (Left err) (Right . head) $ Map.lookup x m+      where+        resolve :: Ord a => err -> a -> Map a (List1 b) -> Either err b+        resolve err x m = maybe (Left err) (Right . List1.head) $ Map.lookup x m  -- | Translation of @ImportDirective@. mapImportDir@@ -979,11 +1072,11 @@   checkForClashes    -- Importing names might shadow existing locals.-  verboseS "scope.locals" 10 $ do+  verboseS "scope.locals" 30 $ do     locals <- mapMaybe (\ (c,x) -> c <$ notShadowedLocal x) <$> getLocalVars     let newdefs = Map.keys $ nsNames ns         shadowed = locals `List.intersect` newdefs-    reportSLn "scope.locals" 10 $ "opening module shadows the following locals vars: " ++ prettyShow shadowed+    reportSLn "scope.locals" 30 $ "opening module shadows the following locals vars: " ++ prettyShow shadowed   -- Andreas, 2014-09-03, issue 1266: shadow local variables by imported defs.   modifyLocalVars $ AssocList.mapWithKey $ \ c x ->     case Map.lookup c $ nsNames ns of@@ -1004,13 +1097,17 @@             modClashes = filter (\ (_c, as) -> length as >= 2) $ Map.toList $ nsModules exported              -- No ambiguity if concrete identifier is only mapped to-            -- constructor names or only to projection names.-            defClash (_, qs) = not $ all (isJust . isConName) ks || all (==FldName) ks-              where ks = map anameKind qs+            -- constructor names or only to projection names or only to pattern synonyms.+            defClash (_, qs) = not $ or+              [ all (isJust . isConName) ks+              , all (== FldName)         ks+              , all (== PatternSynName)  ks+              ]+              where ks = fmap anameKind qs         -- We report the first clashing exported identifier.-        unlessNull (filter (\ x -> defClash x) defClashes) $-          \ ((x, q:_) : _) -> typeError $ ClashingDefinition (C.QName x) (anameName q) Nothing+        () <- List1.unlessNull (filter defClash defClashes) $+          \ ((x, q :| _) :| _) -> typeError $ ClashingDefinition (C.QName x) (anameName q) Nothing -        unlessNull modClashes $ \ ((_, ms) : _) -> do-          caseMaybe (last2 ms) __IMPOSSIBLE__ $ \ (m0, m1) -> do+        List1.unlessNull modClashes $ \ ((_, ms) :| _) -> do+          caseMaybe (List1.last2 ms) __IMPOSSIBLE__ $ \ (m0, m1) -> do             typeError $ ClashingModule (amodName m0) (amodName m1)
+ src/full/Agda/Syntax/TopLevelModuleName.hs view
@@ -0,0 +1,212 @@+{-# OPTIONS_GHC -Wunused-imports #-}++------------------------------------------------------------------------+-- Top-level module names+------------------------------------------------------------------------++module Agda.Syntax.TopLevelModuleName+  ( module Agda.Syntax.TopLevelModuleName+  , module Agda.Syntax.TopLevelModuleName.Boot+  ) where++import Agda.Syntax.TopLevelModuleName.Boot+import Agda.Syntax.Abstract.Name (isNoName)++import Control.DeepSeq++import Data.Function (on)+import qualified Data.List as List+import qualified Data.Text as T++import GHC.Generics (Generic)++import System.FilePath++import qualified Agda.Syntax.Abstract.Name as A+import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Position++import Agda.Utils.FileName+import Agda.Utils.Hash+import Agda.Utils.Impossible+import Agda.Utils.Lens+import qualified Agda.Utils.List1 as List1+import Agda.Syntax.Common.Pretty+import Agda.Utils.Singleton+import Agda.Utils.Size++------------------------------------------------------------------------+-- Raw top-level module names++-- | Raw top-level module names (with linear-time comparisons).++data RawTopLevelModuleName = RawTopLevelModuleName+  { rawModuleNameRange :: Range+  , rawModuleNameParts :: TopLevelModuleNameParts+  , rawModuleNameInferred :: !Bool+      -- ^ Was this module name constructed from a file name+      --   rather than declared in the file?+  }+  deriving (Show, Generic)++instance Eq RawTopLevelModuleName where+  (==) = (==) `on` rawModuleNameParts++instance Ord RawTopLevelModuleName where+  compare = compare `on` rawModuleNameParts++instance Sized RawTopLevelModuleName where+  size = size . rawModuleNameParts+  natSize = natSize . rawModuleNameParts++instance Pretty RawTopLevelModuleName where+  pretty = text . rawTopLevelModuleNameToString++instance HasRange RawTopLevelModuleName where+  getRange = rawModuleNameRange++instance SetRange RawTopLevelModuleName where+  setRange r (RawTopLevelModuleName _ x z) = RawTopLevelModuleName r x z++instance KillRange RawTopLevelModuleName where+  killRange (RawTopLevelModuleName _ x z) =+    RawTopLevelModuleName noRange x z++instance C.IsNoName RawTopLevelModuleName where+  isNoName m = rawModuleNameParts m == singleton "_"++-- | The 'Range' is not forced.++instance NFData RawTopLevelModuleName where+  rnf (RawTopLevelModuleName _ x _) = rnf x++-- | Turns a raw top-level module name into a string.++rawTopLevelModuleNameToString :: RawTopLevelModuleName -> String+rawTopLevelModuleNameToString =+  List.intercalate "." .+  map T.unpack . List1.toList . rawModuleNameParts++-- | Hashes a raw top-level module name.++hashRawTopLevelModuleName :: RawTopLevelModuleName -> ModuleNameHash+hashRawTopLevelModuleName =+  ModuleNameHash . hashString . rawTopLevelModuleNameToString++-- | Turns a qualified name into a 'RawTopLevelModuleName'. The+-- qualified name is assumed to represent a top-level module name.++rawTopLevelModuleNameForQName :: C.QName -> RawTopLevelModuleName+rawTopLevelModuleNameForQName q = RawTopLevelModuleName+  { rawModuleNameRange = getRange q+  , rawModuleNameParts =+      fmap (T.pack . C.nameToRawName) $ C.qnameParts q+  , rawModuleNameInferred = C.isNoName q+  }++-- | Computes the 'RawTopLevelModuleName' corresponding to the given+-- module name, which is assumed to represent a top-level module name.+--+-- Precondition: The module name must be well-formed.++rawTopLevelModuleNameForModuleName ::+  A.ModuleName -> RawTopLevelModuleName+rawTopLevelModuleNameForModuleName x@(A.MName ms) =+  List1.ifNull ms __IMPOSSIBLE__ $ \ms ->+  RawTopLevelModuleName+    { rawModuleNameRange = getRange ms+    , rawModuleNameParts =+        fmap (T.pack . C.nameToRawName . A.nameConcrete) ms+    , rawModuleNameInferred = isNoName x+    }++-- | Computes the top-level module name.+--+-- Precondition: The 'C.Module' has to be well-formed.+-- This means that there are only allowed declarations before the+-- first module declaration, typically import declarations.+-- See 'spanAllowedBeforeModule'.++rawTopLevelModuleNameForModule :: C.Module -> RawTopLevelModuleName+rawTopLevelModuleNameForModule (C.Mod _ []) = __IMPOSSIBLE__+rawTopLevelModuleNameForModule (C.Mod _ ds) =+  case C.spanAllowedBeforeModule ds of+    (_, C.Module _ _ n _ _ : _) -> rawTopLevelModuleNameForQName n+    _                           -> __IMPOSSIBLE__++------------------------------------------------------------------------+-- Top-level module names++-- | Top-level module names (with constant-time comparisons).++type TopLevelModuleName = TopLevelModuleName' Range++instance Sized TopLevelModuleName where+  size = size . rawTopLevelModuleName+  natSize = natSize . rawTopLevelModuleName++instance Pretty TopLevelModuleName where+  pretty = pretty . rawTopLevelModuleName++-- | A lens focusing on the 'moduleNameParts'.++lensTopLevelModuleNameParts ::+  Lens' TopLevelModuleName TopLevelModuleNameParts+lensTopLevelModuleNameParts f m =+  f (moduleNameParts m) <&> \ xs -> m{ moduleNameParts = xs }++-- | Converts a top-level module name to a raw top-level module name.++rawTopLevelModuleName :: TopLevelModuleName -> RawTopLevelModuleName+rawTopLevelModuleName m = RawTopLevelModuleName+  { rawModuleNameRange = moduleNameRange m+  , rawModuleNameParts = moduleNameParts m+  , rawModuleNameInferred = moduleNameInferred m+  }++-- | Converts a raw top-level module name and a hash to a top-level+-- module name.+--+-- This function does not ensure that there are no hash collisions,+-- that is taken care of by+-- 'Agda.TypeChecking.Monad.State.topLevelModuleName'.++unsafeTopLevelModuleName ::+  RawTopLevelModuleName -> ModuleNameHash -> TopLevelModuleName+unsafeTopLevelModuleName m h = TopLevelModuleName+  { moduleNameRange = rawModuleNameRange m+  , moduleNameParts = rawModuleNameParts m+  , moduleNameId    = h+  , moduleNameInferred = rawModuleNameInferred m+  }++-- | A corresponding 'C.QName'. The range of each 'Name' part is the+-- whole range of the 'TopLevelModuleName'.++topLevelModuleNameToQName :: TopLevelModuleName -> C.QName+topLevelModuleNameToQName m =+  List1.foldr C.Qual C.QName $+  fmap (C.Name (getRange m) C.NotInScope .+        C.stringNameParts . T.unpack) $+  moduleNameParts m++-- | Turns a top-level module name into a file name with the given+-- suffix.++moduleNameToFileName :: TopLevelModuleName -> String -> FilePath+moduleNameToFileName TopLevelModuleName{ moduleNameParts = ms } ext =+  joinPath (map T.unpack $ List1.init ms) </>+  T.unpack (List1.last ms) <.> ext++-- | Finds the current project's \"root\" directory, given a project+-- file and the corresponding top-level module name.+--+-- Example: If the module \"A.B.C\" is located in the file+-- \"/foo/A/B/C.agda\", then the root is \"/foo/\".+--+-- Precondition: The module name must be well-formed.++projectRoot :: AbsolutePath -> TopLevelModuleName -> AbsolutePath+projectRoot file TopLevelModuleName{ moduleNameParts = m } =+  mkAbsolute $+    iterate takeDirectory (filePath file) !! length m
+ src/full/Agda/Syntax/TopLevelModuleName/Boot.hs view
@@ -0,0 +1,62 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.Syntax.TopLevelModuleName.Boot where++import Agda.Utils.List1 (List1)+import Agda.Utils.BiMap (HasTag, Tag, tag)++import Control.DeepSeq (NFData, rnf)+import Data.Function (on)+import Data.Hashable (Hashable, hashWithSalt)+import Data.Text (Text)+import Data.Word (Word64)+import GHC.Generics (Generic)++newtype ModuleNameHash = ModuleNameHash { moduleNameHash :: Word64 }+  deriving (Eq, Ord, Hashable)++instance NFData ModuleNameHash where+  rnf _ = ()++instance HasTag ModuleNameHash where+  type Tag ModuleNameHash = ModuleNameHash+  tag = Just++noModuleNameHash :: ModuleNameHash+noModuleNameHash = ModuleNameHash 0++-- | The record selector is not included in the resulting strings.++instance Show ModuleNameHash where+  showsPrec p (ModuleNameHash h) = showParen (p > 0) $+    showString "ModuleNameHash " . shows h++type TopLevelModuleNameParts = List1 Text++data TopLevelModuleName' range = TopLevelModuleName+  { moduleNameRange :: range+  , moduleNameId    :: {-# UNPACK #-} !ModuleNameHash+  , moduleNameParts :: TopLevelModuleNameParts+  , moduleNameInferred :: !Bool+      -- ^ Was this module name constructed from a file name+      --   rather than declared in the file?+  }+  deriving (Show, Generic)++instance HasTag (TopLevelModuleName' range) where+  type Tag (TopLevelModuleName' range) = ModuleNameHash+  tag = Just . moduleNameId++instance Eq (TopLevelModuleName' range) where+  (==) = (==) `on` moduleNameId++instance Ord (TopLevelModuleName' range) where+  compare = compare `on` moduleNameId++instance Hashable (TopLevelModuleName' range) where+  hashWithSalt salt = hashWithSalt salt . moduleNameId++-- | The 'range' is not forced.++instance NFData (TopLevelModuleName' range) where+  rnf (TopLevelModuleName _ x y _) = rnf (x, y)
src/full/Agda/Syntax/Translation/AbstractToConcrete.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP          #-}- -- {-# OPTIONS -fwarn-unused-binds #-}  {-| The translation of abstract syntax to concrete syntax has two purposes.@@ -11,29 +9,25 @@ module Agda.Syntax.Translation.AbstractToConcrete     ( ToConcrete(..)     , toConcreteCtx+    , MonadAbsToCon     , abstractToConcrete_-    , abstractToConcreteScope+    , abstractToConcreteCtx     , abstractToConcreteHiding-    , runAbsToCon+    , abstractToConcreteQName+    , abstractToConcreteScope+    , abstractToConcreteTelescope+    , abstractToConcreteUnqualify     , RangeAndPragma(..)-    , abstractToConcreteCtx-    , withScope-    , preserveInteractionIds-    , MonadAbsToCon, AbsToCon, Env     , noTakenNames-    , lookupQName     ) where  import Prelude hiding (null) -import Control.Arrow        ( (&&&), first )-import Control.Monad        ( (<=<), forM, forM_, guard, liftM2 ) import Control.Monad.Except ( runExceptT )-import Control.Monad.Reader ( MonadReader(..), asks, runReaderT )+import Control.Monad.Reader ( MonadReader(..), asks, ReaderT, runReaderT ) import Control.Monad.State  ( StateT(..), runStateT ) -import qualified Control.Monad.Fail as Fail-+import Data.Bifunctor       ( first ) import qualified Data.Map as Map import Data.Maybe import Data.Monoid@@ -43,10 +37,11 @@ import qualified Data.Foldable as Fold import Data.Void import Data.List (sortBy)-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty+import Data.Semigroup ( sconcat )+import Data.String  import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty import Agda.Syntax.Position import Agda.Syntax.Literal import Agda.Syntax.Info as A@@ -63,9 +58,16 @@ import Agda.Syntax.Scope.Monad ( tryResolveName )  import Agda.TypeChecking.Monad.State (getScope, getAllPatternSyns)-import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Base as I+import Agda.TypeChecking.Monad.Context import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Monad.MetaVars+import Agda.TypeChecking.Monad.Pure+import Agda.TypeChecking.Monad.Trace+import Agda.TypeChecking.Monad.Signature+import {-# SOURCE #-} Agda.TypeChecking.Records (isRecord)+import {-# SOURCE #-} Agda.TypeChecking.Pretty (prettyTCM) import Agda.Interaction.Options  import qualified Agda.Utils.AssocList as AssocList@@ -73,34 +75,129 @@ import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Lens+import Agda.Utils.List import Agda.Utils.List1 (List1, pattern (:|), (<|) ) import Agda.Utils.List2 (List2, pattern List2) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Pretty+import qualified Agda.Syntax.Common.Aspect as Asp+import Agda.Utils.Set1 (Set1)+import qualified Agda.Utils.Set1 as Set1 import Agda.Utils.Singleton import Agda.Utils.Suffix  import Agda.Utils.Impossible --- Environment ------------------------------------------------------------+---------------------------------------------------------------------------+-- * The Interface+--------------------------------------------------------------------------- -data Env = Env { takenVarNames :: Set A.Name-                  -- ^ Abstract names currently in scope. Unlike the-                  --   ScopeInfo, this includes names for hidden-                  --   arguments inserted by the system.-               , takenDefNames :: Set C.Name-                  -- ^ Concrete names of all definitions in scope-               , currentScope :: ScopeInfo-               , builtins     :: Map String A.QName-                  -- ^ Certain builtins (like `fromNat`) have special printing-               , preserveIIds :: Bool-                  -- ^ Preserve interaction point ids-               , foldPatternSynonyms :: Bool-               }+-- | Preconditions to run the AbstractToConcrete translation.+--+type MonadAbsToCon m =+  ( MonadFresh NameId m+  , MonadInteractionPoints m+  , MonadStConcreteNames m+  , HasOptions m+  , PureTCM m+  , IsString (m Doc)+  , Null (m Doc)+  , Semigroup (m Doc)+  ) +abstractToConcreteScope :: (ToConcrete a, MonadAbsToCon m)+  => ScopeInfo -> a -> m (ConOfAbs a)+abstractToConcreteScope scope a = runReaderT (unAbsToCon $ toConcrete a) =<< makeEnv scope++abstractToConcreteCtx :: (ToConcrete a, MonadAbsToCon m)+  => Precedence -> a -> m (ConOfAbs a)+abstractToConcreteCtx ctx x = runAbsToCon $ withPrecedence ctx (toConcrete x)++abstractToConcrete_ :: (ToConcrete a, MonadAbsToCon m)+  => a -> m (ConOfAbs a)+abstractToConcrete_ = runAbsToCon . toConcrete++abstractToConcreteHiding :: (LensHiding i, ToConcrete a, MonadAbsToCon m)+  => i -> a -> m (ConOfAbs a)+abstractToConcreteHiding i = runAbsToCon . toConcreteHiding i++abstractToConcreteTelescope :: MonadAbsToCon m+  => A.Telescope -> m [Maybe C.TypedBinding]+abstractToConcreteTelescope tel = runAbsToCon $ bindToConcrete tel return++abstractToConcreteQName :: MonadAbsToCon m+  => AllowAmbiguousNames -> A.QName -> m (C.QName)+abstractToConcreteQName amb = runAbsToCon . lookupQName amb++abstractToConcreteUnqualify :: (ToConcrete a, MonadAbsToCon m)+  => a -> m (ConOfAbs a)+abstractToConcreteUnqualify = runAbsToCon . doUnqualifyOutOfScopeNames . toConcrete++---------------------------------------------------------------------------+-- * The Monad for the implementation+---------------------------------------------------------------------------++type MonadToConcrete m =+  ( MonadAbsToCon m+  , MonadReader Env m+  )++newtype AbsToConT m a = AbsToCon { unAbsToCon :: ReaderT Env m a }+  deriving+    ( Functor, Applicative, Monad, MonadReader Env+    , HasBuiltins+    , HasConstInfo+    , HasOptions+    , MonadAddContext+    , MonadDebug+    , MonadInteractionPoints+    , MonadReduce+    , MonadStConcreteNames+    , MonadTCEnv+    , PureTCM+    , ReadTCState+    )++deriving instance MonadFresh NameId m => MonadFresh NameId (AbsToConT m)+deriving instance (Monad m, IsString  (m Doc)) => IsString (AbsToConT m Doc)+deriving instance (Monad m, Null      (m Doc)) => Null (AbsToConT m Doc)+deriving instance (Monad m, Semigroup (m Doc)) => Semigroup (AbsToConT m Doc)++runAbsToCon :: MonadAbsToCon m => AbsToConT m c -> m c+runAbsToCon m = do+  scope <- getScope+  verboseBracket "toConcrete" 50 "runAbsToCon" $ do+    reportSLn "toConcrete" 50 $ render $ hsep $+      [ "entering AbsToCon with scope:"+      , prettyList_ (map (text . C.nameToRawName . fst) $ scope ^. scopeLocals)+      ]+    x <- runReaderT (unAbsToCon m) =<< makeEnv scope+    reportSLn "toConcrete" 50 $ "leaving AbsToCon"+    return x++---------------------------------------------------------------------------+-- * The Environment+---------------------------------------------------------------------------++data Env = Env+  { takenVarNames :: Set A.Name+      -- ^ Abstract names currently in scope.+      --   Unlike the 'ScopeInfo', this includes names for hidden arguments+      --   inserted by the system.+  , takenDefNames :: Set C.NameParts+      -- ^ Concrete names of all definitions in scope.+  , currentScope :: ScopeInfo+  , builtins     :: Map BuiltinId A.QName+      -- ^ Certain builtins (like `fromNat`) have special printing.+  , preserveIIds :: Bool+      -- ^ Preserve interaction point ids?+  , foldPatternSynonyms :: Bool+  , unqualifyOutOfScopeNames :: Bool+      -- ^ Print out-of-scope names unqualified (`a` instead of `A.B.a`).+  }+ makeEnv :: MonadAbsToCon m => ScopeInfo -> m Env makeEnv scope = do       -- zero and suc doesn't have to be in scope for natural number literals to work@@ -112,7 +209,7 @@         Just v | Just q <- name v,                  noScopeCheck b || isNameInScope q scope -> return [(b, q)]         _                                                -> return []-  ctxVars <- map (fst . I.unDom) <$> asksTC envContext+  ctxVars <- getContextNames'   letVars <- Map.keys <$> asksTC envLetBindings   let vars = ctxVars ++ letVars @@ -130,40 +227,23 @@         , builtins     = Map.fromListWith __IMPOSSIBLE__ builtinList         , preserveIIds = False         , foldPatternSynonyms = foldPatSyns+        , unqualifyOutOfScopeNames = False         }   where+    defs = Set.fromList $ map (nameParts . fst) $+        filter (uncurry usefulDef) $+        Map.toList $ nsNames $ everythingInScope scope+     -- Jesper, 2018-12-10: It's fine to shadow generalizable names as     -- they will never show up directly in printed terms.     notGeneralizeName AbsName{ anameKind = k }  =       not (k == GeneralizeName || k == DisallowedGeneralizeName) -    defs = Map.keysSet $-           Map.filter (all notGeneralizeName) $-           nsNames $ everythingInScope scope--currentPrecedence :: AbsToCon PrecedenceStack-currentPrecedence = asks $ (^. scopePrecedence) . currentScope--preserveInteractionIds :: AbsToCon a -> AbsToCon a-preserveInteractionIds = local $ \ e -> e { preserveIIds = True }--withPrecedence' :: PrecedenceStack -> AbsToCon a -> AbsToCon a-withPrecedence' ps = local $ \e ->-  e { currentScope = set scopePrecedence ps (currentScope e) }--withPrecedence :: Precedence -> AbsToCon a -> AbsToCon a-withPrecedence p ret = do-  ps <- currentPrecedence-  withPrecedence' (pushPrecedence p ps) ret--withScope :: ScopeInfo -> AbsToCon a -> AbsToCon a-withScope scope = local $ \e -> e { currentScope = scope }--noTakenNames :: AbsToCon a -> AbsToCon a-noTakenNames = local $ \e -> e { takenVarNames = Set.empty }+    usefulDef C.NoName{} _ = False+    usefulDef C.Name{} names = all notGeneralizeName names -dontFoldPatternSynonyms :: AbsToCon a -> AbsToCon a-dontFoldPatternSynonyms = local $ \ e -> e { foldPatternSynonyms = False }+    nameParts (C.NoName {}) = __IMPOSSIBLE__+    nameParts (C.Name { nameNameParts }) = nameNameParts  -- | Bind a concrete name to an abstract in the translation environment. addBinding :: C.Name -> A.Name -> Env -> Env@@ -173,127 +253,55 @@         AssocList.insert y (LocalVar x __IMPOSSIBLE__ [])     } --- | Get a function to check if a name refers to a particular builtin function.-isBuiltinFun :: AbsToCon (A.QName -> String -> Bool)-isBuiltinFun = asks $ is . builtins-  where is m q b = Just q == Map.lookup b m---- | Resolve a concrete name. If illegally ambiguous fail with the ambiguous names.-resolveName :: KindsOfNames -> Maybe (Set A.Name) -> C.QName -> AbsToCon (Either (NonEmpty A.QName) ResolvedName)-resolveName kinds candidates q = runExceptT $ tryResolveName kinds candidates q---- | Treat illegally ambiguous names as UnknownNames.-resolveName_ :: C.QName -> [A.Name] -> AbsToCon ResolvedName-resolveName_ q cands = fromRight (const UnknownName) <$> resolveName allKindsOfNames (Just $ Set.fromList cands) q---- The Monad ------------------------------------------------------------------ | We need:---   - Read access to the AbsToCon environment---   - Read access to the TC environment---   - Read access to the TC state---   - Read and write access to the stConcreteNames part of the TC state---   - Read access to the options---   - Permission to print debug messages-type MonadAbsToCon m =-  ( MonadTCEnv m-  , ReadTCState m-  , MonadStConcreteNames m-  , HasOptions m-  , HasBuiltins m-  , MonadDebug m-  )--newtype AbsToCon a = AbsToCon-  { unAbsToCon :: forall m.-      ( MonadReader Env m-      , MonadAbsToCon m-      ) => m a-  }---- TODO: Is there some way to automatically derive these boilerplate--- instances?  GeneralizedNewtypeDeriving fails us here.-instance Functor AbsToCon where-  fmap f x = AbsToCon $ f <$> unAbsToCon x--instance Applicative AbsToCon where-  pure x = AbsToCon $ pure x-  f <*> m = AbsToCon $ unAbsToCon f <*> unAbsToCon m--instance Monad AbsToCon where-  -- ASR (2021-02-07). The eta-expansion @\m' -> unAbsToCon m'@ is-  -- required by GHC >= 9.0.1 (see Issue #4955).-  m >>= f = AbsToCon $ unAbsToCon m >>= (\m' -> unAbsToCon m'). f-#if __GLASGOW_HASKELL__ < 808-  fail = Fail.fail-#endif--instance Fail.MonadFail AbsToCon where-  fail = error--instance MonadReader Env AbsToCon where-  ask = AbsToCon ask-  local f m = AbsToCon $ local f $ unAbsToCon m+---------------------------------------------------------------------------+-- * Service functions+--------------------------------------------------------------------------- -instance MonadTCEnv AbsToCon where-  askTC = AbsToCon askTC-  localTC f m = AbsToCon $ localTC f $ unAbsToCon m+currentPrecedence :: MonadToConcrete m => m PrecedenceStack+currentPrecedence = asks $ (^. scopePrecedence) . currentScope -instance ReadTCState AbsToCon where-  getTCState = AbsToCon getTCState-  locallyTCState l f m = AbsToCon $ locallyTCState l f $ unAbsToCon m+preserveInteractionIds :: MonadToConcrete m => m a -> m a+preserveInteractionIds = local $ \ e -> e { preserveIIds = True } -instance MonadStConcreteNames AbsToCon where-  -- ASR (2021-02-07). The eta-expansion @\m' -> unAbsToCon m'@ is-  -- required by GHC >= 9.0.1 (see Issue #4955).-  runStConcreteNames m =-    AbsToCon $ runStConcreteNames $ StateT $ (\m' -> unAbsToCon m') . runStateT m+localPrecedenceStack :: MonadToConcrete m+  => (PrecedenceStack -> PrecedenceStack) -> m a -> m a+localPrecedenceStack f = local \ env ->+  env{ currentScope = over scopePrecedence f (currentScope env) } -instance HasBuiltins AbsToCon where-  getBuiltinThing x = AbsToCon $ getBuiltinThing x+withPrecedence' :: MonadToConcrete m => PrecedenceStack -> m a -> m a+withPrecedence' = localPrecedenceStack . const -instance HasOptions AbsToCon where-  pragmaOptions = AbsToCon pragmaOptions-  commandLineOptions = AbsToCon commandLineOptions+withPrecedence :: MonadToConcrete m => Precedence -> m a -> m a+withPrecedence = localPrecedenceStack . pushPrecedence -instance MonadDebug AbsToCon where-  formatDebugMessage k n s      = AbsToCon $ formatDebugMessage k n s-  traceDebugMessage  k n s cont = AbsToCon $ traceDebugMessage  k n s $ unAbsToCon cont  -- can't eta-reduce!-  verboseBracket     k n s cont = AbsToCon $ verboseBracket     k n s $ unAbsToCon cont  -- because of GHC-9.0+withScope :: MonadToConcrete m => ScopeInfo -> m a -> m a+withScope scope = local $ \e -> e { currentScope = scope } -  getVerbosity     = defaultGetVerbosity-  isDebugPrinting  = defaultIsDebugPrinting-  nowDebugPrinting = defaultNowDebugPrinting+noTakenNames :: MonadToConcrete m => m a -> m a+noTakenNames = local $ \e -> e { takenVarNames = Set.empty } -runAbsToCon :: MonadAbsToCon m => AbsToCon c -> m c-runAbsToCon m = do-  scope <- getScope-  verboseBracket "toConcrete" 50 "runAbsToCon" $ do-    reportSLn "toConcrete" 50 $ render $ hsep $-      [ "entering AbsToCon with scope:"-      , prettyList_ (map (text . C.nameToRawName . fst) $ scope ^. scopeLocals)-      ]-    x <- runReaderT (unAbsToCon m) =<< makeEnv scope-    reportSLn "toConcrete" 50 $ "leaving AbsToCon"-    return x+dontFoldPatternSynonyms :: MonadToConcrete m => m a -> m a+dontFoldPatternSynonyms = local $ \ e -> e { foldPatternSynonyms = False } -abstractToConcreteScope :: (ToConcrete a, MonadAbsToCon m)-                        => ScopeInfo -> a -> m (ConOfAbs a)-abstractToConcreteScope scope a = runReaderT (unAbsToCon $ toConcrete a) =<< makeEnv scope+doUnqualifyOutOfScopeNames :: MonadToConcrete m => m a -> m a+doUnqualifyOutOfScopeNames = local $ \ e -> e { unqualifyOutOfScopeNames = True } -abstractToConcreteCtx :: (ToConcrete a, MonadAbsToCon m)-                      => Precedence -> a -> m (ConOfAbs a)-abstractToConcreteCtx ctx x = runAbsToCon $ withPrecedence ctx (toConcrete x)+-- | Get a function to check if a name refers to a particular builtin function.+isBuiltinFun :: MonadToConcrete m => m (A.QName -> BuiltinId -> Bool)+isBuiltinFun = asks $ is . builtins+  where is m q b = Just q == Map.lookup b m -abstractToConcrete_ :: (ToConcrete a, MonadAbsToCon m)-                    => a -> m (ConOfAbs a)-abstractToConcrete_ = runAbsToCon . toConcrete+-- | Resolve a concrete name. If illegally ambiguous fail with the ambiguous names.+resolveName :: MonadToConcrete m => KindsOfNames -> Maybe (Set1 A.Name) -> C.QName -> m (Either NameResolutionError ResolvedName)+resolveName kinds candidates q = runExceptT $ tryResolveName kinds candidates q -abstractToConcreteHiding :: (LensHiding i, ToConcrete a, MonadAbsToCon m)-                         => i -> a -> m (ConOfAbs a)-abstractToConcreteHiding i = runAbsToCon . toConcreteHiding i+-- | Treat illegally ambiguous names as UnknownNames.+resolveName_ :: MonadToConcrete m => C.QName -> A.Name -> m ResolvedName+resolveName_ q cand = fromRight (const UnknownName) <$> resolveName allKindsOfNames (Just $ singleton cand) q --- Dealing with names -----------------------------------------------------+---------------------------------------------------------------------------+-- ** Dealing with names+---------------------------------------------------------------------------  -- | Names in abstract syntax are fully qualified, but the concrete syntax --   requires non-qualified names in places. In theory (if all scopes are@@ -304,27 +312,56 @@ unsafeQNameToName :: C.QName -> C.Name unsafeQNameToName = C.unqualify -lookupQName :: AllowAmbiguousNames -> A.QName -> AbsToCon C.QName+-- | Like 'isRecordConstructor' but does not throw IMPOSSIBLE if the+-- name is not in scope.+isExistingRecordConstructor :: MonadToConcrete m => A.QName -> m (Maybe (A.QName, RecordData))+isExistingRecordConstructor c = getConstInfo' c >>= \case+  Left (SigUnknown err)     -> return Nothing+  Left SigCubicalNotErasure -> return Nothing+  Left SigAbstract          -> return Nothing+  Right def                 -> case theDef $ def of+    I.Constructor{ conData = r } -> fmap (r,) <$> isRecord r+    _                            -> return Nothing+++lookupQName :: MonadToConcrete m => AllowAmbiguousNames -> A.QName -> m C.QName lookupQName ambCon x | Just s <- getGeneralizedFieldName x =   return (C.QName $ C.Name noRange C.InScope $ C.stringNameParts s)-lookupQName ambCon x = do-  ys <- asks (inverseScopeLookupName' ambCon x . currentScope)-  reportSLn "scope.inverse" 100 $-    "inverse looking up abstract name " ++ prettyShow x ++ " yields " ++ prettyShow ys-  loop ys+lookupQName ambCon x = ignoreAbstractMode (isExistingRecordConstructor x) >>= \case+  -- If the QName is the internal name of a record with no named+  -- constructor, we should first concretise the name *of the record*,+  -- since that will *actually* be in scope through a concrete QName.+  Just (r, def) | not (_recNamedCon def) -> do+    reportSLn "scope.inverse" 100 $+      "inverse lookup of record constructor " ++ prettyShow x+    recr <- lookupQName ambCon r+    pure (recr `C.qualify` simpleName "constructor") +  _ -> do+    ys <- asks (inverseScopeLookupName' ambCon x . currentScope)+    reportSLn "scope.inverse" 100 $+      "inverse looking up abstract name " ++ prettyShow x ++ " yields " ++ prettyShow ys+    loop ys+   where     -- Found concrete name: check that it is not shadowed by a local     loop (qy@Qual{}      : _ ) = return qy -- local names cannot be qualified     loop (qy@(C.QName y) : ys) = lookupNameInScope y >>= \case       Just x' | x' /= qnameName x -> loop ys       _ -> return qy-    -- Found no concrete name: make up a new one+    -- Found no concrete name:     loop [] = case qnameToConcrete x of-      qy@Qual{}    -> return $ setNotInScope qy+      -- The name is qualified: in this case, we are likely dealing with a parameterised+      -- module, and the unqualified name might actually be in scope (see #3209).+      -- To make case splitting more useful in that situation, we unqualify the name+      -- if we are generating clauses for a case split.+      qy@Qual{} -> do+          doUnqualify <- asks unqualifyOutOfScopeNames+          return $ setNotInScope $ if doUnqualify then C.QName (unqualify qy) else qy+      -- The name is unqualified: make up a new one       qy@C.QName{} -> C.QName <$> chooseName (qnameName x) -lookupModule :: A.ModuleName -> AbsToCon C.QName+lookupModule :: MonadToConcrete m => A.ModuleName -> m C.QName lookupModule (A.MName []) = return $ C.QName $ C.simpleName "-1"   -- Andreas, 2016-10-10 it can happen that we have an empty module name   -- for instance when we query the current module inside the@@ -340,14 +377,14 @@  -- | Is this concrete name currently in use by a particular abstract --   name in the current scope?-lookupNameInScope :: C.Name -> AbsToCon (Maybe A.Name)+lookupNameInScope :: MonadToConcrete m => C.Name -> m (Maybe A.Name) lookupNameInScope y =   asks ((fmap localVar . lookup y) . ((^. scopeLocals) . currentScope))  -- | Have we already committed to a specific concrete name for this --   abstract name? If yes, return the concrete name(s). hasConcreteNames :: (MonadStConcreteNames m) => A.Name -> m [C.Name]-hasConcreteNames x = Map.findWithDefault [] x <$> useConcreteNames+hasConcreteNames x = maybe [] List1.toList . Map.lookup x <$> useConcreteNames  -- | Commit to a specific concrete name for printing the given --   abstract name. If the abstract name already has associated@@ -355,18 +392,18 @@ ---  names are shadowed. Precondition: the abstract name should be in --   scope. pickConcreteName :: (MonadStConcreteNames m) => A.Name -> C.Name -> m ()-pickConcreteName x y = modifyConcreteNames $ flip Map.alter x $ \case-    Nothing   -> Just $ [y]-    (Just ys) -> Just $ ys ++ [y]+pickConcreteName x y = modifyConcreteNames $ flip Map.alter x $ Just . \case+    Nothing -> singleton y+    Just ys -> List1.snoc (List1.toList ys) y  -- | For the given abstract name, return the names that could shadow it. shadowingNames :: (ReadTCState m, MonadStConcreteNames m)                => A.Name -> m (Set RawName)-shadowingNames x = Set.fromList . Map.findWithDefault [] x <$> useR stShadowingNames+shadowingNames x = Set1.toSet' . Map.lookup x <$> useR stShadowingNames -toConcreteName :: A.Name -> AbsToCon C.Name+toConcreteName :: MonadToConcrete m => A.Name -> m C.Name toConcreteName x | y <- nameConcrete x , isNoName y = return y-toConcreteName x = (Map.findWithDefault [] x <$> useConcreteNames) >>= loop+toConcreteName x = hasConcreteNames x >>= loop   where     -- case: we already have picked some name(s) for x     loop (y:ys) = ifM (isGoodName x y) (return y) (loop ys)@@ -379,18 +416,16 @@       return y      -- Is 'y' a good concrete name for abstract name 'x'?-    isGoodName :: A.Name -> C.Name -> AbsToCon Bool+    isGoodName :: MonadToConcrete m => A.Name -> C.Name -> m Bool     isGoodName x y = do       zs <- asks (Set.toList . takenVarNames)-      allM zs $ \z -> if x == z then return True else do-        czs <- hasConcreteNames z-        return $ notElem y czs+      forallM zs $ \ z -> pure (x == z) `or2M` (notElem y <$> hasConcreteNames z)   -- | Choose a new unshadowed name for the given abstract name -- | NOTE: See @withName@ in @Agda.Syntax.Translation.ReflectedToAbstract@ for similar logic. -- | NOTE: See @freshConcreteName@ in @Agda.Syntax.Scope.Monad@ also for similar logic.-chooseName :: A.Name -> AbsToCon C.Name+chooseName :: MonadToConcrete m => A.Name -> m C.Name chooseName x = lookupNameInScope (nameConcrete x) >>= \case   -- If the name is currently in scope, we do not rename it   Just x' | x == x' -> do@@ -399,13 +434,21 @@     return $ nameConcrete x   -- Otherwise we pick a name that does not shadow other names   _ -> do+    takenDefs <- asks takenDefNames     taken   <- takenNames     toAvoid <- shadowingNames x     glyphMode <- optUseUnicode <$> pragmaOptions     let freshNameMode = case glyphMode of           UnicodeOk -> A.UnicodeSubscript           AsciiOnly -> A.AsciiCounter-    let shouldAvoid = (`Set.member` (taken `Set.union` toAvoid)) . C.nameToRawName++        shouldAvoid C.NoName {} = False+        shouldAvoid name@C.Name { nameNameParts } =+          let raw = C.nameToRawName name in+          nameNameParts `Set.member` takenDefs ||+          raw `Set.member` taken ||+          raw `Set.member` toAvoid+         y = firstNonTakenName freshNameMode shouldAvoid $ nameConcrete x     reportSLn "toConcrete.bindName" 80 $ render $ vcat       [ "picking concrete name for:" <+> text (C.nameToRawName $ nameConcrete x)@@ -416,64 +459,56 @@     return y    where-    takenNames :: AbsToCon (Set RawName)+    takenNames :: MonadToConcrete m => m (Set RawName)     takenNames = do-      xs <- asks takenDefNames-      ys0 <- asks takenVarNames-      reportSLn "toConcrete.bindName" 90 $ render $ "abstract names of local vars: " <+> prettyList_ (map (C.nameToRawName . nameConcrete) $ Set.toList ys0)-      ys <- Set.fromList . concat <$> mapM hasConcreteNames (Set.toList ys0)-      return $ Set.map C.nameToRawName $ xs `Set.union` ys+      ys0 <- Set.toList <$> asks takenVarNames+      reportSLn "toConcrete.bindName" 90 $ render $ "abstract names of local vars: " <+> prettyList_ (map (C.nameToRawName . nameConcrete) ys0)+      Set.fromList . map C.nameToRawName . concat <$> mapM hasConcreteNames ys0   -- | Add a abstract name to the scope and produce an available concrete version of it.-bindName :: A.Name -> (C.Name -> AbsToCon a) -> AbsToCon a+bindName :: MonadToConcrete m => A.Name -> (C.Name -> m a) -> m a bindName x ret = do   y <- toConcreteName x   reportSLn "toConcrete.bindName" 30 $ "adding " ++ C.nameToRawName (nameConcrete x) ++ " to the scope under concrete name " ++ C.nameToRawName y   local (addBinding y x) $ ret y  -- | Like 'bindName', but do not care whether name is already taken.-bindName' :: A.Name -> AbsToCon a -> AbsToCon a+bindName' :: MonadToConcrete m => A.Name -> m a -> m a bindName' x ret = do   reportSLn "toConcrete.bindName" 30 $ "adding " ++ C.nameToRawName (nameConcrete x) ++ " to the scope with forced name"   pickConcreteName x y   applyUnless (isNoName y) (local $ addBinding y x) ret   where y = nameConcrete x --- Dealing with precedences -----------------------------------------------+---------------------------------------------------------------------------+-- ** Dealing with precedences+---------------------------------------------------------------------------  -- | General bracketing function.-bracket' ::    (e -> e)             -- ^ the bracketing function-            -> (PrecedenceStack -> Bool) -- ^ Should we bracket things-                                    --   which have the given-                                    --   precedence?-            -> e -> AbsToCon e+bracket' :: MonadToConcrete m+  => (e -> e)+       -- ^ The bracketing function.+  -> (PrecedenceStack -> Bool)+       -- ^ Should we bracket things which have the given precedence?+  -> e+  -> m e bracket' paren needParen e =     do  p <- currentPrecedence         return $ if needParen p then paren e else e  -- | Expression bracketing-bracket :: (PrecedenceStack -> Bool) -> AbsToCon C.Expr -> AbsToCon C.Expr+bracket :: MonadToConcrete m => (PrecedenceStack -> Bool) -> m C.Expr -> m C.Expr bracket par m =     do  e <- m         bracket' (Paren (getRange e)) par e  -- | Pattern bracketing-bracketP_ :: (PrecedenceStack -> Bool) -> AbsToCon C.Pattern -> AbsToCon C.Pattern+bracketP_ :: MonadToConcrete m => (PrecedenceStack -> Bool) -> m C.Pattern -> m C.Pattern bracketP_ par m =     do  e <- m         bracket' (ParenP (getRange e)) par e -{- UNUSED--- | Pattern bracketing-bracketP :: (PrecedenceStack -> Bool) -> (C.Pattern -> AbsToCon a)-                                 -> ((C.Pattern -> AbsToCon a) -> AbsToCon a)-                                 -> AbsToCon a-bracketP par ret m = m $ \p -> do-    p <- bracket' (ParenP $ getRange p) par p-    ret p--}- -- | Applications where the argument is a lambda without parentheses need --   parens more often than other applications. isLambda :: NamedArg A.Expr -> Bool@@ -485,11 +520,13 @@     A.ExtendedLam{} -> True     _               -> False --- Dealing with infix declarations ----------------------------------------+---------------------------------------------------------------------------+-- ** Dealing with infix declarations+---------------------------------------------------------------------------  -- | If a name is defined with a fixity that differs from the default, we have --   to generate a fixity declaration for that name.-withInfixDecl :: DefInfo -> C.Name -> AbsToCon [C.Declaration] -> AbsToCon [C.Declaration]+withInfixDecl :: MonadToConcrete m => DefInfo -> C.Name -> m [C.Declaration] -> m [C.Declaration] withInfixDecl i x m = ((fixDecl ++ synDecl) ++) <$> m   where   fixDecl = [ C.Infix (theFixity $ defFixity i) $ singleton x@@ -497,32 +534,36 @@             ]   synDecl = [ C.Syntax x $ theNotation $ defFixity i ] --- Dealing with private definitions ---------------------------------------+---------------------------------------------------------------------------+-- ** Dealing with private definitions+---------------------------------------------------------------------------  -- | Add @abstract@, @private@, @instance@ modifiers.-withAbstractPrivate :: DefInfo -> AbsToCon [C.Declaration] -> AbsToCon [C.Declaration]+withAbstractPrivate :: MonadToConcrete m => DefInfo -> m [C.Declaration] -> m [C.Declaration] withAbstractPrivate i m =     priv (defAccess i)       . abst (A.defAbstract i)       . addInstanceB (case A.defInstance i of InstanceDef r -> Just r; NotInstanceDef -> Nothing)       <$> m     where-        priv (PrivateAccess UserWritten)-                         ds = [ C.Private  (getRange ds) UserWritten ds ]+        priv (PrivateAccess kwr UserWritten)+                         ds = [ C.Private kwr UserWritten ds ]         priv _           ds = ds-        abst AbstractDef ds = [ C.Abstract (getRange ds) ds ]+        abst AbstractDef ds = [ C.Abstract empty ds ]         abst ConcreteDef ds = ds -addInstanceB :: Maybe Range -> [C.Declaration] -> [C.Declaration]+addInstanceB :: Maybe KwRange -> [C.Declaration] -> [C.Declaration] addInstanceB (Just r) ds = [ C.InstanceB r ds ] addInstanceB Nothing  ds = ds --- The To Concrete Class --------------------------------------------------+---------------------------------------------------------------------------+-- * The To Concrete Class+---------------------------------------------------------------------------  class ToConcrete a where     type ConOfAbs a-    toConcrete :: a -> AbsToCon (ConOfAbs a)-    bindToConcrete :: a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b+    toConcrete :: MonadToConcrete m => a -> m (ConOfAbs a)+    bindToConcrete :: MonadToConcrete m => a -> (ConOfAbs a -> m b) -> m b      -- Christian Sattler, 2017-08-05:     -- These default implementations are not valid semantically (at least@@ -530,24 +571,26 @@     toConcrete     x     = bindToConcrete x return     bindToConcrete x ret = ret =<< toConcrete x +    {-# MINIMAL toConcrete | bindToConcrete #-}+ -- | Translate something in a context of the given precedence.-toConcreteCtx :: ToConcrete a => Precedence -> a -> AbsToCon (ConOfAbs a)+toConcreteCtx :: MonadToConcrete m => ToConcrete a => Precedence -> a -> m (ConOfAbs a) toConcreteCtx p x = withPrecedence p $ toConcrete x  -- | Translate something in a context of the given precedence.-bindToConcreteCtx :: ToConcrete a => Precedence -> a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b+bindToConcreteCtx :: MonadToConcrete m => ToConcrete a => Precedence -> a -> (ConOfAbs a -> m b) -> m b bindToConcreteCtx p x ret = withPrecedence p $ bindToConcrete x ret  -- | Translate something in the top context.-toConcreteTop :: ToConcrete a => a -> AbsToCon (ConOfAbs a)+toConcreteTop :: MonadToConcrete m => ToConcrete a => a -> m (ConOfAbs a) toConcreteTop = toConcreteCtx TopCtx  -- | Translate something in the top context.-bindToConcreteTop :: ToConcrete a => a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b+bindToConcreteTop :: MonadToConcrete m => ToConcrete a => a -> (ConOfAbs a -> m b) -> m b bindToConcreteTop = bindToConcreteCtx TopCtx  -- | Translate something in a context indicated by 'Hiding' info.-toConcreteHiding :: (LensHiding h, ToConcrete a) => h -> a -> AbsToCon (ConOfAbs a)+toConcreteHiding :: MonadToConcrete m => (LensHiding h, ToConcrete a) => h -> a -> m (ConOfAbs a) toConcreteHiding h =   case getHiding h of     NotHidden  -> toConcrete@@ -555,14 +598,14 @@     Instance{} -> toConcreteTop  -- | Translate something in a context indicated by 'Hiding' info.-bindToConcreteHiding :: (LensHiding h, ToConcrete a) => h -> a -> (ConOfAbs a -> AbsToCon b) -> AbsToCon b+bindToConcreteHiding :: MonadToConcrete m => (LensHiding h, ToConcrete a) => h -> a -> (ConOfAbs a -> m b) -> m b bindToConcreteHiding h =   case getHiding h of     NotHidden  -> bindToConcrete     Hidden     -> bindToConcreteTop     Instance{} -> bindToConcreteTop --- General instances ------------------------------------------------------+-- Base type instances ------------------------------------------------------  instance ToConcrete () where   type ConOfAbs () = ()@@ -572,12 +615,18 @@   type ConOfAbs Bool = Bool   toConcrete = pure +instance ToConcrete Char where+  type ConOfAbs Char = Char+  toConcrete = pure++-- Functors ---------------------------------------------------------------+ instance ToConcrete a => ToConcrete [a] where     type ConOfAbs [a] = [ConOfAbs a]      toConcrete     = mapM toConcrete     bindToConcrete []     ret = ret []-    bindToConcrete (a:as) ret = bindToConcrete (a:|as) $ \ (c:|cs) -> ret (c:cs)+    bindToConcrete (a:as) ret = bindToConcrete (a :| as) $ \ (c :| cs) -> ret (c:cs)  instance ToConcrete a => ToConcrete (List1 a) where     type ConOfAbs (List1 a) = List1 (ConOfAbs a)@@ -594,6 +643,14 @@           bindToConcrete as $ \ cs ->             ret (c :| cs) +instance ToConcrete a => ToConcrete (Maybe a)  where+    type ConOfAbs (Maybe a) = Maybe (ConOfAbs a)+    toConcrete = traverse toConcrete+    bindToConcrete (Just x) ret = bindToConcrete x $ ret . Just+    bindToConcrete Nothing  ret = ret Nothing++-- Bifunctors etc. --------------------------------------------------------+ instance (ToConcrete a1, ToConcrete a2) => ToConcrete (Either a1 a2) where     type ConOfAbs (Either a1 a2) = Either (ConOfAbs a1) (ConOfAbs a2) @@ -625,6 +682,8 @@         where             reorder (x,(y,z)) = (x,y,z) +-- Decorations ------------------------------------------------------------+ instance ToConcrete a => ToConcrete (Arg a) where     type ConOfAbs (Arg a) = Arg (ConOfAbs a) @@ -642,10 +701,36 @@  instance ToConcrete a => ToConcrete (Named name a)  where     type ConOfAbs (Named name a) = Named name (ConOfAbs a)--    toConcrete (Named n x) = Named n <$> toConcrete x+    toConcrete = traverse toConcrete     bindToConcrete (Named n x) ret = bindToConcrete x $ ret . Named n +instance ToConcrete a => ToConcrete (Ranged a)  where+    type ConOfAbs (Ranged a) = Ranged (ConOfAbs a)+    toConcrete = traverse toConcrete+    bindToConcrete (Ranged r x) ret = bindToConcrete x $ ret . Ranged r++-- Christian Sattler, 2017-08-05, fixing #2669+-- Both methods of ToConcrete (FieldAssignment' a) need+-- to be implemented, each in terms of the corresponding one of ToConcrete a.+-- This mirrors the instance ToConcrete (Ranged a).+-- The default implementations of ToConcrete are not valid semantically.+instance ToConcrete a => ToConcrete (FieldAssignment' a) where+    type ConOfAbs (FieldAssignment' a) = FieldAssignment' (ConOfAbs a)+    toConcrete = traverse toConcrete++    bindToConcrete (FieldAssignment name a) ret =+      bindToConcrete a $ ret . FieldAssignment name++-- Newtypes ---------------------------------------------------------------++-- Deriving this requires UndecidableInstances,+-- as TacticAttribute' is not larger than its expansion (Maybe . Ranged).+-- (Also the derived instance produce a type error.)+instance ToConcrete a => ToConcrete (TacticAttribute' a) where+  type ConOfAbs (TacticAttribute' a) = TacticAttribute' (ConOfAbs a)+  toConcrete = traverse toConcrete+  bindToConcrete (TacticAttribute a) ret = bindToConcrete a $ ret . TacticAttribute+ -- Names ------------------------------------------------------------------  instance ToConcrete A.Name where@@ -680,9 +765,9 @@   toConcrete = \case     VarName x _          -> C.QName <$> toConcrete x     DefinedName _ x s    -> addSuffixConcrete s $ toConcrete x-    FieldName xs         -> toConcrete (NonEmpty.head xs)-    ConstructorName _ xs -> toConcrete (NonEmpty.head xs)-    PatternSynResName xs -> toConcrete (NonEmpty.head xs)+    FieldName xs         -> toConcrete (List1.head xs)+    ConstructorName _ xs -> toConcrete (List1.head xs)+    PatternSynResName xs -> toConcrete (List1.head xs)     UnknownName          -> __IMPOSSIBLE__  addSuffixConcrete :: HasOptions m => A.Suffix -> m C.QName -> m C.QName@@ -703,12 +788,12 @@ instance ToConcrete A.Expr where     type ConOfAbs A.Expr = C.Expr -    toConcrete (Var x)             = Ident . C.QName <$> toConcrete x-    toConcrete (Def' x suffix)     = Ident <$> addSuffixConcrete suffix (toConcrete x)-    toConcrete (Proj ProjPrefix p) = Ident <$> toConcrete (headAmbQ p)-    toConcrete (Proj _          p) = C.Dot noRange . Ident <$> toConcrete (headAmbQ p)-    toConcrete (A.Macro x)         = Ident <$> toConcrete x-    toConcrete e@(Con c)           = tryToRecoverPatternSyn e $ Ident <$> toConcrete (headAmbQ c)+    toConcrete (Var x)             = KnownIdent Asp.Bound . C.QName <$> toConcrete x+    toConcrete (Def' x suffix)     = KnownIdent Asp.Function <$> addSuffixConcrete suffix (toConcrete x)+    toConcrete (Proj ProjPrefix p) = KnownIdent Asp.Field <$> toConcrete (headAmbQ p)+    toConcrete (Proj _          p) = C.Dot empty . KnownIdent Asp.Field <$> toConcrete (headAmbQ p)+    toConcrete (A.Macro x)         = KnownIdent Asp.Macro <$> toConcrete x+    toConcrete e@(Con c)           = tryToRecoverPatternSyn e $ KnownIdent (Asp.Constructor Inductive) <$> toConcrete (headAmbQ c)         -- for names we have to use the name from the info, since the abstract         -- name has been resolved to a fully qualified name (except for         -- variables)@@ -727,12 +812,13 @@       return $ C.QuestionMark (getRange i) $                  interactionId ii <$ guard (preserve || isJust (metaNumber i)) -    toConcrete (A.Underscore i)     = return $-      C.Underscore (getRange i) $-        prettyShow . NamedMeta (metaNameSuggestion i) . MetaId . metaId <$> metaNumber i+    toConcrete (A.Underscore i) =+      C.Underscore (getRange i) <$>+      traverse (render <.> prettyTCM)+        (NamedMeta (metaNameSuggestion i) <$> metaNumber i)      toConcrete (A.Dot i e) =-      C.Dot (getRange i) <$> toConcrete e+      C.Dot empty <$> toConcrete e      toConcrete e@(A.App i e1 e2) = do       is <- isBuiltinFun@@ -799,16 +885,23 @@           lamView e = ([], e)     toConcrete (A.ExtendedLam i di erased qname cs) =         bracket lamBrackets $ do-          decls <- concat <$> toConcrete cs-          let namedPat np = case getHiding np of+          decls <- sconcat <$> toConcrete cs+          puns  <- optHiddenArgumentPuns <$> pragmaOptions+          let -- If --hidden-argument-puns is active, then {x} is+              -- replaced by {(x)} and ⦃ x ⦄ by ⦃ (x) ⦄.+              noPun (Named Nothing p@C.IdentP{}) | puns =+                Named Nothing (C.ParenP noRange p)+              noPun p = p++              namedPat np = case getHiding np of                  NotHidden  -> namedArg np-                 Hidden     -> C.HiddenP noRange (unArg np)-                 Instance{} -> C.InstanceP noRange (unArg np)+                 Hidden     -> C.HiddenP noRange (noPun (unArg np))+                 Instance{} -> C.InstanceP noRange (noPun (unArg np))               -- we know all lhs are of the form `.extlam p1 p2 ... pn`,               -- with the name .extlam leftmost. It is our mission to remove it.-          let removeApp :: C.Pattern -> AbsToCon [C.Pattern]+          let removeApp :: MonadToConcrete m => C.Pattern -> m [C.Pattern]               removeApp (C.RawAppP _ (List2 _ p ps)) = return $ p:ps-              removeApp (C.AppP (C.IdentP _) np) = return [namedPat np]+              removeApp (C.AppP (C.IdentP _ _) np) = return [namedPat np]               removeApp (C.AppP p np)            = removeApp p <&> (++ [namedPat np])               -- Andreas, 2018-06-18, issue #3136               -- Empty pattern list also allowed in extended lambda,@@ -826,9 +919,8 @@                 reportSLn "extendedlambda" 50 $ "abstractToConcrete extended lambda patterns ps = " ++ prettyShow ps                 return $ LamClause ps rhs ca               decl2clause _ = __IMPOSSIBLE__-          C.ExtendedLam (getRange i) erased . List1.fromList <$>+          C.ExtendedLam (getRange i) erased <$>             mapM decl2clause decls-            -- TODO List1: can we demonstrate non-emptiness?      toConcrete (A.Pi _ tel1 e0) = do       let (tel, e) = piTel1 tel1 e0@@ -846,16 +938,19 @@         bracket piBrackets         $ do a' <- toConcreteCtx ctx a              b' <- toConcreteTop b-             let dom = setQuantity (getQuantity a') $ defaultArg $ addRel a' $ mkArg a'+             -- NOTE We set relevance to Relevant in arginfo because we wrap+             -- with C.Dot or C.DoubleDot using addRel instead.+             let dom = setRelevance relevant $ setModality (getModality a') $ defaultArg $ addRel a' $ mkArg a'              return $ C.Fun (getRange i) dom b'              -- Andreas, 2018-06-14, issue #2513              -- TODO: print attributes         where             ctx = if isRelevant a then FunctionSpaceDomainCtx else DotPatternCtx-            addRel a e = case getRelevance a of-                           Irrelevant -> C.Dot (getRange a) e-                           NonStrict  -> C.DoubleDot (getRange a) e-                           _          -> e+            addRel a e =+              case getRelevance a of+                Irrelevant      {} -> C.Dot empty e+                ShapeIrrelevant {} -> C.DoubleDot empty e+                Relevant        {} -> e             mkArg (Arg info e) = case getHiding info of                                           Hidden     -> HiddenArg   (getRange e) (unnamed e)                                           Instance{} -> InstanceArg (getRange e) (unnamed e)@@ -867,15 +962,13 @@              e'  <- toConcreteTop e              return $ C.mkLet (getRange i) (concat ds') e' -    toConcrete (A.Rec i fs) =+    toConcrete (A.Rec kwr i fs) =       bracket appBrackets $ do-        C.Rec (getRange i) . map (fmap (\x -> ModuleAssignment x [] defaultImportDir)) <$> toConcreteTop fs+        C.Rec kwr (getRange i) . map (fmap (\x -> ModuleAssignment x [] defaultImportDir)) <$> toConcreteTop fs -    toConcrete (A.RecUpdate i e fs) =+    toConcrete (A.RecUpdate kwr i e fs) =       bracket appBrackets $ do-        C.RecUpdate (getRange i) <$> toConcrete e <*> toConcreteTop fs--    toConcrete (A.ETel tel) = C.ETel . catMaybes <$> toConcrete tel+        C.RecUpdate kwr (getRange i) <$> toConcrete e <*> toConcreteTop fs      toConcrete (A.ScopedExpr _ e) = toConcrete e     toConcrete (A.Quote i) = return $ C.Quote (getRange i)@@ -884,7 +977,7 @@      -- Andreas, 2012-04-02: TODO!  print DontCare as irrAxiom     -- Andreas, 2010-10-05 print irrelevant things as ordinary things-    toConcrete (A.DontCare e) = C.Dot r . C.Paren r  <$> toConcrete e+    toConcrete (A.DontCare e) = C.Dot empty . C.Paren r  <$> toConcrete e        where r = getRange e     toConcrete (A.PatternSyn n) = C.Ident <$> toConcrete (headAmbQ n) @@ -892,23 +985,11 @@ makeDomainFree b@(A.DomainFull (A.TBind _ tac (x :| []) t)) =   case unScope t of     A.Underscore A.MetaInfo{metaNumber = Nothing} ->-      A.DomainFree tac x+      A.DomainFree (tbTacticAttr tac) x     _ -> b makeDomainFree b = b --- Christian Sattler, 2017-08-05, fixing #2669--- Both methods of ToConcrete (FieldAssignment' a) (FieldAssignment' c) need--- to be implemented, each in terms of the corresponding one of ToConcrete a c.--- This mirrors the instance ToConcrete (Arg a) (Arg c).--- The default implementations of ToConcrete are not valid semantically.-instance ToConcrete a => ToConcrete (FieldAssignment' a) where-    type ConOfAbs (FieldAssignment' a) = FieldAssignment' (ConOfAbs a)-    toConcrete = traverse toConcrete -    bindToConcrete (FieldAssignment name a) ret =-      bindToConcrete a $ ret . FieldAssignment name-- -- Binder instances -------------------------------------------------------  -- If there is no label we set it to the bound name, to make renaming the bound@@ -927,10 +1008,10 @@ instance ToConcrete a => ToConcrete (A.Binder' a) where   type ConOfAbs (A.Binder' a) = C.Binder' (ConOfAbs a) -  bindToConcrete (A.Binder p a) ret =+  bindToConcrete (A.Binder p o a) ret =     bindToConcrete a $ \ a ->     bindToConcrete p $ \ p ->-    ret $ C.Binder p a+    ret $ C.Binder p o a  instance ToConcrete A.LamBinding where     type ConOfAbs A.LamBinding = Maybe C.LamBinding@@ -946,10 +1027,10 @@     type ConOfAbs A.TypedBinding = Maybe C.TypedBinding      bindToConcrete (A.TBind r t xs e) ret = do-        t <- traverse toConcrete t+        tac <- traverse toConcrete (tbTacticAttr t)         bindToConcrete (fmap forceNameIfHidden xs) $ \ xs -> do           e <- toConcreteTop e-          let setTac x = x { bnameTactic = t }+          let setTac x = x { bnameTactic = tac , C.bnameIsFinite = tbFinite t }           ret $ Just $ C.TBind r (fmap (updateNamedArg (fmap setTac)) xs) e     bindToConcrete (A.TLet r lbs) ret =         bindToConcrete lbs $ \ ds -> do@@ -959,19 +1040,26 @@     type ConOfAbs A.LetBinding = [C.Declaration]      bindToConcrete (A.LetBind i info x t e) ret =-        bindToConcrete x $ \ x ->-        do (t, (e, [], [], [])) <- toConcrete (t, A.RHS e Nothing)-           ret $ addInstanceB (if isInstance info then Just noRange else Nothing) $-               [ C.TypeSig info Nothing (C.boundName x) t-               , C.FunClause (C.LHS (C.IdentP $ C.QName $ C.boundName x) [] [])-                             e C.NoWhere False+      bindToConcrete x \ x -> do+        toConcrete (t, A.RHS e Nothing) >>= \case+          (t, (e, [], [], [])) ->+           ret $ addInstanceB (if isInstance info then Just empty else Nothing) $+               [ C.TypeSig info empty (C.boundName x) t+               , C.FunClause+                   (C.LHS (C.IdentP True $ C.QName $ C.boundName x) [] [])+                   e C.NoWhere empty                ]+          _ -> __IMPOSSIBLE__+    bindToConcrete (A.LetAxiom i info x t) ret = bindToConcrete x \x -> do+      t <- toConcrete t+      ret $ addInstanceB (if isInstance info then Just empty else Nothing) $+        [ C.TypeSig info empty (C.boundName x) t ]     -- TODO: bind variables     bindToConcrete (LetPatBind i p e) ret = do         p <- toConcrete p         e <- toConcrete e-        ret [ C.FunClause (C.LHS p [] []) (C.RHS e) NoWhere False ]-    bindToConcrete (LetApply i x modapp _ _) ret = do+        ret [ C.FunClause (C.LHS p [] []) (C.RHS e) NoWhere empty ]+    bindToConcrete (LetApply i erased x modapp _ _) ret = do       x' <- unqualify <$> toConcrete x       modapp <- toConcrete modapp       let r = getRange modapp@@ -979,35 +1067,36 @@           dir  = fromMaybe defaultImportDir{ importDirRange = r } $ minfoDirective i       -- This is no use since toAbstract LetDefs is in localToAbstract.       local (openModule' x dir id) $-        ret [ C.ModuleMacro (getRange i) x' modapp open dir ]+        ret [ C.ModuleMacro (getRange i) erased x' modapp open dir ]     bindToConcrete (LetOpen i x _) ret = do       x' <- toConcrete x       let dir = fromMaybe defaultImportDir $ minfoDirective i       local (openModule' x dir restrictPrivate) $             ret [ C.Open (getRange i) x' dir ]-    bindToConcrete (LetDeclaredVariable _) ret =-      -- Note that the range of the declaration site is dropped.-      ret []  instance ToConcrete A.WhereDeclarations where   type ConOfAbs A.WhereDeclarations = WhereClause -  bindToConcrete (A.WhereDecls _ Nothing) ret = ret C.NoWhere-  bindToConcrete (A.WhereDecls (Just am) (Just (A.Section _ _ _ ds))) ret = do+  bindToConcrete (A.WhereDecls _ _ Nothing) ret = ret C.NoWhere+  bindToConcrete (A.WhereDecls (Just am) False+                    (Just (A.Section _ erased _ _ ds)))+                 ret = do     ds' <- declsToConcrete ds     cm  <- unqualify <$> lookupModule am     -- Andreas, 2016-07-08 I put PublicAccess in the following SomeWhere     -- Should not really matter for printing...-    let wh' = (if isNoName cm then AnyWhere noRange else SomeWhere noRange cm PublicAccess) $ ds'+    let wh' = if isNoName cm && not (isErased erased)+              then AnyWhere noRange ds'+              else SomeWhere noRange erased cm PublicAccess ds'     local (openModule' am defaultImportDir id) $ ret wh'-  bindToConcrete (A.WhereDecls _ (Just d)) ret =+  bindToConcrete (A.WhereDecls _ _ (Just d)) ret =     ret . AnyWhere noRange =<< toConcrete d  mergeSigAndDef :: [C.Declaration] -> [C.Declaration]-mergeSigAndDef (C.RecordSig _ x bs e : C.RecordDef r y dir _ fs : ds)-  | x == y = C.Record r y dir bs e fs : mergeSigAndDef ds-mergeSigAndDef (C.DataSig _ x bs e : C.DataDef r y _ cs : ds)-  | x == y = C.Data r y bs e cs : mergeSigAndDef ds+mergeSigAndDef (C.RecordSig _ er x bs e : C.RecordDef r y dir _ fs : ds)+  | x == y = C.Record r er y dir bs e fs : mergeSigAndDef ds+mergeSigAndDef (C.DataSig _ er x bs e : C.DataDef r y _ cs : ds)+  | x == y = C.Data r er y bs e cs : mergeSigAndDef ds mergeSigAndDef (d : ds) = d : mergeSigAndDef ds mergeSigAndDef [] = [] @@ -1025,7 +1114,7 @@  -- Declaration instances -------------------------------------------------- -declsToConcrete :: [A.Declaration] -> AbsToCon [C.Declaration]+declsToConcrete :: MonadToConcrete m => [A.Declaration] -> m [C.Declaration] declsToConcrete ds = mergeSigAndDef . concat <$> toConcrete ds  instance ToConcrete A.RHS where@@ -1041,8 +1130,8 @@                forM es $ \ (Named n e) -> do                  n <- traverse toConcrete n                  pure $ Named (C.boundName <$> n) e-      cs <- noTakenNames $ concat <$> toConcrete cs-      return (C.AbsurdRHS, [], es, cs)+      cs <- noTakenNames $ sconcat <$> toConcrete cs+      return (C.AbsurdRHS, [], List1.toList es, List1.toList cs)     toConcrete (A.RewriteRHS xeqs _spats rhs wh) = do       wh <- maybe (return []) toConcrete $ A.whereDecls wh       (rhs, eqs', es, whs) <- toConcrete rhs@@ -1057,17 +1146,9 @@     Rewrite es    -> Rewrite <$> mapM (toConcrete . (\ (_, e) -> ((),e))) es     Invert qn pes -> fmap (Invert ()) $ forM pes $ \ (Named n pe) -> do       pe <- toConcrete pe-      n  <- toConcrete n+      n  <- fmap C.boundName <$> toConcrete n       pure $ Named n pe--instance ToConcrete (Maybe A.BindName) where-  type ConOfAbs (Maybe A.BindName) = Maybe C.Name-  toConcrete = traverse (C.boundName <.> toConcrete)--instance ToConcrete (Maybe A.QName) where-  type ConOfAbs (Maybe A.QName) = Maybe C.Name--  toConcrete = mapM (toConcrete . qnameName)+    LeftLet pes -> LeftLet <$> mapM toConcrete pes  instance ToConcrete (Constr A.Constructor) where   type ConOfAbs (Constr A.Constructor) = C.Declaration@@ -1077,19 +1158,19 @@   toConcrete (Constr (A.Axiom _ i info Nothing x t)) = do     x' <- unsafeQNameToName <$> toConcrete x     t' <- toConcreteTop t-    return $ C.TypeSig info Nothing x' t'+    return $ C.TypeSig info empty x' t'   toConcrete (Constr (A.Axiom _ _ _ (Just _) _ _)) = __IMPOSSIBLE__-  toConcrete (Constr d) = head <$> toConcrete d+  toConcrete (Constr d) = headWithDefault __IMPOSSIBLE__ <$> toConcrete d  instance (ToConcrete a, ConOfAbs a ~ C.LHS) => ToConcrete (A.Clause' a) where-  type ConOfAbs (A.Clause' a) = [C.Declaration]+  type ConOfAbs (A.Clause' a) = List1 C.Declaration    toConcrete (A.Clause lhs _ rhs wh catchall) =       bindToConcrete lhs $ \case           C.LHS p _ _ -> do             bindToConcrete wh $ \ wh' -> do                 (rhs', eqs, with, wcs) <- toConcreteTop rhs-                return $ FunClause (C.LHS p eqs with) rhs' wh' catchall : wcs+                return $ FunClause (C.LHS p eqs with) rhs' wh' catchall :| wcs  instance ToConcrete A.ModuleApplication where   type ConOfAbs A.ModuleApplication = C.ModuleApplication@@ -1099,12 +1180,22 @@     bindToConcrete tel $ \ tel -> do       es <- toConcreteCtx argumentCtx_ es       let r = fuseRange y es-      return $ C.SectionApp r (catMaybes tel) (foldl (C.App r) (C.Ident y) es)+      return $ C.SectionApp r (catMaybes tel) y $ map unNamedArg es    toConcrete (A.RecordModuleInstance recm) = do     recm <- toConcrete recm     return $ C.RecordModuleInstance (getRange recm) recm +instance ToConcrete A.RecordDirectives where+  type ConOfAbs A.RecordDirectives = [C.RecordDirective]++  toConcrete dir = C.ungatherRecordDirectives <$> traverse f dir+    where+      f :: MonadToConcrete m => RecordConName -> m (Maybe (C.Name, IsInstance))+      f (FreshRecCon _) = pure Nothing+      f (NamedRecCon nm) = Just . (, NotInstanceDef) . C.unqualify <$> toConcrete nm++ instance ToConcrete A.Declaration where   type ConOfAbs A.Declaration = [C.Declaration] @@ -1119,20 +1210,20 @@       return $         (case mp of            Nothing   -> []-           Just occs -> [C.Pragma (PolarityPragma noRange x' occs)]) ++-        [C.Postulate (getRange i) [C.TypeSig info Nothing x' t']]+           Just occs -> [C.Pragma (PolarityPragma noRange x' $ List1.toList occs)]) +++        [C.Postulate empty [C.TypeSig info empty x' t']]    toConcrete (A.Generalize s i j x t) = do     x' <- unsafeQNameToName <$> toConcrete x-    tac <- traverse toConcrete (defTactic i)+    tac <- toConcrete (defTactic i)     withAbstractPrivate i $       withInfixDecl i x'  $ do       t' <- toConcreteTop t-      return [C.Generalize (getRange i) [C.TypeSig j tac x' $ C.Generalized t']]+      return [C.Generalize empty [C.TypeSig j tac x' $ C.Generalized t']]    toConcrete (A.Field i x t) = do     x' <- unsafeQNameToName <$> toConcrete x-    tac <- traverse toConcrete (defTactic i)+    tac <- toConcrete (defTactic i)     withAbstractPrivate i $       withInfixDecl i x'  $ do       t' <- toConcreteTop t@@ -1143,18 +1234,19 @@     withAbstractPrivate i $       withInfixDecl i x'  $ do       t' <- traverse toConcreteTop t-      return [C.Primitive (getRange i) [C.TypeSig (argInfo t') Nothing x' (unArg t')]]+      return [C.Primitive empty [C.TypeSig (argInfo t') empty x' (unArg t')]]         -- Primitives are always relevant. -  toConcrete (A.FunDef i _ _ cs) =-    withAbstractPrivate i $ concat <$> toConcrete cs+  toConcrete (A.FunDef i _ cs) =+    withAbstractPrivate i $ List1.concat <$> toConcrete cs -  toConcrete (A.DataSig i x bs t) =+  toConcrete (A.DataSig i erased x bs t) =     withAbstractPrivate i $     bindToConcrete (A.generalizeTel bs) $ \ tel' -> do       x' <- unsafeQNameToName <$> toConcrete x       t' <- toConcreteTop t-      return [ C.DataSig (getRange i) x' (map C.DomainFull $ catMaybes tel') t' ]+      return [ C.DataSig (getRange i) erased x'+                 (map C.DomainFull $ catMaybes tel') t' ]    toConcrete (A.DataDef i x uc bs cs) =     withAbstractPrivate i $@@ -1162,34 +1254,36 @@       (x',cs') <- first unsafeQNameToName <$> toConcrete (x, map Constr cs)       return [ C.DataDef (getRange i) x' (catMaybes tel') cs' ] -  toConcrete (A.RecSig i x bs t) =+  toConcrete (A.RecSig i erased x bs t) =     withAbstractPrivate i $     bindToConcrete (A.generalizeTel bs) $ \ tel' -> do       x' <- unsafeQNameToName <$> toConcrete x       t' <- toConcreteTop t-      return [ C.RecordSig (getRange i) x' (map C.DomainFull $ catMaybes tel') t' ]+      return [ C.RecordSig (getRange i) erased x'+                 (map C.DomainFull $ catMaybes tel') t' ]    toConcrete (A.RecDef  i x uc dir bs t cs) =     withAbstractPrivate i $     bindToConcrete (map makeDomainFree $ dataDefParams bs) $ \ tel' -> do+      dirs <- toConcrete dir       (x',cs') <- first unsafeQNameToName <$> toConcrete (x, map Constr cs)-      return [ C.RecordDef (getRange i) x' (dir { recConstructor = Nothing }) (catMaybes tel') cs' ]+      return [ C.RecordDef (getRange i) x' dirs (catMaybes tel') cs' ] -  toConcrete (A.Mutual i ds) = declsToConcrete ds+  toConcrete (A.Mutual i ds) = pure . C.Mutual empty <$> declsToConcrete ds -  toConcrete (A.Section i x (A.GeneralizeTel _ tel) ds) = do+  toConcrete (A.Section i erased x (A.GeneralizeTel _ tel) ds) = do     x <- toConcrete x     bindToConcrete tel $ \ tel -> do       ds <- declsToConcrete ds-      return [ C.Module (getRange i) x (catMaybes tel) ds ]+      return [ C.Module (getRange i) erased x (catMaybes tel) ds ] -  toConcrete (A.Apply i x modapp _ _) = do+  toConcrete (A.Apply i erased x modapp _ _) = do     x  <- unsafeQNameToName <$> toConcrete x     modapp <- toConcrete modapp     let r = getRange modapp         open = fromMaybe DontOpen $ minfoOpenShort i         dir  = fromMaybe defaultImportDir{ importDirRange = r } $ minfoDirective i-    return [ C.ModuleMacro (getRange i) x modapp open dir ]+    return [ C.ModuleMacro (getRange i) erased x modapp open dir ]    toConcrete (A.Import i x _) = do     x <- toConcrete x@@ -1205,11 +1299,11 @@     x <- toConcrete x     return [C.Open (getRange i) x defaultImportDir] -  toConcrete (A.PatternSynDef x xs p) = do-    C.QName x <- toConcrete x-    bindToConcrete (map (fmap A.unBind) xs) $ \ xs ->+  toConcrete (A.PatternSynDef x xs p) = toConcrete x >>= \case+    C.QName x -> bindToConcrete (map (fmap A.unBind) xs) \ xs ->       singleton . C.PatternSyn (getRange x) x xs <$> do         dontFoldPatternSynonyms $ toConcrete (vacuous p :: A.Pattern)+    _ -> __IMPOSSIBLE__    toConcrete (A.UnquoteDecl _ i xs e) = do     let unqual (C.QName x) = return x@@ -1223,6 +1317,8 @@     xs <- mapM (unqual <=< toConcrete) xs     (:[]) . C.UnquoteDef (getRange i) xs <$> toConcrete e +  toConcrete (A.UnquoteData i xs uc j cs e) = __IMPOSSIBLE__+  toConcrete (A.UnfoldingDecl r ns) = pure []  data RangeAndPragma = RangeAndPragma Range A.Pragma @@ -1239,7 +1335,10 @@       return $ C.CompilePragma r b x s     A.StaticPragma x -> C.StaticPragma r <$> toConcrete x     A.InjectivePragma x -> C.InjectivePragma r <$> toConcrete x+    A.InjectiveForInferencePragma x -> C.InjectiveForInferencePragma r <$> toConcrete x     A.InlinePragma b x -> C.InlinePragma r b <$> toConcrete x+    A.NotProjectionLikePragma q -> C.NotProjectionLikePragma r <$> toConcrete q+    A.OverlapPragma q i -> C.OverlapPragma r <$> (fmap pure (toConcrete q)) <*> pure i     A.EtaPragma x    -> C.EtaPragma    r <$> toConcrete x     A.DisplayPragma f ps rhs ->       C.DisplayPragma r <$> toConcrete (A.DefP (PatRange noRange) (unambiguous f) ps) <*> toConcrete rhs@@ -1305,12 +1404,13 @@         | otherwise          -> bindToConcrete (map UserPattern args) $ ret . A.ConP i c       A.DefP i f args        -> bindToConcrete (map UserPattern args) $ ret . A.DefP i f       A.PatternSynP i f args -> bindToConcrete (map UserPattern args) $ ret . A.PatternSynP i f-      A.RecP i args          -> bindToConcrete ((map . fmap) UserPattern args) $ ret . A.RecP i+      A.RecP kwr i args+        | conPatOrigin i == ConOSplit -> ret p+        | otherwise          -> bindToConcrete ((map . fmap) UserPattern args) $ ret . A.RecP kwr i       A.AsP i x p            -> bindName' (unBind x) $                                 bindToConcrete (UserPattern p) $ \ p ->                                 ret (A.AsP i x p)       A.WithP i p            -> bindToConcrete (UserPattern p) $ ret . A.WithP i-      A.AnnP i a p           -> bindToConcrete (UserPattern p) $ ret . A.AnnP i a  instance ToConcrete (UserPattern (NamedArg A.Pattern)) where   type ConOfAbs (UserPattern (NamedArg A.Pattern)) = NamedArg A.Pattern@@ -1342,11 +1442,13 @@         | otherwise          -> bindToConcrete (map SplitPattern args) $ ret . A.ConP i c       A.DefP i f args        -> bindToConcrete (map SplitPattern args) $ ret . A.DefP i f       A.PatternSynP i f args -> bindToConcrete (map SplitPattern args) $ ret . A.PatternSynP i f-      A.RecP i args          -> bindToConcrete ((map . fmap) SplitPattern args) $ ret . A.RecP i+      A.RecP kwr i args+        | conPatOrigin i == ConOSplit+                             -> bindToConcrete ((map . fmap) BindingPat args) $ ret . A.RecP kwr i+        | otherwise          -> bindToConcrete ((map . fmap) SplitPattern args) $ ret . A.RecP kwr i       A.AsP i x p            -> bindToConcrete (SplitPattern p)  $ \ p ->                                 ret (A.AsP i x p)       A.WithP i p            -> bindToConcrete (SplitPattern p) $ ret . A.WithP i-      A.AnnP i a p           -> bindToConcrete (SplitPattern p) $ ret . A.AnnP i a  instance ToConcrete (SplitPattern (NamedArg A.Pattern)) where   type ConOfAbs (SplitPattern (NamedArg A.Pattern)) = NamedArg A.Pattern@@ -1374,12 +1476,11 @@       A.ConP i c args        -> bindToConcrete (map (updateNamedArg BindingPat) args) $ ret . A.ConP i c       A.DefP i f args        -> bindToConcrete (map (updateNamedArg BindingPat) args) $ ret . A.DefP i f       A.PatternSynP i f args -> bindToConcrete (map (updateNamedArg BindingPat) args) $ ret . A.PatternSynP i f-      A.RecP i args          -> bindToConcrete ((map . fmap)        BindingPat args) $ ret . A.RecP i+      A.RecP kwr i args      -> bindToConcrete ((map . fmap)        BindingPat  args) $ ret . A.RecP kwr i       A.AsP i x p            -> bindToConcrete (FreshenName x) $ \ x ->                                 bindToConcrete (BindingPat p)  $ \ p ->                                 ret (A.AsP i (mkBindName x) p)       A.WithP i p            -> bindToConcrete (BindingPat p) $ ret . A.WithP i-      A.AnnP i a p           -> bindToConcrete (BindingPat p) $ ret . A.AnnP i a  instance ToConcrete A.Pattern where   type ConOfAbs A.Pattern = C.Pattern@@ -1392,15 +1493,15 @@   toConcrete p =     case p of       A.VarP x ->-        C.IdentP . C.QName . C.boundName <$> toConcrete x+        C.IdentP True . C.QName . C.boundName <$> toConcrete x        A.WildP i ->         return $ C.WildP (getRange i)        A.ConP i c args  -> tryOp (headAmbQ c) (A.ConP i c) args -      A.ProjP i ProjPrefix p -> C.IdentP <$> toConcrete (headAmbQ p)-      A.ProjP i _          p -> C.DotP noRange . C.Ident <$> toConcrete (headAmbQ p)+      A.ProjP i ProjPrefix p -> C.IdentP True <$> toConcrete (headAmbQ p)+      A.ProjP i _          p -> C.DotP empty noRange . C.Ident <$> toConcrete (headAmbQ p)        A.DefP i x args -> tryOp (headAmbQ x) (A.DefP i x)  args @@ -1413,14 +1514,16 @@        A.LitP i (LitQName x) -> do         x <- lookupQName AmbiguousNothing x-        bracketP_ appBrackets $ return $ C.AppP (C.QuoteP (getRange i)) (defaultNamedArg (C.IdentP x))+        bracketP_ appBrackets $ return $+          C.AppP (C.QuoteP (getRange i))+            (defaultNamedArg (C.IdentP True x))       A.LitP i l ->         return $ C.LitP (getRange i) l        -- Andreas, 2018-06-19, issue #3130       -- Print .p as .(p) if p is a projection       -- to avoid confusion with projection pattern.-      A.DotP i e@A.Proj{} -> C.DotP r . C.Paren r <$> toConcreteCtx TopCtx e+      A.DotP i e@A.Proj{} -> C.DotP empty r . C.Paren r <$> toConcreteCtx TopCtx e         where r = getRange i        -- gallais, 2019-02-12, issue #3491@@ -1435,7 +1538,7 @@           -- If we do then we print .(v) rather than .v           Right FieldName{} -> do             reportSLn "print.dotted" 50 $ "Wrapping ambiguous name " ++ prettyShow (nameConcrete v)-            C.DotP r . C.Paren r <$> toConcrete (A.Var v)+            C.DotP empty r . C.Paren r <$> toConcrete (A.Var v)           Right _ -> printDotDefault i e           Left _ -> __IMPOSSIBLE__ @@ -1446,16 +1549,14 @@        A.PatternSynP i n args -> tryOp (headAmbQ n) (A.PatternSynP i n) args -      A.RecP i as ->-        C.RecP (getRange i) <$> mapM (traverse toConcrete) as+      A.RecP kwr i as ->+        C.RecP kwr (getRange i) <$> mapM (traverse toConcrete) as        A.WithP i p -> C.WithP (getRange i) <$> toConcreteCtx WithArgCtx p -      A.AnnP i a p -> toConcrete p -- TODO: print type annotation-     where -    printDotDefault :: PatInfo -> A.Expr -> AbsToCon C.Pattern+    printDotDefault :: MonadToConcrete m => PatInfo -> A.Expr -> m C.Pattern     printDotDefault i e = do       c <- toConcreteCtx DotPatternCtx e       let r = getRange i@@ -1463,9 +1564,9 @@         -- Andreas, 2016-02-04 print ._ pattern as _ pattern,         -- following the fusing of WildP and ImplicitP.         C.Underscore{} -> return $ C.WildP r-        _ -> return $ C.DotP r c+        _ -> return $ C.DotP empty r c -    tryOp :: A.QName -> (A.Patterns -> A.Pattern) -> A.Patterns -> AbsToCon C.Pattern+    tryOp :: MonadToConcrete m => A.QName -> (A.Patterns -> A.Pattern) -> A.Patterns -> m C.Pattern     tryOp x f args = do       -- Andreas, 2016-02-04, Issue #1792       -- To prevent failing of tryToRecoverOpAppP for overapplied operators,@@ -1475,24 +1576,31 @@       let funCtx = applyUnless (null args2) (withPrecedence FunctionCtx)       tryToRecoverPatternSynP (f args) $ funCtx (tryToRecoverOpAppP $ f args1) >>= \case         Just c  -> applyTo args2 c-        Nothing -> applyTo args . C.IdentP =<< toConcrete x+        Nothing -> applyTo args . C.IdentP True =<< toConcrete x     -- Note: applyTo [] c = return c     applyTo args c = bracketP_ (appBracketsArgs args) $ do-      foldl C.AppP c <$> toConcreteCtx argumentCtx_ args--instance ToConcrete (Maybe A.Pattern) where-  type ConOfAbs (Maybe A.Pattern) = Maybe C.Pattern+      foldl C.AppP c <$>+        (mapM avoidPun =<< toConcreteCtx argumentCtx_ args) -  toConcrete = traverse toConcrete+    -- If --hidden-argument-puns is active, then {x} is replaced by+    -- {(x)} and ⦃ x ⦄ by ⦃ (x) ⦄.+    avoidPun :: MonadToConcrete m => NamedArg C.Pattern -> m (NamedArg C.Pattern)+    avoidPun arg =+      ifM (optHiddenArgumentPuns <$> pragmaOptions)+          (return $ case arg of+             Arg i (Named Nothing x@C.IdentP{}) | notVisible i ->+               Arg i (Named Nothing (C.ParenP noRange x))+             arg -> arg)+          (return arg)  -- Helpers for recovering natural number literals -tryToRecoverNatural :: A.Expr -> AbsToCon C.Expr -> AbsToCon C.Expr+tryToRecoverNatural :: MonadToConcrete m => A.Expr -> m C.Expr -> m C.Expr tryToRecoverNatural e def = do   is <- isBuiltinFun   caseMaybe (recoverNatural is e) def $ return . C.Lit noRange . LitNat -recoverNatural :: (A.QName -> String -> Bool) -> A.Expr -> Maybe Integer+recoverNatural :: (A.QName -> BuiltinId -> Bool) -> A.Expr -> Maybe Integer recoverNatural is e = explore (`is` builtinZero) (`is` builtinSuc) 0 e   where     explore :: (A.QName -> Bool) -> (A.QName -> Bool) -> Integer -> A.Expr -> Maybe Integer@@ -1529,22 +1637,21 @@ getHead (A.PatternSyn n) = Just (HdSyn $ headAmbQ n) getHead _                = Nothing -cOpApp :: Range -> C.QName -> A.Name -> List1 (MaybeSection C.Expr) -> C.Expr-cOpApp r x n es =-  C.OpApp r x (Set.singleton n) $+cOpApp :: Asp.NameKind -> Range -> C.QName -> A.Name -> List1 (MaybeSection C.Expr) -> C.Expr+cOpApp nk r x n es =+  C.KnownOpApp nk r x (singleton n) $   fmap (defaultNamedArg . placeholder) $-  List1.toList eps+  List1.zip es positions   where     x0 = C.unqualify x     positions | isPrefix  x0 =              (const Middle <$> List1.drop 1 es) `List1.snoc` End               | isPostfix x0 = Beginning :| (const Middle <$> List1.drop 1 es)               | isInfix x0   = Beginning :| (const Middle <$> List1.drop 2 es) ++ [ End ]               | otherwise    =               const Middle <$> es-    eps = List1.zip es positions     placeholder (YesSection , pos ) = Placeholder pos     placeholder (NoSection e, _pos) = noPlaceholder (Ordinary e) -tryToRecoverOpApp :: A.Expr -> AbsToCon C.Expr -> AbsToCon C.Expr+tryToRecoverOpApp :: MonadToConcrete m => A.Expr -> m C.Expr -> m C.Expr tryToRecoverOpApp e def = fromMaybeM def $   recoverOpApp bracket (isLambda . defaultNamedArg) cOpApp view e   where@@ -1582,9 +1689,9 @@     view e = (, (map . fmap . fmap) NoSection args) <$> getHead hd       where Application hd args = A.appView' e -tryToRecoverOpAppP :: A.Pattern -> AbsToCon (Maybe C.Pattern)+tryToRecoverOpAppP :: MonadToConcrete m => A.Pattern -> m (Maybe C.Pattern) tryToRecoverOpAppP p = do-  res <- recoverOpApp bracketP_ (const False) opApp view p+  res <- recoverOpApp bracketP_ (const False) (const opApp) view p   reportS "print.op" 90     [ "tryToRecoverOpApp"     , "in:  " ++ show p@@ -1592,10 +1699,10 @@     ]   return res   where-    opApp r x n ps = C.OpAppP r x (Set.singleton n) $+    opApp r x n ps = C.OpAppP r x (singleton n) $       fmap (defaultNamedArg . fromNoSection __IMPOSSIBLE__) $       -- `view` does not generate any `Nothing`s-      List1.toList ps+      ps      appInfo = defaultAppInfo_ @@ -1607,13 +1714,13 @@       _                   -> Nothing       -- ProjP _ _ d   -> Just (HdDef (headAmbQ d), [])   -- ? Andreas, 2016-04-21 -recoverOpApp :: forall a c . (ToConcrete a, c ~ ConOfAbs a, HasRange c)-  => ((PrecedenceStack -> Bool) -> AbsToCon c -> AbsToCon c)+recoverOpApp :: forall a c m. (ToConcrete a, c ~ ConOfAbs a, HasRange c, MonadToConcrete m)+  => ((PrecedenceStack -> Bool) -> m c -> m c)   -> (a -> Bool)  -- ^ Check for lambdas-  -> (Range -> C.QName -> A.Name -> List1 (MaybeSection c) -> c)  -- ^ @opApp@+  -> (Asp.NameKind -> Range -> C.QName -> A.Name -> List1 (MaybeSection c) -> c)  -- ^ @opApp@   -> (a -> Maybe (Hd, [NamedArg (MaybeSection (AppInfo, a))]))   -> a-  -> AbsToCon (Maybe c)+  -> m (Maybe c) recoverOpApp bracket isLam opApp view e = case view e of   Nothing -> mDefault   Just (hd, args)@@ -1639,30 +1746,30 @@      YesSection       -> False      NoSection (i, e) -> isLam e && preferParenless (appParens i) -  doQNameHelper :: Either A.Name A.QName -> [MaybeSection (AppInfo, a)] -> AbsToCon (Maybe c)+  doQNameHelper :: MonadToConcrete m => Either A.Name A.QName -> [MaybeSection (AppInfo, a)] -> m (Maybe c)   doQNameHelper n args = do     x <- either (C.QName <.> toConcrete) toConcrete n     let n' = either id A.qnameName n     -- #1346: The fixity of the abstract name is not necessarily correct, it depends on which     -- concrete name we choose! Make sure to resolve ambiguities with n'.-    fx <- resolveName_ x [n'] <&> \ case-            VarName y _                -> y ^. lensFixity-            DefinedName _ q _          -> q ^. lensFixity-            FieldName (q :| _)         -> q ^. lensFixity-            ConstructorName _ (q :| _) -> q ^. lensFixity-            PatternSynResName (q :| _) -> q ^. lensFixity-            UnknownName                -> noFixity+    (fx, nk) <- resolveName_ x n' <&> \ case+      VarName y _                -> (y ^. lensFixity, Asp.Bound)+      DefinedName _ q _          -> (q ^. lensFixity, Asp.Function)+      FieldName (q :| _)         -> (q ^. lensFixity, Asp.Field)+      ConstructorName _ (q :| _) -> (q ^. lensFixity, Asp.Constructor Asp.Inductive)+      PatternSynResName (q :| _) -> (q ^. lensFixity, Asp.Constructor Asp.Inductive)+      UnknownName                -> (noFixity, Asp.Bound)     List1.ifNull args {-then-} mDefault {-else-} $ \ as ->-      doQName fx x n' as (C.nameParts $ C.unqualify x)+      doQName nk fx x n' as (C.nameParts $ C.unqualify x) -  doQName :: Fixity -> C.QName -> A.Name -> List1 (MaybeSection (AppInfo, a)) -> NameParts -> AbsToCon (Maybe c)+  doQName :: MonadToConcrete m => Asp.NameKind -> Fixity -> C.QName -> A.Name -> List1 (MaybeSection (AppInfo, a)) -> NameParts -> m (Maybe c)    -- fall-back (wrong number of arguments or no holes)-  doQName _ x _ as xs+  doQName nk _ x _ as xs     | length as /= numHoles x = mDefault    -- binary case-  doQName fixity x n (a1 :| as) xs+  doQName nk fixity x n (a1 :| as) xs     | Hole <- List1.head xs     , Hole <- List1.last xs = do         let (as', an) = List1.ifNull as {-then-} __IMPOSSIBLE__ {-else-} List1.initLast@@ -1671,20 +1778,20 @@             e1 <- traverse (toConcreteCtx (LeftOperandCtx fixity) . snd) a1             es <- (mapM . traverse) (toConcreteCtx InsideOperandCtx . snd) as'             en <- traverse (uncurry $ toConcreteCtx . RightOperandCtx fixity . appParens) an-            return $ opApp (getRange (e1, en)) x n (e1 :| es ++ [en])+            return $ opApp nk (getRange (e1, en)) x n (e1 :| es ++ [en])    -- prefix-  doQName fixity x n as xs+  doQName nk fixity x n as xs     | Hole <- List1.last xs = do         let (as', an) = List1.initLast as         Just <$> do           bracket (opBrackets' (skipParens an) fixity) $ do             es <- (mapM . traverse) (toConcreteCtx InsideOperandCtx . snd) as'             en <- traverse (\ (i, e) -> toConcreteCtx (RightOperandCtx fixity $ appParens i) e) an-            return $ opApp (getRange (n, en)) x n (List1.snoc es en)+            return $ opApp nk (getRange (n, en)) x n (List1.snoc es en)    -- postfix-  doQName fixity x n as xs+  doQName nk fixity x n as xs     | Hole <- List1.head xs = do         let a1  = List1.head as             as' = List1.tail as@@ -1692,19 +1799,19 @@         es <- (mapM . traverse) (toConcreteCtx InsideOperandCtx . snd) as'         Just <$> do           bracket (opBrackets fixity) $-            return $ opApp (getRange (e1, n)) x n (e1 :| es)+            return $ opApp nk (getRange (e1, n)) x n (e1 :| es)    -- roundfix-  doQName _ x n as _ = do+  doQName nk _ x n as _ = do     es <- (mapM . traverse) (toConcreteCtx InsideOperandCtx . snd) as     Just <$> do       bracket roundFixBrackets $-        return $ opApp (getRange x) x n es+        return $ opApp nk (getRange x) x n es  -- Recovering pattern synonyms --------------------------------------------  -- | Recover pattern synonyms for expressions.-tryToRecoverPatternSyn :: A.Expr -> AbsToCon C.Expr -> AbsToCon C.Expr+tryToRecoverPatternSyn :: MonadToConcrete m => A.Expr -> m C.Expr -> m C.Expr tryToRecoverPatternSyn e fallback   | userWritten e = fallback   | litOrCon e    = recoverPatternSyn apply matchPatternSyn e fallback@@ -1723,15 +1830,17 @@     apply c args = A.unAppView $ Application (A.PatternSyn $ unambiguous c) args  -- | Recover pattern synonyms in patterns.-tryToRecoverPatternSynP :: A.Pattern -> AbsToCon C.Pattern -> AbsToCon C.Pattern+tryToRecoverPatternSynP :: MonadToConcrete m => A.Pattern -> m C.Pattern -> m C.Pattern tryToRecoverPatternSynP = recoverPatternSyn apply matchPatternSynP   where apply c args = PatternSynP patNoRange (unambiguous c) args --- | General pattern synonym recovery parameterised over expression type-recoverPatternSyn :: ToConcrete a =>-  (A.QName -> [NamedArg a] -> a)         -> -- applySyn-  (PatternSynDefn -> a -> Maybe [Arg a]) -> -- match-  a -> AbsToCon (ConOfAbs a) -> AbsToCon (ConOfAbs a)+-- | General pattern synonym recovery parameterised over expression type.+recoverPatternSyn :: forall a m. (ToConcrete a, MonadToConcrete m)+  => (A.QName -> [NamedArg a] -> a)                 -- applySyn+  -> (PatternSynDefn -> a -> Maybe [WithHiding a])  -- match+  -> a                                              -- expressions+  -> m (ConOfAbs a)                       -- fallback+  -> m (ConOfAbs a) recoverPatternSyn applySyn match e fallback = do   doFold <- asks foldPatternSynonyms   if not doFold then fallback else do@@ -1758,8 +1867,9 @@       , prettyList_ $ map (\ (q,_,_) -> q) cands       ]     case sortBy cmp cands of-      (q, args, _) : _ -> toConcrete $ applySyn q $ (map . fmap) unnamed args-      []               -> fallback+      (q, args, _) : _ -> toConcrete $ applySyn q $+        for args $ \ (WithHiding h arg) -> setHiding h $ defaultNamedArg arg+      [] -> fallback   where     -- Heuristic to pick the best pattern synonym: the one that folds the most     -- constructors.@@ -1776,5 +1886,5 @@  instance ToConcrete NamedMeta where     type ConOfAbs NamedMeta = C.Expr-    toConcrete i = do-      return $ C.Underscore noRange (Just $ prettyShow i)+    toConcrete i =+      C.Underscore noRange . Just . render <$> prettyTCM i
src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs view
@@ -1,3047 +1,3676 @@--{-| Translation from "Agda.Syntax.Concrete" to "Agda.Syntax.Abstract". Involves scope analysis,-    figuring out infix operator precedences and tidying up definitions.--}-module Agda.Syntax.Translation.ConcreteToAbstract-    ( ToAbstract(..), localToAbstract-    , concreteToAbstract_-    , concreteToAbstract-    , NewModuleQName(..)-    , TopLevel(..)-    , TopLevelInfo(..)-    , topLevelModuleName-    , AbstractRHS-    , NewModuleName, OldModuleName-    , NewName, OldQName-    , PatName, APatName-    , importPrimitives-    ) where--import Prelude hiding ( null )--import Control.Monad        ( (<=<), foldM, forM, forM_, zipWithM, zipWithM_ )-import Control.Applicative  ( liftA2, liftA3 )-import Control.Monad.Except ( MonadError(..) )--import Data.Bifunctor-import Data.Foldable (traverse_)-import Data.Set (Set)-import Data.Map (Map)-import Data.Functor (void)-import qualified Data.List as List-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty-import qualified Data.Set as Set-import qualified Data.Map as Map-import Data.Maybe-import Data.Monoid (First(..))-import Data.Void--import Agda.Syntax.Concrete as C hiding (topLevelModuleName)-import Agda.Syntax.Concrete.Generic-import Agda.Syntax.Concrete.Operators-import Agda.Syntax.Concrete.Pattern-import Agda.Syntax.Abstract as A-import Agda.Syntax.Abstract.Pattern as A ( patternVars, checkPatternLinearity, containsAsPattern, lhsCoreApp, lhsCoreWith )-import Agda.Syntax.Abstract.Pretty-import qualified Agda.Syntax.Internal as I-import Agda.Syntax.Position-import Agda.Syntax.Literal-import Agda.Syntax.Common-import Agda.Syntax.Info-import Agda.Syntax.Concrete.Definitions as C-import Agda.Syntax.Fixity-import Agda.Syntax.Concrete.Fixity (DoWarn(..))-import Agda.Syntax.Notation-import Agda.Syntax.Scope.Base as A-import Agda.Syntax.Scope.Monad-import Agda.Syntax.Translation.AbstractToConcrete (ToConcrete, ConOfAbs)-import Agda.Syntax.DoNotation-import Agda.Syntax.IdiomBrackets--import Agda.TypeChecking.Monad.Base hiding (ModuleInfo, MetaInfo)-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Monad.Trace (traceCall, setCurrentRange)-import Agda.TypeChecking.Monad.State-import Agda.TypeChecking.Monad.MetaVars (registerInteractionPoint)-import Agda.TypeChecking.Monad.Debug-import Agda.TypeChecking.Monad.Env (insideDotPattern, isInsideDotPattern, getCurrentPath)-import Agda.TypeChecking.Rules.Builtin (isUntypedBuiltin, bindUntypedBuiltin, builtinKindOfName)--import Agda.TypeChecking.Patterns.Abstract (expandPatternSynonyms)-import Agda.TypeChecking.Pretty hiding (pretty, prettyA)-import Agda.TypeChecking.Quote (quotedName)-import Agda.TypeChecking.Warnings--import Agda.Interaction.FindFile (checkModuleName, rootNameModule, SourceFile(SourceFile))--- import Agda.Interaction.Imports  -- for type-checking in ghci-import {-# SOURCE #-} Agda.Interaction.Imports (scopeCheckImport)-import Agda.Interaction.Options-import qualified Agda.Interaction.Options.Lenses as Lens-import Agda.Interaction.Options.Warnings--import qualified Agda.Utils.AssocList as AssocList-import Agda.Utils.CallStack ( HasCallStack, withCurrentCallStack )-import Agda.Utils.Char-import Agda.Utils.Either-import Agda.Utils.FileName-import Agda.Utils.Functor-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.List1 ( List1, pattern (:|) )-import Agda.Utils.List2 ( List2, pattern List2 )-import qualified Agda.Utils.List1 as List1-import qualified Agda.Utils.Map as Map-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import qualified Agda.Utils.Pretty as P-import Agda.Utils.Pretty (render, Pretty, pretty, prettyShow)-import Agda.Utils.Singleton-import Agda.Utils.Tuple--import Agda.Utils.Impossible-import Agda.ImpossibleTest (impossibleTest, impossibleTestReduceM)--{---------------------------------------------------------------------------    Exceptions- --------------------------------------------------------------------------}--notAnExpression :: (HasCallStack, MonadTCError m) => C.Expr -> m a-notAnExpression = locatedTypeError NotAnExpression--nothingAppliedToHiddenArg :: (HasCallStack, MonadTCError m) => C.Expr -> m a-nothingAppliedToHiddenArg = locatedTypeError NothingAppliedToHiddenArg--nothingAppliedToInstanceArg :: (HasCallStack, MonadTCError m) => C.Expr -> m a-nothingAppliedToInstanceArg = locatedTypeError NothingAppliedToInstanceArg--notAValidLetBinding :: (HasCallStack, MonadTCError m) => C.NiceDeclaration -> m a-notAValidLetBinding = locatedTypeError NotAValidLetBinding--{---------------------------------------------------------------------------    Helpers- --------------------------------------------------------------------------}---UNUSED Liang-Ting Chen 2019-07-16---annotateDecl :: ScopeM A.Declaration -> ScopeM A.Declaration---annotateDecl m = annotateDecls $ (:[]) <$> m---- | Make sure that there are no dot patterns (called on pattern synonyms).-noDotorEqPattern :: String -> A.Pattern' e -> ScopeM (A.Pattern' Void)-noDotorEqPattern err = dot-  where-    dot :: A.Pattern' e -> ScopeM (A.Pattern' Void)-    dot = \case-      A.VarP x               -> pure $ A.VarP x-      A.ConP i c args        -> A.ConP i c <$> (traverse $ traverse $ traverse dot) args-      A.ProjP i o d          -> pure $ A.ProjP i o d-      A.WildP i              -> pure $ A.WildP i-      A.AsP i x p            -> A.AsP i x <$> dot p-      A.DotP{}               -> genericError err-      A.EqualP{}             -> genericError err   -- Andrea: so we also disallow = patterns, reasonable?-      A.AbsurdP i            -> pure $ A.AbsurdP i-      A.LitP i l             -> pure $ A.LitP i l-      A.DefP i f args        -> A.DefP i f <$> (traverse $ traverse $ traverse dot) args-      A.PatternSynP i c args -> A.PatternSynP i c <$> (traverse $ traverse $ traverse dot) args-      A.RecP i fs            -> A.RecP i <$> (traverse $ traverse dot) fs-      A.WithP i p            -> A.WithP i <$> dot p-      A.AnnP i a p           -> genericError err   -- TODO: should this be allowed?---UNUSED Liang-Ting Chen 2019-07-16----- | Make sure that there are no dot patterns (WAS: called on pattern synonyms).---noDotPattern :: String -> A.Pattern' e -> ScopeM (A.Pattern' Void)---noDotPattern err = traverse $ const $ genericError err--newtype RecordConstructorType = RecordConstructorType [C.Declaration]--instance ToAbstract RecordConstructorType where-  type AbsOfCon RecordConstructorType = A.Expr-  toAbstract (RecordConstructorType ds) = recordConstructorType ds---- | Compute the type of the record constructor (with bogus target type)-recordConstructorType :: [C.Declaration] -> ScopeM A.Expr-recordConstructorType decls =-    -- Nicify all declarations since there might be fixity declarations after-    -- the the last field. Use NoWarn to silence fixity warnings. We'll get-    -- them again when scope checking the declarations to build the record-    -- module.-    niceDecls NoWarn decls $ buildType . takeFields-  where-    takeFields = List.dropWhileEnd notField--    notField NiceField{} = False-    notField _           = True--    buildType :: [C.NiceDeclaration] -> ScopeM A.Expr-      -- TODO: Telescope instead of Expr in abstract RecDef-    buildType ds = do-      dummy <- A.Def . fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSet-      tel   <- catMaybes <$> mapM makeBinding ds-      return $ A.mkPi (ExprRange (getRange ds)) tel dummy--    makeBinding :: C.NiceDeclaration -> ScopeM (Maybe A.TypedBinding)-    makeBinding d = do-      let failure = typeError $ NotValidBeforeField d-          r       = getRange d-          mkLet d = Just . A.TLet r <$> toAbstract (LetDef d)-      traceCall (SetRange r) $ case d of--        C.NiceField r pr ab inst tac x a -> do-          fx  <- getConcreteFixity x-          let bv = unnamed (C.mkBinder $ (C.mkBoundName x fx) { bnameTactic = tac }) <$ a-          toAbstract $ C.TBind r (singleton bv) (unArg a)--        -- Public open is allowed and will take effect when scope checking as-        -- proper declarations.-        C.NiceOpen r m dir -> do-          mkLet $ C.NiceOpen r m dir{ publicOpen = Nothing }-        C.NiceModuleMacro r p x modapp open dir -> do-          mkLet $ C.NiceModuleMacro r p x modapp open dir{ publicOpen = Nothing }--        -- Do some rudimentary matching here to get NotValidBeforeField instead-        -- of NotAValidLetDecl.-        C.NiceMutual _ _ _ _-          [ C.FunSig _ _ _ _ macro _ _ _ _ _-          , C.FunDef _ _ abstract _ _ _ _-             [ C.Clause _ _ (C.LHS _p [] []) (C.RHS _) NoWhere [] ]-          ] | abstract /= AbstractDef && macro /= MacroDef -> do-          mkLet d--        C.NiceLoneConstructor{} -> failure-        C.NiceMutual{}        -> failure-        -- TODO: some of these cases might be __IMPOSSIBLE__-        C.Axiom{}             -> failure-        C.PrimitiveFunction{} -> failure-        C.NiceModule{}        -> failure-        C.NiceImport{}        -> failure-        C.NicePragma{}        -> failure-        C.NiceRecSig{}        -> failure-        C.NiceDataSig{}       -> failure-        C.NiceFunClause{}     -> failure-        C.FunSig{}            -> failure  -- Note: these are bundled with FunDef in NiceMutual-        C.FunDef{}            -> failure-        C.NiceDataDef{}       -> failure-        C.NiceRecDef{}        -> failure-        C.NicePatternSyn{}    -> failure-        C.NiceGeneralize{}    -> failure-        C.NiceUnquoteDecl{}   -> failure-        C.NiceUnquoteDef{}    -> failure--checkModuleApplication-  :: C.ModuleApplication-  -> ModuleName-  -> C.Name-  -> C.ImportDirective-  -> ScopeM (A.ModuleApplication, ScopeCopyInfo, A.ImportDirective)--checkModuleApplication (C.SectionApp _ tel e) m0 x dir' = do-  reportSDoc "scope.decl" 70 $ vcat $-    [ text $ "scope checking ModuleApplication " ++ prettyShow x-    ]--  -- For the following, set the current module to be m0.-  withCurrentModule m0 $ do-    -- Check that expression @e@ is of the form @m args@.-    (m, args) <- parseModuleApplication e-    -- Scope check the telescope (introduces bindings!).-    tel' <- catMaybes <$> toAbstract tel-    -- Scope check the old module name and the module args.-    m1    <- toAbstract $ OldModuleName m-    args' <- toAbstractCtx (ArgumentCtx PreferParen) args-    -- Copy the scope associated with m and take the parts actually imported.-    (adir, s) <- applyImportDirectiveM (C.QName x) dir' =<< getNamedScope m1-    (s', copyInfo) <- copyScope m m0 s-    -- Set the current scope to @s'@-    modifyCurrentScope $ const s'-    printScope "mod.inst" 20 "copied source module"-    reportSDoc "scope.mod.inst" 30 $ return $ pretty copyInfo-    let amodapp = A.SectionApp tel' m1 args'-    reportSDoc "scope.decl" 70 $ vcat $-      [ text $ "scope checked ModuleApplication " ++ prettyShow x-      ]-    reportSDoc "scope.decl" 70 $ vcat $-      [ nest 2 $ prettyA amodapp-      ]-    return (amodapp, copyInfo, adir)--checkModuleApplication (C.RecordModuleInstance _ recN) m0 x dir' =-  withCurrentModule m0 $ do-    m1 <- toAbstract $ OldModuleName recN-    s <- getNamedScope m1-    (adir, s) <- applyImportDirectiveM recN dir' s-    (s', copyInfo) <- copyScope recN m0 s-    modifyCurrentScope $ const s'--    printScope "mod.inst" 20 "copied record module"-    return (A.RecordModuleInstance m1, copyInfo, adir)---- | @checkModuleMacro mkApply range access concreteName modapp open dir@------   Preserves local variables.--checkModuleMacro-  :: (ToConcrete a, Pretty (ConOfAbs a))-  => (ModuleInfo-      -> ModuleName-      -> A.ModuleApplication-      -> ScopeCopyInfo-      -> A.ImportDirective-      -> a)-  -> OpenKind-  -> Range-  -> Access-  -> C.Name-  -> C.ModuleApplication-  -> OpenShortHand-  -> C.ImportDirective-  -> ScopeM a-checkModuleMacro apply kind r p x modapp open dir = do-    reportSDoc "scope.decl" 70 $ vcat $-      [ text $ "scope checking ModuleMacro " ++ prettyShow x-      ]-    dir <- notPublicWithoutOpen open dir--    m0 <- toAbstract (NewModuleName x)-    reportSDoc "scope.decl" 90 $ "NewModuleName: m0 =" <+> prettyA m0--    printScope "mod.inst" 20 "module macro"--    -- If we're opening a /named/ module, the import directive is-    -- applied to the "open", otherwise to the module itself. However,-    -- "public" is always applied to the "open".-    let (moduleDir, openDir) = case (open, isNoName x) of-          (DoOpen,   False) -> (defaultImportDir, dir)-          (DoOpen,   True)  -> ( dir { publicOpen = Nothing }-                               , defaultImportDir { publicOpen = publicOpen dir }-                               )-          (DontOpen, _)     -> (dir, defaultImportDir)--    -- Restore the locals after module application has been checked.-    (modapp', copyInfo, adir') <- withLocalVars $ checkModuleApplication modapp m0 x moduleDir-    printScope "mod.inst.app" 20 "checkModuleMacro, after checkModuleApplication"--    reportSDoc "scope.decl" 90 $ "after mod app: trying to print m0 ..."-    reportSDoc "scope.decl" 90 $ "after mod app: m0 =" <+> prettyA m0--    bindModule p x m0-    reportSDoc "scope.decl" 90 $ "after bindMod: m0 =" <+> prettyA m0--    printScope "mod.inst.copy.after" 20 "after copying"--    -- Open the module if DoOpen.-    -- Andreas, 2014-09-02: @openModule@ might shadow some locals!-    adir <- case open of-      DontOpen -> return adir'-      DoOpen   -> do-        adir'' <- openModule kind (Just m0) (C.QName x) openDir-        -- Andreas, 2020-05-14, issue #4656-        -- Keep the more meaningful import directive for highlighting-        -- (the other one is a defaultImportDir).-        return $ if isNoName x then adir' else adir''--    printScope "mod.inst" 20 $ show open-    reportSDoc "scope.decl" 90 $ "after open   : m0 =" <+> prettyA m0--    stripNoNames-    printScope "mod.inst" 10 $ "after stripping"-    reportSDoc "scope.decl" 90 $ "after stripNo: m0 =" <+> prettyA m0--    let m      = m0 `withRangesOf` singleton x-        adecl  = apply info m modapp' copyInfo adir--    reportSDoc "scope.decl" 70 $ vcat $-      [ text $ "scope checked ModuleMacro " ++ prettyShow x-      ]-    reportSLn  "scope.decl" 90 $ "info    = " ++ show info-    reportSLn  "scope.decl" 90 $ "m       = " ++ prettyShow m-    reportSLn  "scope.decl" 90 $ "modapp' = " ++ show modapp'-    reportSDoc "scope.decl" 90 $ return $ pretty copyInfo-    reportSDoc "scope.decl" 70 $ nest 2 $ prettyA adecl-    return adecl-  where-    info = ModuleInfo-             { minfoRange  = r-             , minfoAsName = Nothing-             , minfoAsTo   = renamingRange dir-             , minfoOpenShort = Just open-             , minfoDirective = Just dir-             }---- | The @public@ keyword must only be used together with @open@.--notPublicWithoutOpen :: OpenShortHand -> C.ImportDirective -> ScopeM C.ImportDirective-notPublicWithoutOpen DoOpen   dir = return dir-notPublicWithoutOpen DontOpen dir = do-  whenJust (publicOpen dir) $ \ r ->-    setCurrentRange r $ warning UselessPublic-  return $ dir { publicOpen = Nothing }---- | Computes the range of all the \"to\" keywords used in a renaming--- directive.--renamingRange :: C.ImportDirective -> Range-renamingRange = getRange . map renToRange . impRenaming---- | Scope check a 'NiceOpen'.-checkOpen-  :: Range                -- ^ Range of @open@ statement.-  -> Maybe A.ModuleName   -- ^ Resolution of concrete module name (if already resolved).-  -> C.QName              -- ^ Module to open.-  -> C.ImportDirective    -- ^ Scope modifier.-  -> ScopeM (ModuleInfo, A.ModuleName, A.ImportDirective) -- ^ Arguments of 'A.Open'-checkOpen r mam x dir = do-  reportSDoc "scope.decl" 70 $ do-    cm <- getCurrentModule-    vcat $-      [ text   "scope checking NiceOpen " <> return (pretty x)-      , text   "  getCurrentModule       = " <> prettyA cm-      , text $ "  getCurrentModule (raw) = " ++ show cm-      , text $ "  C.ImportDirective      = " ++ prettyShow dir-      ]-  -- Andreas, 2017-01-01, issue #2377: warn about useless `public`-  whenJust (publicOpen dir) $ \ r -> do-    whenM ((A.noModuleName ==) <$> getCurrentModule) $ do-      setCurrentRange r $ warning UselessPublic--  m <- caseMaybe mam (toAbstract (OldModuleName x)) return-  printScope "open" 20 $ "opening " ++ prettyShow x-  adir <- openModule TopOpenModule (Just m) x dir-  printScope "open" 20 $ "result:"-  let minfo = ModuleInfo-        { minfoRange     = r-        , minfoAsName    = Nothing-        , minfoAsTo      = renamingRange dir-        , minfoOpenShort = Nothing-        , minfoDirective = Just dir-        }-  let adecls = [A.Open minfo m adir]-  reportSDoc "scope.decl" 70 $ vcat $-    text ( "scope checked NiceOpen " ++ prettyShow x-         ) : map (nest 2 . prettyA) adecls-  return (minfo, m, adir)---- | Check a literal, issuing an error warning for bad literals.-checkLiteral :: Literal -> ScopeM ()-checkLiteral (LitChar c)-  | isSurrogateCodePoint c = genericNonFatalError $ P.text $ "Invalid character literal " ++ show c ++-                                                             " (surrogate code points are not supported)"-checkLiteral _ = return ()--{---------------------------------------------------------------------------    Translation- --------------------------------------------------------------------------}--concreteToAbstract_ :: ToAbstract c => c -> ScopeM (AbsOfCon c)-concreteToAbstract_ = toAbstract--concreteToAbstract :: ToAbstract c => ScopeInfo -> c -> ScopeM (AbsOfCon c)-concreteToAbstract scope x = withScope_ scope (toAbstract x)---- | Things that can be translated to abstract syntax are instances of this---   class.-class ToAbstract c where-    type AbsOfCon c-    toAbstract :: c -> ScopeM (AbsOfCon c)---- | This function should be used instead of 'toAbstract' for things that need---   to keep track of precedences to make sure that we don't forget about it.-toAbstractCtx :: ToAbstract c => Precedence -> c-> ScopeM (AbsOfCon c)-toAbstractCtx ctx c = withContextPrecedence ctx $ toAbstract c----UNUSED Liang-Ting Chen 2019-07-16---toAbstractTopCtx :: ToAbstract c a => c -> ScopeM a---toAbstractTopCtx = toAbstractCtx TopCtx--toAbstractHiding :: (LensHiding h, ToAbstract c) => h -> c -> ScopeM (AbsOfCon c)-toAbstractHiding h | visible h = toAbstract -- don't change precedence if visible-toAbstractHiding _             = toAbstractCtx TopCtx----UNUSED Liang-Ting Chen 2019-07-16---setContextCPS :: Precedence -> (a -> ScopeM b) ->---                 ((a -> ScopeM b) -> ScopeM b) -> ScopeM b---setContextCPS p ret f = do---  old <- useScope scopePrecedence---  withContextPrecedence p $ f $ \ x -> setContextPrecedence old >> ret x------localToAbstractCtx :: ToAbstract c =>---                     Precedence -> c -> (AbsOfCon -> ScopeM (AbsOfCon c)) -> ScopeM (AbsOfCon c)---localToAbstractCtx ctx c ret = setContextCPS ctx ret (localToAbstract c)---- | This operation does not affect the scope, i.e. the original scope---   is restored upon completion.-localToAbstract :: ToAbstract c => c -> (AbsOfCon c -> ScopeM b) -> ScopeM b-localToAbstract x ret = fst <$> localToAbstract' x ret---- | Like 'localToAbstract' but returns the scope after the completion of the---   second argument.-localToAbstract' :: ToAbstract c => c -> (AbsOfCon c -> ScopeM b) -> ScopeM (b, ScopeInfo)-localToAbstract' x ret = do-  scope <- getScope-  withScope scope $ ret =<< toAbstract x--instance ToAbstract () where-  type AbsOfCon () = ()-  toAbstract = pure--instance (ToAbstract c1, ToAbstract c2) => ToAbstract (c1, c2) where-  type AbsOfCon (c1, c2) = (AbsOfCon c1, AbsOfCon c2)-  toAbstract (x,y) = (,) <$> toAbstract x <*> toAbstract y--instance (ToAbstract c1, ToAbstract c2, ToAbstract c3) => ToAbstract (c1, c2, c3) where-  type AbsOfCon (c1, c2, c3) = (AbsOfCon c1, AbsOfCon c2, AbsOfCon c3)-  toAbstract (x,y,z) = flatten <$> toAbstract (x,(y,z))-    where-      flatten (x,(y,z)) = (x,y,z)--instance ToAbstract c => ToAbstract [c] where-  type AbsOfCon [c] = [AbsOfCon c]-  toAbstract = mapM toAbstract--instance ToAbstract c => ToAbstract (List1 c) where-  type AbsOfCon (List1 c) = List1 (AbsOfCon c)-  toAbstract = mapM toAbstract--instance (ToAbstract c1, ToAbstract c2) => ToAbstract (Either c1 c2) where-  type AbsOfCon (Either c1 c2) = Either (AbsOfCon c1) (AbsOfCon c2)-  toAbstract = traverseEither toAbstract toAbstract--instance ToAbstract c => ToAbstract (Maybe c) where-  type AbsOfCon (Maybe c) = Maybe (AbsOfCon c)-  toAbstract = traverse toAbstract---- Names --------------------------------------------------------------------data NewName a = NewName-  { newBinder   :: A.BindingSource -- what kind of binder?-  , newName     :: a-  } deriving (Functor)--data OldQName = OldQName-  C.QName              -- ^ Concrete name to be resolved-  (Maybe (Set A.Name)) -- ^ If a set is given, then the first name must-                       --   correspond to one of the names in the set.---- | We sometimes do not want to fail hard if the name is not actually---   in scope because we have a strategy to recover from this problem---   (e.g. drop the offending COMPILE pragma)-data MaybeOldQName = MaybeOldQName OldQName--newtype OldName a = OldName a---- | Wrapper to resolve a name to a 'ResolvedName' (rather than an 'A.Expr').-data ResolveQName = ResolveQName C.QName--data PatName      = PatName C.QName (Maybe (Set A.Name))-  -- ^ If a set is given, then the first name must correspond to one-  -- of the names in the set.--instance ToAbstract (NewName C.Name) where-  type AbsOfCon (NewName C.Name) = A.Name-  toAbstract (NewName b x) = do-    y <- freshAbstractName_ x-    bindVariable b x y-    return y--instance ToAbstract (NewName C.BoundName) where-  type AbsOfCon (NewName C.BoundName) = A.BindName-  toAbstract NewName{ newBinder = b, newName = BName{ boundName = x, bnameFixity = fx }} = do-    y <- freshAbstractName fx x-    bindVariable b x y-    return $ A.BindName y--instance ToAbstract OldQName where-  type AbsOfCon OldQName = A.Expr-  toAbstract q@(OldQName x _) =-    fromMaybeM (notInScopeError x) $ toAbstract (MaybeOldQName q)--instance ToAbstract MaybeOldQName where-  type AbsOfCon MaybeOldQName = Maybe A.Expr-  toAbstract (MaybeOldQName (OldQName x ns)) = do-    qx <- resolveName' allKindsOfNames ns x-    reportSLn "scope.name" 10 $ "resolved " ++ prettyShow x ++ ": " ++ prettyShow qx-    case qx of-      VarName x' _         -> return $ Just $ A.Var x'-      DefinedName _ d suffix -> do-        raiseWarningsOnUsage $ anameName d-        -- then we take note of generalized names used-        case anameKind d of-          GeneralizeName -> do-            gvs <- useTC stGeneralizedVars-            case gvs of   -- Subtle: Use (left-biased) union instead of insert to keep the old name if-                          -- already present. This way we can sort by source location when generalizing-                          -- (Issue 3354).-                Just s -> stGeneralizedVars `setTCLens` Just (s `Set.union` Set.singleton (anameName d))-                Nothing -> typeError $ GeneralizeNotSupportedHere $ anameName d-          DisallowedGeneralizeName -> do-            typeError . GenericDocError =<<-              text "Cannot use generalized variable from let-opened module:" <+> prettyTCM (anameName d)-          _ -> return ()-        -- and then we return the name-        return $ withSuffix suffix $ nameToExpr d-        where-          withSuffix NoSuffix   e         = Just e-          withSuffix s@Suffix{} (A.Def x) = Just $ A.Def' x s-          withSuffix _          _         = Nothing--      FieldName     ds     -> ambiguous (A.Proj ProjPrefix) ds-      ConstructorName _ ds -> ambiguous A.Con ds-      PatternSynResName ds -> ambiguous A.PatternSyn ds-      UnknownName          -> pure Nothing-    where-      ambiguous :: (AmbiguousQName -> A.Expr) -> List1 AbstractName -> ScopeM (Maybe A.Expr)-      ambiguous f ds = do-        let xs = fmap anameName ds-        raiseWarningsOnUsageIfUnambiguous xs-        return $ Just $ f $ AmbQ xs--      -- Note: user warnings on ambiguous names will be raised by the type checker,-      -- see storeDiamsbiguatedName.-      raiseWarningsOnUsageIfUnambiguous :: List1 A.QName -> ScopeM ()-      raiseWarningsOnUsageIfUnambiguous = \case-        x :| [] -> raiseWarningsOnUsage x-        _       -> return ()---instance ToAbstract ResolveQName where-  type AbsOfCon ResolveQName = ResolvedName-  toAbstract (ResolveQName x) = resolveName x >>= \case-    UnknownName -> notInScopeError x-    q -> return q--data APatName = VarPatName A.Name-              | ConPatName (NonEmpty AbstractName)-              | PatternSynPatName (NonEmpty AbstractName)--instance ToAbstract PatName where-  type AbsOfCon PatName = APatName-  toAbstract (PatName x ns) = do-    reportSLn "scope.pat" 10 $ "checking pattern name: " ++ prettyShow x-    rx <- resolveName' (someKindsOfNames [ConName, CoConName, PatternSynName]) ns x-          -- Andreas, 2013-03-21 ignore conflicting names which cannot-          -- be meant since we are in a pattern-          -- Andreas, 2020-04-11 CoConName:-          -- coinductive constructors will be rejected later, in the type checker-    reportSLn "scope.pat" 20 $ "resolved as " ++ prettyShow rx-    case (rx, x) of-      (VarName y _,       C.QName x)                           -> bindPatVar x-      (FieldName d,       C.QName x)                           -> bindPatVar x-      (DefinedName _ d _, C.QName x) | isDefName (anameKind d) -> bindPatVar x-      (UnknownName,       C.QName x)                           -> bindPatVar x-      (ConstructorName _ ds, _)                                -> patCon ds-      (PatternSynResName d, _)                                 -> patSyn d-      _ -> genericError $ "Cannot pattern match on non-constructor " ++ prettyShow x-    where-      bindPatVar = VarPatName <.> bindPatternVariable-      patCon ds = do-        reportSLn "scope.pat" 10 $ "it was a con: " ++ prettyShow (fmap anameName ds)-        return $ ConPatName ds-      patSyn ds = do-        reportSLn "scope.pat" 10 $ "it was a pat syn: " ++ prettyShow (fmap anameName ds)-        return $ PatternSynPatName ds---- | Translate and possibly bind a pattern variable---   (which could have been bound before due to non-linearity).-bindPatternVariable :: C.Name -> ScopeM A.Name-bindPatternVariable x = do-  y <- (AssocList.lookup x <$> getVarsToBind) >>= \case-    Just (LocalVar y _ _) -> do-      reportSLn "scope.pat" 10 $ "it was a old var: " ++ prettyShow x-      return $ setRange (getRange x) y-    Nothing -> do-      reportSLn "scope.pat" 10 $ "it was a new var: " ++ prettyShow x-      freshAbstractName_ x-  addVarToBind x $ LocalVar y PatternBound []-  return y--class ToQName a where-  toQName :: a -> C.QName--instance ToQName C.Name  where toQName = C.QName-instance ToQName C.QName where toQName = id---- Should be a defined name.-instance ToQName a => ToAbstract (OldName a) where-  type AbsOfCon (OldName a) = A.QName-  toAbstract (OldName x) = do-    rx <- resolveName (toQName x)-    case rx of-      DefinedName _ d NoSuffix -> return $ anameName d-      DefinedName _ d Suffix{} -> notInScopeError (toQName x)-      -- We can get the cases below for DISPLAY pragmas-      ConstructorName _ ds -> return $ anameName (NonEmpty.head ds)   -- We'll throw out this one, so it doesn't matter which one we pick-      FieldName ds         -> return $ anameName (NonEmpty.head ds)-      PatternSynResName ds -> return $ anameName (NonEmpty.head ds)-      VarName x _          -> genericError $ "Not a defined name: " ++ prettyShow x-      UnknownName          -> notInScopeError (toQName x)---- | Resolve a non-local name and return its possibly ambiguous abstract name.-toAbstractExistingName :: ToQName a => a -> ScopeM (List1 AbstractName)-toAbstractExistingName x = resolveName (toQName x) >>= \case-    DefinedName _ d NoSuffix -> return $ singleton d-    DefinedName _ d Suffix{} -> notInScopeError (toQName x)-    ConstructorName _ ds     -> return ds-    FieldName ds             -> return ds-    PatternSynResName ds     -> return ds-    VarName x _              -> genericError $ "Not a defined name: " ++ prettyShow x-    UnknownName              -> notInScopeError (toQName x)--newtype NewModuleName      = NewModuleName      C.Name-newtype NewModuleQName     = NewModuleQName     C.QName-newtype OldModuleName      = OldModuleName      C.QName--freshQModule :: A.ModuleName -> C.Name -> ScopeM A.ModuleName-freshQModule m x = A.qualifyM m . mnameFromList1 . singleton <$> freshAbstractName_ x--checkForModuleClash :: C.Name -> ScopeM ()-checkForModuleClash x = do-  ms :: [AbstractModule] <- scopeLookup (C.QName x) <$> getScope-  unless (null ms) $ do-    reportSLn "scope.clash" 20 $ "clashing modules ms = " ++ prettyShow ms-    reportSLn "scope.clash" 60 $ "clashing modules ms = " ++ show ms-    setCurrentRange x $-      typeError $ ShadowedModule x $-                map ((`withRangeOf` x) . amodName) ms--instance ToAbstract NewModuleName where-  type AbsOfCon NewModuleName = A.ModuleName-  toAbstract (NewModuleName x) = do-    checkForModuleClash x-    m <- getCurrentModule-    y <- freshQModule m x-    createModule Nothing y-    return y--instance ToAbstract NewModuleQName where-  type AbsOfCon NewModuleQName = A.ModuleName-  toAbstract (NewModuleQName m) = toAbs noModuleName m-    where-      toAbs m (C.QName x)  = do-        y <- freshQModule m x-        createModule Nothing y-        return y-      toAbs m (C.Qual x q) = do-        m' <- freshQModule m x-        toAbs m' q--instance ToAbstract OldModuleName where-  type AbsOfCon OldModuleName = A.ModuleName--  toAbstract (OldModuleName q) = setCurrentRange q $ do-    amodName <$> resolveModule q---- Expressions ---------------------------------------------------------------UNUSED Liang-Ting Chen 2019-07-16----- | Peel off 'C.HiddenArg' and represent it as an 'NamedArg'.---mkNamedArg :: C.Expr -> NamedArg C.Expr---mkNamedArg (C.HiddenArg   _ e) = Arg (hide         defaultArgInfo) e---mkNamedArg (C.InstanceArg _ e) = Arg (makeInstance defaultArgInfo) e---mkNamedArg e                   = Arg defaultArgInfo $ unnamed e---- | Peel off 'C.HiddenArg' and represent it as an 'Arg', throwing away any name.-mkArg' :: ArgInfo -> C.Expr -> Arg C.Expr-mkArg' info (C.HiddenArg   _ e) = Arg (hide         info) $ namedThing e-mkArg' info (C.InstanceArg _ e) = Arg (makeInstance info) $ namedThing e-mkArg' info e                   = Arg (setHiding NotHidden info) e---UNUSED Liang-Ting 2019-07-16----- | By default, arguments are @Relevant@.---mkArg :: C.Expr -> Arg C.Expr---mkArg e = mkArg' defaultArgInfo e--inferParenPreference :: C.Expr -> ParenPreference-inferParenPreference C.Paren{} = PreferParen-inferParenPreference _         = PreferParenless---- | Parse a possibly dotted and braced @C.Expr@ as @A.Expr@,---   interpreting dots as relevance and braces as hiding.---   Only accept a layer of dotting/bracing if the respective accumulator is @Nothing@.-toAbstractDotHiding :: Maybe Relevance -> Maybe Hiding -> Precedence -> C.Expr -> ScopeM (A.Expr, Relevance, Hiding)-toAbstractDotHiding mr mh prec e = do-    reportSLn "scope.irrelevance" 100 $ "toAbstractDotHiding: " ++ render (pretty e)-    traceCall (ScopeCheckExpr e) $ case e of--      C.RawApp _ es     -> toAbstractDotHiding mr mh prec =<< parseApplication es-      C.Paren _ e       -> toAbstractDotHiding mr mh TopCtx e--      C.Dot _ e-        | Nothing <- mr -> toAbstractDotHiding (Just Irrelevant) mh prec e--      C.DoubleDot _ e-        | Nothing <- mr -> toAbstractDotHiding (Just NonStrict) mh prec e--      C.HiddenArg _ (Named Nothing e)-        | Nothing <- mh -> toAbstractDotHiding mr (Just Hidden) TopCtx e--      C.InstanceArg _ (Named Nothing e)-        | Nothing <- mh -> toAbstractDotHiding mr (Just $ Instance NoOverlap) TopCtx e--      e                 -> (, fromMaybe Relevant mr, fromMaybe NotHidden mh) <$>-                             toAbstractCtx prec e---- | Translate concrete expression under at least one binder into nested---   lambda abstraction in abstract syntax.-toAbstractLam :: Range -> List1 C.LamBinding -> C.Expr -> Precedence -> ScopeM A.Expr-toAbstractLam r bs e ctx = do-  -- Translate the binders-  lvars0 <- getLocalVars-  localToAbstract (fmap (C.DomainFull . makeDomainFull) bs) $ \ bs -> do-    lvars1 <- getLocalVars-    checkNoShadowing lvars0 lvars1-    -- Translate the body-    e <- toAbstractCtx ctx e-    -- We have at least one binder.  Get first @b@ and rest @bs@.-    return $ case List1.catMaybes bs of-      -- Andreas, 2020-06-18-      -- There is a pathological case in which we end up without binder:-      --   λ (let-      --        mutual -- warning: empty mutual block-      --     ) -> Set-      []   -> e-      b:bs -> A.Lam (ExprRange r) b $ foldr mkLam e bs-  where-    mkLam b e = A.Lam (ExprRange $ fuseRange b e) b e---- | Scope check extended lambda expression.-scopeCheckExtendedLam ::-  Range -> Erased -> List1 C.LamClause -> ScopeM A.Expr-scopeCheckExtendedLam r erased cs = do-  whenM isInsideDotPattern $-    genericError "Extended lambdas are not allowed in dot patterns"--  -- Find an unused name for the extended lambda definition.-  cname <- freshConcreteName r 0 extendedLambdaName-  name  <- freshAbstractName_ cname-  a <- asksTC (^. lensIsAbstract)-  reportSDoc "scope.extendedLambda" 10 $ vcat-    [ text $ "new extended lambda name (" ++ show a ++ "): " ++ prettyShow name-    ]-  verboseS "scope.extendedLambda" 60 $ do-    forM_ cs $ \ c -> do-      reportSLn "scope.extendedLambda" 60 $ "extended lambda lhs: " ++ show (C.lamLHS c)-  qname <- qualifyName_ name-  bindName (PrivateAccess Inserted) FunName cname qname--  -- Andreas, 2019-08-20-  -- Keep the following __IMPOSSIBLE__, which is triggered by -v scope.decl.trace:80,-  -- for testing issue #4016.-  d <- C.FunDef r [] a NotInstanceDef __IMPOSSIBLE__ __IMPOSSIBLE__ cname . List1.toList <$> do-          forM cs $ \ (LamClause ps rhs ca) -> do-            let p   = C.rawAppP $ (killRange $ IdentP $ C.QName cname) :| ps-            let lhs = C.LHS p [] []-            return $ C.Clause cname ca lhs rhs NoWhere []-  scdef <- toAbstract d--  -- Create the abstract syntax for the extended lambda.-  case scdef of-    A.ScopedDecl si [A.FunDef di qname' NotDelayed cs] -> do-      setScope si  -- This turns into an A.ScopedExpr si $ A.ExtendedLam...-      return $-        A.ExtendedLam (ExprRange r) di erased qname' $-        List1.fromList cs-    _ -> __IMPOSSIBLE__---- | Raise an error if argument is a C.Dot with Hiding info.--rejectPostfixProjectionWithHiding :: NamedArg C.Expr -> ScopeM ()-rejectPostfixProjectionWithHiding arg =-  case namedArg arg of-    C.Dot{} | notVisible arg -> setCurrentRange arg $ genericDocError $-      "Illegal hiding in postfix projection " P.<+> P.pretty arg-    _ -> return ()---- | Scope check an expression.--instance ToAbstract C.Expr where-  type AbsOfCon C.Expr = A.Expr--  toAbstract e =-    traceCall (ScopeCheckExpr e) $ annotateExpr $ case e of--  -- Names-      Ident x -> toAbstract (OldQName x Nothing)--  -- Literals-      C.Lit r l -> do-        checkLiteral l-        case l of-          LitNat n -> do-            let builtin | n < 0     = Just <$> primFromNeg    -- negative literals are only allowed if FROMNEG is defined-                        | otherwise = ensureInScope =<< getBuiltin' builtinFromNat-            builtin >>= \case-              Just (I.Def q _) -> return $ mkApp q $ A.Lit i $ LitNat $ abs n-              _                -> return alit--          LitString s -> do-            getBuiltin' builtinFromString >>= ensureInScope >>= \case-              Just (I.Def q _) -> return $ mkApp q alit-              _                -> return alit--          _ -> return alit-        where-        i       = ExprRange r-        alit    = A.Lit i l-        mkApp q = A.App (defaultAppInfo r) (A.Def q) . defaultNamedArg--        -- #4925: Require fromNat/fromNeg to be in scope *unqualified* for literal overloading to-        -- apply.-        ensureInScope :: Maybe I.Term -> ScopeM (Maybe I.Term)-        ensureInScope v@(Just (I.Def q _)) =-          ifM (isNameInScopeUnqualified q <$> getScope) (return v) (return Nothing)-        ensureInScope _ = return Nothing--  -- Meta variables-      C.QuestionMark r n -> do-        scope <- getScope-        -- Andreas, 2014-04-06 create interaction point.-        ii <- registerInteractionPoint True r n-        let info = MetaInfo-             { metaRange  = r-             , metaScope  = scope-             , metaNumber = Nothing-             , metaNameSuggestion = ""-             }-        return $ A.QuestionMark info ii-      C.Underscore r n -> do-        scope <- getScope-        return $ A.Underscore $ MetaInfo-                    { metaRange  = r-                    , metaScope  = scope-                    , metaNumber = __IMPOSSIBLE__ =<< n-                    , metaNameSuggestion = fromMaybe "" n-                    }--  -- Raw application-      C.RawApp r es -> do-        e <- parseApplication es-        toAbstract e--  -- Application-      C.App r e1 e2 -> do-        -- Andreas, 2021-02-10, issue #3289: reject @e {.p}@ and @e ⦃ .p ⦄@.-        rejectPostfixProjectionWithHiding e2--        let parenPref = inferParenPreference (namedArg e2)-            info = (defaultAppInfo r) { appOrigin = UserWritten, appParens = parenPref }-        e1 <- toAbstractCtx FunctionCtx e1-        e2 <- toAbstractCtx (ArgumentCtx parenPref) e2-        return $ A.App info e1 e2--  -- Operator application-      C.OpApp r op ns es -> toAbstractOpApp op ns es--  -- With application-      C.WithApp r e es -> do-        e  <- toAbstractCtx WithFunCtx e-        es <- mapM (toAbstractCtx WithArgCtx) es-        return $ A.WithApp (ExprRange r) e es--  -- Misplaced hidden argument-      C.HiddenArg _ _ -> nothingAppliedToHiddenArg e-      C.InstanceArg _ _ -> nothingAppliedToInstanceArg e--  -- Lambda-      C.AbsurdLam r h -> return $ A.AbsurdLam (ExprRange r) h--      C.Lam r bs e -> toAbstractLam r bs e TopCtx--  -- Extended Lambda-      C.ExtendedLam r e cs -> scopeCheckExtendedLam r e cs--  -- Relevant and irrelevant non-dependent function type-      C.Fun r (Arg info1 e1) e2 -> do-        let arg = mkArg' info1 e1-        let mr = case getRelevance arg of-              Relevant  -> Nothing-              r         -> Just r-        let mh = case getHiding arg of-              NotHidden -> Nothing-              h         -> Just h-        Arg info (e1', rel, hid) <- traverse (toAbstractDotHiding mr mh FunctionSpaceDomainCtx) arg-        let updRel = case rel of-              Relevant -> id-              rel      -> setRelevance rel-        let updHid = case hid of-              NotHidden -> id-              hid       -> setHiding hid-        A.Fun (ExprRange r) (Arg (updRel $ updHid info) e1') <$> toAbstractCtx TopCtx e2--  -- Dependent function type-      e0@(C.Pi tel e) -> do-        lvars0 <- getLocalVars-        localToAbstract tel $ \tel -> do-          lvars1 <- getLocalVars-          checkNoShadowing lvars0 lvars1-          e <- toAbstractCtx TopCtx e-          let info = ExprRange (getRange e0)-          return $ A.mkPi info (List1.catMaybes tel) e--  -- Let-      e0@(C.Let _ ds (Just e)) ->-        ifM isInsideDotPattern (genericError $ "Let-expressions are not allowed in dot patterns") $-        localToAbstract (LetDefs ds) $ \ds' -> do-          e <- toAbstractCtx TopCtx e-          let info = ExprRange (getRange e0)-          return $ A.mkLet info ds' e-      C.Let _ _ Nothing -> genericError "Missing body in let-expression"--  -- Record construction-      C.Rec r fs  -> do-        fs' <- toAbstractCtx TopCtx fs-        let ds'  = [ d | Right (_, Just d) <- fs' ]-            fs'' = map (mapRight fst) fs'-            i    = ExprRange r-        return $ A.mkLet i ds' (A.Rec i fs'')--  -- Record update-      C.RecUpdate r e fs -> do-        A.RecUpdate (ExprRange r) <$> toAbstract e <*> toAbstractCtx TopCtx fs--  -- Parenthesis-      C.Paren _ e -> toAbstractCtx TopCtx e--  -- Idiom brackets-      C.IdiomBrackets r es ->-        toAbstractCtx TopCtx =<< parseIdiomBracketsSeq r es--  -- Do notation-      C.DoBlock r ss ->-        toAbstractCtx TopCtx =<< desugarDoNotation r ss--  -- Post-fix projections-      C.Dot r e  -> A.Dot (ExprRange r) <$> toAbstract e--  -- Pattern things-      C.As _ _ _ -> notAnExpression e-      C.Absurd _ -> notAnExpression e--  -- Impossible things-      C.ETel _  -> __IMPOSSIBLE__-      C.Equal{} -> genericError "Parse error: unexpected '='"-      C.Ellipsis _ -> genericError "Parse error: unexpected '...'"-      C.DoubleDot _ _ -> genericError "Parse error: unexpected '..'"--  -- Quoting-      C.Quote r -> return $ A.Quote (ExprRange r)-      C.QuoteTerm r -> return $ A.QuoteTerm (ExprRange r)-      C.Unquote r -> return $ A.Unquote (ExprRange r)--      C.Tactic r e -> genericError "Syntax error: 'tactic' can only appear in attributes"--  -- DontCare-      C.DontCare e -> A.DontCare <$> toAbstract e--  -- forall-generalize-      C.Generalized e -> do-        (s, e) <- collectGeneralizables $ toAbstract e-        pure $ A.generalized s e--instance ToAbstract C.ModuleAssignment where-  type AbsOfCon C.ModuleAssignment = (A.ModuleName, Maybe A.LetBinding)-  toAbstract (C.ModuleAssignment m es i)-    | null es && isDefaultImportDir i = (, Nothing) <$> toAbstract (OldModuleName m)-    | otherwise = do-        x <- C.NoName (getRange m) <$> fresh-        r <- checkModuleMacro LetApply LetOpenModule (getRange (m, es, i)) PublicAccess x-               (C.SectionApp (getRange (m , es)) [] (rawApp (Ident m :| es)))-               DontOpen i-        case r of-          LetApply _ m' _ _ _ -> return (m', Just r)-          _ -> __IMPOSSIBLE__--instance ToAbstract c => ToAbstract (FieldAssignment' c) where-  type AbsOfCon (FieldAssignment' c) = FieldAssignment' (AbsOfCon c)--  toAbstract = traverse toAbstract--instance ToAbstract (C.Binder' (NewName C.BoundName)) where-  type AbsOfCon (C.Binder' (NewName C.BoundName)) = A.Binder--  toAbstract (C.Binder p n) = do-    let name = C.boundName $ newName n-    -- If we do have a pattern then the variable needs to be inserted-    -- so we do need a proper internal name for it.-    n <- if not (isNoName name && isJust p) then pure n else do-           n' <- freshConcreteName (getRange $ newName n) 0 patternInTeleName-           pure $ fmap (\ n -> n { C.boundName = n' }) n-    n <- toAbstract n-    -- Actually parsing the pattern, checking it is linear,-    -- and bind its variables-    p <- traverse parsePattern p-    p <- toAbstract p-    checkPatternLinearity p $ \ys ->-      typeError $ RepeatedVariablesInPattern ys-    bindVarsToBind-    p <- toAbstract p-    pure $ A.Binder p n--instance ToAbstract C.LamBinding where-  type AbsOfCon C.LamBinding = Maybe A.LamBinding--  toAbstract (C.DomainFree x)  = do-    tac <- traverse toAbstract $ bnameTactic $ C.binderName $ namedArg x-    Just . A.DomainFree tac <$> toAbstract (updateNamedArg (fmap $ NewName LambdaBound) x)-  toAbstract (C.DomainFull tb) = fmap A.DomainFull <$> toAbstract tb--makeDomainFull :: C.LamBinding -> C.TypedBinding-makeDomainFull (C.DomainFull b) = b-makeDomainFull (C.DomainFree x) = C.TBind r (singleton x) $ C.Underscore r Nothing-  where r = getRange x--instance ToAbstract C.TypedBinding where-  type AbsOfCon C.TypedBinding = Maybe A.TypedBinding--  toAbstract (C.TBind r xs t) = do-    t' <- toAbstractCtx TopCtx t-    tac <- traverse toAbstract $-             case List1.mapMaybe (bnameTactic . C.binderName . namedArg) xs of-               []      -> Nothing-               tac : _ -> Just tac-               -- Invariant: all tactics are the same-               -- (distributed in the parser, TODO: don't)-    xs' <- toAbstract $ fmap (updateNamedArg (fmap $ NewName LambdaBound)) xs-    return $ Just $ A.TBind r tac xs' t'-  toAbstract (C.TLet r ds) = A.mkTLet r <$> toAbstract (LetDefs ds)---- | Scope check a module (top level function).----scopeCheckNiceModule-  :: Range-  -> Access-  -> C.Name-  -> C.Telescope-  -> ScopeM [A.Declaration]-  -> ScopeM A.Declaration-       -- ^ The returned declaration is an 'A.Section'.-scopeCheckNiceModule r p name tel checkDs-  | telHasOpenStmsOrModuleMacros tel = do-      -- Andreas, 2013-12-10:-      -- If the module telescope contains open statements-      -- or module macros (Issue 1299),-      -- add an extra anonymous module around the current one.-      -- Otherwise, the open statements would create-      -- identifiers in the parent scope of the current module.-      -- But open statements in the module telescope should-      -- only affect the current module!-      scopeCheckNiceModule noRange p noName_ [] $ singleton <$>-        scopeCheckNiceModule_ PublicAccess  -- See #4350--  | otherwise = do-        scopeCheckNiceModule_ p-  where-    -- The actual workhorse:-    scopeCheckNiceModule_ :: Access -> ScopeM A.Declaration-    scopeCheckNiceModule_ p = do--      -- Check whether we are dealing with an anonymous module.-      -- This corresponds to a Coq/LEGO section.-      (name, p', open) <- do-        if isNoName name then do-          (i :: NameId) <- fresh-          return (C.NoName (getRange name) i, PrivateAccess Inserted, True)-         else return (name, p, False)--      -- Check and bind the module, using the supplied check for its contents.-      aname <- toAbstract (NewModuleName name)-      d <- snd <$> do-        scopeCheckModule r (C.QName name) aname tel checkDs-      bindModule p' name aname--      -- If the module was anonymous open it public-      -- unless it's private, in which case we just open it (#2099)-      when open $-       void $ -- We can discard the returned default A.ImportDirective.-        openModule TopOpenModule (Just aname) (C.QName name) $-          defaultImportDir { publicOpen = boolToMaybe (p == PublicAccess) noRange }-      return d---- | Check whether a telescope has open declarations or module macros.-telHasOpenStmsOrModuleMacros :: C.Telescope -> Bool-telHasOpenStmsOrModuleMacros = any yesBind-  where-    yesBind C.TBind{}     = False-    yesBind (C.TLet _ ds) = any yes ds-    yes C.ModuleMacro{}   = True-    yes C.Open{}          = True-    yes C.Import{}        = True -- not __IMPOSSIBLE__, see Issue #1718-      -- However, it does not matter what we return here, as this will-      -- become an error later: "Not a valid let-declaration".-      -- (Andreas, 2015-11-17)-    yes (C.Mutual   _ ds) = any yes ds-    yes (C.Abstract _ ds) = any yes ds-    yes (C.Private _ _ ds) = any yes ds-    yes _                 = False--{- UNUSED-telHasLetStms :: C.Telescope -> Bool-telHasLetStms = any isLetBind-  where-    isLetBind C.TBind{} = False-    isLetBind C.TLet{}  = True--}---- | We for now disallow let-bindings in @data@ and @record@ telescopes.---   This due "nested datatypes"; there is no easy interpretation of---   @---      data D (A : Set) (open M A) (b : B) : Set where---        c : D (A × A) b → D A b---   @---   where @B@ is brought in scope by @open M A@.--class EnsureNoLetStms a where-  ensureNoLetStms :: a -> ScopeM ()--  default ensureNoLetStms :: (Foldable t, EnsureNoLetStms b, t b ~ a) => a -> ScopeM ()-  ensureNoLetStms = traverse_ ensureNoLetStms--instance EnsureNoLetStms C.Binder where-  ensureNoLetStms arg@(C.Binder p n) =-    when (isJust p) $ typeError $ IllegalPatternInTelescope arg--instance EnsureNoLetStms C.TypedBinding where-  ensureNoLetStms = \case-    tb@C.TLet{}    -> typeError $ IllegalLetInTelescope tb-    C.TBind _ xs _ -> traverse_ (ensureNoLetStms . namedArg) xs--instance EnsureNoLetStms a => EnsureNoLetStms (LamBinding' a) where-  ensureNoLetStms = \case-    -- GA: DO NOT use traverse here: `LamBinding'` only uses its parameter in-    --     the DomainFull constructor so we would miss out on some potentially-    --     illegal lets! Cf. #4402-    C.DomainFree a -> ensureNoLetStms a-    C.DomainFull a -> ensureNoLetStms a--instance EnsureNoLetStms a => EnsureNoLetStms (Named_ a) where-instance EnsureNoLetStms a => EnsureNoLetStms (NamedArg a) where-instance EnsureNoLetStms a => EnsureNoLetStms [a] where----- | Returns the scope inside the checked module.-scopeCheckModule-  :: Range                   -- ^ The range of the module.-  -> C.QName                 -- ^ The concrete name of the module.-  -> A.ModuleName            -- ^ The abstract name of the module.-  -> C.Telescope             -- ^ The module telescope.-  -> ScopeM [A.Declaration]  -- ^ The code for checking the module contents.-  -> ScopeM (ScopeInfo, A.Declaration)-       -- ^ The returned declaration is an 'A.Section'.-scopeCheckModule r x qm tel checkDs = do-  printScope "module" 20 $ "checking module " ++ prettyShow x-  -- Andreas, 2013-12-10: Telescope does not live in the new module-  -- but its parent, so check it before entering the new module.-  -- This is important for Nicolas Pouillard's open parametrized modules-  -- statements inside telescopes.-  res <- withLocalVars $ do-    tel <- toAbstract (GenTel tel)-    withCurrentModule qm $ do-      -- pushScope m-      -- qm <- getCurrentModule-      printScope "module" 20 $ "inside module " ++ prettyShow x-      ds    <- checkDs-      scope <- getScope-      return (scope, A.Section r (qm `withRangesOfQ` x) tel ds)--  -- Binding is done by the caller-  printScope "module" 20 $ "after module " ++ prettyShow x-  return res---- | Temporary data type to scope check a file.-data TopLevel a = TopLevel-  { topLevelPath           :: AbsolutePath-    -- ^ The file path from which we loaded this module.-  , topLevelExpectedName   :: C.TopLevelModuleName-    -- ^ The expected module name-    --   (coming from the import statement that triggered scope checking this file).-  , topLevelTheThing       :: a-    -- ^ The file content.-  }--data TopLevelInfo = TopLevelInfo-        { topLevelDecls :: [A.Declaration]-        , topLevelScope :: ScopeInfo  -- ^ as seen from inside the module-        }---- | The top-level module name.--topLevelModuleName :: TopLevelInfo -> A.ModuleName-topLevelModuleName = (^. scopeCurrent) . topLevelScope---- | Top-level declarations are always---   @---     (import|open)*         -- a bunch of possibly opened imports---     module ThisModule ...  -- the top-level module of this file---   @-instance ToAbstract (TopLevel [C.Declaration]) where-    type AbsOfCon (TopLevel [C.Declaration]) = TopLevelInfo--    toAbstract (TopLevel file expectedMName ds) =-      -- A file is a bunch of preliminary decls (imports etc.)-      -- plus a single module decl.-      case C.spanAllowedBeforeModule ds of--        -- If there are declarations after the top-level module-        -- we have to report a parse error here.-        (_, C.Module{} : d : _) -> traceCall (SetRange $ getRange d) $-          genericError $ "No declarations allowed after top-level module."--        -- Otherwise, proceed.-        (outsideDecls, [ C.Module r m0 tel insideDecls ]) -> do-          -- If the module name is _ compute the name from the file path-          m <- if isNoName m0-                then do-                  -- Andreas, 2017-07-28, issue #1077-                  -- Check if the insideDecls end in a single module which has the same-                  -- name as the file.  In this case, it is highly likely that the user-                  -- put some non-allowed declarations before the top-level module in error.-                  -- Andreas, 2017-10-19, issue #2808-                  -- Widen this check to:-                  -- If the first module of the insideDecls has the same name as the file,-                  -- report an error.-                  case flip span insideDecls $ \case { C.Module{} -> False; _ -> True } of-                    (ds0, (C.Module _ m1 _ _ : _))-                       | C.toTopLevelModuleName m1 == expectedMName-                         -- If the anonymous module comes from the user,-                         -- the range cannot be the beginningOfFile.-                         -- That is the range if the parser inserted the anon. module.-                       , r == beginningOfFile (getRange insideDecls) -> do--                         -- GA #4888: We know we are in a bad place. But we still scopecheck-                         -- the initial segment on the off chance we generate a better error-                         -- message.-                         void importPrimitives-                         void $ toAbstract (Declarations outsideDecls)-                         void $ toAbstract (Declarations ds0)-                         -- Fail with a crude error otherwise-                         traceCall (SetRange $ getRange ds0) $ genericError-                           "Illegal declaration(s) before top-level module"--                    -- Otherwise, reconstruct the top-level module name-                    _ -> return $ C.QName $ setRange (getRange m0) $-                           C.simpleName $ stringToRawName $ rootNameModule file-                -- Andreas, 2017-05-17, issue #2574, keep name as jump target!-                -- Andreas, 2016-07-12, ALTERNATIVE:-                -- -- We assign an anonymous file module the name expected from-                -- -- its import.  For flat file structures, this is the same.-                -- -- For hierarchical file structures, this reverses the behavior:-                -- -- Loading the file by itself will fail, but it can be imported.-                -- -- The previous behavior is: it can be loaded by itself, but not-                -- -- be imported-                -- then return $ C.fromTopLevelModuleName expectedMName-                else do-                -- Andreas, 2014-03-28  Issue 1078-                -- We need to check the module name against the file name here.-                -- Otherwise one could sneak in a lie and confuse the scope-                -- checker.-                  checkModuleName (C.toTopLevelModuleName m0) (SourceFile file) $ Just expectedMName-                  return m0-          setTopLevelModule m-          am <- toAbstract (NewModuleQName m)-          primitiveImport <- importPrimitives-          -- Scope check the declarations outside-          outsideDecls <- toAbstract (Declarations outsideDecls)-          (insideScope, insideDecl) <- scopeCheckModule r m am tel $-             toAbstract (Declarations insideDecls)-          -- Andreas, 2020-05-13, issue #1804, #4647-          -- Do not eagerly remove private definitions, only when serializing-          -- let scope = over scopeModules (fmap $ restrictLocalPrivate am) insideScope-          let scope = insideScope-          setScope scope-          return $ TopLevelInfo (primitiveImport ++ outsideDecls ++ [ insideDecl ]) scope--        -- We already inserted the missing top-level module, see-        -- 'Agda.Syntax.Parser.Parser.figureOutTopLevelModule',-        -- thus, this case is impossible:-        _ -> __IMPOSSIBLE__---- | Declaration @open import Agda.Primitive using (Set; Prop)@ when 'optImportSorts'.-importPrimitives :: ScopeM [A.Declaration]-importPrimitives = do-    noImportSorts <- not . optImportSorts <$> pragmaOptions-    -- Add implicit `open import Agda.Primitive using (Set; Prop)`-    let agdaPrimitiveName   = Qual (C.simpleName "Agda") $ C.QName $ C.simpleName "Primitive"-        agdaSetName         = C.simpleName "Set"-        agdaPropName        = C.simpleName "Prop"-        usingDirective      = Using [ImportedName agdaSetName, ImportedName agdaPropName]-        directives          = ImportDirective noRange usingDirective [] [] Nothing-        importAgdaPrimitive = [C.Import noRange agdaPrimitiveName Nothing C.DoOpen directives]-    if noImportSorts-      then return []-      else toAbstract (Declarations importAgdaPrimitive)---- | runs Syntax.Concrete.Definitions.niceDeclarations on main module-niceDecls :: DoWarn -> [C.Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a-niceDecls warn ds ret = setCurrentRange ds $ computeFixitiesAndPolarities warn ds $ do-  fixs <- useScope scopeFixities  -- We need to pass the fixities to the nicifier for clause grouping-  let (result, warns') = runNice $ niceDeclarations fixs ds--  -- COMPILED pragmas are not allowed in safe mode unless we are in a builtin module.-  -- So we start by filtering out all the PragmaCompiled warnings if one of these two-  -- conditions is not met.-  isSafe    <- Lens.getSafeMode <$> pragmaOptions-  isBuiltin <- Lens.isBuiltinModule . filePath =<< getCurrentPath-  let warns = if isSafe && not isBuiltin then warns' else filter notOnlyInSafeMode warns'--  -- Respect the @DoWarn@ directive. For this to be sound, we need to know for-  -- sure that each @Declaration@ is checked at least once with @DoWarn@.-  unless (warn == NoWarn || null warns) $ do-    -- If there are some warnings and the --safe flag is set,-    -- we check that none of the NiceWarnings are fatal-    when isSafe $ do-      let (errs, ws) = List.partition unsafeDeclarationWarning warns-      -- If some of them are, we fail-      unless (null errs) $ do-        warnings $ NicifierIssue <$> ws-        tcerrs <- mapM warning_ $ NicifierIssue <$> errs-        setCurrentRange errs $ typeError $ NonFatalErrors tcerrs-    -- Otherwise we simply record the warnings-    mapM_ (\ w -> warning' (dwLocation w) $ NicifierIssue w) warns-  case result of-    Left (DeclarationException loc e) -> do-      reportSLn "error" 2 $ "Error raised at " ++ prettyShow loc-      throwError $ Exception (getRange e) $ pretty e-    Right ds -> ret ds--  where notOnlyInSafeMode = (PragmaCompiled_ /=) . declarationWarningName---- | Wrapper to avoid instance conflict with generic list instance.-newtype Declarations = Declarations [C.Declaration]--instance ToAbstract Declarations where-  type AbsOfCon Declarations = [A.Declaration]--  toAbstract (Declarations ds) = do-    -- When --safe is active the termination checker (Issue 586),-    -- positivity checker (Issue 1614) and the coverage checker-    -- may not be switched off, and polarities may not be assigned.-    ds <- ifM (Lens.getSafeMode <$> pragmaOptions)-               {- then -} (mapM noUnsafePragma ds)-               {- else -} (return ds)--    niceDecls DoWarn ds toAbstract-   where--     -- We need to dig deep into a declaration, otherwise it is possible-     -- to hide an illegal pragma in a block. Cf. Issue #3983-     noUnsafePragma :: C.Declaration -> TCM C.Declaration-     noUnsafePragma = \case-       C.Pragma pr                 -> warnUnsafePragma pr-       C.RecordDef r n dir lams ds -> C.RecordDef r n dir lams <$> mapM noUnsafePragma ds-       C.Record r n dir lams e ds  -> C.Record r n dir lams e <$> mapM noUnsafePragma ds-       C.Mutual r ds               -> C.Mutual r <$> mapM noUnsafePragma ds-       C.Abstract r ds             -> C.Abstract r <$> mapM noUnsafePragma ds-       C.Private r o ds            -> C.Private r o <$> mapM noUnsafePragma ds-       C.InstanceB r ds            -> C.InstanceB r <$> mapM noUnsafePragma ds-       C.Macro r ds                -> C.Macro r <$> mapM noUnsafePragma ds-       d -> pure d--     warnUnsafePragma :: C.Pragma -> TCM C.Declaration-     warnUnsafePragma pr = C.Pragma pr <$ do-       ifM (Lens.isBuiltinModuleWithSafePostulates . filePath =<< getCurrentPath)-         {- then -} (pure ())-         {- else -} $ case unsafePragma pr of-         Nothing -> pure ()-         Just w  -> setCurrentRange pr $ warning w--     unsafePragma :: C.Pragma -> Maybe Warning-     unsafePragma = \case-       C.NoCoverageCheckPragma{}    -> Just SafeFlagNoCoverageCheck-       C.NoPositivityCheckPragma{}  -> Just SafeFlagNoPositivityCheck-       C.PolarityPragma{}           -> Just SafeFlagPolarity-       C.NoUniverseCheckPragma{}    -> Just SafeFlagNoUniverseCheck-       C.InjectivePragma{}          -> Just SafeFlagInjective-       C.TerminationCheckPragma _ m -> case m of-         NonTerminating       -> Just SafeFlagNonTerminating-         Terminating          -> Just SafeFlagTerminating-         TerminationCheck     -> Nothing-         TerminationMeasure{} -> Nothing-         -- ASR (31 December 2015). We don't pattern-match on-         -- @NoTerminationCheck@ because the @NO_TERMINATION_CHECK@ pragma-         -- was removed. See Issue #1763.-         NoTerminationCheck -> Nothing-       -- exhaustive match to get told by ghc we should have a look at this-       -- when we add new pragmas.-       C.OptionsPragma{}    -> Nothing-       C.BuiltinPragma{}    -> Nothing-       C.ForeignPragma{}    -> Nothing-       C.StaticPragma{}     -> Nothing-       C.InlinePragma{}     -> Nothing-       C.ImpossiblePragma{} -> Nothing-       C.EtaPragma{}        -> Just SafeFlagEta-       C.WarningOnUsage{}   -> Nothing-       C.WarningOnImport{}  -> Nothing-       C.DisplayPragma{}    -> Nothing-       C.CatchallPragma{}   -> Nothing-       -- @RewritePragma@ already requires --rewriting which is incompatible with --safe-       C.RewritePragma{}    -> Nothing-       -- @CompilePragma@ already handled in the nicifier-       C.CompilePragma{}    -> Nothing---newtype LetDefs = LetDefs (List1 C.Declaration)-newtype LetDef = LetDef NiceDeclaration--instance ToAbstract LetDefs where-  type AbsOfCon LetDefs = [A.LetBinding]--  toAbstract (LetDefs ds) =-    List1.concat <$> niceDecls DoWarn (List1.toList ds) (toAbstract . map LetDef)--instance ToAbstract LetDef where-  type AbsOfCon LetDef = List1 A.LetBinding-  toAbstract (LetDef d) =-    case d of-      NiceMutual _ _ _ _ d@[C.FunSig _ _ _ instanc macro info _ _ x t, C.FunDef _ _ abstract _ _ _ _ [cl]] ->-          do  when (abstract == AbstractDef) $ do-                genericError $ "`abstract` not allowed in let expressions"-              when (macro == MacroDef) $ do-                genericError $ "Macros cannot be defined in a let expression"-              t <- toAbstract t-              -- We bind the name here to make sure it's in scope for the LHS (#917).-              -- It's unbound for the RHS in letToAbstract.-              fx <- getConcreteFixity x-              x  <- A.unBind <$> toAbstract (NewName LetBound $ mkBoundName x fx)-              (x', e) <- letToAbstract cl-              -- If InstanceDef set info to Instance-              let info' = case instanc of-                    InstanceDef _  -> makeInstance info-                    NotInstanceDef -> info-              -- There are sometimes two instances of the-              -- let-bound variable, one declaration and one-              -- definition. The first list element below is-              -- used to highlight the declared instance in the-              -- right way (see Issue 1618).-              return $ A.LetDeclaredVariable (A.mkBindName (setRange (getRange x') x)) :|-                     [ A.LetBind (LetRange $ getRange d) info' (A.mkBindName x) t e-                     ]--      -- irrefutable let binding, like  (x , y) = rhs-      NiceFunClause r PublicAccess ConcreteDef tc cc catchall d@(C.FunClause lhs@(C.LHS p0 [] []) rhs0 wh ca) -> do-        noWhereInLetBinding wh-        rhs <- letBindingMustHaveRHS rhs0-        mp  <- setCurrentRange p0 $-                 (Right <$> parsePattern p0)-                   `catchError`-                 (return . Left)-        case mp of-          Right p -> do-            rhs <- toAbstract rhs-            setCurrentRange p0 $ do-              p   <- toAbstract p-              checkValidLetPattern p-              checkPatternLinearity p $ \ys ->-                typeError $ RepeatedVariablesInPattern ys-              bindVarsToBind-              p   <- toAbstract p-              return $ singleton $ A.LetPatBind (LetRange r) p rhs-          -- It's not a record pattern, so it should be a prefix left-hand side-          Left err ->-            case definedName p0 of-              Nothing -> throwError err-              Just x  -> toAbstract $ LetDef $ NiceMutual r tc cc YesPositivityCheck-                [ C.FunSig r PublicAccess ConcreteDef NotInstanceDef NotMacroDef (setOrigin Inserted defaultArgInfo) tc cc x (C.Underscore (getRange x) Nothing)-                , C.FunDef r __IMPOSSIBLE__ ConcreteDef NotInstanceDef __IMPOSSIBLE__ __IMPOSSIBLE__ __IMPOSSIBLE__-                  [C.Clause x (ca || catchall) lhs (C.RHS rhs) NoWhere []]-                ]-            where-              definedName (C.IdentP (C.QName x)) = Just x-              definedName C.IdentP{}             = Nothing-              definedName (C.RawAppP _ (List2 p _ _)) = definedName p-              definedName (C.ParenP _ p)         = definedName p-              definedName C.WildP{}              = Nothing   -- for instance let _ + x = x in ... (not allowed)-              definedName C.AbsurdP{}            = Nothing-              definedName C.AsP{}                = Nothing-              definedName C.DotP{}               = Nothing-              definedName C.EqualP{}             = Nothing-              definedName C.LitP{}               = Nothing-              definedName C.RecP{}               = Nothing-              definedName C.QuoteP{}             = Nothing-              definedName C.HiddenP{}            = Nothing -- Not impossible, see issue #2291-              definedName C.InstanceP{}          = Nothing-              definedName C.WithP{}              = Nothing-              definedName C.AppP{}               = Nothing -- Not impossible, see issue #4586-              definedName C.OpAppP{}             = __IMPOSSIBLE__-              definedName C.EllipsisP{}          = Nothing -- Not impossible, see issue #3937--      -- You can't open public in a let-      NiceOpen r x dirs -> do-        whenJust (publicOpen dirs) $ \r -> setCurrentRange r $ warning UselessPublic-        m    <- toAbstract (OldModuleName x)-        adir <- openModule_ LetOpenModule x dirs-        let minfo = ModuleInfo-              { minfoRange  = r-              , minfoAsName = Nothing-              , minfoAsTo   = renamingRange dirs-              , minfoOpenShort = Nothing-              , minfoDirective = Just dirs-              }-        return $ singleton $ A.LetOpen minfo m adir--      NiceModuleMacro r p x modapp open dir -> do-        whenJust (publicOpen dir) $ \ r -> setCurrentRange r $ warning UselessPublic-        -- Andreas, 2014-10-09, Issue 1299: module macros in lets need-        -- to be private-        singleton <$> checkModuleMacro LetApply LetOpenModule r (PrivateAccess Inserted) x modapp open dir--      _   -> notAValidLetBinding d-    where-        letToAbstract (C.Clause top _catchall (C.LHS p [] []) rhs0 wh []) = do-            noWhereInLetBinding wh-            rhs <- letBindingMustHaveRHS rhs0-            (x, args) <- do-              res <- setCurrentRange p $ parseLHS (C.QName top) p-              case res of-                C.LHSHead x args -> return (x, args)-                C.LHSProj{} -> genericError $ "Copatterns not allowed in let bindings"-                C.LHSWith{} -> genericError $ "`with` patterns not allowed in let bindings"-                C.LHSEllipsis{} -> genericError "`...` not allowed in let bindings"--            e <- localToAbstract args $ \args -> do-                bindVarsToBind-                -- Make sure to unbind the function name in the RHS, since lets are non-recursive.-                rhs <- unbindVariable top $ toAbstract rhs-                foldM lambda rhs (reverse args)  -- just reverse because these are DomainFree-            return (x, e)-        letToAbstract _ = notAValidLetBinding d--        -- Named patterns not allowed in let definitions-        lambda e (Arg info (Named Nothing (A.VarP x))) =-                return $ A.Lam i (A.mkDomainFree $ unnamedArg info $ A.mkBinder x) e-            where i = ExprRange (fuseRange x e)-        lambda e (Arg info (Named Nothing (A.WildP i))) =-            do  x <- freshNoName (getRange i)-                return $ A.Lam i' (A.mkDomainFree $ unnamedArg info $ A.mkBinder_ x) e-            where i' = ExprRange (fuseRange i e)-        lambda _ _ = notAValidLetBinding d--        noWhereInLetBinding :: C.WhereClause -> ScopeM ()-        noWhereInLetBinding = \case-          NoWhere -> return ()-          wh -> setCurrentRange wh $ genericError $ "`where` clauses not allowed in let bindings"-        letBindingMustHaveRHS :: C.RHS -> ScopeM C.Expr-        letBindingMustHaveRHS = \case-          C.RHS e -> return e-          C.AbsurdRHS -> genericError $ "Missing right hand side in let binding"--        -- Only record patterns allowed, but we do not exclude data constructors here.-        -- They will fail in the type checker.-        checkValidLetPattern :: A.Pattern' e -> ScopeM ()-        checkValidLetPattern = \case-            A.VarP{}             -> yes-            A.ConP _ _ ps        -> mapM_ (checkValidLetPattern . namedArg) ps-            A.ProjP{}            -> no-            A.DefP{}             -> no-            A.WildP{}            -> yes-            A.AsP _ _ p          -> checkValidLetPattern p-            A.DotP{}             -> no-            A.AbsurdP{}          -> no-            A.LitP{}             -> no-            A.PatternSynP _ _ ps -> mapM_ (checkValidLetPattern . namedArg) ps-            A.RecP _ fs          -> mapM_ (checkValidLetPattern . _exprFieldA) fs-            A.EqualP{}           -> no-            A.WithP{}            -> no-            A.AnnP _ _ p         -> checkValidLetPattern p-          where-          yes = return ()-          no  = genericError "Not a valid let pattern"---instance ToAbstract NiceDeclaration where-  type AbsOfCon NiceDeclaration = A.Declaration--  toAbstract d = annotateDecls $-    traceS "scope.decl.trace" 50-      [ "scope checking declaration"-      , "  " ++  prettyShow d-      ] $-    traceS "scope.decl.trace" 80  -- keep this debug message for testing issue #4016-      [ "scope checking declaration (raw)"-      , "  " ++  show d-      ] $-    traceCall (ScopeCheckDeclaration d) $-    -- Andreas, 2015-10-05, Issue 1677:-    -- We record in the environment whether we are scope checking an-    -- abstract definition.  This way, we can propagate this attribute-    -- the extended lambdas.-    caseMaybe (niceHasAbstract d) id (\ a -> localTC $ \ e -> e { envAbstractMode = aDefToMode a }) $-    case d of--  -- Axiom (actual postulate)-    C.Axiom r p a i rel x t -> do-      -- check that we do not postulate in --safe mode, unless it is a-      -- builtin module with safe postulates-      whenM ((Lens.getSafeMode <$> commandLineOptions) `and2M`-             (not <$> (Lens.isBuiltinModuleWithSafePostulates . filePath =<< getCurrentPath)))-            (warning $ SafeFlagPostulate x)-      -- check the postulate-      singleton <$> toAbstractNiceAxiom AxiomName d--    C.NiceGeneralize r p i tac x t -> do-      reportSLn "scope.decl" 10 $ "found nice generalize: " ++ prettyShow x-      tac <- traverse (toAbstractCtx TopCtx) tac-      t_ <- toAbstractCtx TopCtx t-      let (s, t) = unGeneralized t_-      reportSLn "scope.decl" 50 $ "generalizations: " ++ show (Set.toList s, t)-      f <- getConcreteFixity x-      y <- freshAbstractQName f x-      bindName p GeneralizeName x y-      let info = (mkDefInfo x f p ConcreteDef r) { defTactic = tac }-      return [A.Generalize s info i y t]--  -- Fields-    C.NiceField r p a i tac x t -> do-      unless (p == PublicAccess) $ genericError "Record fields can not be private"-      -- Interaction points for record fields have already been introduced-      -- when checking the type of the record constructor.-      -- To avoid introducing interaction points (IP) twice, we turn-      -- all question marks to underscores.  (See issue 1138.)-      let maskIP (C.QuestionMark r _) = C.Underscore r Nothing-          maskIP e                     = e-      tac <- traverse (toAbstractCtx TopCtx) tac-      t' <- toAbstractCtx TopCtx $ mapExpr maskIP t-      f  <- getConcreteFixity x-      y  <- freshAbstractQName f x-      -- Andreas, 2018-06-09 issue #2170-      -- We want dependent irrelevance without irrelevant projections,-      -- thus, do not disable irrelevant projections via the scope checker.-      -- irrProj <- optIrrelevantProjections <$> pragmaOptions-      -- unless (isIrrelevant t && not irrProj) $-      --   -- Andreas, 2010-09-24: irrelevant fields are not in scope-      --   -- this ensures that projections out of irrelevant fields cannot occur-      --   -- Ulf: unless you turn on --irrelevant-projections-      bindName p FldName x y-      let info = (mkDefInfoInstance x f p a i NotMacroDef r) { defTactic = tac }-      return [ A.Field info y t' ]--  -- Primitive function-    PrimitiveFunction r p a x t -> do-      t' <- traverse (toAbstractCtx TopCtx) t-      f  <- getConcreteFixity x-      y  <- freshAbstractQName f x-      bindName p PrimName x y-      return [ A.Primitive (mkDefInfo x f p a r) y t' ]--  -- Definitions (possibly mutual)-    NiceMutual r tc cc pc ds -> do-      ds' <- toAbstract ds-      -- We only termination check blocks that do not have a measure.-      return [ A.Mutual (MutualInfo tc cc pc r) ds' ]--    C.NiceRecSig r p a _pc _uc x ls t -> do-      ensureNoLetStms ls-      withLocalVars $ do-        (ls', _) <- withCheckNoShadowing $-          -- Minor hack: record types don't have indices so we include t when-          -- computing generalised parameters, but in the type checker any named-          -- generalizable arguments in the sort should be bound variables.-          toAbstract (GenTelAndType (map makeDomainFull ls) t)-        t' <- toAbstract t-        f  <- getConcreteFixity x-        x' <- freshAbstractQName f x-        bindName' p RecName (GeneralizedVarsMetadata $ generalizeTelVars ls') x x'-        return [ A.RecSig (mkDefInfo x f p a r) x' ls' t' ]--    C.NiceDataSig r p a pc uc x ls t -> do-        reportSLn "scope.data.sig" 20 ("checking DataSig for " ++ prettyShow x)-        ensureNoLetStms ls-        withLocalVars $ do-          ls' <- withCheckNoShadowing $-            toAbstract $ GenTel $ map makeDomainFull ls-          t'  <- toAbstract $ C.Generalized t-          f  <- getConcreteFixity x-          x' <- freshAbstractQName f x-          mErr <- bindName'' p DataName (GeneralizedVarsMetadata $ generalizeTelVars ls') x x'-          whenJust mErr $ \case-            err@(ClashingDefinition cn an _) -> do-              resolveName (C.QName x) >>= \case-                -- #4435: if a data type signature causes a ClashingDefinition error, and if-                -- the data type name is bound to an Axiom, then the error may be caused by-                -- the illegal type signature. Convert the NiceDataSig into a NiceDataDef-                -- (which removes the type signature) and suggest it as a possible fix.-                DefinedName p ax NoSuffix | anameKind ax == AxiomName -> do-                  let suggestion = NiceDataDef r Inserted a pc uc x ls []-                  typeError $ ClashingDefinition cn an (Just suggestion)-                _ -> typeError err-            otherErr -> typeError otherErr-          return [ A.DataSig (mkDefInfo x f p a r) x' ls' t' ]--  -- Type signatures-    C.FunSig r p a i m rel _ _ x t -> do-        let kind = if m == MacroDef then MacroName else FunName-        singleton <$> toAbstractNiceAxiom kind (C.Axiom r p a i rel x t)--  -- Function definitions-    C.FunDef r ds a i _ _ x cs -> do-        printLocals 10 $ "checking def " ++ prettyShow x-        (x',cs) <- toAbstract (OldName x,cs)-        -- Andreas, 2017-12-04 the name must reside in the current module-        unlessM ((A.qnameModule x' ==) <$> getCurrentModule) $-          __IMPOSSIBLE__-        let delayed = NotDelayed-        -- (delayed, cs) <- translateCopatternClauses cs -- TODO-        f <- getConcreteFixity x-        return [ A.FunDef (mkDefInfoInstance x f PublicAccess a i NotMacroDef r) x' delayed cs ]--  -- Uncategorized function clauses-    C.NiceFunClause _ _ _ _ _ _ (C.FunClause lhs _ _ _) ->-      genericError $-        "Missing type signature for left hand side " ++ prettyShow lhs-    C.NiceFunClause{} -> __IMPOSSIBLE__--  -- Data definitions-    C.NiceDataDef r o a _ uc x pars cons -> do-        reportSLn "scope.data.def" 20 ("checking " ++ show o ++ " DataDef for " ++ prettyShow x)-        (p, ax) <- resolveName (C.QName x) >>= \case-          DefinedName p ax NoSuffix -> do-            clashUnless x DataName ax  -- Andreas 2019-07-07, issue #3892-            livesInCurrentModule ax  -- Andreas, 2017-12-04, issue #2862-            clashIfModuleAlreadyDefinedInCurrentModule x ax-            return (p, ax)-          _ -> genericError $ "Missing type signature for data definition " ++ prettyShow x-        ensureNoLetStms pars-        withLocalVars $ do-          gvars <- bindGeneralizablesIfInserted o ax-          -- Check for duplicate constructors-          do cs <- mapM conName cons-             unlessNull (duplicates cs) $ \ dups -> do-               let bad = filter (`elem` dups) cs-               setCurrentRange bad $-                 typeError $ DuplicateConstructors dups--          pars <- catMaybes <$> toAbstract pars-          let x' = anameName ax-          -- Create the module for the qualified constructors-          checkForModuleClash x -- disallow shadowing previously defined modules-          let m = qnameToMName x'-          createModule (Just IsDataModule) m-          bindModule p x m  -- make it a proper module-          cons <- toAbstract (map (DataConstrDecl m a p) cons)-          printScope "data" 20 $ "Checked data " ++ prettyShow x-          f <- getConcreteFixity x-          return [ A.DataDef (mkDefInfo x f PublicAccess a r) x' uc (DataDefParams gvars pars) cons ]-      where-        conName (C.Axiom _ _ _ _ _ c _) = return c-        conName d = errorNotConstrDecl d--  -- Record definitions (mucho interesting)-    C.NiceRecDef r o a _ uc x (RecordDirectives ind eta pat cm) pars fields -> do-      reportSLn "scope.rec.def" 20 ("checking " ++ show o ++ " RecDef for " ++ prettyShow x)-      -- #3008: Termination pragmas are ignored in records-      checkNoTerminationPragma InRecordDef fields-      -- Andreas, 2020-04-19, issue #4560-      -- 'pattern' declaration is incompatible with 'coinductive' or 'eta-equality'.-      whenJust pat $ \ r -> do-        let warn = setCurrentRange r . warning . UselessPatternDeclarationForRecord-        if | Just (Ranged _ CoInductive) <- ind -> warn "coinductive"-           | Just YesEta                 <- eta -> warn "eta"-           | otherwise -> return ()--      (p, ax) <- resolveName (C.QName x) >>= \case-        DefinedName p ax NoSuffix -> do-          clashUnless x RecName ax  -- Andreas 2019-07-07, issue #3892-          livesInCurrentModule ax  -- Andreas, 2017-12-04, issue #2862-          clashIfModuleAlreadyDefinedInCurrentModule x ax-          return (p, ax)-        _ -> genericError $ "Missing type signature for record definition " ++ prettyShow x-      ensureNoLetStms pars-      withLocalVars $ do-        gvars <- bindGeneralizablesIfInserted o ax-        -- Check that the generated module doesn't clash with a previously-        -- defined module-        checkForModuleClash x-        pars   <- catMaybes <$> toAbstract pars-        let x' = anameName ax-        -- We scope check the fields a first time when putting together-        -- the type of the constructor.-        contel <- localToAbstract (RecordConstructorType fields) return-        m0     <- getCurrentModule-        let m = A.qualifyM m0 $ mnameFromList1 $ singleton $ List1.last $ qnameToList x'-        printScope "rec" 15 "before record"-        createModule (Just IsRecordModule) m-        -- We scope check the fields a second time, as actual fields.-        afields <- withCurrentModule m $ do-          afields <- toAbstract (Declarations fields)-          printScope "rec" 15 "checked fields"-          return afields-        -- Andreas, 2017-07-13 issue #2642 disallow duplicate fields-        -- Check for duplicate fields. (See "Check for duplicate constructors")-        do let fs :: [C.Name]-               fs = concat $ forMaybe fields $ \case-                 C.Field _ fs -> Just $ fs <&> \case-                   -- a Field block only contains field signatures-                   C.FieldSig _ _ f _ -> f-                   _ -> __IMPOSSIBLE__-                 _ -> Nothing-           unlessNull (duplicates fs) $ \ dups -> do-             let bad = filter (`elem` dups) fs-             setCurrentRange bad $-               typeError $ DuplicateFields dups-        bindModule p x m-        let kind = maybe ConName (conKindOfName . rangedThing) ind-        -- Andreas, 2019-11-11, issue #4189, no longer add record constructor to record module.-        cm' <- forM cm $ \ (c, _) -> bindRecordConstructorName c kind a p-        let inst = caseMaybe cm NotInstanceDef snd-        printScope "rec" 15 "record complete"-        f <- getConcreteFixity x-        let params = DataDefParams gvars pars-        let dir' = RecordDirectives ind eta pat cm'-        return [ A.RecDef (mkDefInfoInstance x f PublicAccess a inst NotMacroDef r) x' uc dir' params contel afields ]--    NiceModule r p a x@(C.QName name) tel ds -> do-      reportSDoc "scope.decl" 70 $ vcat $-        [ text $ "scope checking NiceModule " ++ prettyShow x-        ]--      adecl <- traceCall (ScopeCheckDeclaration $ NiceModule r p a x tel []) $ do-        scopeCheckNiceModule r p name tel $ toAbstract (Declarations ds)--      reportSDoc "scope.decl" 70 $ vcat $-        [ text $ "scope checked NiceModule " ++ prettyShow x-        , nest 2 $ prettyA adecl-        ]-      return [ adecl ]--    NiceModule _ _ _ m@C.Qual{} _ _ ->-      genericError $ "Local modules cannot have qualified names"--    NiceModuleMacro r p x modapp open dir -> do-      reportSDoc "scope.decl" 70 $ vcat $-        [ text $ "scope checking NiceModuleMacro " ++ prettyShow x-        ]--      adecl <- checkModuleMacro Apply TopOpenModule r p x modapp open dir--      reportSDoc "scope.decl" 70 $ vcat $-        [ text $ "scope checked NiceModuleMacro " ++ prettyShow x-        , nest 2 $ prettyA adecl-        ]-      return [ adecl ]--    NiceOpen r x dir -> do-      (minfo, m, adir) <- checkOpen r Nothing x dir-      return [A.Open minfo m adir]--    NicePragma r p -> do-      ps <- toAbstract p  -- could result in empty list of pragmas-      return $ map (A.Pragma r) ps--    NiceImport r x as open dir -> setCurrentRange r $ do-      dir <- notPublicWithoutOpen open dir--      -- Andreas, 2018-11-03, issue #3364, parse expression in as-clause as Name.-      let illformedAs s = traceCall (SetRange $ getRange as) $ do-            -- If @as@ is followed by something that is not a simple name,-            -- throw a warning and discard the as-clause.-            Nothing <$ warning (IllformedAsClause s)-      as <- case as of-        -- Ok if no as-clause or it (already) contains a Name.-        Nothing -> return Nothing-        Just (AsName (Right asName) r)                    -> return $ Just $ AsName asName r-        Just (AsName (Left (C.Ident (C.QName asName))) r) -> return $ Just $ AsName asName r-        Just (AsName (Left C.Underscore{})     r)         -> return $ Just $ AsName underscore r-        Just (AsName (Left (C.Ident C.Qual{})) r) -> illformedAs "; a qualified name is not allowed here"-        Just (AsName (Left e)                  r) -> illformedAs ""--      -- First scope check the imported module and return its name and-      -- interface. This is done with that module as the top-level module.-      -- This is quite subtle. We rely on the fact that when setting the-      -- top-level module and generating a fresh module name, the generated-      -- name will be exactly the same as the name generated when checking-      -- the imported module.-      (m, i) <- withCurrentModule noModuleName $ withTopLevelModule x $ do-        m <- toAbstract $ NewModuleQName x  -- (No longer erases the contents of @m@.)-        printScope "import" 10 "before import:"-        (m, i) <- scopeCheckImport m-        printScope "import" 10 $ "scope checked import: " ++ prettyShow i-        -- We don't want the top scope of the imported module (things happening-        -- before the module declaration)-        return (m, Map.delete noModuleName i)--      -- Bind the desired module name to the right abstract name.-      (name, theAsSymbol, theAsName) <- case as of--         Just a | let y = asName a, not (isNoName y) -> do-           bindModule (PrivateAccess Inserted) y m-           return (C.QName y, asRange a, Just y)--         _ -> do-           -- Don't bind if @import ... as _@ with "no name"-           whenNothing as $ bindQModule (PrivateAccess Inserted) x m-           return (x, noRange, Nothing)--      -- Open if specified, otherwise apply import directives-      adir <- case open of--        -- With @open@ import directives apply to the opening.-        -- The module is thus present in its qualified form without restrictions.-        DoOpen   -> do--          -- Merge the imported scopes with the current scopes.-          -- This might override a previous import of @m@, but monotonously (add stuff).-          modifyScopes $ \ ms -> Map.unionWith mergeScope (Map.delete m ms) i--          -- Andreas, 2019-05-29, issue #3818.-          -- Pass the resolved name to open instead triggering another resolution.-          -- This helps in situations like-          -- @-          --    module Top where-          --    module M where-          --    open import M-          -- @-          -- It is clear than in @open import M@, name @M@ must refer to a file-          -- rather than the above defined local module @M@.-          -- This already worked in the situation-          -- @-          --    module Top where-          --    module M where-          --    import M-          -- @-          -- Note that the manual desugaring of @open import@ as-          -- @-          --    module Top where-          --    module M where-          --    import M-          --    open M-          -- @-          -- will not work, as @M@ is now ambiguous in @open M@;-          -- the information that @M@ is external is lost here.-          (_minfo, _m, adir) <- checkOpen r (Just m) name dir-          return adir--        -- If not opening, import directives are applied to the original scope.-        DontOpen -> do-          (adir, i') <- Map.adjustM' (applyImportDirectiveM x dir) m i-          -- Andreas, 2020-05-18, issue #3933-          -- We merge the new imports without deleting old imports, to be monotone.-          modifyScopes $ \ ms -> Map.unionWith mergeScope ms i'-          return adir--      printScope "import" 10 "merged imported sig:"-      let minfo = ModuleInfo-            { minfoRange     = r-            , minfoAsName    = theAsName-            , minfoAsTo      = getRange (theAsSymbol, renamingRange dir)-            , minfoOpenShort = Just open-            , minfoDirective = Just dir-            }-      return [ A.Import minfo m adir ]--    NiceUnquoteDecl r p a i tc cc xs e -> do-      fxs <- mapM getConcreteFixity xs-      ys <- zipWithM freshAbstractQName fxs xs-      zipWithM_ (bindName p QuotableName) xs ys-      e <- toAbstract e-      zipWithM_ (rebindName p OtherDefName) xs ys-      let mi = MutualInfo tc cc YesPositivityCheck r-      return [ A.Mutual mi [A.UnquoteDecl mi [ mkDefInfoInstance x fx p a i NotMacroDef r | (fx, x) <- zip fxs xs ] ys e] ]--    NiceUnquoteDef r p a _ _ xs e -> do-      fxs <- mapM getConcreteFixity xs-      ys <- mapM (toAbstract . OldName) xs-      zipWithM_ (rebindName p QuotableName) xs ys-      e <- toAbstract e-      zipWithM_ (rebindName p OtherDefName) xs ys-      return [ A.UnquoteDef [ mkDefInfo x fx PublicAccess a r | (fx, x) <- zip fxs xs ] ys e ]--    NicePatternSyn r a n as p -> do-      reportSLn "scope.pat" 10 $ "found nice pattern syn: " ++ prettyShow n-      (as, p) <- withLocalVars $ do-         p  <- toAbstract =<< parsePatternSyn p-         when (containsAsPattern p) $-           typeError $ GenericError $-             "@-patterns are not allowed in pattern synonyms"-         checkPatternLinearity p $ \ys ->-           typeError $ RepeatedVariablesInPattern ys-         bindVarsToBind-         let err = "Dot or equality patterns are not allowed in pattern synonyms. Maybe use '_' instead."-         p <- noDotorEqPattern err p-         as <- (traverse . mapM) (unVarName <=< resolveName . C.QName) as-         unlessNull (patternVars p List.\\ map unArg as) $ \ xs -> do-           typeError . GenericDocError =<< do-             "Unbound variables in pattern synonym: " <+>-               sep (map prettyA xs)-         return (as, p)-      y <- freshAbstractQName' n-      bindName a PatternSynName n y-      -- Expanding pattern synonyms already at definition makes it easier to-      -- fold them back when printing (issue #2762).-      ep <- expandPatternSynonyms p-      modifyPatternSyns (Map.insert y (as, ep))-      return [A.PatternSynDef y (map (fmap BindName) as) p]   -- only for highlighting, so use unexpanded version-      where unVarName (VarName a _) = return a-            unVarName _ = typeError $ UnusedVariableInPatternSynonym--    d@NiceLoneConstructor{} -> withCurrentCallStack $ \ stk -> do-      warning $ NicifierIssue (DeclarationWarning stk (InvalidConstructorBlock (getRange d)))-      pure []--    where-      -- checking postulate or type sig. without checking safe flag-      toAbstractNiceAxiom :: KindOfName -> C.NiceDeclaration -> ScopeM A.Declaration-      toAbstractNiceAxiom kind (C.Axiom r p a i info x t) = do-        t' <- toAbstractCtx TopCtx t-        f  <- getConcreteFixity x-        mp <- getConcretePolarity x-        y  <- freshAbstractQName f x-        let isMacro | kind == MacroName = MacroDef-                    | otherwise         = NotMacroDef-        bindName p kind x y-        return $ A.Axiom kind (mkDefInfoInstance x f p a i isMacro r) info mp y t'-      toAbstractNiceAxiom _ _ = __IMPOSSIBLE__--unGeneralized :: A.Expr -> (Set.Set I.QName, A.Expr)-unGeneralized (A.Generalized s t) = (s, t)-unGeneralized (A.ScopedExpr si e) = A.ScopedExpr si <$> unGeneralized e-unGeneralized t = (mempty, t)--alreadyGeneralizing :: ScopeM Bool-alreadyGeneralizing = isJust <$> useTC stGeneralizedVars--collectGeneralizables :: ScopeM a -> ScopeM (Set I.QName, a)-collectGeneralizables m =-  -- #5683: No nested generalization-  ifM alreadyGeneralizing ((Set.empty,) <$> m) $-  {-else-} bracket_ open close $ do-      a <- m-      s <- useTC stGeneralizedVars-      case s of-          Nothing -> __IMPOSSIBLE__-          Just s -> return (s, a)-  where-    open = do-        gvs <- useTC stGeneralizedVars-        stGeneralizedVars `setTCLens` Just mempty-        pure gvs-    close = (stGeneralizedVars `setTCLens`)--createBoundNamesForGeneralizables :: Set I.QName -> ScopeM (Map I.QName I.Name)-createBoundNamesForGeneralizables vs =-  flip Map.traverseWithKey (Map.fromSet (const ()) vs) $ \ q _ -> do-    let x  = nameConcrete $ qnameName q-        fx = nameFixity   $ qnameName q-    freshAbstractName fx x--collectAndBindGeneralizables :: ScopeM a -> ScopeM (Map I.QName I.Name, a)-collectAndBindGeneralizables m = do-  fvBefore <- length <$> getLocalVars-  (s, res) <- collectGeneralizables m-  fvAfter  <- length <$> getLocalVars-  -- We should bind the named generalizable variables as fresh variables-  binds <- createBoundNamesForGeneralizables s-  -- Issue #3735: We need to bind the generalizable variables outside any variables bound by `m`.-  outsideLocalVars (fvAfter - fvBefore) $ bindGeneralizables binds-  return (binds, res)--bindGeneralizables :: Map A.QName A.Name -> ScopeM ()-bindGeneralizables vars =-  forM_ (Map.toList vars) $ \ (q, y) ->-    bindVariable LambdaBound (nameConcrete $ qnameName q) y---- | Bind generalizable variables if data or record decl was split by the system---   (origin == Inserted)-bindGeneralizablesIfInserted :: Origin -> AbstractName -> ScopeM (Set A.Name)-bindGeneralizablesIfInserted Inserted y = bound <$ bindGeneralizables gvars-  where gvars = case anameMetadata y of-          GeneralizedVarsMetadata gvars -> gvars-          NoMetadata                    -> Map.empty-        bound = Set.fromList (Map.elems gvars)-bindGeneralizablesIfInserted UserWritten _ = return Set.empty-bindGeneralizablesIfInserted _ _           = __IMPOSSIBLE__--newtype GenTel = GenTel C.Telescope-data GenTelAndType = GenTelAndType C.Telescope C.Expr--instance ToAbstract GenTel where-  type AbsOfCon GenTel = A.GeneralizeTelescope-  toAbstract (GenTel tel) =-    uncurry A.GeneralizeTel <$> collectAndBindGeneralizables (catMaybes <$> toAbstract tel)--instance ToAbstract GenTelAndType where-  type AbsOfCon GenTelAndType = (A.GeneralizeTelescope, A.Expr)--  toAbstract (GenTelAndType tel t) = do-    (binds, (tel, t)) <- collectAndBindGeneralizables $-                          (,) <$> toAbstract tel <*> toAbstract t-    return (A.GeneralizeTel binds (catMaybes tel), t)---- | Make sure definition is in same module as signature.-class LivesInCurrentModule a where-  livesInCurrentModule :: a -> ScopeM ()--instance LivesInCurrentModule AbstractName where-  livesInCurrentModule = livesInCurrentModule . anameName--instance LivesInCurrentModule A.QName where-  livesInCurrentModule x = do-    m <- getCurrentModule-    reportS "scope.data.def" 30-      [ "  A.QName of data type: " ++ prettyShow x-      , "  current module: " ++ prettyShow m-      ]-    unless (A.qnameModule x == m) $-      genericError $ "Definition in different module than its type signature"---- | Unless the resolved 'AbstractName' has the given 'KindOfName',---   report a 'ClashingDefinition' for the 'C.Name'.-clashUnless :: C.Name -> KindOfName -> AbstractName -> ScopeM ()-clashUnless x k ax = unless (anameKind ax == k) $-  typeError $ ClashingDefinition (C.QName x) (anameName ax) Nothing---- | If a (data/record) module with the given name is already present in the current module,---   we take this as evidence that a data/record with that name is already defined.-clashIfModuleAlreadyDefinedInCurrentModule :: C.Name -> AbstractName -> ScopeM ()-clashIfModuleAlreadyDefinedInCurrentModule x ax = do-  datRecMods <- catMaybes <$> do-    mapM (isDatatypeModule . amodName) =<< lookupModuleInCurrentModule x-  unlessNull datRecMods $ const $-    typeError $ ClashingDefinition (C.QName x) (anameName ax) Nothing--lookupModuleInCurrentModule :: C.Name -> ScopeM [AbstractModule]-lookupModuleInCurrentModule x =-  fromMaybe [] . Map.lookup x . nsModules . thingsInScope [PublicNS, PrivateNS] <$> getCurrentScope--data DataConstrDecl = DataConstrDecl A.ModuleName IsAbstract Access C.NiceDeclaration---- | Bind a @data@ constructor.-bindConstructorName-  :: ModuleName      -- ^ Name of @data@/@record@ module.-  -> C.Name          -- ^ Constructor name.-  -> IsAbstract-  -> Access-  -> ScopeM A.QName-bindConstructorName m x a p = do-  f <- getConcreteFixity x-  -- The abstract name is the qualified one-  y <- withCurrentModule m $ freshAbstractQName f x-  -- Bind it twice, once unqualified and once qualified-  bindName p' ConName x y-  withCurrentModule m $ bindName p'' ConName x y-  return y-  where-    -- An abstract constructor is private (abstract constructor means-    -- abstract datatype, so the constructor should not be exported).-    p' = case a of-           AbstractDef -> PrivateAccess Inserted-           _           -> p-    p'' = case a of-            AbstractDef -> PrivateAccess Inserted-            _           -> PublicAccess---- | Record constructors do not live in the record module (as it is parameterized).---   Abstract constructors are bound privately, so that they are not exported.-bindRecordConstructorName :: C.Name -> KindOfName -> IsAbstract -> Access -> ScopeM A.QName-bindRecordConstructorName x kind a p = do-  y <- freshAbstractQName' x-  bindName p' kind x y-  return y-  where-    -- An abstract constructor is private (abstract constructor means-    -- abstract datatype, so the constructor should not be exported).-    p' = case a of-           AbstractDef -> PrivateAccess Inserted-           _           -> p--instance ToAbstract DataConstrDecl where-  type AbsOfCon DataConstrDecl = A.Declaration--  toAbstract (DataConstrDecl m a p d) = do-    case d of-      C.Axiom r p1 a1 i info x t -> do -- rel==Relevant-        -- unless (p1 == p) __IMPOSSIBLE__  -- This invariant is currently violated by test/Succeed/Issue282.agda-        unless (a1 == a) __IMPOSSIBLE__-        t' <- toAbstractCtx TopCtx t-        -- The abstract name is the qualified one-        -- Bind it twice, once unqualified and once qualified-        f <- getConcreteFixity x-        y <- bindConstructorName m x a p-        printScope "con" 15 "bound constructor"-        return $ A.Axiom ConName (mkDefInfoInstance x f p a i NotMacroDef r)-                         info Nothing y t'-      _ -> errorNotConstrDecl d--errorNotConstrDecl :: C.NiceDeclaration -> ScopeM a-errorNotConstrDecl d = typeError . GenericDocError $-        "Illegal declaration in data type definition " P.$$-        P.nest 2 (P.vcat $ map pretty (notSoNiceDeclarations d))--instance ToAbstract C.Pragma where-  type AbsOfCon C.Pragma = [A.Pragma]--  toAbstract (C.ImpossiblePragma _ strs) =-    case strs of-      "ReduceM" : _ -> impossibleTestReduceM strs-      _ -> impossibleTest strs-  toAbstract (C.OptionsPragma _ opts) = return [ A.OptionsPragma opts ]-  toAbstract (C.RewritePragma _ _ []) = [] <$ warning EmptyRewritePragma-  toAbstract (C.RewritePragma _ r xs) = singleton . A.RewritePragma r . concat <$> do-   forM xs $ \ x -> do-    e <- toAbstract $ OldQName x Nothing-    case e of-      A.Def x          -> return [ x ]-      A.Proj _ p | Just x <- getUnambiguous p -> return [ x ]-      A.Proj _ x       -> genericError $ "REWRITE used on ambiguous name " ++ prettyShow x-      A.Con c | Just x <- getUnambiguous c -> return [ x ]-      A.Con x          -> genericError $ "REWRITE used on ambiguous name " ++ prettyShow x-      A.Var x          -> genericError $ "REWRITE used on parameter " ++ prettyShow x ++ " instead of on a defined symbol"-      _       -> __IMPOSSIBLE__-  toAbstract (C.ForeignPragma _ rb s) = [] <$ addForeignCode (rangedThing rb) s-  toAbstract (C.CompilePragma _ rb x s) = do-    me <- toAbstract $ MaybeOldQName $ OldQName x Nothing-    case me of-      Nothing -> [] <$ notInScopeWarning x-      Just e  -> do-        let err what = genericError $ "Cannot COMPILE " ++ what ++ " " ++ prettyShow x-        y <- case e of-          A.Def x             -> return x-          A.Proj _ p | Just x <- getUnambiguous p -> return x-          A.Proj _ x          -> err "ambiguous projection"-          A.Con c | Just x <- getUnambiguous c -> return x-          A.Con x             -> err "ambiguous constructor"-          A.PatternSyn{}      -> err "pattern synonym"-          A.Var{}             -> err "local variable"-          _                   -> __IMPOSSIBLE__-        return [ A.CompilePragma rb y s ]--  toAbstract (C.StaticPragma _ x) = do-      e <- toAbstract $ OldQName x Nothing-      y <- case e of-          A.Def  x -> return x-          A.Proj _ p | Just x <- getUnambiguous p -> return x-          A.Proj _ x -> genericError $-            "STATIC used on ambiguous name " ++ prettyShow x-          _        -> genericError "Target of STATIC pragma should be a function"-      return [ A.StaticPragma y ]-  toAbstract (C.InjectivePragma _ x) = do-      e <- toAbstract $ OldQName x Nothing-      y <- case e of-          A.Def  x -> return x-          A.Proj _ p | Just x <- getUnambiguous p -> return x-          A.Proj _ x -> genericError $-            "INJECTIVE used on ambiguous name " ++ prettyShow x-          _        -> genericError "Target of INJECTIVE pragma should be a defined symbol"-      return [ A.InjectivePragma y ]-  toAbstract (C.InlinePragma _ b x) = do-      e <- toAbstract $ OldQName x Nothing-      let sINLINE = if b then "INLINE" else "NOINLINE"-      y <- case e of-          A.Def  x -> return x-          A.Proj _ p | Just x <- getUnambiguous p -> return x-          A.Proj _ x -> genericError $-            sINLINE ++ " used on ambiguous name " ++ prettyShow x-          _        -> genericError $ "Target of " ++ sINLINE ++ " pragma should be a function"-      return [ A.InlinePragma b y ]-  toAbstract (C.BuiltinPragma _ rb qx)-    | isUntypedBuiltin b = do-        q <- toAbstract $ ResolveQName qx-        bindUntypedBuiltin b q-        return [ A.BuiltinPragma rb q ]-        -- Andreas, 2015-02-14-        -- Some builtins cannot be given a valid Agda type,-        -- thus, they do not come with accompanying postulate or definition.-    | isBuiltinNoDef b = do-          case qx of-            C.QName x -> do-              -- The name shouldn't exist yet. If it does, we raise a warning-              -- and drop the existing definition.-              unlessM ((UnknownName ==) <$> resolveName qx) $ do-                genericWarning $ P.text $-                   "BUILTIN " ++ b ++ " declares an identifier " ++-                   "(no longer expects an already defined identifier)"-                modifyCurrentScope $ removeNameFromScope PublicNS x-              -- We then happily bind the name-              y <- freshAbstractQName' x-              let kind = fromMaybe __IMPOSSIBLE__ $ builtinKindOfName b-              bindName PublicAccess kind x y-              return [ A.BuiltinNoDefPragma rb kind y ]-            _ -> genericError $-              "Pragma BUILTIN " ++ b ++ ": expected unqualified identifier, " ++-              "but found " ++ prettyShow qx-    | otherwise = do-          q0 <- toAbstract $ ResolveQName qx--          -- Andreas, 2020-04-12, pr #4574.  For highlighting purposes:-          -- Rebind 'BuiltinPrim' as 'PrimName' and similar.-          q <- case (q0, builtinKindOfName b, qx) of-            (DefinedName acc y suffix, Just kind, C.QName x)-              | anameKind y /= kind-              , kind `elem` [ PrimName, AxiomName ] -> do-                  rebindName acc kind x $ anameName y-                  return $ DefinedName acc y{ anameKind = kind } suffix-            _ -> return q0--          return [ A.BuiltinPragma rb q ]-    where b = rangedThing rb--  toAbstract (C.EtaPragma _ x) = do-    e <- toAbstract $ OldQName x Nothing-    case e of-      A.Def x -> return [ A.EtaPragma x ]-      _       -> do-       e <- showA e-       genericError $ "Pragma ETA: expected identifier, " ++-         "but found expression " ++ e--  toAbstract (C.DisplayPragma _ lhs rhs) = withLocalVars $ do-    let err = genericError "DISPLAY pragma left-hand side must have form 'f e1 .. en'"-        getHead (C.IdentP x)          = return x-        getHead (C.RawAppP _ (List2 p _ _)) = getHead p-        getHead _                     = err--    top <- getHead lhs--    (isPatSyn, hd) <- do-      qx <- resolveName' allKindsOfNames Nothing top-      case qx of-        VarName x' _                -> return . (False,) $ A.qnameFromList $ singleton x'-        DefinedName _ d NoSuffix    -> return . (False,) $ anameName d-        DefinedName _ d Suffix{}    -> genericError $ "Invalid pattern " ++ prettyShow top-        FieldName     (d :| [])     -> return . (False,) $ anameName d-        FieldName ds                -> genericError $ "Ambiguous projection " ++ prettyShow top ++ ": " ++ prettyShow (fmap anameName ds)-        ConstructorName _ (d :| []) -> return . (False,) $ anameName d-        ConstructorName _ ds        -> genericError $ "Ambiguous constructor " ++ prettyShow top ++ ": " ++ prettyShow (fmap anameName ds)-        UnknownName                 -> notInScopeError top-        PatternSynResName (d :| []) -> return . (True,) $ anameName d-        PatternSynResName ds        -> genericError $ "Ambiguous pattern synonym" ++ prettyShow top ++ ": " ++ prettyShow (fmap anameName ds)--    lhs <- toAbstract $ LeftHandSide top lhs-    ps  <- case lhs of-             A.LHS _ (A.LHSHead _ ps) -> return ps-             _ -> err--    -- Andreas, 2016-08-08, issue #2132-    -- Remove pattern synonyms on lhs-    (hd, ps) <- do-      let mkP | isPatSyn  = A.PatternSynP (PatRange $ getRange lhs) (unambiguous hd)-              | otherwise = A.DefP (PatRange $ getRange lhs) (unambiguous hd)-      p <- expandPatternSynonyms $ mkP ps-      case p of-        A.DefP _ f ps | Just hd <- getUnambiguous f -> return (hd, ps)-        A.ConP _ c ps | Just hd <- getUnambiguous c -> return (hd, ps)-        A.PatternSynP{} -> __IMPOSSIBLE__-        _ -> err--    rhs <- toAbstract rhs-    return [A.DisplayPragma hd ps rhs]--  -- A warning attached to an ambiguous name shall apply to all disambiguations.-  toAbstract (C.WarningOnUsage _ x str) = do-    ys <- fmap anameName <$> toAbstractExistingName x-    forM_ ys $ \ qn -> stLocalUserWarnings `modifyTCLens` Map.insert qn str-    return []--  toAbstract (C.WarningOnImport _ str) = do-    stWarningOnImport `setTCLens` Just str-    pure []--  -- Termination, Coverage, Positivity, Universe, and Catchall-  -- pragmes are handled by the nicifier-  toAbstract C.TerminationCheckPragma{}  = __IMPOSSIBLE__-  toAbstract C.NoCoverageCheckPragma{}   = __IMPOSSIBLE__-  toAbstract C.NoPositivityCheckPragma{} = __IMPOSSIBLE__-  toAbstract C.NoUniverseCheckPragma{}   = __IMPOSSIBLE__-  toAbstract C.CatchallPragma{}          = __IMPOSSIBLE__--  -- Polarity pragmas are handled by the niceifier.-  toAbstract C.PolarityPragma{} = __IMPOSSIBLE__--instance ToAbstract C.Clause where-  type AbsOfCon C.Clause = A.Clause--  toAbstract (C.Clause top catchall lhs@(C.LHS p eqs with) rhs wh wcs) = withLocalVars $ do-    -- Jesper, 2018-12-10, #3095: pattern variables bound outside the-    -- module are locally treated as module parameters-    modifyScope_ $ updateScopeLocals $ map $ second patternToModuleBound-    -- Andreas, 2012-02-14: need to reset local vars before checking subclauses-    vars0 <- getLocalVars-    lhs' <- toAbstract $ LeftHandSide (C.QName top) p-    printLocals 10 "after lhs:"-    vars1 <- getLocalVars-    eqs <- mapM (toAbstractCtx TopCtx) eqs-    vars2 <- getLocalVars-    let vars = dropEnd (length vars1) vars2 ++ vars0-    let wcs' = (vars, wcs)--    -- Handle rewrite equations first.-    if not (null eqs)-      then do-        rhs <- toAbstractCtx TopCtx $ RightHandSide eqs with wcs' rhs wh-        rhs <- toAbstract rhs-        return $ A.Clause lhs' [] rhs A.noWhereDecls catchall-      else do-        -- the right hand side is checked with the module of the local definitions opened-        (rhs, ds) <- whereToAbstract (getRange wh) wh $-                       toAbstractCtx TopCtx $ RightHandSide [] with wcs' rhs NoWhere-        rhs <- toAbstract rhs-        return $ A.Clause lhs' [] rhs ds catchall---whereToAbstract-  :: Range                            -- ^ The range of the @where@ block.-  -> C.WhereClause                    -- ^ The @where@ block.-  -> ScopeM a                         -- ^ The scope-checking task to be run in the context of the @where@ module.-  -> ScopeM (a, A.WhereDeclarations)  -- ^ Additionally return the scope-checked contents of the @where@ module.-whereToAbstract r wh inner = do-  case wh of-    NoWhere       -> ret-    AnyWhere _ [] -> warnEmptyWhere-    AnyWhere _ ds -> do-      -- Andreas, 2016-07-17 issues #2081 and #2101-      -- where-declarations are automatically private.-      -- This allows their type signature to be checked InAbstractMode.-      whereToAbstract1 r Nothing (singleton $ C.Private noRange Inserted ds) inner-    SomeWhere _ m a ds0 -> List1.ifNull ds0 warnEmptyWhere {-else-} $ \ ds -> do-      -- Named where-modules do not default to private.-      whereToAbstract1 r (Just (m, a)) ds inner-  where-  ret = (,A.noWhereDecls) <$> inner-  warnEmptyWhere = do-    setCurrentRange r $ warning EmptyWhere-    ret--whereToAbstract1-  :: Range                            -- ^ The range of the @where@-block.-  -> Maybe (C.Name, Access)           -- ^ The name of the @where@ module (if any).-  -> List1 C.Declaration              -- ^ The contents of the @where@ module.-  -> ScopeM a                         -- ^ The scope-checking task to be run in the context of the @where@ module.-  -> ScopeM (a, A.WhereDeclarations)  -- ^ Additionally return the scope-checked contents of the @where@ module.-whereToAbstract1 r whname whds inner = do-  -- ASR (16 November 2015) Issue 1137: We ban termination-  -- pragmas inside `where` clause.-  checkNoTerminationPragma InWhereBlock whds--  -- Create a fresh concrete name if there isn't (a proper) one.-  (m, acc) <- do-    case whname of-      Just (m, acc) | not (isNoName m) -> return (m, acc)-      _ -> fresh <&> \ x -> (C.NoName (getRange whname) x, PrivateAccess Inserted)-           -- unnamed where's are private-  old <- getCurrentModule-  am  <- toAbstract (NewModuleName m)-  (scope, d) <- scopeCheckModule r (C.QName m) am [] $ toAbstract $ Declarations $ List1.toList whds-  setScope scope-  x <- inner-  setCurrentModule old-  bindModule acc m am-  -- Issue 848: if the module was anonymous (module _ where) open it public-  let anonymousSomeWhere = maybe False (isNoName . fst) whname-  when anonymousSomeWhere $-   void $ -- We can ignore the returned default A.ImportDirective.-    openModule TopOpenModule (Just am) (C.QName m) $-      defaultImportDir { publicOpen = Just noRange }-  return (x, A.WhereDecls (am <$ whname) $ singleton d)--data TerminationOrPositivity = Termination | Positivity-  deriving (Show)--data WhereOrRecord = InWhereBlock | InRecordDef--checkNoTerminationPragma :: Foldable f => WhereOrRecord -> f C.Declaration -> ScopeM ()-checkNoTerminationPragma b ds =-  mapM_ (\ (p, r) -> warning $ GenericUseless r $ P.vcat [ P.text $ show p ++ " pragmas are ignored in " ++ what b-                                                         , P.text $ "(see " ++ issue b ++ ")" ])-        (foldMap terminationPragmas ds)-  where-    what InWhereBlock = "where clauses"-    what InRecordDef  = "record definitions"-    github n = "https://github.com/agda/agda/issues/" ++ show n-    issue InWhereBlock = github 3355-    issue InRecordDef  = github 3008--terminationPragmas :: C.Declaration -> [(TerminationOrPositivity, Range)]-terminationPragmas (C.Private  _ _      ds) = concatMap terminationPragmas ds-terminationPragmas (C.Abstract _        ds) = concatMap terminationPragmas ds-terminationPragmas (C.InstanceB _       ds) = concatMap terminationPragmas ds-terminationPragmas (C.Mutual _          ds) = concatMap terminationPragmas ds-terminationPragmas (C.Module _ _ _      ds) = concatMap terminationPragmas ds-terminationPragmas (C.Macro _           ds) = concatMap terminationPragmas ds-terminationPragmas (C.Record _ _ _ _ _  ds) = concatMap terminationPragmas ds-terminationPragmas (C.RecordDef _ _ _ _ ds) = concatMap terminationPragmas ds-terminationPragmas (C.Pragma (TerminationCheckPragma r _)) = [(Termination, r)]-terminationPragmas (C.Pragma (NoPositivityCheckPragma r))  = [(Positivity, r)]-terminationPragmas _                                       = []--data RightHandSide = RightHandSide-  { _rhsRewriteEqn :: [RewriteEqn' () A.BindName A.Pattern A.Expr]-    -- ^ @rewrite e | with p <- e in eq@ (many)-  , _rhsWithExpr   :: [C.WithExpr]-    -- ^ @with e@ (many)-  , _rhsSubclauses :: (LocalVars, [C.Clause])-    -- ^ the subclauses spawned by a with (monadic because we need to reset the local vars before checking these clauses)-  , _rhs           :: C.RHS-  , _rhsWhere      :: WhereClause-      -- ^ @where@ module.-  }--data AbstractRHS-  = AbsurdRHS'-  | WithRHS' [A.WithExpr] [ScopeM C.Clause]-    -- ^ The with clauses haven't been translated yet-  | RHS' A.Expr C.Expr-  | RewriteRHS' [RewriteEqn' () A.BindName A.Pattern A.Expr] AbstractRHS A.WhereDeclarations--qualifyName_ :: A.Name -> ScopeM A.QName-qualifyName_ x = do-  m <- getCurrentModule-  return $ A.qualify m x--withFunctionName :: String -> ScopeM A.QName-withFunctionName s = do-  NameId i _ <- fresh-  qualifyName_ =<< freshName_ (s ++ show i)--instance ToAbstract (RewriteEqn' () A.BindName A.Pattern A.Expr) where-  type AbsOfCon (RewriteEqn' () A.BindName A.Pattern A.Expr) = A.RewriteEqn-  toAbstract = \case-    Rewrite es -> fmap Rewrite $ forM es $ \ (_, e) -> do-      qn <- withFunctionName "-rewrite"-      pure (qn, e)-    Invert _ pes -> do-      qn <- withFunctionName "-invert"-      pure $ Invert qn pes--instance ToAbstract C.RewriteEqn where-  type AbsOfCon C.RewriteEqn = RewriteEqn' () A.BindName A.Pattern A.Expr-  toAbstract = \case-    Rewrite es   -> Rewrite <$> mapM toAbstract es-    Invert _ npes -> Invert () <$> do-      -- Given a list of irrefutable with expressions of the form @p <- e in q@-      let (nps, es) = List1.unzip-                    $ fmap (\ (Named nm (p, e)) -> ((nm, p), e)) npes-      -- we first check the expressions @e@: the patterns may shadow some of the-      -- variables mentioned in them!-      es <- toAbstract es-      -- we then parse the pairs of patterns @p@ and names @q@ for the equality-      -- constraints of the form @p ≡ e@.-      nps <- forM nps $ \ (n, p) -> do-        -- first the pattern-        p <- parsePattern p-        p <- toAbstract p-        checkPatternLinearity p (typeError . RepeatedVariablesInPattern)-        bindVarsToBind-        p <- toAbstract p-        -- and then the name-        n <- toAbstract $ fmap (NewName WithBound . C.mkBoundName_) n-        pure (n, p)-      -- we finally reassemble the telescope-      pure $ List1.zipWith (\ (n,p) e -> Named n (p, e)) nps es--instance ToAbstract AbstractRHS where-  type AbsOfCon AbstractRHS = A.RHS--  toAbstract AbsurdRHS'            = return A.AbsurdRHS-  toAbstract (RHS' e c)            = return $ A.RHS e $ Just c-  toAbstract (RewriteRHS' eqs rhs wh) = do-    eqs <- toAbstract eqs-    rhs <- toAbstract rhs-    return $ RewriteRHS eqs [] rhs wh-  toAbstract (WithRHS' es cs) = do-    aux <- withFunctionName "with-"-    A.WithRHS aux es <$> do toAbstract =<< sequence cs--instance ToAbstract RightHandSide where-  type AbsOfCon RightHandSide = AbstractRHS-  toAbstract (RightHandSide eqs@(_:_) es cs rhs wh)               = do-    (rhs, ds) <- whereToAbstract (getRange wh) wh $-                   toAbstract (RightHandSide [] es cs rhs NoWhere)-    return $ RewriteRHS' eqs rhs ds-  toAbstract (RightHandSide [] []    (_  , _:_) _          _)  = __IMPOSSIBLE__-  toAbstract (RightHandSide [] (_:_) _         (C.RHS _)   _)  = typeError $ BothWithAndRHS-  toAbstract (RightHandSide [] []    (_  , []) rhs         NoWhere) = toAbstract rhs-  toAbstract (RightHandSide [] nes   (lv , cs) C.AbsurdRHS NoWhere) = do-    let (ns , es) = unzipWith (\ (Named nm e) -> (NewName WithBound . C.mkBoundName_ <$> nm, e)) nes-    es <- toAbstractCtx TopCtx es-    lvars0 <- getLocalVars-    ns <- toAbstract ns-    lvars1 <- getLocalVars-    let lv' = dropEnd (length lvars0) lvars1 ++ lv-    let cs' = for cs $ \ c -> setLocalVars lv' $> c-    let nes = zipWith Named ns es-    return $ WithRHS' nes cs'-  -- TODO: some of these might be possible-  toAbstract (RightHandSide [] (_ : _) _ C.AbsurdRHS  AnyWhere{}) = __IMPOSSIBLE__-  toAbstract (RightHandSide [] (_ : _) _ C.AbsurdRHS SomeWhere{}) = __IMPOSSIBLE__-  toAbstract (RightHandSide [] []     (_, []) C.AbsurdRHS  AnyWhere{}) = __IMPOSSIBLE__-  toAbstract (RightHandSide [] []     (_, []) C.AbsurdRHS SomeWhere{}) = __IMPOSSIBLE__-  toAbstract (RightHandSide [] []     (_, []) C.RHS{}      AnyWhere{}) = __IMPOSSIBLE__-  toAbstract (RightHandSide [] []     (_, []) C.RHS{}     SomeWhere{}) = __IMPOSSIBLE__--instance ToAbstract C.RHS where-    type AbsOfCon C.RHS = AbstractRHS--    toAbstract C.AbsurdRHS = return $ AbsurdRHS'-    toAbstract (C.RHS e)   = RHS' <$> toAbstract e <*> pure e--data LeftHandSide = LeftHandSide C.QName C.Pattern--instance ToAbstract LeftHandSide where-    type AbsOfCon LeftHandSide = A.LHS--    toAbstract (LeftHandSide top lhs) =-      traceCall (ScopeCheckLHS top lhs) $ do-        reportSLn "scope.lhs" 5 $ "original lhs: " ++ prettyShow lhs-        reportSLn "scope.lhs" 60 $ "patternQNames: " ++ prettyShow (patternQNames lhs)-        reportSLn "scope.lhs" 60 $ "original lhs (raw): " ++ show lhs-        lhscore <- parseLHS top lhs-        let ell = hasExpandedEllipsis lhscore-        reportSLn "scope.lhs" 5 $ "parsed lhs: " ++ prettyShow lhscore-        reportSLn "scope.lhs" 60 $ "parsed lhs (raw): " ++ show lhscore-        printLocals 10 "before lhs:"-        -- error if copattern parsed but --no-copatterns option-        unlessM (optCopatterns <$> pragmaOptions) $-          when (hasCopatterns lhscore) $-            typeError $ NeedOptionCopatterns-        -- scope check patterns except for dot patterns-        lhscore <- toAbstract lhscore-        bindVarsToBind-        -- reportSLn "scope.lhs" 5 $ "parsed lhs patterns: " ++ prettyShow lhscore  -- TODO: Pretty A.LHSCore'-        reportSLn "scope.lhs" 60 $ "parsed lhs patterns: " ++ show lhscore-        printLocals 10 "checked pattern:"-        -- scope check dot patterns-        lhscore <- toAbstract lhscore-        -- reportSLn "scope.lhs" 5 $ "parsed lhs dot patterns: " ++ prettyShow lhscore  -- TODO: Pretty A.LHSCore'-        reportSLn "scope.lhs" 60 $ "parsed lhs dot patterns: " ++ show lhscore-        printLocals 10 "checked dots:"-        return $ A.LHS (LHSInfo (getRange lhs) ell) lhscore--hasExpandedEllipsis :: C.LHSCore -> ExpandedEllipsis-hasExpandedEllipsis core = case core of-  C.LHSHead{}       -> NoEllipsis-  C.LHSProj{}       -> hasExpandedEllipsis $ namedArg $ C.lhsFocus core -- can this ever be ExpandedEllipsis?-  C.LHSWith{}       -> hasExpandedEllipsis $ C.lhsHead core-  C.LHSEllipsis r p -> case p of-    C.LHSWith p wps _ -> hasExpandedEllipsis p <> ExpandedEllipsis r (length wps)-    C.LHSHead{}       -> ExpandedEllipsis r 0-    C.LHSProj{}       -> ExpandedEllipsis r 0-    C.LHSEllipsis{}   -> __IMPOSSIBLE__---- | Merges adjacent EqualP patterns into one:--- type checking expects only one pattern for each domain in the telescope.-mergeEqualPs :: [NamedArg (Pattern' e)] -> ScopeM [NamedArg (Pattern' e)]-mergeEqualPs = go (empty, [])-  where-    go acc (p@(Arg i (Named mn (A.EqualP r es))) : ps) = setCurrentRange p $ do-      -- Face constraint patterns must be defaultNamedArg; check this:-      unless (getModality i == defaultModality) __IMPOSSIBLE__-      when (hidden     i) $ warn i $ "Face constraint patterns cannot be hidden arguments"-      when (isInstance i) $ warn i $ "Face constraint patterns cannot be instance arguments"-      whenJust mn $ \ x -> setCurrentRange x $ warn x $ P.hcat-          [ "Ignoring name `", P.pretty x, "` given to face constraint pattern" ]-      go (acc `mappend` (r, es)) ps-    go (r, es@(_:_)) ps = (defaultNamedArg (A.EqualP r es) :) <$> mergeEqualPs ps-    go (_, []) []       = return []-    go (_, []) (p : ps) = (p :) <$> mergeEqualPs ps--    warn r d = warning $ GenericUseless (getRange r) d---- does not check pattern linearity-instance ToAbstract C.LHSCore where-    type AbsOfCon C.LHSCore = (A.LHSCore' C.Expr)--    toAbstract (C.LHSHead x ps) = do-        x <- withLocalVars $ do-          setLocalVars []-          toAbstract (OldName x)-        A.LHSHead x <$> do mergeEqualPs =<< toAbstract ps-    toAbstract (C.LHSProj d ps1 l ps2) = do-        unless (null ps1) $ typeError $ GenericDocError $-          "Ill-formed projection pattern" P.<+> P.pretty (foldl C.AppP (C.IdentP d) ps1)-        qx <- resolveName d-        ds <- case qx of-                FieldName ds -> return $ fmap anameName ds-                UnknownName -> notInScopeError d-                _           -> genericError $-                  "head of copattern needs to be a field identifier, but "-                  ++ prettyShow d ++ " isn't one"-        A.LHSProj (AmbQ ds) <$> toAbstract l <*> (mergeEqualPs =<< toAbstract ps2)-    toAbstract (C.LHSWith core wps ps) = do-      liftA2 A.lhsCoreApp-        (liftA2 A.lhsCoreWith-          (toAbstract core)-          (map defaultArg <$> toAbstract wps))-        (toAbstract ps)-    -- In case of a part of the LHS which was expanded from an ellipsis,-    -- we flush the @scopeVarsToBind@ in order to allow variables bound-    -- in the ellipsis to be shadowed.-    toAbstract (C.LHSEllipsis _ p) = do-      ap <- toAbstract p-      bindVarsToBind-      return ap--instance ToAbstract c => ToAbstract (WithHiding c) where-  type AbsOfCon (WithHiding c) = WithHiding (AbsOfCon c)-  toAbstract (WithHiding h a) = WithHiding h <$> toAbstractHiding h a--instance ToAbstract c => ToAbstract (Arg c) where-    type AbsOfCon (Arg c) = Arg (AbsOfCon c)-    toAbstract (Arg info e) =-        Arg info <$> toAbstractHiding info e--instance ToAbstract c => ToAbstract (Named name c) where-    type AbsOfCon (Named name c) = Named name (AbsOfCon c)-    toAbstract (Named n e) = Named n <$> toAbstract e--{- DOES NOT WORK ANYMORE with pattern synonyms-instance ToAbstract c a => ToAbstract (A.LHSCore' c) (A.LHSCore' a) where-    toAbstract = mapM toAbstract--}--instance ToAbstract (A.LHSCore' C.Expr) where-    type AbsOfCon (A.LHSCore' C.Expr) = A.LHSCore' A.Expr-    toAbstract (A.LHSHead f ps)         = A.LHSHead f <$> mapM toAbstract ps-    toAbstract (A.LHSProj d lhscore ps) = A.LHSProj d <$> mapM toAbstract lhscore <*> mapM toAbstract ps-    toAbstract (A.LHSWith core wps ps)  = liftA3 A.LHSWith (toAbstract core) (toAbstract wps) (toAbstract ps)---- Patterns are done in two phases. First everything but the dot patterns, and--- then the dot patterns. This is because dot patterns can refer to variables--- bound anywhere in the pattern.--instance ToAbstract (A.Pattern' C.Expr) where-  type AbsOfCon (A.Pattern' C.Expr) = A.Pattern' A.Expr-  toAbstract = traverse $ insideDotPattern . toAbstractCtx DotPatternCtx  -- Issue #3033--resolvePatternIdentifier ::-  Range -> C.QName -> Maybe (Set A.Name) -> ScopeM (A.Pattern' C.Expr)-resolvePatternIdentifier r x ns = do-  reportSLn "scope.pat" 60 $ "resolvePatternIdentifier " ++ prettyShow x ++ " at source position " ++ prettyShow r-  px <- toAbstract (PatName x ns)-  case px of-    VarPatName y         -> do-      reportSLn "scope.pat" 60 $ "  resolved to VarPatName " ++ prettyShow y ++ " with range " ++ prettyShow (getRange y)-      return $ VarP $ A.mkBindName y-    ConPatName ds        -> return $ ConP (ConPatInfo ConOCon (PatRange r) ConPatEager)-                                          (AmbQ $ fmap anameName ds) []-    PatternSynPatName ds -> return $ PatternSynP (PatRange r)-                                                 (AmbQ $ fmap anameName ds) []---- | Apply an abstract syntax pattern head to pattern arguments.------   Fails with 'InvalidPattern' if head is not a constructor pattern---   (or similar) that can accept arguments.----applyAPattern-  :: C.Pattern            -- ^ The application pattern in concrete syntax.-  -> A.Pattern' C.Expr    -- ^ Head of application.-  -> NAPs C.Expr          -- ^ Arguments of application.-  -> ScopeM (A.Pattern' C.Expr)-applyAPattern p0 p ps = do-  setRange (getRange p0) <$> do-    case p of-      A.ConP i x as        -> return $ A.ConP        i x (as ++ ps)-      A.DefP i x as        -> return $ A.DefP        i x (as ++ ps)-      A.PatternSynP i x as -> return $ A.PatternSynP i x (as ++ ps)-      -- Dotted constructors are turned into "lazy" constructor patterns.-      A.DotP i (Ident x)   -> resolveName x >>= \case-        ConstructorName _ ds -> do-          let cpi = ConPatInfo ConOCon i ConPatLazy-              c   = AmbQ (fmap anameName ds)-          return $ A.ConP cpi c ps-        _ -> failure-      A.DotP{}    -> failure-      A.VarP{}    -> failure-      A.ProjP{}   -> failure-      A.WildP{}   -> failure-      A.AsP{}     -> failure-      A.AbsurdP{} -> failure-      A.LitP{}    -> failure-      A.RecP{}    -> failure-      A.EqualP{}  -> failure-      A.WithP{}   -> failure-      A.AnnP{}    -> failure-  where-    failure = typeError $ InvalidPattern p0--instance ToAbstract C.Pattern where-    type AbsOfCon C.Pattern = A.Pattern' C.Expr--    toAbstract (C.IdentP x) =-      resolvePatternIdentifier (getRange x) x Nothing--    toAbstract (AppP (QuoteP _) p)-      | IdentP x <- namedArg p,-        visible p = do-      e <- toAbstract (OldQName x Nothing)-      A.LitP (PatRange $ getRange x) . LitQName <$> quotedName e--    toAbstract (QuoteP r) =-      genericError "quote must be applied to an identifier"--    toAbstract p0@(AppP p q) = do-        reportSLn "scope.pat" 50 $ "distributeDots before = " ++ show p-        p <- distributeDots p-        reportSLn "scope.pat" 50 $ "distributeDots after  = " ++ show p-        (p', q') <- toAbstract (p, q)-        applyAPattern p0 p' $ singleton q'--        where-            distributeDots :: C.Pattern -> ScopeM C.Pattern-            distributeDots p@(C.DotP r e) = distributeDotsExpr r e-            distributeDots p = return p--            distributeDotsExpr :: Range -> C.Expr -> ScopeM C.Pattern-            distributeDotsExpr r e = parseRawApp e >>= \case-              C.App r e a     ->-                AppP <$> distributeDotsExpr r e-                     <*> (traverse . traverse) (distributeDotsExpr r) a-              OpApp r q ns as ->-                case (traverse . traverse . traverse) fromNoPlaceholder as of-                  Just as -> OpAppP r q ns <$>-                    (traverse . traverse . traverse) (distributeDotsExpr r) as-                  Nothing -> return $ C.DotP r e-              Paren r e -> ParenP r <$> distributeDotsExpr r e-              _ -> return $ C.DotP r e--            fromNoPlaceholder :: MaybePlaceholder (OpApp a) -> Maybe a-            fromNoPlaceholder (NoPlaceholder _ (Ordinary e)) = Just e-            fromNoPlaceholder _ = Nothing--            parseRawApp :: C.Expr -> ScopeM C.Expr-            parseRawApp (RawApp r es) = parseApplication es-            parseRawApp e             = return e--    toAbstract p0@(OpAppP r op ns ps) = do-        reportSLn "scope.pat" 60 $ "ConcreteToAbstract.toAbstract OpAppP{}: " ++ show p0-        p  <- resolvePatternIdentifier (getRange op) op (Just ns)-        ps <- toAbstract ps-        applyAPattern p0 p ps--    toAbstract (EllipsisP _ mp) = maybe __IMPOSSIBLE__ toAbstract mp--    -- Removed when parsing-    toAbstract (HiddenP _ _)   = __IMPOSSIBLE__-    toAbstract (InstanceP _ _) = __IMPOSSIBLE__-    toAbstract (RawAppP _ _)   = __IMPOSSIBLE__--    toAbstract p@(C.WildP r)    = return $ A.WildP (PatRange r)-    -- Andreas, 2015-05-28 futile attempt to fix issue 819: repeated variable on lhs "_"-    -- toAbstract p@(C.WildP r)    = A.VarP <$> freshName r "_"-    toAbstract (C.ParenP _ p)   = toAbstract p-    toAbstract (C.LitP r l)     = setCurrentRange r $ A.LitP (PatRange r) l <$ checkLiteral l--    toAbstract p0@(C.AsP r x p) = do-        -- Andreas, 2018-06-30, issue #3147: as-variables can be non-linear a priori!-        -- x <- toAbstract (NewName PatternBound x)-        -- Andreas, 2020-05-01, issue #4631: as-variables should not shadow constructors.-        -- x <- bindPatternVariable x-      toAbstract (PatName (C.QName x) Nothing) >>= \case-        VarPatName x        -> A.AsP (PatRange r) (A.mkBindName x) <$> toAbstract p-        ConPatName{}        -> ignoreAsPat False-        PatternSynPatName{} -> ignoreAsPat True-      where-      -- An @-bound name which shadows a constructor is illegal and becomes dead code.-      ignoreAsPat b = do-        setCurrentRange x $ warning $ AsPatternShadowsConstructorOrPatternSynonym b-        toAbstract p--    toAbstract p0@(C.EqualP r es)  = return $ A.EqualP (PatRange r) es--    -- We have to do dot patterns at the end since they can-    -- refer to the variables bound by the other patterns.-    toAbstract p0@(C.DotP r e) = do-      let fallback = return $ A.DotP (PatRange r) e-      case e of-        C.Ident x -> resolveName x >>= \case-          -- Andreas, 2018-06-19, #3130-          -- We interpret .x as postfix projection if x is a field name in scope-          FieldName xs -> return $ A.ProjP (PatRange r) ProjPostfix $ AmbQ $-            fmap anameName xs-          _ -> fallback-        _ -> fallback--    toAbstract p0@(C.AbsurdP r)    = return $ A.AbsurdP (PatRange r)-    toAbstract (C.RecP r fs)       = A.RecP (PatRange r) <$> mapM (traverse toAbstract) fs-    toAbstract (C.WithP r p)       = A.WithP (PatRange r) <$> toAbstract p---- | An argument @OpApp C.Expr@ to an operator can have binders,---   in case the operator is some @syntax@-notation.---   For these binders, we have to create lambda-abstractions.-toAbstractOpArg :: Precedence -> OpApp C.Expr -> ScopeM A.Expr-toAbstractOpArg ctx (Ordinary e)                 = toAbstractCtx ctx e-toAbstractOpArg ctx (SyntaxBindingLambda r bs e) = toAbstractLam r bs e ctx---- | Turn an operator application into abstract syntax. Make sure to--- record the right precedences for the various arguments.-toAbstractOpApp :: C.QName -> Set A.Name -> OpAppArgs -> ScopeM A.Expr-toAbstractOpApp op ns es = do-    -- Replace placeholders with bound variables.-    (binders, es) <- replacePlaceholders es-    -- Get the notation for the operator.-    nota <- getNotation op ns-    let parts = notation nota-    -- We can throw away the @BindingHoles@, since binders-    -- have been preprocessed into @OpApp C.Expr@.-    let nonBindingParts = filter (not . isBindingHole) parts-    -- We should be left with as many holes as we have been given args @es@.-    -- If not, crash.-    unless (length (filter isAHole nonBindingParts) == length es) __IMPOSSIBLE__-    -- Translate operator and its arguments (each in the right context).-    op <- toAbstract (OldQName op (Just ns))-    es <- left (notaFixity nota) nonBindingParts es-    -- Prepend the generated section binders (if any).-    let body = List.foldl' app op es-    return $ foldr (A.Lam (ExprRange (getRange body))) body binders-  where-    -- Build an application in the abstract syntax, with correct Range.-    app e (pref, arg) = A.App info e arg-      where info = (defaultAppInfo r) { appOrigin = getOrigin arg-                                      , appParens = pref }-            r = fuseRange e arg--    inferParenPref :: NamedArg (Either A.Expr (OpApp C.Expr)) -> ParenPreference-    inferParenPref e =-      case namedArg e of-        Right (Ordinary e) -> inferParenPreference e-        Left{}             -> PreferParenless  -- variable inserted by section expansion-        Right{}            -> PreferParenless  -- syntax lambda--    -- Translate an argument. Returns the paren preference for the argument, so-    -- we can build the correct info for the A.App node.-    toAbsOpArg :: Precedence ->-                  NamedArg (Either A.Expr (OpApp C.Expr)) ->-                  ScopeM (ParenPreference, NamedArg A.Expr)-    toAbsOpArg cxt e = (pref,) <$> (traverse . traverse) (either return (toAbstractOpArg cxt)) e-      where pref = inferParenPref e--    -- The hole left to the first @IdPart@ is filled with an expression in @LeftOperandCtx@.-    left f (IdPart _ : xs) es = inside f xs es-    left f (_ : xs) (e : es) = do-        e  <- toAbsOpArg (LeftOperandCtx f) e-        es <- inside f xs es-        return (e : es)-    left f (_  : _)  [] = __IMPOSSIBLE__-    left f []        _  = __IMPOSSIBLE__--    -- The holes in between the @IdPart@s is filled with an expression in @InsideOperandCtx@.-    inside f [x]          es    = right f x es-    inside f (IdPart _ : xs) es = inside f xs es-    inside f (_  : xs) (e : es) = do-        e  <- toAbsOpArg InsideOperandCtx e-        es <- inside f xs es-        return (e : es)-    inside _ (_ : _) [] = __IMPOSSIBLE__-    inside _ []         _  = __IMPOSSIBLE__--    -- The hole right of the last @IdPart@ is filled with an expression in @RightOperandCtx@.-    right _ (IdPart _)  [] = return []-    right f _          [e] = do-        let pref = inferParenPref e-        e <- toAbsOpArg (RightOperandCtx f pref) e-        return [e]-    right _ _     _  = __IMPOSSIBLE__--    replacePlaceholders ::-      OpAppArgs' e ->-      ScopeM ([A.LamBinding], [NamedArg (Either A.Expr (OpApp e))])-    replacePlaceholders []       = return ([], [])-    replacePlaceholders (a : as) = case namedArg a of-      NoPlaceholder _ x -> mapSnd (set (Right x) a :) <$>-                             replacePlaceholders as-      Placeholder _     -> do-        x <- freshName noRange "section"-        let i = setOrigin Inserted $ argInfo a-        (ls, ns) <- replacePlaceholders as-        return ( A.mkDomainFree (unnamedArg i $ A.mkBinder_ x) : ls-               , set (Left (Var x)) a : ns-               )-      where-      set :: a -> NamedArg b -> NamedArg a-      set x arg = fmap (fmap (const x)) arg-+{-| Translation from "Agda.Syntax.Concrete" to "Agda.Syntax.Abstract".+    Involves scope analysis,+    figuring out infix operator precedences and tidying up definitions.+-}++module Agda.Syntax.Translation.ConcreteToAbstract+    ( ToAbstract(..), localToAbstract+    , concreteToAbstract_+    , concreteToAbstract+    , TopLevel(..)+    , TopLevelInfo(..)+    , topLevelModuleName+    , importPrimitives+    , checkAttributes+    ) where++import Prelude hiding ( null, (||) )++import Control.Monad        ( (>=>), (<=<), foldM, forM, forM_, zipWithM, zipWithM_ )+import Control.Applicative  ( liftA2, liftA3 )+import Control.Monad.Except ( runExceptT, MonadError(..) )+import Control.Monad.State  ( StateT, execStateT, get, put )+import Control.Monad.Trans.Maybe+import Control.Monad.Trans  ( lift )++import Data.Bifunctor+import Data.Foldable (traverse_)+import Data.Set (Set)+import Data.Map (Map)+import Data.Functor (void)+import qualified Data.List as List+import qualified Data.Set as Set+import qualified Data.Map as Map+import qualified Data.HashSet as HashSet+import Data.Maybe+import Data.Void++import Agda.Syntax.Common+import qualified Agda.Syntax.Common.Pretty as P+import Agda.Syntax.Common.Pretty (render, Pretty, pretty, prettyShow)+import Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Attribute as CA+import Agda.Syntax.Concrete.Generic+import Agda.Syntax.Concrete.Operators+import Agda.Syntax.Concrete.Pattern+import Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract.Pattern as A+  ( patternVars, checkPatternLinearity, containsAsPattern, lhsCoreApp, lhsCoreWith, noDotOrEqPattern )+import Agda.Syntax.Abstract.Pretty+import Agda.Syntax.Abstract.UsedNames+  ( allUsedNames )+import qualified Agda.Syntax.Internal as I+import Agda.Syntax.Position+import Agda.Syntax.Literal+import Agda.Syntax.Info as Info+import Agda.Syntax.Concrete.Definitions as C+import Agda.Syntax.Fixity+import Agda.Syntax.Concrete.Fixity (DoWarn(..))+import Agda.Syntax.Notation+import Agda.Syntax.Scope.Base as A+import Agda.Syntax.Scope.Monad+import Agda.Syntax.Translation.AbstractToConcrete (ToConcrete, ConOfAbs)+import Agda.Syntax.DoNotation+import Agda.Syntax.IdiomBrackets+import Agda.Syntax.TopLevelModuleName++import Agda.TypeChecking.Monad.Base hiding (ModuleInfo, MetaInfo)+import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Monad.Trace (traceCall, setCurrentRange)+import Agda.TypeChecking.Monad.State hiding (topLevelModuleName)+import qualified Agda.TypeChecking.Monad.State as S+import Agda.TypeChecking.Monad.Signature (notUnderOpaque)+import Agda.TypeChecking.Monad.MetaVars (registerInteractionPoint)+import Agda.TypeChecking.Monad.Debug+import Agda.TypeChecking.Monad.Env (insideDotPattern, isInsideDotPattern, getCurrentPath)+import Agda.TypeChecking.Rules.Builtin (isUntypedBuiltin, bindUntypedBuiltin, builtinKindOfName)++import Agda.TypeChecking.Patterns.Abstract (expandPatternSynonyms)+import Agda.TypeChecking.Pretty hiding (pretty, prettyA)+import Agda.TypeChecking.Quote (quotedName)+import Agda.TypeChecking.Opacity+import Agda.TypeChecking.Warnings++import Agda.Interaction.FindFile (checkModuleName, rootNameModule, SourceFile(SourceFile))+-- import Agda.Interaction.Imports  -- for type-checking in ghci+import {-# SOURCE #-} Agda.Interaction.Imports (scopeCheckImport)+import Agda.Interaction.Options+import qualified Agda.Interaction.Options.Lenses as Lens+import Agda.Interaction.Options.Warnings++import qualified Agda.Utils.AssocList as AssocList+import Agda.Utils.Boolean   ( (||), ifThenElse )+import Agda.Utils.CallStack ( HasCallStack, withCurrentCallStack )+import Agda.Utils.Char+import Agda.Utils.Either+import Agda.Utils.FileName+import Agda.Utils.Function ( applyWhen, applyWhenJust, applyWhenM, applyUnless )+import Agda.Utils.Functor+import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.List1 ( List1, pattern (:|) )+import Agda.Utils.List2 ( List2, pattern List2 )+import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.Map as Map+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Set1 ( Set1 )+import qualified Agda.Utils.Set1 as Set1+import Agda.Utils.Singleton+import Agda.Utils.Tuple++import Agda.Utils.Impossible ( __IMPOSSIBLE__ )+import Agda.ImpossibleTest (impossibleTest, impossibleTestReduceM)+import qualified Agda.Syntax.Common as A++{--------------------------------------------------------------------------+    Exceptions+ --------------------------------------------------------------------------}++notAnExpression :: (HasCallStack, MonadTCError m) => C.Expr -> m a+notAnExpression = locatedTypeError NotAnExpression++notAValidLetBinding :: (HasCallStack, MonadTCError m) => Maybe NotAValidLetBinding -> m a+notAValidLetBinding = locatedTypeError NotAValidLetBinding++{--------------------------------------------------------------------------+    Helpers+ --------------------------------------------------------------------------}++newtype RecordConstructorType = RecordConstructorType [C.Declaration]++instance ToAbstract RecordConstructorType where+  type AbsOfCon RecordConstructorType = A.Expr+  toAbstract (RecordConstructorType ds) = recordConstructorType ds++-- | Compute the type of the record constructor (with bogus target type)+recordConstructorType :: [C.Declaration] -> ScopeM A.Expr+recordConstructorType decls =+    -- Nicify all declarations since there might be fixity declarations after+    -- the the last field. Use NoWarn to silence fixity warnings. We'll get+    -- them again when scope checking the declarations to build the record+    -- module.+    niceDecls NoWarn decls $ buildType . takeFields+  where+    takeFields = List.dropWhileEnd notField++    notField NiceField{} = False+    notField _           = True++    buildType :: [C.NiceDeclaration] -> ScopeM A.Expr+      -- TODO: Telescope instead of Expr in abstract RecDef+    buildType ds = do+      -- The constructor target type is computed in the type checker.+      -- For now, we put a dummy expression there.+      -- Andreas, 2022-10-06, issue #6165:+      -- The dummy was builtinSet, but this might not be defined yet.+      let dummy = A.Lit empty $ LitString "TYPE"+      tel   <- catMaybes <$> mapM makeBinding ds+      return $ A.mkPi (ExprRange (getRange ds)) tel dummy++    makeBinding :: C.NiceDeclaration -> ScopeM (Maybe A.TypedBinding)+    makeBinding d = do+      let failure = typeError $ NotValidBeforeField d+          r       = getRange d+          mkLet d = Just . A.TLet r <$> toAbstract (LetDef RecordLetDef d)+      setCurrentRange r $ case d of++        C.NiceField r pr ab inst tac x (Arg ai t) -> do+          fx  <- getConcreteFixity x+          ai  <- checkFieldArgInfo True ai+          let bv = Arg ai $ unnamed $ C.mkBinder $ (C.mkBoundName x fx) { bnameTactic = tac }+          toAbstract $ C.TBind r (singleton bv) t++        -- Public open is allowed and will take effect when scope checking as+        -- proper declarations.+        C.NiceOpen r m dir -> do+          mkLet $ C.NiceOpen r m dir{ publicOpen = Nothing }+        C.NiceModuleMacro r p e x modapp open dir -> do+          mkLet $ C.NiceModuleMacro r p e x modapp open+                    dir{ publicOpen = Nothing }++        -- Do some rudimentary matching here to get NotValidBeforeField instead+        -- of NotAValidLetDecl.+        C.NiceMutual _ _ _ _+          [ C.FunSig _ _ _ _ macro _ _ _ _ _+          , C.FunDef _ _ abstract _ _ _ _+             [ C.Clause _ _ (C.LHS _p [] []) (C.RHS _) NoWhere [] ]+          ] | abstract /= AbstractDef && macro /= MacroDef -> do+          mkLet d++        C.NiceLoneConstructor{} -> failure+        C.NiceMutual{}        -> failure+        -- TODO: some of these cases might be __IMPOSSIBLE__+        C.Axiom{}             -> failure+        C.PrimitiveFunction{} -> failure+        C.NiceModule{}        -> failure+        C.NiceImport{}        -> failure+        C.NicePragma{}        -> failure+        C.NiceRecSig{}        -> failure+        C.NiceDataSig{}       -> failure+        C.NiceFunClause{}     -> failure+        C.FunSig{}            -> failure  -- Note: these are bundled with FunDef in NiceMutual+        C.FunDef{}            -> failure+        C.NiceDataDef{}       -> failure+        C.NiceRecDef{}        -> failure+        C.NicePatternSyn{}    -> failure+        C.NiceGeneralize{}    -> failure+        C.NiceUnquoteDecl{}   -> failure+        C.NiceUnquoteDef{}    -> failure+        C.NiceUnquoteData{}   -> failure+        C.NiceOpaque{}        -> failure++checkModuleApplication+  :: C.ModuleApplication+  -> ModuleName+  -> C.Name+  -> C.ImportDirective+  -> ScopeM (A.ModuleApplication, ScopeCopyInfo, A.ImportDirective)++checkModuleApplication (C.SectionApp _ tel m es) m0 x dir' = do+  reportSDoc "scope.decl" 70 $ vcat $+    [ text $ "scope checking ModuleApplication " ++ prettyShow x+    ]++  -- For the following, set the current module to be m0.+  withCurrentModule m0 $ do+    -- Parse the raw arguments of the module application. (See issue #1245.)+    args <- parseArguments (C.Ident m) es+    -- Scope check the telescope (introduces bindings!).+    tel' <- catMaybes <$> toAbstract tel+    -- Scope check the old module name and the module args.+    m1    <- toAbstract $ OldModuleName m+    args' <- toAbstractCtx (ArgumentCtx PreferParen) args+    -- Copy the scope associated with m and take the parts actually imported.+    (adir, s) <- applyImportDirectiveM (C.QName x) dir' =<< getNamedScope m1+    (s', copyInfo) <- copyScope m m0 s+    -- Set the current scope to @s'@+    modifyCurrentScope $ const s'+    printScope "mod.inst" 40 "copied source module"+    reportSDoc "scope.mod.inst" 30 $ return $ pretty copyInfo+    let amodapp = A.SectionApp tel' m1 args'+    reportSDoc "scope.decl" 70 $ vcat $+      [ text $ "scope checked ModuleApplication " ++ prettyShow x+      ]+    reportSDoc "scope.decl" 70 $ vcat $+      [ nest 2 $ prettyA amodapp+      ]+    return (amodapp, copyInfo, adir)++checkModuleApplication (C.RecordModuleInstance _ recN) m0 x dir' =+  withCurrentModule m0 $ do+    m1 <- toAbstract $ OldModuleName recN+    s <- getNamedScope m1+    (adir, s) <- applyImportDirectiveM recN dir' s+    (s', copyInfo) <- copyScope recN m0 s+    modifyCurrentScope $ const s'++    printScope "mod.inst" 40 "copied record module"+    return (A.RecordModuleInstance m1, copyInfo, adir)++-- | @checkModuleMacro mkApply range access concreteName modapp open dir@+--+--   Preserves local variables.++checkModuleMacro+  :: (ToConcrete a, Pretty (ConOfAbs a))+  => (ModuleInfo+      -> Erased+      -> ModuleName+      -> A.ModuleApplication+      -> ScopeCopyInfo+      -> A.ImportDirective+      -> a)+  -> OpenKind+  -> Range+  -> Access+  -> Erased+  -> C.Name+  -> C.ModuleApplication+  -> OpenShortHand+  -> C.ImportDirective+  -> ScopeM a+checkModuleMacro apply kind r p e x modapp open dir = do+    reportSDoc "scope.decl" 70 $ vcat $+      [ text $ "scope checking ModuleMacro " ++ prettyShow x+      ]+    dir <- notPublicWithoutOpen open dir++    m0 <- toAbstract (NewModuleName x)+    reportSDoc "scope.decl" 90 $ "NewModuleName: m0 =" <+> prettyA m0++    printScope "mod.inst" 40 "module macro"++    -- If we're opening a /named/ module, the import directive is+    -- applied to the "open", otherwise to the module itself. However,+    -- "public" is always applied to the "open".+    let (moduleDir, openDir) = case (open, isNoName x) of+          (DoOpen,   False) -> (defaultImportDir, dir)+          (DoOpen,   True)  -> ( dir { publicOpen = Nothing }+                               , defaultImportDir { publicOpen = publicOpen dir }+                               )+          (DontOpen, _)     -> (dir, defaultImportDir)++    -- Restore the locals after module application has been checked.+    (modapp', copyInfo, adir') <- withLocalVars $ checkModuleApplication modapp m0 x moduleDir+    printScope "mod.inst.app" 40 "checkModuleMacro, after checkModuleApplication"++    reportSDoc "scope.decl" 90 $ "after mod app: trying to print m0 ..."+    reportSDoc "scope.decl" 90 $ "after mod app: m0 =" <+> prettyA m0++    bindModule p x m0+    reportSDoc "scope.decl" 90 $ "after bindMod: m0 =" <+> prettyA m0++    printScope "mod.inst.copy.after" 40 "after copying"++    -- Open the module if DoOpen.+    -- Andreas, 2014-09-02: @openModule@ might shadow some locals!+    adir <- case open of+      DontOpen -> return adir'+      DoOpen   -> do+        adir'' <- openModule kind (Just m0) (C.QName x) openDir+        -- Andreas, 2020-05-14, issue #4656+        -- Keep the more meaningful import directive for highlighting+        -- (the other one is a defaultImportDir).+        return $ if isNoName x then adir' else adir''++    printScope "mod.inst" 40 $ show open+    reportSDoc "scope.decl" 90 $ "after open   : m0 =" <+> prettyA m0++    stripNoNames+    printScope "mod.inst.strip" 30 $ "after stripping"+    reportSDoc "scope.decl" 90 $ "after stripNo: m0 =" <+> prettyA m0++    let m      = m0 `withRangesOf` singleton x+        adecl  = apply info e m modapp' copyInfo adir++    reportSDoc "scope.decl" 70 $ vcat $+      [ text $ "scope checked ModuleMacro " ++ prettyShow x+      ]+    reportSLn  "scope.decl" 90 $ "info    = " ++ show info+    reportSLn  "scope.decl" 90 $ "m       = " ++ prettyShow m+    reportSLn  "scope.decl" 90 $ "modapp' = " ++ show modapp'+    reportSDoc "scope.decl" 90 $ return $ pretty copyInfo+    reportSDoc "scope.decl" 70 $ nest 2 $ prettyA adecl+    return adecl+  where+    info = ModuleInfo+             { minfoRange  = r+             , minfoAsName = Nothing+             , minfoAsTo   = renamingRange dir+             , minfoOpenShort = Just open+             , minfoDirective = Just dir+             }++-- | The @public@ keyword must only be used together with @open@.++notPublicWithoutOpen :: OpenShortHand -> C.ImportDirective -> ScopeM C.ImportDirective+notPublicWithoutOpen DoOpen   = return+notPublicWithoutOpen DontOpen = uselessPublic UselessPublicNoOpen++-- | Warn about useless @public@.++uselessPublic :: UselessPublicReason -> C.ImportDirective -> ScopeM C.ImportDirective+uselessPublic reason dir = do+  whenJust (publicOpen dir) \ r ->+    setCurrentRange r $ warning $ UselessPublic reason+  return $ dir { publicOpen = Nothing }++-- | Computes the range of all the \"to\" keywords used in a renaming+-- directive.++renamingRange :: C.ImportDirective -> Range+renamingRange = getRange . map renToRange . impRenaming++-- | Scope check a 'NiceOpen'.+checkOpen+  :: Range                -- ^ Range of @open@ statement.+  -> Maybe A.ModuleName   -- ^ Resolution of concrete module name (if already resolved).+  -> C.QName              -- ^ Module to open.+  -> C.ImportDirective    -- ^ Scope modifier.+  -> ScopeM (ModuleInfo, A.ModuleName, A.ImportDirective) -- ^ Arguments of 'A.Open'+checkOpen r mam x dir = do+  cm <- getCurrentModule+  reportSDoc "scope.decl" 70 $ do+    vcat $+      [ text   "scope checking NiceOpen " <> return (pretty x)+      , text   "  getCurrentModule       = " <> prettyA cm+      , text $ "  getCurrentModule (raw) = " ++ show cm+      , text $ "  C.ImportDirective      = " ++ prettyShow dir+      ]+  -- Andreas, 2017-01-01, issue #2377: warn about useless `public`+  dir <- if null cm then uselessPublic UselessPublicPreamble dir else return dir++  m <- caseMaybe mam (toAbstract (OldModuleName x)) return+  printScope "open" 40 $ "opening " ++ prettyShow x+  adir <- openModule TopOpenModule (Just m) x dir+  printScope "open" 40 $ "result:"+  let minfo = ModuleInfo+        { minfoRange     = r+        , minfoAsName    = Nothing+        , minfoAsTo      = renamingRange dir+        , minfoOpenShort = Nothing+        , minfoDirective = Just dir+        }+  let adecls = [A.Open minfo m adir]+  reportSDoc "scope.decl" 70 $ vcat $+    text ( "scope checked NiceOpen " ++ prettyShow x+         ) : map (nest 2 . prettyA) adecls+  return (minfo, m, adir)++-- | Check a literal, issuing an error warning for bad literals.+checkLiteral :: Literal -> ScopeM ()+checkLiteral = \case+  LitChar   c   -> when (isSurrogateCodePoint c) $ warning $ InvalidCharacterLiteral c+  LitNat    _   -> return ()+  LitWord64 _   -> return ()+  LitFloat  _   -> return ()+  LitString _   -> return ()+  LitQName  _   -> return ()+  LitMeta   _ _ -> return ()++{--------------------------------------------------------------------------+    Translation+ --------------------------------------------------------------------------}++concreteToAbstract_ :: ToAbstract c => c -> ScopeM (AbsOfCon c)+concreteToAbstract_ = toAbstract++concreteToAbstract :: ToAbstract c => ScopeInfo -> c -> ScopeM (AbsOfCon c)+concreteToAbstract scope x = withScope_ scope (toAbstract x)++-- | Things that can be translated to abstract syntax are instances of this+--   class.+class ToAbstract c where+    type AbsOfCon c+    toAbstract :: c -> ScopeM (AbsOfCon c)++-- | This function should be used instead of 'toAbstract' for things that need+--   to keep track of precedences to make sure that we don't forget about it.+toAbstractCtx :: ToAbstract c => Precedence -> c-> ScopeM (AbsOfCon c)+toAbstractCtx ctx c = withContextPrecedence ctx $ toAbstract c++--UNUSED Liang-Ting Chen 2019-07-16+--toAbstractTopCtx :: ToAbstract c a => c -> ScopeM a+--toAbstractTopCtx = toAbstractCtx TopCtx++toAbstractHiding :: (LensHiding h, ToAbstract c) => h -> c -> ScopeM (AbsOfCon c)+toAbstractHiding h | visible h = toAbstract -- don't change precedence if visible+toAbstractHiding _             = toAbstractCtx TopCtx++--UNUSED Liang-Ting Chen 2019-07-16+--setContextCPS :: Precedence -> (a -> ScopeM b) ->+--                 ((a -> ScopeM b) -> ScopeM b) -> ScopeM b+--setContextCPS p ret f = do+--  old <- useScope scopePrecedence+--  withContextPrecedence p $ f $ \ x -> setContextPrecedence old >> ret x+--+--localToAbstractCtx :: ToAbstract c =>+--                     Precedence -> c -> (AbsOfCon -> ScopeM (AbsOfCon c)) -> ScopeM (AbsOfCon c)+--localToAbstractCtx ctx c ret = setContextCPS ctx ret (localToAbstract c)++-- | This operation does not affect the scope, i.e. the original scope+--   is restored upon completion.+localToAbstract :: ToAbstract c => c -> (AbsOfCon c -> ScopeM b) -> ScopeM b+localToAbstract x ret = localScope $ ret =<< toAbstract x++-- | Like 'localToAbstract' but returns the scope after the completion of the+--   second argument.+localToAbstract' :: ToAbstract c => c -> (AbsOfCon c -> ScopeM b) -> ScopeM (b, ScopeInfo)+localToAbstract' x ret = do+  scope <- getScope+  withScope scope $ ret =<< toAbstract x++instance ToAbstract () where+  type AbsOfCon () = ()+  toAbstract = pure++instance (ToAbstract c1, ToAbstract c2) => ToAbstract (c1, c2) where+  type AbsOfCon (c1, c2) = (AbsOfCon c1, AbsOfCon c2)+  toAbstract (x,y) = (,) <$> toAbstract x <*> toAbstract y++instance (ToAbstract c1, ToAbstract c2, ToAbstract c3) => ToAbstract (c1, c2, c3) where+  type AbsOfCon (c1, c2, c3) = (AbsOfCon c1, AbsOfCon c2, AbsOfCon c3)+  toAbstract (x,y,z) = flatten <$> toAbstract (x,(y,z))+    where+      flatten (x,(y,z)) = (x,y,z)++instance ToAbstract c => ToAbstract [c] where+  type AbsOfCon [c] = [AbsOfCon c]+  toAbstract = mapM toAbstract++instance ToAbstract c => ToAbstract (List1 c) where+  type AbsOfCon (List1 c) = List1 (AbsOfCon c)+  toAbstract = mapM toAbstract++instance (ToAbstract c1, ToAbstract c2) => ToAbstract (Either c1 c2) where+  type AbsOfCon (Either c1 c2) = Either (AbsOfCon c1) (AbsOfCon c2)+  toAbstract = traverseEither toAbstract toAbstract++instance ToAbstract c => ToAbstract (Maybe c) where+  type AbsOfCon (Maybe c) = Maybe (AbsOfCon c)+  toAbstract = traverse toAbstract++-- Names ------------------------------------------------------------------++data NewName a = NewName+  { newBinder   :: A.BindingSource -- what kind of binder?+  , newName     :: a+  } deriving (Functor)++data OldQName = OldQName+  C.QName+    -- ^ Concrete name to be resolved.+  (Maybe (Set1 A.Name))+    -- ^ If a set is given, then the first name must+    --   correspond to one of the names in the set.++-- | We sometimes do not want to fail hard if the name is not actually+--   in scope because we have a strategy to recover from this problem+--   (e.g. drop the offending COMPILE pragma)+data MaybeOldQName = MaybeOldQName OldQName++-- | Wrapper for a concrete name that we already bound to an 'A.Def'.+--+newtype OldName a = OldName a++-- | Wrapper to resolve a name in a pattern.+data PatName = PatName+  C.QName+    -- ^ Concrete name to be resolved in a pattern.+  (Maybe (Set1 A.Name))+    -- ^ If a set is given, then the first name must correspond to one+    --   of the names in the set.+  Hiding+    -- ^ If pattern variable is hidden, its status is indicated in 'Hiding'.+  DisplayLHS+    -- ^ If we parse the lhs of a 'DisplayPragma',+    --   names of arbitrary definitions count as constructors.++instance ToAbstract (NewName C.Name) where+  type AbsOfCon (NewName C.Name) = A.Name+  toAbstract (NewName b x) = do+    y <- freshAbstractName_ x+    bindVariable b x y+    return y++instance ToAbstract (NewName C.BoundName) where+  type AbsOfCon (NewName C.BoundName) = A.BindName+  toAbstract NewName{ newBinder = b, newName = BName{ boundName = x, bnameFixity = fx }} = do+    y <- freshAbstractName fx x+    bindVariable b x y+    return $ A.BindName y++instance ToAbstract OldQName where+  type AbsOfCon OldQName = A.Expr+  toAbstract q@(OldQName x _) =+    fromMaybeM (notInScopeError x) $ toAbstract (MaybeOldQName q)++instance ToAbstract MaybeOldQName where+  type AbsOfCon MaybeOldQName = Maybe A.Expr+  toAbstract (MaybeOldQName (OldQName x ns)) = do+    qx <- resolveName' allKindsOfNames ns x+    reportSLn "scope.name" 30 $ "resolved " ++ prettyShow x ++ ": " ++ prettyShow qx+    case qx of+      VarName x' _         -> return $ Just $ A.Var x'+      DefinedName _ d suffix -> do+        raiseWarningsOnUsage $ anameName d+        -- then we take note of generalized names used+        addGeneralizable d+        -- and then we return the name+        return $ withSuffix suffix $ nameToExpr d+        where+          withSuffix NoSuffix   e         = Just e+          withSuffix s@Suffix{} (A.Def x) = Just $ A.Def' x s+          withSuffix _          _         = Nothing++      FieldName     ds     -> ambiguous (A.Proj ProjPrefix) ds+      ConstructorName _ ds -> ambiguous A.Con ds+      PatternSynResName ds -> ambiguous A.PatternSyn ds+      UnknownName          -> do+        reportSLn "scope.name.unknown" 80 $ "resolved : unknown " ++ prettyShow x+        pure Nothing+    where+      ambiguous :: (AmbiguousQName -> A.Expr) -> List1 AbstractName -> ScopeM (Maybe A.Expr)+      ambiguous f ds = do+        let xs = fmap anameName ds+        raiseWarningsOnUsageIfUnambiguous xs+        return $ Just $ f $ AmbQ xs++      -- Note: user warnings on ambiguous names will be raised by the type checker,+      -- see 'storeDisambiguatedName'.+      raiseWarningsOnUsageIfUnambiguous :: List1 A.QName -> ScopeM ()+      raiseWarningsOnUsageIfUnambiguous = \case+        x :| [] -> raiseWarningsOnUsage x+        _       -> return ()++-- | Resolve a name and fail hard if it is not in scope.+--+resolveQName :: C.QName -> ScopeM ResolvedName+resolveQName x = resolveName x >>= \case+    UnknownName -> notInScopeError x+    q -> q <$ addGeneralizable q+      -- Issue #7575:+      -- If the name is a @variable@, add it to the things we wish to generalize.+      -- If generalization is not supported here, this will throw an error.++-- | A name resolved in a pattern.+data APatName+  = VarPatName A.Name+      -- ^ Pattern variable.+  | ConPatName (List1 AbstractName)+      -- ^ A (possibly ambiguous) constructor.+      --   When parsing a 'C.DisplayPragma', this can be the name of a definition.+  | PatternSynPatName (List1 AbstractName)+      -- ^ A (possibly ambiguous) pattern synonym.+  | DefPatName AbstractName+      -- ^ A defined name, only possible when checking a 'C.DisplayPragma'.++instance ToAbstract PatName where+  type AbsOfCon PatName = APatName+  toAbstract (PatName x ns h displayLhs) = do+    reportSLn "scope.pat" 30 $ "checking pattern name: " ++ prettyShow x+    let kinds = applyWhen displayLhs (defNameKinds ++) conLikeNameKinds+    rx <- resolveName' (someKindsOfNames kinds) ns x+          -- Andreas, 2013-03-21 ignore conflicting names which cannot+          -- be meant since we are in a pattern+          -- Andreas, 2020-04-11 CoConName:+          -- coinductive constructors will be rejected later, in the type checker+    reportSLn "scope.pat" 40 $ "resolved as " ++ prettyShow rx+    case rx of+      ConstructorName _ ds -> ConPatName ds <$ do+        reportSLn "scope.pat" 30 $ "it was a con: " ++ prettyShow (fmap anameName ds)+      PatternSynResName ds -> PatternSynPatName ds <$ do+        reportSLn "scope.pat" 30 $ "it was a pat syn: " ++ prettyShow (fmap anameName ds)+      DefinedName _ d suffix | YesDisplayLHS <- displayLhs, null suffix -> DefPatName d <$ do+        reportSLn "scope.pat" 30 $ "it was a def: " ++ prettyShow (anameName d)+      _ -> case x of+        C.QName y -> VarPatName <$> bindPatternVariable h y+        C.Qual{}  -> typeError $ InvalidPattern $ C.IdentP True x++-- | Translate and possibly bind a pattern variable+--   (which could have been bound before due to non-linearity).+bindPatternVariable :: Hiding -> C.Name -> ScopeM A.Name+bindPatternVariable h x = do+  y <- (AssocList.lookup x <$> getVarsToBind) >>= \case+    Just (LocalVar y _ _) -> do+      reportSLn "scope.pat" 30 $ "it was a old var: " ++ prettyShow x+      return $ setRange (getRange x) y+    Nothing -> do+      reportSLn "scope.pat" 30 $ "it was a new var: " ++ prettyShow x+      freshAbstractName_ x+  addVarToBind x $ LocalVar y (PatternBound h) []+  return y++class ToQName a where+  toQName :: a -> C.QName++instance ToQName C.Name  where toQName = C.QName+instance ToQName C.QName where toQName = id++-- | Should be a defined name.+instance ToQName a => ToAbstract (OldName a) where+  type AbsOfCon (OldName a) = A.QName+  toAbstract (OldName x) = do+    resolveName (toQName x) >>= \case+      DefinedName _ d NoSuffix -> return $ anameName d+      DefinedName _ d Suffix{} -> __IMPOSSIBLE__+      VarName{}                -> __IMPOSSIBLE__+      UnknownName              -> __IMPOSSIBLE__+      -- We can get the cases below for DISPLAY pragmas+      ConstructorName _ ds -> return $ anameName (List1.head ds)   -- We'll throw out this one, so it doesn't matter which one we pick+      FieldName ds         -> return $ anameName (List1.head ds)+      PatternSynResName ds -> return $ anameName (List1.head ds)++newtype NewModuleName      = NewModuleName      C.Name+newtype NewModuleQName     = NewModuleQName     C.QName+newtype OldModuleName      = OldModuleName      C.QName++freshQModule :: A.ModuleName -> C.Name -> ScopeM A.ModuleName+freshQModule m x = A.qualifyM m . mnameFromList1 . singleton <$> freshAbstractName_ x++checkForModuleClash :: C.Name -> ScopeM ()+checkForModuleClash x = do+  ms :: [AbstractModule] <- scopeLookup (C.QName x) <$> getScope+  List1.unlessNull ms \ ms -> do+    reportSLn "scope.clash" 40 $ "clashing modules ms = " ++ prettyShow ms+    reportSLn "scope.clash" 60 $ "clashing modules ms = " ++ show ms+    setCurrentRange x $+      typeError $ ShadowedModule x $ fmap ((`withRangeOf` x) . amodName) ms++instance ToAbstract NewModuleName where+  type AbsOfCon NewModuleName = A.ModuleName+  toAbstract (NewModuleName x) = do+    checkForModuleClash x+    m <- getCurrentModule+    y <- freshQModule m x+    createModule Nothing y+    return y++instance ToAbstract NewModuleQName where+  type AbsOfCon NewModuleQName = A.ModuleName+  toAbstract (NewModuleQName m) = toAbs noModuleName m+    where+      toAbs m (C.QName x)  = do+        y <- freshQModule m x+        createModule Nothing y+        return y+      toAbs m (C.Qual x q) = do+        m' <- freshQModule m x+        toAbs m' q++instance ToAbstract OldModuleName where+  type AbsOfCon OldModuleName = A.ModuleName++  toAbstract (OldModuleName q) = setCurrentRange q $ do+    amodName <$> resolveModule q++-- Expressions ------------------------------------------------------------+--UNUSED Liang-Ting Chen 2019-07-16+---- | Peel off 'C.HiddenArg' and represent it as an 'NamedArg'.+--mkNamedArg :: C.Expr -> NamedArg C.Expr+--mkNamedArg (C.HiddenArg   _ e) = Arg (hide         defaultArgInfo) e+--mkNamedArg (C.InstanceArg _ e) = Arg (makeInstance defaultArgInfo) e+--mkNamedArg e                   = Arg defaultArgInfo $ unnamed e++-- | Peel off 'C.HiddenArg' and represent it as an 'Arg', throwing away any name.+mkArg' :: ArgInfo -> C.Expr -> Arg C.Expr+mkArg' info (C.HiddenArg   _ e) = Arg (hide         info) $ namedThing e+mkArg' info (C.InstanceArg _ e) = Arg (makeInstance info) $ namedThing e+mkArg' info e                   = Arg (setHiding NotHidden info) e++inferParenPreference :: C.Expr -> ParenPreference+inferParenPreference C.Paren{} = PreferParen+inferParenPreference _         = PreferParenless++-- | Parse a possibly dotted and braced @C.Expr@ as @A.Expr@,+--   interpreting dots as relevance and braces as hiding.+--   Only accept a layer of dotting/bracing if the respective accumulator is @Nothing@.+toAbstractDotHiding :: Maybe Relevance -> Maybe Hiding -> Precedence -> C.Expr -> ScopeM (A.Expr, Relevance, Hiding)+toAbstractDotHiding mr mh prec e = do+    reportSLn "scope.irrelevance" 100 $ "toAbstractDotHiding: " ++ render (pretty e)+    traceCall (ScopeCheckExpr e) $ case e of++      C.RawApp _ es     -> toAbstractDotHiding mr mh prec =<< parseApplication es+      C.Paren _ e       -> toAbstractDotHiding mr mh TopCtx e++      C.Dot kwr e+        | Nothing <- mr -> toAbstractDotHiding (Just $ Irrelevant $ OIrrDot $ getRange kwr) mh prec e++      C.DoubleDot kwr e+        | Nothing <- mr -> toAbstractDotHiding (Just $ ShapeIrrelevant $ OShIrrDotDot $ getRange kwr) mh prec e++      C.HiddenArg _ (Named Nothing e)+        | Nothing <- mh -> toAbstractDotHiding mr (Just Hidden) TopCtx e++      C.InstanceArg _ (Named Nothing e)+        | Nothing <- mh -> toAbstractDotHiding mr (Just $ Instance NoOverlap) TopCtx e++      e                 -> (, fromMaybe relevant mr, fromMaybe NotHidden mh) <$>+                             toAbstractCtx prec e++-- | Translate concrete expression under at least one binder into nested+--   lambda abstraction in abstract syntax.+toAbstractLam :: Range -> List1 C.LamBinding -> C.Expr -> Precedence -> ScopeM A.Expr+toAbstractLam r bs e ctx = do+  -- Translate the binders+  lvars0 <- getLocalVars+  localToAbstract (fmap (C.DomainFull . makeDomainFull) bs) $ \ bs -> do+    lvars1 <- getLocalVars+    checkNoShadowing lvars0 lvars1+    -- Translate the body+    e <- toAbstractCtx ctx e+    -- We have at least one binder.  Get first @b@ and rest @bs@.+    return $ case List1.catMaybes bs of+      -- Andreas, 2020-06-18+      -- There is a pathological case in which we end up without binder:+      --   λ (let+      --        mutual -- warning: empty mutual block+      --     ) -> Set+      []   -> e+      b:bs -> A.Lam (ExprRange r) b $ foldr mkLam e bs+  where+    mkLam b e = A.Lam (ExprRange $ fuseRange b e) b e++-- | Scope check extended lambda expression.+scopeCheckExtendedLam ::+  Range -> Erased -> List1 C.LamClause -> ScopeM A.Expr+scopeCheckExtendedLam r e cs = do+  whenM isInsideDotPattern $ typeError $ NotAllowedInDotPatterns PatternLambdas++  -- Find an unused name for the extended lambda definition.+  cname <- freshConcreteName r 0 extendedLambdaName+  name  <- freshAbstractName_ cname+  a <- asksTC (^. lensIsAbstract)+  reportSDoc "scope.extendedLambda" 30 $ vcat+    [ text $ "new extended lambda name (" ++ show a ++ "): " ++ prettyShow name+    ]+  verboseS "scope.extendedLambda" 60 $ do+    forM_ cs $ \ c -> do+      reportSLn "scope.extendedLambda" 60 $ "extended lambda lhs: " ++ show (C.lamLHS c)+  qname <- qualifyName_ name+  bindName privateAccessInserted FunName cname qname++  -- Andreas, 2019-08-20+  -- Keep the following __IMPOSSIBLE__, which is triggered by -v scope.decl.trace:80,+  -- for testing issue #4016.+  d <- C.FunDef r [] a NotInstanceDef __IMPOSSIBLE__ __IMPOSSIBLE__ cname . List1.toList <$> do+          forM cs $ \ (LamClause ps rhs ca) -> do+            let p   = C.rawAppP $+                        killRange (IdentP True $ C.QName cname) :| ps+            let lhs = C.LHS p [] []+            return $ C.Clause cname ca lhs rhs NoWhere []+  scdef <- toAbstract d++  -- Create the abstract syntax for the extended lambda.+  case scdef of+    A.ScopedDecl si [A.FunDef di qname' cs] -> do+      setScope si  -- This turns into an A.ScopedExpr si $ A.ExtendedLam...+      return $+        A.ExtendedLam (ExprRange r) di e qname' $+        List1.fromListSafe __IMPOSSIBLE__ cs+    _ -> __IMPOSSIBLE__++-- | Scope check an expression.++instance ToAbstract C.Expr where+  type AbsOfCon C.Expr = A.Expr++  toAbstract e =+    traceCall (ScopeCheckExpr e) $ annotateExpr $ case e of++  -- Names+      Ident x -> toAbstract (OldQName x Nothing)+      KnownIdent _ x -> toAbstract (OldQName x Nothing)+      -- Just discard the syntax highlighting information.++  -- Literals+      C.Lit r l -> do+        checkLiteral l+        case l of+          LitNat n -> do+            let builtin | n < 0     = Just <$> primFromNeg    -- negative literals are only allowed if FROMNEG is defined+                        | otherwise = ensureInScope =<< getBuiltin' builtinFromNat+            builtin >>= \case+              Just (I.Def q _) -> return $ mkApp q $ A.Lit i $ LitNat $ abs n+              _                -> return alit++          LitString s -> do+            getBuiltin' builtinFromString >>= ensureInScope >>= \case+              Just (I.Def q _) -> return $ mkApp q alit+              _                -> return alit++          _ -> return alit+        where+        i       = ExprRange r+        alit    = A.Lit i l+        mkApp q = A.App (defaultAppInfo r) (A.Def q) . defaultNamedArg++        -- #4925: Require fromNat/fromNeg to be in scope *unqualified* for literal overloading to+        -- apply.+        ensureInScope :: Maybe I.Term -> ScopeM (Maybe I.Term)+        ensureInScope v@(Just (I.Def q _)) =+          ifM (isNameInScopeUnqualified q <$> getScope) (return v) (return Nothing)+        ensureInScope _ = return Nothing++  -- Meta variables+      C.QuestionMark r n -> do+        scope <- getScope+        -- Andreas, 2014-04-06 create interaction point.+        ii <- registerInteractionPoint True r n+        let info = MetaInfo+             { metaRange  = r+             , metaScope  = scope+             , metaNumber = Nothing+             , metaNameSuggestion = ""+             , metaKind   = UnificationMeta+             }+        return $ A.QuestionMark info ii+      C.Underscore r n -> do+        scope <- getScope+        return $ A.Underscore $ MetaInfo+                    { metaRange  = r+                    , metaScope  = scope+                    , metaNumber = __IMPOSSIBLE__ =<< n+                    , metaNameSuggestion = fromMaybe "" n+                    , metaKind   = UnificationMeta+                    }++  -- Raw application+      C.RawApp r es -> do+        e <- parseApplication es+        toAbstract e++  -- Application+      C.App r e1 e2 -> do+        -- Andreas, 2021-02-10, issue #3289: reject @e {.p}@ and @e ⦃ .p ⦄@.++        -- Raise an error if argument is a C.Dot with Hiding info.+        case namedArg e2 of+          C.Dot{} | notVisible e2 -> setCurrentRange e2 $ typeError $ IllegalHidingInPostfixProjection e2+          _ -> return ()++        let parenPref = inferParenPreference (namedArg e2)+            info = (defaultAppInfo r) { appOrigin = UserWritten, appParens = parenPref }+        e1 <- toAbstractCtx FunctionCtx e1+        e2 <- toAbstractCtx (ArgumentCtx parenPref) e2+        return $ A.App info e1 e2++  -- Operator application+      C.OpApp r op ns es -> toAbstractOpApp op ns es+      C.KnownOpApp _ r op ns es -> toAbstractOpApp op ns es++  -- With application+      C.WithApp r e es -> do+        e  <- toAbstractCtx WithFunCtx e+        es <- mapM (toAbstractCtx WithArgCtx) es+        return $ A.WithApp (ExprRange r) e es++  -- Misplaced hidden argument. We can treat these as parentheses and+  -- raise an error-warning+      C.HiddenArg _ e' -> do+        warning (HiddenNotInArgumentPosition e)+        toAbstract (namedThing e')++      C.InstanceArg _ e' -> do+        warning (InstanceNotInArgumentPosition e)+        toAbstract (namedThing e')++  -- Lambda+      C.AbsurdLam r h -> return $ A.AbsurdLam (ExprRange r) h++      C.Lam r bs e -> toAbstractLam r bs e TopCtx++  -- Extended Lambda+      C.ExtendedLam r e cs -> scopeCheckExtendedLam r e cs++  -- Relevant and irrelevant non-dependent function type+      C.Fun r (Arg info1 e1) e2 -> do+        let arg = mkArg' info1 e1+        let mr = case getRelevance arg of+              Relevant{} -> Nothing+              r -> Just r+        let mh = case getHiding arg of+              NotHidden -> Nothing+              h         -> Just h+        Arg info (e1', rel, hid) <- traverse (toAbstractDotHiding mr mh FunctionSpaceDomainCtx) arg+        let updRel = applyUnless (isRelevant rel) $ setRelevance rel+        let updHid = case hid of+              NotHidden -> id+              hid       -> setHiding hid+        A.Fun (ExprRange r) (Arg (updRel $ updHid info) e1') <$> toAbstractCtx TopCtx e2++  -- Dependent function type+      e0@(C.Pi tel e) -> do+        lvars0 <- getLocalVars+        localToAbstract tel $ \tel -> do+          lvars1 <- getLocalVars+          checkNoShadowing lvars0 lvars1+          e <- toAbstractCtx TopCtx e+          let info = ExprRange (getRange e0)+          return $ A.mkPi info (List1.catMaybes tel) e++  -- Let+      e0@(C.Let _ ds (Just e)) ->+        ifM isInsideDotPattern (typeError $ NotAllowedInDotPatterns LetExpressions) {-else-} do+        localToAbstract (LetDefs ExprLetDef ds) $ \ds' -> do+          e <- toAbstractCtx TopCtx e+          let info = ExprRange (getRange e0)+          return $ A.mkLet info ds' e+      C.Let _ _ Nothing -> typeError $ NotAValidLetExpression MissingBody++  -- Record construction+      C.Rec kwr r fs -> do+        fs' <- toAbstractCtx TopCtx fs+        let ds'  = [ d | Right (_, Just d) <- fs' ]+            fs'' = map (mapRight fst) fs'+            i    = ExprRange r+        return $ A.mkLet i ds' (A.Rec kwr i fs'')++  -- Record update+      C.RecUpdate kwr r e fs -> do+        A.RecUpdate kwr (ExprRange r) <$> toAbstract e <*> toAbstractCtx TopCtx fs++  -- Parenthesis+      C.Paren _ e -> toAbstractCtx TopCtx e++  -- Idiom brackets+      C.IdiomBrackets r es ->+        toAbstractCtx TopCtx =<< parseIdiomBracketsSeq r es++  -- Do notation+      C.DoBlock r ss ->+        toAbstractCtx TopCtx =<< desugarDoNotation r ss++  -- Post-fix projections+      e0@(C.Dot _kwr e) -> A.Dot (ExprRange $ getRange e0) <$> toAbstract e++  -- Pattern things+      C.As _ _ _ -> notAnExpression e+      C.Absurd _ -> notAnExpression e++  -- Impossible things+      C.Equal{} -> syntaxError "unexpected '='" -- triggered by 'f = (x = e)'+      C.Ellipsis _ -> syntaxError "unexpected '...'"  -- triggered by 'f = ...'+      C.DoubleDot _ _ -> syntaxError "unexpected '..'" -- triggered by 'f = ..x'++  -- Quoting+      C.Quote r -> return $ A.Quote (ExprRange r)+      C.QuoteTerm r -> return $ A.QuoteTerm (ExprRange r)+      C.Unquote r -> return $ A.Unquote (ExprRange r)++      C.Tactic r e -> syntaxError "'tactic' can only appear in attributes"++  -- DontCare+      C.DontCare e -> A.DontCare <$> toAbstract e++  -- forall-generalize+      C.Generalized e -> do+        (s, e) <- collectGeneralizables $ toAbstract e+        pure $ A.generalized s e++instance ToAbstract C.ModuleAssignment where+  type AbsOfCon C.ModuleAssignment = (A.ModuleName, Maybe A.LetBinding)+  toAbstract (C.ModuleAssignment m es i)+    | null es && isDefaultImportDir i = (, Nothing) <$> toAbstract (OldModuleName m)+    | otherwise = do+        x <- C.NoName (getRange m) <$> fresh+        r <- checkModuleMacro LetApply LetOpenModule+               (getRange (m, es, i)) PublicAccess defaultErased x+               (C.SectionApp (getRange (m , es)) [] m es)+               DontOpen i+        case r of+          LetApply _ _ m' _ _ _ -> return (m', Just r)+          _ -> __IMPOSSIBLE__++instance ToAbstract c => ToAbstract (FieldAssignment' c) where+  type AbsOfCon (FieldAssignment' c) = FieldAssignment' (AbsOfCon c)++  toAbstract = traverse toAbstract++instance ToAbstract (C.Binder' (NewName C.BoundName)) where+  type AbsOfCon (C.Binder' (NewName C.BoundName)) = A.Binder++  toAbstract (C.Binder p o n) = do+    let name = C.boundName $ newName n++    -- If we do have a pattern then the variable needs to be inserted+    -- so we do need a proper internal name for it.+    --+    -- Amy, 2024-10-18: If we generated a name, then mark the binder+    -- name as being inserted.+    (n, o) <- if not (isNoName name && isJust p) then pure (n, o) else do+      n' <- freshConcreteName (getRange $ newName n) 0 patternInTeleName+      pure (fmap (\ n -> n { C.boundName = n' }) n, InsertedBinderName)++    n <- toAbstract n+    -- Expand puns if optHiddenArgumentPuns is True.+    p <- traverse expandPunsOpt p+    -- Actually parsing the pattern, checking it is linear,+    -- and bind its variables+    p <- traverse parsePattern p+    p <- toAbstract p+    checkPatternLinearity p $ \ys ->+      typeError $ RepeatedVariablesInPattern ys+    bindVarsToBind+    p <- toAbstract p+    pure $ A.Binder p o n++instance ToAbstract C.LamBinding where+  type AbsOfCon C.LamBinding = Maybe A.LamBinding++  toAbstract (C.DomainFree x)  = do+    tac <- scopeCheckTactic x+    Just . A.DomainFree tac <$> toAbstract (updateNamedArg (fmap $ NewName LambdaBound) x)+  toAbstract (C.DomainFull tb) = fmap A.DomainFull <$> toAbstract tb++-- | Scope check tactic attribute, make sure they are only used in hidden arguments.+scopeCheckTactic :: NamedArg C.Binder -> ScopeM A.TacticAttribute+scopeCheckTactic x = do+  let ctac = bnameTactic $ C.binderName $ namedArg x+  let r = getRange ctac+  setCurrentRange r $ do+    tac <- traverse toAbstract ctac+    if null tac || hidden x then return tac else empty <$ warning UselessTactic++makeDomainFull :: C.LamBinding -> C.TypedBinding+makeDomainFull (C.DomainFull b) = b+makeDomainFull (C.DomainFree x) = C.TBind r (singleton x) $ C.Underscore r Nothing+  where r = getRange x++instance ToAbstract C.TypedBinding where+  type AbsOfCon C.TypedBinding = Maybe A.TypedBinding++  toAbstract (C.TBind r xs t) = do+    t' <- toAbstractCtx TopCtx t+    -- Invariant: all tactics are the same+    -- (distributed in the parser, TODO: don't)+    let tacArg = List1.find (not . null . bnameTactic . C.binderName . namedArg) xs+    tac <- maybe (pure empty) scopeCheckTactic tacArg++    let fin = all (bnameIsFinite . C.binderName . namedArg) xs+    xs' <- toAbstract $ fmap (updateNamedArg (fmap $ NewName LambdaBound)) xs++    return $ Just $ A.TBind r (TypedBindingInfo tac fin) xs' t'+  toAbstract (C.TLet r ds) = A.mkTLet r <$> toAbstract (LetDefs ExprLetDef ds)++-- | Scope check a module (top level function).+--+scopeCheckNiceModule+  :: Range+  -> Access+  -> Erased+  -> C.Name+  -> C.Telescope+  -> ScopeM [A.Declaration]+  -> ScopeM A.Declaration+       -- ^ The returned declaration is an 'A.Section'.+scopeCheckNiceModule r p e name tel checkDs = do+    -- Andreas, 2025-03-29: clear @envCheckingWhere@+    -- We are no longer directly in a @where@ block if we enter a module.+    localTC (\ env -> env{ envCheckingWhere = C.NoWhere_ }) $+      checkWrappedModules p (splitModuleTelescope tel)+  where+    -- Andreas, 2013-12-10:+    -- If the module telescope contains open statements+    -- or module macros (Issue 1299),+    -- add an extra anonymous module around the current one.+    -- Otherwise, the open statements would create+    -- identifiers in the parent scope of the current module.+    -- But open statements in the module telescope should+    -- only affect the current module!+    -- Ulf, 2024-11-21 (#7440): We need the wrapper module to have to correct parameters, otherwise+    -- open public of a module created in the telescope will behave incorrectly when applying the+    -- outer module.+    splitModuleTelescope :: C.Telescope -> [C.Telescope]+    splitModuleTelescope [] = [[]]+    splitModuleTelescope (b : tel) =+      case b of+        C.TLet _ ds | any needsWrapper ds -> [] : addBind b (splitModuleTelescope tel)+        _ -> addBind b $ splitModuleTelescope tel+      where+        addBind b (tel : ms) = (b : tel) : ms+        addBind _ [] = __IMPOSSIBLE__++        needsWrapper C.ModuleMacro{}    = True+        needsWrapper C.Open{}           = True+        needsWrapper C.Import{}         = True -- not __IMPOSSIBLE__, see Issue #1718+          -- However, it does not matter what we return here, as this will+          -- become an error later: "Not a valid let-declaration".+          -- (Andreas, 2015-11-17)+        needsWrapper (C.Mutual   _ ds)  = any needsWrapper ds+        needsWrapper (C.Abstract _ ds)  = any needsWrapper ds+        needsWrapper (C.Private _ _ ds) = any needsWrapper ds+        needsWrapper _                  = False++    checkWrappedModules :: Access -> [C.Telescope] -> ScopeM A.Declaration+    checkWrappedModules _ []           = __IMPOSSIBLE__+    checkWrappedModules p [tel]        = scopeCheckNiceModule_ r p name tel checkDs+    checkWrappedModules p (tel : tels) =+      scopeCheckNiceModule_ r p noName_ tel $ singleton <$>+        checkWrappedModules PublicAccess tels -- Inner modules are PublicAccess (see #4350)++    -- The actual workhorse:+    scopeCheckNiceModule_ :: Range -> Access -> C.Name -> C.Telescope -> ScopeM [A.Declaration] -> ScopeM A.Declaration+    scopeCheckNiceModule_ r p name tel checkDs = do++      -- Check whether we are dealing with an anonymous module.+      -- This corresponds to a Coq/LEGO section.+      (name, p', open) <- do+        if isNoName name then do+          (i :: NameId) <- fresh+          return (C.NoName (getRange name) i, privateAccessInserted, True)+         else return (name, p, False)++      -- Check and bind the module, using the supplied check for its contents.+      aname <- toAbstract (NewModuleName name)+      d <- snd <$> do+        scopeCheckModule r e (C.QName name) aname tel checkDs+      bindModule p' name aname++      -- If the module was anonymous open it public+      -- unless it's private, in which case we just open it (#2099)+      when open $+       void $ -- We can discard the returned default A.ImportDirective.+        openModule TopOpenModule (Just aname) (C.QName name) $+          defaultImportDir { publicOpen = boolToMaybe (p == PublicAccess) empty }+      return d++-- | We for now disallow let-bindings in @data@ and @record@ telescopes.+--   This due "nested datatypes"; there is no easy interpretation of+--   @+--      data D (A : Set) (open M A) (b : B) : Set where+--        c : D (A × A) b → D A b+--   @+--   where @B@ is brought in scope by @open M A@.++class EnsureNoLetStms a where+  ensureNoLetStms :: a -> ScopeM ()++  default ensureNoLetStms :: (Foldable t, EnsureNoLetStms b, t b ~ a) => a -> ScopeM ()+  ensureNoLetStms = traverse_ ensureNoLetStms++instance EnsureNoLetStms C.Binder where+  ensureNoLetStms arg@(C.Binder p _ n) =+    when (isJust p) $ typeError $ IllegalPatternInTelescope arg++instance EnsureNoLetStms C.TypedBinding where+  ensureNoLetStms = \case+    tb@C.TLet{}    -> typeError $ IllegalLetInTelescope tb+    C.TBind _ xs _ -> traverse_ (ensureNoLetStms . namedArg) xs++instance EnsureNoLetStms a => EnsureNoLetStms (LamBinding' a) where+  ensureNoLetStms = \case+    -- GA: DO NOT use traverse here: `LamBinding'` only uses its parameter in+    --     the DomainFull constructor so we would miss out on some potentially+    --     illegal lets! Cf. #4402+    C.DomainFree a -> ensureNoLetStms a+    C.DomainFull a -> ensureNoLetStms a++instance EnsureNoLetStms a => EnsureNoLetStms (Named_ a) where+instance EnsureNoLetStms a => EnsureNoLetStms (NamedArg a) where+instance EnsureNoLetStms a => EnsureNoLetStms [a] where+++-- | Returns the scope inside the checked module.+scopeCheckModule+  :: Range                   -- ^ The range of the module.+  -> Erased                  -- ^ Is the module erased?+  -> C.QName                 -- ^ The concrete name of the module.+  -> A.ModuleName            -- ^ The abstract name of the module.+  -> C.Telescope             -- ^ The module telescope.+  -> ScopeM [A.Declaration]  -- ^ The code for checking the module contents.+  -> ScopeM (ScopeInfo, A.Declaration)+       -- ^ The returned declaration is an 'A.Section'.+scopeCheckModule r e x qm tel checkDs = do+  printScope "module" 40 $ "checking module " ++ prettyShow x+  -- Andreas, 2013-12-10: Telescope does not live in the new module+  -- but its parent, so check it before entering the new module.+  -- This is important for Nicolas Pouillard's open parametrized modules+  -- statements inside telescopes.+  res <- withLocalVars $ do+    tel <- toAbstract (GenTel tel)+    withCurrentModule qm $ do+      -- pushScope m+      -- qm <- getCurrentModule+      printScope "module" 40 $ "inside module " ++ prettyShow x+      ds    <- checkDs+      scope <- getScope+      return (scope, A.Section r e (qm `withRangesOfQ` x) tel ds)++  -- Binding is done by the caller+  printScope "module" 40 $ "after module " ++ prettyShow x+  return res++-- | Temporary data type to scope check a file.+data TopLevel a = TopLevel+  { topLevelSourceFile     :: SourceFile+    -- ^ The file from which we loaded this module.+  , topLevelExpectedName   :: TopLevelModuleName+    -- ^ The expected module name+    --   (coming from the import statement that triggered scope checking this file).+  , topLevelTheThing       :: a+    -- ^ The file content.+  }++data TopLevelInfo = TopLevelInfo+        { topLevelDecls :: [A.Declaration]+        , topLevelScope :: ScopeInfo  -- ^ as seen from inside the module+        }++-- | The top-level module name.++topLevelModuleName :: TopLevelInfo -> A.ModuleName+topLevelModuleName = (^. scopeCurrent) . topLevelScope++-- | Top-level declarations are always+--   @+--     (import|open)*         -- a bunch of possibly opened imports+--     module ThisModule ...  -- the top-level module of this file+--   @+instance ToAbstract (TopLevel [C.Declaration]) where+    type AbsOfCon (TopLevel [C.Declaration]) = TopLevelInfo++    toAbstract (TopLevel src expectedMName ds) =+      -- A file is a bunch of preliminary decls (imports etc.)+      -- plus a single module decl.+      case C.spanAllowedBeforeModule ds of++        -- If there are declarations after the top-level module+        -- we have to report a parse error here.+        (_, C.Module{} : d : _) -> setCurrentRange d $ typeError DeclarationsAfterTopLevelModule++        -- Otherwise, proceed.+        (outsideDecls, [ C.Module r e m0 tel insideDecls ]) -> do+          -- If the module name is _ compute the name from the file path+          (m, top) <- if isNoName m0+                then do+                  -- Andreas, 2017-07-28, issue #1077+                  -- Check if the insideDecls end in a single module which has the same+                  -- name as the file.  In this case, it is highly likely that the user+                  -- put some non-allowed declarations before the top-level module in error.+                  -- Andreas, 2017-10-19, issue #2808+                  -- Widen this check to:+                  -- If the first module of the insideDecls has the same name as the file,+                  -- report an error.+                  case flip span insideDecls $ \case { C.Module{} -> False; _ -> True } of+                    (ds0, (C.Module _ _ m1 _ _ : _))+                       | rawTopLevelModuleNameForQName m1 ==+                         rawTopLevelModuleName expectedMName+                         -- If the anonymous module comes from the user,+                         -- the range cannot be the beginningOfFile.+                         -- That is the range if the parser inserted the anon. module.+                       , r == beginningOfFile (getRange insideDecls) -> do++                         -- GA #4888: We know we are in a bad place. But we still scopecheck+                         -- the initial segment on the off chance we generate a better error+                         -- message.+                         void importPrimitives+                         void $ toAbstract (Declarations outsideDecls)+                         void $ toAbstract (Declarations ds0)+                         -- Fail with a crude error otherwise+                         setCurrentRange ds0 $ typeError IllegalDeclarationBeforeTopLevelModule++                    -- Otherwise, reconstruct the top-level module name+                    _ -> do+                      file <- srcFilePath src+                      let m = C.QName $ setRange (getRange m0) $+                              C.simpleName $ stringToRawName $+                              rootNameModule file+                      top <- S.topLevelModuleName+                               (rawTopLevelModuleNameForQName m)+                      return (m, top)+                -- Andreas, 2017-05-17, issue #2574, keep name as jump target!+                -- Andreas, 2016-07-12, ALTERNATIVE:+                -- -- We assign an anonymous file module the name expected from+                -- -- its import.  For flat file structures, this is the same.+                -- -- For hierarchical file structures, this reverses the behavior:+                -- -- Loading the file by itself will fail, but it can be imported.+                -- -- The previous behavior is: it can be loaded by itself, but not+                -- -- be imported+                -- then return $ C.fromTopLevelModuleName expectedMName+                else do+                -- Andreas, 2014-03-28  Issue 1078+                -- We need to check the module name against the file name here.+                -- Otherwise one could sneak in a lie and confuse the scope+                -- checker.+                  top <- S.topLevelModuleName+                           (rawTopLevelModuleNameForQName m0)+                  checkModuleName top src (Just expectedMName)+                  return (m0, top)+          setTopLevelModule top+          am <- toAbstract (NewModuleQName m)+          primitiveImport <- importPrimitives+          -- Scope check the declarations outside+          outsideDecls <- toAbstract (Declarations outsideDecls)+          (insideScope, insideDecl) <- scopeCheckModule r e m am tel $+             toAbstract (Declarations insideDecls)+          -- Andreas, 2020-05-13, issue #1804, #4647+          -- Do not eagerly remove private definitions, only when serializing+          -- let scope = over scopeModules (fmap $ restrictLocalPrivate am) insideScope+          let scope = insideScope+          setScope scope++          -- While scope-checking the top-level module we might have+          -- encountered several (possibly nested) opaque blocks. We+          -- must now ensure that these have transitively-closed+          -- unfolding sets.+          saturateOpaqueBlocks++          return $ TopLevelInfo (primitiveImport ++ outsideDecls ++ [ insideDecl ]) scope++        -- We already inserted the missing top-level module, see+        -- 'Agda.Syntax.Parser.Parser.figureOutTopLevelModule',+        -- thus, this case is impossible:+        _ -> __IMPOSSIBLE__++-- | Declaration @open import Agda.Primitive using (Set)@ when 'optImportSorts'.+--   @Prop@ is added when 'optProp', and @SSet@ when 'optTwoLevel'.+importPrimitives :: ScopeM [A.Declaration]+importPrimitives = do+  ifNotM (optImportSorts <$> pragmaOptions) (return []) {- else -} do+    prop     <- optProp     <$> pragmaOptions+    twoLevel <- optTwoLevel <$> pragmaOptions+    -- Add implicit `open import Agda.Primitive using (Prop; Set; SSet)`+    let agdaPrimitiveName   = Qual (C.simpleName "Agda") $ C.QName $ C.simpleName "Primitive"+        usingDirective      = map (ImportedName . C.simpleName) $ concat+          [ [ "Prop" | prop     ]+          , [ "Set"  | True     ]+          , [ "SSet" | twoLevel ]+          ]+        directives          = ImportDirective noRange (Using usingDirective) [] [] Nothing+        importAgdaPrimitive = [C.Import noRange agdaPrimitiveName Nothing C.DoOpen directives]+    toAbstract (Declarations importAgdaPrimitive)++-- | runs Syntax.Concrete.Definitions.niceDeclarations on main module+niceDecls :: DoWarn -> [C.Declaration] -> ([NiceDeclaration] -> ScopeM a) -> ScopeM a+niceDecls warn ds ret = setCurrentRange ds $ computeFixitiesAndPolarities warn ds $ do++  -- Some pragmas are not allowed in safe mode unless we are in a builtin module.+  -- So we need to tell the nicifier whether it should yell about unsafe pragmas.+  isSafe <- Lens.getSafeMode <$> pragmaOptions+  safeButNotBuiltin <- and2M+    -- NB: BlockArguments allow bullet-point style argument lists using @do@, hehe!+    do pure isSafe+    do not <$> do isBuiltinModuleWithSafePostulates . fromMaybe __IMPOSSIBLE__ =<< asksTC envCurrentPath++  -- We need to pass the fixities to the nicifier for clause grouping.+  fixs <- useScope scopeFixities+  niceEnv <- NiceEnv safeButNotBuiltin <$> asksTC envCheckingWhere++  -- Run nicifier.+  let (result, warns) = runNice niceEnv $ niceDeclarations fixs ds++  -- Respect the @DoWarn@ directive. For this to be sound, we need to know for+  -- sure that each @Declaration@ is checked at least once with @DoWarn@.+  unless (warn == NoWarn || null warns) $ do+    -- If there are some warnings and the --safe flag is set,+    -- we check that none of the NiceWarnings are fatal+    when isSafe $ do+      let (errs, ws) = List.partition unsafeDeclarationWarning warns+      -- If some of them are, we fail+      List1.unlessNull errs \ errs -> do+        List1.unlessNull ws \ ws -> warnings $ fmap NicifierIssue ws+        tcerrs <- mapM (warning_ . NicifierIssue) errs+        setCurrentRange errs $ typeError $ NonFatalErrors $ Set1.fromList tcerrs+    -- Otherwise we simply record the warnings+    mapM_ (\ w -> warning' (dwLocation w) $ NicifierIssue w) warns+  case result of+    Left (DeclarationException loc e) -> do+      reportSLn "error" 2 $ "Error raised at " ++ prettyShow loc+      setCurrentRange e $ typeError $ NicifierError e+    Right ds -> ret ds++-- | Wrapper to avoid instance conflict with generic list instance.+newtype Declarations = Declarations [C.Declaration]++instance ToAbstract Declarations where+  type AbsOfCon Declarations = [A.Declaration]++  toAbstract (Declarations ds) = niceDecls DoWarn ds toAbstract++-- | Where did these 'LetDef's come from?+data LetDefOrigin+  = ExprLetDef+  -- ^ A let expression or do statement+  | RecordWhereLetDef+  -- ^ A @record where@ expression+  | RecordLetDef+  -- ^ Definitions in a record declaration, before the last field+  deriving (Eq, Show)++data LetDefs = LetDefs LetDefOrigin (List1 C.Declaration)+data LetDef = LetDef LetDefOrigin NiceDeclaration++instance ToAbstract LetDefs where+  type AbsOfCon LetDefs = [A.LetBinding]++  toAbstract :: LetDefs -> ScopeM (AbsOfCon LetDefs)+  toAbstract (LetDefs wh ds) =+    List1.concat <$> niceDecls DoWarn (List1.toList ds) (toAbstract . map (LetDef wh))++-- | Raise appropriate (error-)warnings for if a declaration with+-- illegal access, macro flag, or abstractness appear in a let+-- expression.+checkLetDefInfo :: LetDefOrigin -> Access -> IsMacro -> IsAbstract -> ScopeM ()+checkLetDefInfo wh access macro abstract = do+  when (abstract == AbstractDef) $ warning AbstractInLetBindings++  when (macro == MacroDef) $ warning MacroInLetBindings++  case access of+    -- Marking a let declaration as private should only raise a warning+    -- in explicit, user-written expressions.+    --+    -- It should not raise a warning when scope-checking the type of a+    -- record constructor (it has an effect there), or when elaborating+    -- the lets generated by a 'record where' expression.+    PrivateAccess rng _+      | wh == ExprLetDef -> scopeWarning (UselessPrivate rng)+    _ -> pure ()++instance ToAbstract LetDef where+  type AbsOfCon LetDef = List1 A.LetBinding+  toAbstract :: LetDef -> ScopeM (AbsOfCon LetDef)+  toAbstract (LetDef wh d) = setCurrentRange d case d of+    NiceMutual _ _ _ _ d@[C.FunSig _ access _ instanc macro info _ _ x t, C.FunDef _ _ abstract _ _ _ _ [cl]] -> do+      checkLetDefInfo wh access macro abstract++      t <- toAbstract t+      -- We bind the name here to make sure it's in scope for the LHS (#917).+      -- It's unbound for the RHS in letToAbstract.+      fx <- getConcreteFixity x++      x <- A.unBind <$> toAbstract (NewName LetBound $ mkBoundName x fx)+      (x', e) <- letToAbstract cl++      -- There are sometimes two instances of the let-bound variable,+      -- one declaration and one definition (see issue #1618).+      -- Andreas, 2015-08-27 keeping both the range of x and x' solves Issue 1618.+      -- The situation is+      -- @+      --    let y : t+      --        y = e+      -- @+      -- and we need to store the ranges of both occurences of y so that+      -- the highlighter does the right thing.+      let x2 = setRange (fuseRange x x') x++      -- If InstanceDef set info to Instance+      let info' = case instanc of+            InstanceDef _  -> makeInstance info+            NotInstanceDef -> info++      return $+        A.LetBind (LetRange $ getRange d) info' (A.mkBindName x2) t e :|+        []++    -- Function signature without a body+    C.Axiom _ acc abs instanc info x t -> do+      checkLetDefInfo wh acc NotMacroDef abs++      t <- toAbstract t+      fx <- getConcreteFixity x+      x  <- toAbstract (NewName LetBound $ mkBoundName x fx)++      let+        info' = case instanc of+          InstanceDef _  -> makeInstance info+          NotInstanceDef -> info++      pure $ A.LetAxiom (LetRange $ getRange d) info' x t :| []++    -- irrefutable let binding, like  (x , y) = rhs+    NiceFunClause r PublicAccess ConcreteDef tc cc catchall d@(C.FunClause lhs@(C.LHS p0 [] []) rhs0 whcl ca) -> do+      noWhereInLetBinding whcl+      rhs <- letBindingMustHaveRHS rhs0+      -- Expand puns if optHiddenArgumentPuns is True.+      p0   <- expandPunsOpt p0+      mp   <- setCurrentRange p0 $+                (Right <$> parsePattern p0)+                  `catchError`+                (return . Left)+      case mp of+        Right p -> do+          rhs <- toAbstract rhs+          setCurrentRange p0 $ do+            p   <- toAbstract p+            checkValidLetPattern p+            checkPatternLinearity p $ \ys ->+              typeError $ RepeatedVariablesInPattern ys+            bindVarsToBind+            p   <- toAbstract p+            return $ singleton $ A.LetPatBind (LetRange r) p rhs+        -- It's not a record pattern, so it should be a prefix left-hand side+        Left err ->+          case definedName p0 of+            Nothing -> throwError err+            Just x  -> toAbstract $ LetDef wh $ NiceMutual empty tc cc YesPositivityCheck+              [ C.FunSig r PublicAccess ConcreteDef NotInstanceDef NotMacroDef+                  (setOrigin Inserted defaultArgInfo) tc cc x (C.Underscore (getRange x) Nothing)+              , C.FunDef r __IMPOSSIBLE__ ConcreteDef NotInstanceDef __IMPOSSIBLE__ __IMPOSSIBLE__ __IMPOSSIBLE__+                [C.Clause x (ca <> catchall) lhs (C.RHS rhs) NoWhere []]+              ]+          where+            definedName (C.IdentP _ (C.QName x)) = Just x+            definedName C.IdentP{}             = Nothing+            definedName (C.RawAppP _ (List2 p _ _)) = definedName p+            definedName (C.ParenP _ p)         = definedName p+            definedName C.WildP{}              = Nothing   -- for instance let _ + x = x in ... (not allowed)+            definedName C.AbsurdP{}            = Nothing+            definedName C.AsP{}                = Nothing+            definedName C.DotP{}               = Nothing+            definedName C.EqualP{}             = Nothing+            definedName C.LitP{}               = Nothing+            definedName C.RecP{}               = Nothing+            definedName C.QuoteP{}             = Nothing+            definedName C.HiddenP{}            = Nothing -- Not impossible, see issue #2291+            definedName C.InstanceP{}          = Nothing+            definedName C.WithP{}              = Nothing+            definedName C.AppP{}               = Nothing -- Not impossible, see issue #4586+            definedName C.OpAppP{}             = __IMPOSSIBLE__+            definedName C.EllipsisP{}          = Nothing -- Not impossible, see issue #3937++    -- You can't open public in a let+    NiceOpen r x dir -> do+      dir  <- uselessPublic UselessPublicLet dir+      m    <- toAbstract (OldModuleName x)+      adir <- openModule_ LetOpenModule x dir+      let minfo = ModuleInfo+            { minfoRange  = r+            , minfoAsName = Nothing+            , minfoAsTo   = renamingRange dir+            , minfoOpenShort = Nothing+            , minfoDirective = Just dir+            }+      return $ singleton $ A.LetOpen minfo m adir++    NiceModuleMacro r p erased x modapp open dir -> do+      dir <- uselessPublic UselessPublicLet dir+      -- Andreas, 2014-10-09, Issue 1299: module macros in lets need+      -- to be private+      singleton <$> checkModuleMacro LetApply LetOpenModule r+                      privateAccessInserted erased x modapp open dir++    _ -> notAValidLetBinding Nothing++    where+      letToAbstract (C.Clause top _catchall (C.LHS p [] []) rhs0 wh []) = do+        noWhereInLetBinding wh+        rhs <- letBindingMustHaveRHS rhs0+        (x, args) <- do+          res <- setCurrentRange p $ parseLHS NoDisplayLHS (C.QName top) p+          case res of+            C.LHSHead x args -> return (x, args)+            C.LHSProj{}      -> __IMPOSSIBLE__  -- notAValidLetBinding $ Just CopatternsNotAllowed+            C.LHSWith{}      -> __IMPOSSIBLE__  -- notAValidLetBinding $ Just WithPatternsNotAllowed+            C.LHSEllipsis{}  -> __IMPOSSIBLE__  -- notAValidLetBinding $ Just EllipsisNotAllowed++        e <- localToAbstract args $ \args -> do+          bindVarsToBind+          -- Make sure to unbind the function name in the RHS, since lets are non-recursive.+          rhs <- unbindVariable top $ toAbstract rhs+          foldM lambda rhs (reverse args)  -- just reverse because these are DomainFree+        return (x, e)++      letToAbstract _ = notAValidLetBinding Nothing++      -- These patterns all have a chance of being accepted in a lambda:+      allowedPat A.VarP{}      = True+      allowedPat A.ConP{}      = True+      allowedPat A.WildP{}     = True+      allowedPat (A.AsP _ _ x) = allowedPat x+      allowedPat (A.RecP _ _ as) = all (allowedPat . view exprFieldA) as+      allowedPat (A.PatternSynP _ _ as) = all (allowedPat . namedArg) as++      -- These have no chance:+      allowedPat A.AbsurdP{}     = False+      allowedPat A.ProjP{}       = False+      allowedPat A.DefP{}        = False+      allowedPat A.EqualP{}      = False+      allowedPat A.WithP{}       = False+      allowedPat A.DotP{}        = False+      allowedPat A.LitP{}        = False++      patternName (A.VarP bn)    = Just bn+      patternName (A.AsP _ bn _) = Just bn+      patternName _ = Nothing++      -- Named patterns not allowed in let definitions+      lambda :: A.Expr -> A.NamedArg (A.Pattern' C.Expr) -> TCM A.Expr+      lambda e ai@(Arg info (Named thing pat)) | allowedPat pat = do+        let+          i = ExprRange (fuseRange pat e)++        pat <- toAbstract pat++        bn <- case pat of+          A.VarP bn    -> pure bn+          A.AsP _ bn _ -> pure bn+          _ -> fmap mkBindName . freshAbstractName_ =<< freshConcreteName (getRange pat) 0 patternInTeleName++        -- Annoyingly, for the lambdas to be elaborated properly, we+        -- have to generate domainful binders. Domain-free binders can+        -- not be named (or have pattern matching!).+        --+        -- Moreover, we need to avoid generating named patterns that are+        -- like {B = B @ B}.++        let+          pat' = case pat of+            A.VarP{} -> Nothing+            pat -> Just pat+          binder = Arg info (Named thing (A.Binder pat' InsertedBinderName bn)) :| []++        pure $ A.Lam i (A.DomainFull (A.TBind (getRange ai) empty binder (A.Underscore empty))) e++      lambda _ _ = notAValidLetBinding Nothing++      noWhereInLetBinding :: C.WhereClause -> ScopeM ()+      noWhereInLetBinding = \case+        NoWhere -> return ()+        wh -> setCurrentRange wh $ notAValidLetBinding $ Just WhereClausesNotAllowed+      letBindingMustHaveRHS :: C.RHS -> ScopeM C.Expr+      letBindingMustHaveRHS = \case+        C.RHS e -> return e+        C.AbsurdRHS -> notAValidLetBinding $ Just MissingRHS++      -- Only record patterns allowed, but we do not exclude data constructors here.+      -- They will fail in the type checker.+      checkValidLetPattern :: A.Pattern' e -> ScopeM ()+      checkValidLetPattern a = unless (allowedPat a) do+        notAValidLetBinding $ Just NotAValidLetPattern++checkFieldArgInfo :: Bool -> ArgInfo -> ScopeM ArgInfo+checkFieldArgInfo warn =+    ensureContinuous msg >=>+    ensureMixedPolarity msg+  where+    msg = if warn then Just "of field" else Nothing++instance ToAbstract NiceDeclaration where+  type AbsOfCon NiceDeclaration = A.Declaration++  toAbstract d = annotateDecls $+    traceS "scope.decl.trace" 50+      [ "scope checking declaration"+      , "  " ++  prettyShow d+      ] $+    traceS "scope.decl.trace" 80  -- keep this debug message for testing issue #4016+      [ "scope checking declaration (raw)"+      , "  " ++  show d+      ] $+    traceCall (ScopeCheckDeclaration d) $+    -- Andreas, 2015-10-05, Issue 1677:+    -- We record in the environment whether we are scope checking an+    -- abstract definition.  This way, we can propagate this attribute+    -- the extended lambdas.+    applyWhenJust (niceHasAbstract d) (\ a -> localTC $ \ e -> e { envAbstractMode = aDefToMode a }) $+    case d of++  -- Axiom (actual postulate)+    C.Axiom r p a i rel x t -> do+      (y, decl) <- toAbstractNiceAxiom AxiomName d+      -- check that we do not postulate in --safe mode, unless it is a+      -- builtin module with safe postulates, or the axiom is generated+      -- from a lone signature+      whenM (andM [ Lens.getSafeMode <$> commandLineOptions+                  , not <$> (isBuiltinModuleWithSafePostulates . fromMaybe __IMPOSSIBLE__ =<< asksTC envCurrentPath)+                  , pure $ getOrigin rel /= Inserted+                  ])+            (warning $ SafeFlagPostulate y)+      -- check the postulate+      return $ singleton decl++    C.NiceGeneralize r p i tac x t -> do+      reportSLn "scope.decl" 30 $ "found nice generalize: " ++ prettyShow x+      tac <- traverse (toAbstractCtx TopCtx) tac+      t_ <- toAbstractCtx TopCtx t+      let (s, t) = unGeneralized t_+      reportSLn "scope.decl" 50 $ "generalizations: " ++ show (Set.toList s, t)+      f <- getConcreteFixity x+      y <- freshAbstractQName f x+      bindName p GeneralizeName x y+      let info = (mkDefInfo x f p ConcreteDef r) { defTactic = tac }+      return [A.Generalize s info i y t]++  -- Fields+    C.NiceField r p a i tac x (Arg ai t) -> do+      unless (p == PublicAccess) $ typeError PrivateRecordField+      ai  <- checkFieldArgInfo False ai  -- we already warned in recordConstructorType+      tac <- traverse (toAbstractCtx TopCtx) tac+      -- Interaction points for record fields have already been introduced+      -- when checking the type of the record constructor.+      -- To avoid introducing interaction points (IP) twice, we turn+      -- all question marks to underscores.  (See issue 1138.)+      let maskIP (C.QuestionMark r _) = C.Underscore r Nothing+          maskIP e                     = e+      t  <- toAbstractCtx TopCtx $ mapExpr maskIP t+      f  <- getConcreteFixity x+      y  <- freshAbstractQName f x+      -- Andreas, 2018-06-09 issue #2170+      -- We want dependent irrelevance without irrelevant projections,+      -- thus, do not disable irrelevant projections via the scope checker.+      -- irrProj <- optIrrelevantProjections <$> pragmaOptions+      -- unless (isIrrelevant t && not irrProj) $+      --   -- Andreas, 2010-09-24: irrelevant fields are not in scope+      --   -- this ensures that projections out of irrelevant fields cannot occur+      --   -- Ulf: unless you turn on --irrelevant-projections+      bindName p FldName x y+      let info = (mkDefInfoInstance x f p a i NotMacroDef r) { defTactic = tac }+      return [ A.Field info y (Arg ai t) ]++  -- Primitive function+    PrimitiveFunction r p a x t -> notAffectedByOpaque $ do+      t' <- traverse (toAbstractCtx TopCtx) t+      f  <- getConcreteFixity x+      y  <- freshAbstractQName f x+      bindName p PrimName x y+      unfoldFunction y+      let di = mkDefInfo x f p a r+      return [ A.Primitive di y t' ]++  -- Definitions (possibly mutual)+    NiceMutual kwr tc cc pc ds -> do+      reportSLn "scope.mutual" 40 ("starting checking mutual definitions: " ++ prettyShow ds)+      ds' <- toAbstract ds+      reportSLn "scope.mutual" 40 ("finishing checking mutual definitions")+      -- We only termination check blocks that do not have a measure.+      return [ A.Mutual (MutualInfo tc cc pc (fuseRange kwr ds)) ds' ]++    C.NiceRecSig r er p a _pc _uc x ls t -> do+      ensureNoLetStms ls+      withLocalVars $ do+        (ls', _) <- withCheckNoShadowing $+          -- Minor hack: record types don't have indices so we include t when+          -- computing generalised parameters, but in the type checker any named+          -- generalizable arguments in the sort should be bound variables.+          toAbstract (GenTelAndType (map makeDomainFull ls) t)+        t' <- toAbstract t+        f  <- getConcreteFixity x+        x' <- freshAbstractQName f x+        bindName' p RecName (GeneralizedVarsMetadata $ generalizeTelVars ls') x x'+        return [ A.RecSig (mkDefInfo x f p a r) er x' ls' t' ]++    C.NiceDataSig r er p a pc uc x ls t -> do+        reportSLn "scope.data.sig" 40 ("checking DataSig for " ++ prettyShow x)+        ensureNoLetStms ls+        withLocalVars $ do+          ls' <- withCheckNoShadowing $+            toAbstract $ GenTel $ map makeDomainFull ls+          t'  <- toAbstract $ C.Generalized t+          f  <- getConcreteFixity x+          x' <- freshAbstractQName f x+          mErr <- bindName'' p DataName (GeneralizedVarsMetadata $ generalizeTelVars ls') x x'+          whenJust mErr $ \case+            err@(ClashingDefinition cn an _) -> do+              resolveName (C.QName x) >>= \case+                -- #4435: if a data type signature causes a ClashingDefinition error, and if+                -- the data type name is bound to an Axiom, then the error may be caused by+                -- the illegal type signature. Convert the NiceDataSig into a NiceDataDef+                -- (which removes the type signature) and suggest it as a possible fix.+                DefinedName p ax NoSuffix | anameKind ax == AxiomName -> do+                  let suggestion = NiceDataDef r Inserted a pc uc x ls []+                  typeError $ ClashingDefinition cn an (Just suggestion)+                _ -> typeError err+            otherErr -> typeError otherErr+          return [ A.DataSig (mkDefInfo x f p a r) er x' ls' t' ]++  -- Type signatures+    C.FunSig r p a i m rel _ _ x t -> do+        let kind = if m == MacroDef then MacroName else FunName+        singleton . snd <$> toAbstractNiceAxiom kind (C.Axiom r p a i rel x t)++  -- Function definitions+    C.FunDef r ds a i _ _ x cs -> do+        printLocals 30 $ "checking def " ++ prettyShow x+        (x',cs) <- toAbstract (OldName x,cs)+        -- Andreas, 2017-12-04 the name must reside in the current module+        unlessM ((A.qnameModule x' ==) <$> getCurrentModule) $+          __IMPOSSIBLE__+        f <- getConcreteFixity x++        unfoldFunction x'+        di <- updateDefInfoOpacity (mkDefInfoInstance x f PublicAccess a i NotMacroDef r)+        return [ A.FunDef di x' cs ]++  -- Uncategorized function clauses+    C.NiceFunClause _ _ _ _ _ _ (C.FunClause lhs _ _ _) ->+      typeError $ MissingTypeSignature $ MissingFunctionSignature lhs+    C.NiceFunClause{} -> __IMPOSSIBLE__++  -- Data definitions+    C.NiceDataDef r o a _ uc x pars cons -> notAffectedByOpaque $ do+        reportSLn "scope.data.def" 40 ("checking " ++ show o ++ " DataDef for " ++ prettyShow x)+        (p, ax) <- resolveName (C.QName x) >>= \case+          DefinedName p ax NoSuffix -> do+            clashUnless x DataName ax  -- Andreas 2019-07-07, issue #3892+            livesInCurrentModule ax  -- Andreas, 2017-12-04, issue #2862+            clashIfModuleAlreadyDefinedInCurrentModule x ax+            return (p, ax)+          _ -> typeError $ MissingTypeSignature $ MissingDataSignature x+        ensureNoLetStms pars+        withLocalVars $ do+          gvars <- bindGeneralizablesIfInserted o ax+          -- Check for duplicate constructors+          do cs <- mapM conName cons+             List1.unlessNull (duplicates cs) $ \ dups -> do+               let bad = filter (`elem` dups) cs+               setCurrentRange bad $+                 typeError $ DuplicateConstructors dups++          pars <- catMaybes <$> toAbstract pars+          let x' = anameName ax+          -- Create the module for the qualified constructors+          checkForModuleClash x -- disallow shadowing previously defined modules+          let m = qnameToMName x'+          createModule (Just IsDataModule) m+          bindModule p x m  -- make it a proper module+          cons <- toAbstract (map (DataConstrDecl m a p) cons)+          printScope "data" 40 $ "Checked data " ++ prettyShow x+          f <- getConcreteFixity x+          return [ A.DataDef (mkDefInfo x f PublicAccess a r) x' uc (DataDefParams gvars pars) cons ]+      where+        conName (C.Axiom _ _ _ _ _ c _) = return c+        conName d = errorNotConstrDecl d++  -- Record definitions (mucho interesting)+    C.NiceRecDef r o a _ uc x directives pars fields -> notAffectedByOpaque $ do+      reportSLn "scope.rec.def" 40 ("checking " ++ show o ++ " RecDef for " ++ prettyShow x)+      -- #3008: Termination pragmas are ignored in records+      checkNoTerminationPragma InRecordDef fields+      RecordDirectives ind eta pat cm <- gatherRecordDirectives directives+      -- Andreas, 2020-04-19, issue #4560+      -- 'pattern' declaration is incompatible with 'coinductive' or 'eta-equality'.+      pat <- case pat of+        Just r+          | Just (Ranged _ CoInductive) <- ind -> Nothing <$ warn "coinductive"+          | Just (Ranged _ YesEta)      <- eta -> Nothing <$ warn "eta"+          | otherwise -> return pat+          where warn = setCurrentRange r . warning . UselessPatternDeclarationForRecord+        Nothing -> return pat++      (p, ax) <- resolveName (C.QName x) >>= \case+        DefinedName p ax NoSuffix -> do+          clashUnless x RecName ax  -- Andreas 2019-07-07, issue #3892+          livesInCurrentModule ax  -- Andreas, 2017-12-04, issue #2862+          clashIfModuleAlreadyDefinedInCurrentModule x ax+          return (p, ax)+        _ -> typeError $ MissingTypeSignature $ MissingRecordSignature x+      ensureNoLetStms pars+      withLocalVars $ do+        gvars <- bindGeneralizablesIfInserted o ax+        -- Check that the generated module doesn't clash with a previously+        -- defined module+        checkForModuleClash x+        pars   <- catMaybes <$> toAbstract pars+        let x' = anameName ax+        -- We scope check the fields a first time when putting together+        -- the type of the constructor.+        contel <- localToAbstract (RecordConstructorType fields) return+        m0     <- getCurrentModule+        let m = A.qualifyM m0 $ mnameFromList1 $ singleton $ List1.last $ qnameToList x'+        printScope "rec" 25 "before record"+        createModule (Just IsRecordModule) m+        -- We scope check the fields a second time, as actual fields.+        afields <- withCurrentModule m $ do+          afields <- toAbstract (Declarations fields)+          printScope "rec" 25 "checked fields"+          return afields+        -- Andreas, 2017-07-13 issue #2642 disallow duplicate fields+        -- Check for duplicate fields. (See "Check for duplicate constructors")+        do let fs :: [C.Name]+               fs = concat $ forMaybe fields $ \case+                 C.Field _ fs -> Just $ fs <&> \case+                   -- a Field block only contains field signatures+                   C.FieldSig _ _ f _ -> f+                   _ -> __IMPOSSIBLE__+                 _ -> Nothing+           List1.unlessNull (duplicates fs) $ \ dups -> do+             let bad = filter (`elem` dups) fs+             setCurrentRange bad $+               typeError $ DuplicateFields dups++        bindModule p x m+        let kind = maybe ConName (conKindOfName . rangedThing) ind++        cm' <- case cm of+          -- Andreas, 2019-11-11, issue #4189, no longer add record constructor to record module.+          Just (c, _) -> NamedRecCon <$> bindRecordConstructorName c kind a p++          -- Amy, 2024-09-25: if the record does not have a named+          -- constructor, then generate the QName here, and record it in+          -- the TC state so that 'Record.constructor' can be resolved.+          Nothing -> do+            -- Technically it doesn't matter with what this name is+            -- qualified since record constructor names have a special+            -- printing rule in lookupQName.+            constr <- withCurrentModule m $+              freshAbstractQName noFixity' $ simpleName "constructor"+            pure $ FreshRecCon constr++        setRecordConstructor x' (recordConName cm', fmap rangedThing ind)++        let inst = caseMaybe cm NotInstanceDef snd+        printScope "rec" 25 "record complete"+        f <- getConcreteFixity x+        let params = DataDefParams gvars pars+        let dir' = RecordDirectives ind eta pat cm'+        return [ A.RecDef (mkDefInfoInstance x f PublicAccess a inst NotMacroDef r) x' uc dir' params contel afields ]++    NiceModule r p a e x@(C.QName name) tel ds -> notAffectedByOpaque $ do+      reportSDoc "scope.decl" 70 $ vcat $+        [ text $ "scope checking NiceModule " ++ prettyShow x+        ]++      adecl <- traceCall (ScopeCheckDeclaration $+                          NiceModule r p a e x tel []) $ do+        scopeCheckNiceModule r p e name tel $+          toAbstract (Declarations ds)++      reportSDoc "scope.decl" 70 $ vcat $+        [ text $ "scope checked NiceModule " ++ prettyShow x+        , nest 2 $ prettyA adecl+        ]+      return [ adecl ]++    NiceModule _ _ _ _ m@C.Qual{} _ _ -> typeError QualifiedLocalModule++    NiceModuleMacro r p e x modapp open dir -> do+      reportSDoc "scope.decl" 70 $ vcat $+        [ text $ "scope checking NiceModuleMacro " ++ prettyShow x+        ]++      adecl <- checkModuleMacro Apply TopOpenModule+                 r p e x modapp open dir++      reportSDoc "scope.decl" 70 $ vcat $+        [ text $ "scope checked NiceModuleMacro " ++ prettyShow x+        , nest 2 $ prettyA adecl+        ]+      return [ adecl ]++    NiceOpen r x dir -> do+      (minfo, m, adir) <- checkOpen r Nothing x dir+      return [A.Open minfo m adir]++    NicePragma r p -> do+      ps <- toAbstract p  -- could result in empty list of pragmas+      return $ map (A.Pragma r) ps++    NiceImport r x as open dir -> setCurrentRange r $ do+      dir <- notPublicWithoutOpen open dir++      -- Andreas, 2018-11-03, issue #3364, parse expression in as-clause as Name.+      let illformedAs s = setCurrentRange as $ do+            -- If @as@ is followed by something that is not a simple name,+            -- throw a warning and discard the as-clause.+            Nothing <$ warning (IllformedAsClause s)+      as <- case as of+        -- Ok if no as-clause or it (already) contains a Name.+        Nothing -> return Nothing+        Just (AsName (Right asName) r)                    -> return $ Just $ AsName asName r+        Just (AsName (Left (C.Ident (C.QName asName))) r) -> return $ Just $ AsName asName r+        Just (AsName (Left C.Underscore{})     r)         -> return $ Just $ AsName underscore r+        Just (AsName (Left (C.Ident C.Qual{})) r) -> illformedAs "; a qualified name is not allowed here"+        Just (AsName (Left e)                  r) -> illformedAs ""++      top <- S.topLevelModuleName (rawTopLevelModuleNameForQName x)+      -- First scope check the imported module and return its name and+      -- interface. This is done with that module as the top-level module.+      -- This is quite subtle. We rely on the fact that when setting the+      -- top-level module and generating a fresh module name, the generated+      -- name will be exactly the same as the name generated when checking+      -- the imported module.+      (m, i) <- withCurrentModule noModuleName $+                withTopLevelModule top $ do+        printScope "import" 30 "before import:"+        (m0, i) <- scopeCheckImport top+        printScope "import" 30 $ "scope checked import: " ++ prettyShow i+        -- We don't want the top scope of the imported module (things happening+        -- before the module declaration)+        return (m0 `withRangesOfQ` x, Map.delete noModuleName i)++      -- Bind the desired module name to the right abstract name.+      (name, theAsSymbol, theAsName) <- case as of++         Just a | let y = asName a, not (isNoName y) -> do+           bindModule privateAccessInserted y m+           return (C.QName y, asRange a, Just y)++         _ -> do+           -- Don't bind if @import ... as _@ with "no name"+           whenNothing as $ bindQModule (privateAccessInserted) x m+           return (x, noRange, Nothing)++      -- Open if specified, otherwise apply import directives+      adir <- case open of++        -- With @open@ import directives apply to the opening.+        -- The module is thus present in its qualified form without restrictions.+        DoOpen   -> do++          -- Merge the imported scopes with the current scopes.+          -- This might override a previous import of @m@, but monotonously (add stuff).+          modifyScopes $ \ ms -> Map.unionWith mergeScope (Map.delete m ms) i++          -- Andreas, 2019-05-29, issue #3818.+          -- Pass the resolved name to open instead triggering another resolution.+          -- This helps in situations like+          -- @+          --    module Top where+          --    module M where+          --    open import M+          -- @+          -- It is clear than in @open import M@, name @M@ must refer to a file+          -- rather than the above defined local module @M@.+          -- This already worked in the situation+          -- @+          --    module Top where+          --    module M where+          --    import M+          -- @+          -- Note that the manual desugaring of @open import@ as+          -- @+          --    module Top where+          --    module M where+          --    import M+          --    open M+          -- @+          -- will not work, as @M@ is now ambiguous in @open M@;+          -- the information that @M@ is external is lost here.+          (_minfo, _m, adir) <- checkOpen r (Just m) name dir+          return adir++        -- If not opening, import directives are applied to the original scope.+        DontOpen -> do+          (adir, i') <- Map.adjustM' (applyImportDirectiveM x dir) m i+          -- Andreas, 2020-05-18, issue #3933+          -- We merge the new imports without deleting old imports, to be monotone.+          modifyScopes $ \ ms -> Map.unionWith mergeScope ms i'+          return adir++      printScope "import" 30 "merged imported sig:"+      let minfo = ModuleInfo+            { minfoRange     = r+            , minfoAsName    = theAsName+            , minfoAsTo      = getRange (theAsSymbol, renamingRange dir)+            , minfoOpenShort = Just open+            , minfoDirective = Just dir+            }+      return [ A.Import minfo m adir ]++    NiceUnquoteDecl r p a i tc cc xs e -> do+      fxs <- mapM getConcreteFixity xs+      ys <- zipWithM freshAbstractQName fxs xs+      zipWithM_ (bindName p QuotableName) xs ys+      e <- toAbstract e+      zipWithM_ (rebindName p OtherDefName) xs ys+      let mi = MutualInfo tc cc YesPositivityCheck r+      mapM_ unfoldFunction ys+      opaque <- contextIsOpaque+      return [ A.Mutual mi+        [ A.UnquoteDecl mi+            [ (mkDefInfoInstance x fx p a i NotMacroDef r) { Info.defOpaque = opaque } | (fx, x) <- zip fxs xs ]+          ys e+        ] ]++    NiceUnquoteDef r p a _ _ xs e -> do+      fxs <- mapM getConcreteFixity xs+      ys <- mapM (toAbstract . OldName) xs+      zipWithM_ (rebindName p QuotableName) xs ys+      e <- toAbstract e+      zipWithM_ (rebindName p OtherDefName) xs ys+      mapM_ unfoldFunction ys+      opaque <- contextIsOpaque+      return [ A.UnquoteDef [ (mkDefInfo x fx PublicAccess a r) { Info.defOpaque = opaque } | (fx, x) <- zip fxs xs ] ys e ]++    NiceUnquoteData r p a pc uc x cs e -> notAffectedByOpaque $ do+      fx <- getConcreteFixity x+      x' <- freshAbstractQName fx x+      bindName p QuotableName x x'++      -- Create the module for the qualified constructors+      checkForModuleClash x+      let m = qnameToMName x'+      createModule (Just IsDataModule) m+      bindModule p x m  -- make it a proper module++      cs' <- mapM (bindUnquoteConstructorName m p) cs++      e <- withCurrentModule m $ toAbstract e++      rebindName p DataName x x'+      zipWithM_ (rebindName p ConName) cs cs'+      withCurrentModule m $ zipWithM_ (rebindName p ConName) cs cs'++      fcs <- mapM getConcreteFixity cs+      let mi = MutualInfo TerminationCheck YesCoverageCheck pc r+      return+        [ A.Mutual+          mi [A.UnquoteData+            [ mkDefInfo x fx p a r ] x' uc+            [ mkDefInfo c fc p a r | (fc, c) <- zip fcs cs] cs' e ]+        ]++    NicePatternSyn r a n as p -> do+      reportSLn "scope.pat" 30 $ "found nice pattern syn: " ++ prettyShow n+      (as, p) <- withLocalVars $ do+         -- Expand puns if optHiddenArgumentPuns is True.+         p <- parsePatternSyn =<< expandPunsOpt p+         p <- toAbstract p+         when (containsAsPattern p) $+           typeError AsPatternInPatternSynonym+         checkPatternLinearity p $ \ys ->+           typeError $ RepeatedVariablesInPattern ys+         -- Bind the pattern variables accumulated by @ToAbstract Pattern@ applied to the rhs.+         bindVarsToBind+         p <- A.noDotOrEqPattern (typeError DotPatternInPatternSynonym) p+         as <- mapM checkPatSynParam as+         List1.unlessNull (patternVars p List.\\ map whThing as) $ \ xs -> do+           typeError $ UnboundVariablesInPatternSynonym xs+         return (as, p)+      y <- freshAbstractQName' n+      bindName a PatternSynName n y+      -- Expanding pattern synonyms already at definition makes it easier to+      -- fold them back when printing (issue #2762).+      ep <- expandPatternSynonyms p+      modifyPatternSyns (Map.insert y (as, ep))+      return [A.PatternSynDef y (map (fmap BindName) as) p]   -- only for highlighting, so use unexpanded version+      where+        checkPatSynParam :: WithHiding C.Name -> ScopeM (WithHiding A.Name)+        checkPatSynParam (WithHiding h x) = do+          let err = setCurrentRange x . typeError+          resolveName (C.QName x) >>= \case+            VarName a (PatternBound h')+              | isInstance h, not (isInstance h') -> err $ IllegalInstanceVariableInPatternSynonym x+              | otherwise -> return $ WithHiding h a+            ConstructorName _ ys -> err $ PatternSynonymArgumentShadows IsConstructor x ys+            PatternSynResName ys -> err $ PatternSynonymArgumentShadows IsPatternSynonym x ys+            UnknownName -> err $ UnusedVariableInPatternSynonym x+            -- Other cases are impossible because parsing the pattern syn rhs would have failed.+            _ -> __IMPOSSIBLE__++    d@NiceLoneConstructor{} -> withCurrentCallStack $ \ stk -> do+      warning $ NicifierIssue (DeclarationWarning stk (InvalidConstructorBlock (getRange d)))+      pure []++    d@(NiceOpaque kwr xs decls) -> do+      -- The names in an 'unfolding' clause must be unambiguous names of definitions:+      -- Resolve all the names, and use them as an initial unfolding set:+      names  <- catMaybes <$> forM xs \ x -> do+        setCurrentRange x $ unambiguousConOrDef (const . UnfoldingWrongName) x+      -- Generate the identifier for this block:+      oid    <- fresh+      -- Record the parent unfolding block, if any:+      parent <- asksTC envCurrentOpaqueId++      let r = getRange d+      stOpaqueBlocks `modifyTCLens` Map.insert oid OpaqueBlock+        { opaqueId        = oid+        , opaqueUnfolding = HashSet.fromList names+        , opaqueDecls     = mempty+        , opaqueParent    = parent+        , opaqueRange     = r+        }++      -- Keep going!+      localTC (\e -> e { envCurrentOpaqueId = Just oid }) $ do+        out <- traverse toAbstract decls+        unless (any interestingOpaqueDecl out) $ setCurrentRange kwr $ warning UselessOpaque+        pure $ UnfoldingDecl r names : out++-- | Checking postulate or type sig. without checking safe flag.+toAbstractNiceAxiom :: KindOfName -> C.NiceDeclaration -> ScopeM (A.QName, A.Declaration)+toAbstractNiceAxiom kind (C.Axiom r p a i info x t) = do+  -- Amy, 2025-05-04, issue 7856: type signatures (more+  -- importantly extended lambdas within them) should not belong+  -- to opaque blocks+  --+  -- Note that only scope checking the type happens outside the+  -- block since a bit below we need the proper opaque id to+  -- possibly update the info.+  t' <- notUnderOpaque $ toAbstractCtx TopCtx t++  f  <- getConcreteFixity x+  mp <- getConcretePolarity x+  y  <- freshAbstractQName f x+  let isMacro | kind == MacroName = MacroDef+              | otherwise         = NotMacroDef+  bindName p kind x y+  definfo <- updateDefInfoOpacity $ mkDefInfoInstance x f p a i isMacro r+  return (y, A.Axiom kind definfo info mp y t')+toAbstractNiceAxiom _ _ = __IMPOSSIBLE__++interestingOpaqueDecl :: A.Declaration -> Bool+interestingOpaqueDecl (A.Mutual _ ds)     = any interestingOpaqueDecl ds+interestingOpaqueDecl (A.ScopedDecl _ ds) = any interestingOpaqueDecl ds++interestingOpaqueDecl A.FunDef{}      = True+interestingOpaqueDecl A.UnquoteDecl{} = True+interestingOpaqueDecl A.UnquoteDef{}  = True++interestingOpaqueDecl _ = False++-- ** Helper functions for @opaque@+------------------------------------------------------------------------++-- | Add a 'QName' to the set of declarations /contained in/ the current+-- opaque block.+unfoldFunction :: A.QName -> ScopeM ()+unfoldFunction qn = asksTC envCurrentOpaqueId >>= \case+  Just id -> do+    let go Nothing   = __IMPOSSIBLE__+        go (Just ob) = Just ob{ opaqueDecls = qn `HashSet.insert` opaqueDecls ob }+    stOpaqueBlocks `modifyTCLens` Map.alter go id+  Nothing -> pure ()++-- | Look up the current opaque identifier as a value in 'IsOpaque'.+contextIsOpaque :: ScopeM IsOpaque+contextIsOpaque =  maybe TransparentDef OpaqueDef <$> asksTC envCurrentOpaqueId++updateDefInfoOpacity :: DefInfo -> ScopeM DefInfo+updateDefInfoOpacity di = (\a -> di { Info.defOpaque = a }) <$> contextIsOpaque++-- | Raise a warning indicating that the current Declaration is not+-- affected by opacity, but only if we are actually in an Opaque block.+notAffectedByOpaque :: ScopeM a -> ScopeM a+notAffectedByOpaque k = do+  whenM ((NoWhere_ ==) <$> asksTC envCheckingWhere) $+    whenJustM (asksTC envCurrentOpaqueId) \ _ ->+      warning NotAffectedByOpaque+  notUnderOpaque k++-- * Helper functions for @variable@ generalization+------------------------------------------------------------------------++unGeneralized :: A.Expr -> (Set A.QName, A.Expr)+unGeneralized (A.Generalized s t) = (Set1.toSet s, t)+unGeneralized (A.ScopedExpr si e) = A.ScopedExpr si <$> unGeneralized e+unGeneralized t = (mempty, t)++alreadyGeneralizing :: ScopeM Bool+alreadyGeneralizing = isJust <$> useTC stGeneralizedVars++-- | In the context of scope checking an expression, given a resolved name @d@:+--+--   * If @d@ is a @variable@ (generalizable), add it to the collection 'stGeneralizedVars'+--     of variables we wish to abstract over.+--+--   * Otherwise, do nothing.+--+class AddGeneralizable a where+  addGeneralizable :: a -> ScopeM ()++instance AddGeneralizable AbstractName where+  addGeneralizable :: AbstractName -> ScopeM ()+  addGeneralizable d = case anameKind d of+    GeneralizeName -> do+      gvs <- useTC stGeneralizedVars+      case gvs of   -- Subtle: Use (left-biased) union instead of insert to keep the old name if+                    -- already present. This way we can sort by source location when generalizing+                    -- (Issue 3354).+          Just s -> stGeneralizedVars `setTCLens` Just (s `Set.union` Set.singleton (anameName d))+          Nothing -> typeError $ GeneralizeNotSupportedHere $ anameName d+    DisallowedGeneralizeName -> typeError $ GeneralizedVarInLetOpenedModule $ anameName d+    _ -> return ()++instance AddGeneralizable ResolvedName where+  addGeneralizable = \case+    -- Only 'DefinedName' can be a @variable@.+    DefinedName _ d NoSuffix -> addGeneralizable d+    DefinedName _ d Suffix{} -> return ()+    VarName{}                -> return ()+    FieldName{}              -> return ()+    ConstructorName{}        -> return ()+    PatternSynResName{}      -> return ()+    UnknownName{}            -> return ()++collectGeneralizables :: ScopeM a -> ScopeM (Set A.QName, a)+collectGeneralizables m =+  -- #5683: No nested generalization+  ifM alreadyGeneralizing ((Set.empty,) <$> m) $+  {-else-} bracket_ open close $ do+      a <- m+      s <- useTC stGeneralizedVars+      case s of+          Nothing -> __IMPOSSIBLE__+          Just s -> return (s, a)+  where+    open = do+        gvs <- useTC stGeneralizedVars+        stGeneralizedVars `setTCLens` Just mempty+        pure gvs+    close = (stGeneralizedVars `setTCLens`)++createBoundNamesForGeneralizables :: Set A.QName -> ScopeM (Map A.QName A.Name)+createBoundNamesForGeneralizables vs =+  flip Map.traverseWithKey (Map.fromSet (const ()) vs) $ \ q _ -> do+    let x  = nameConcrete $ qnameName q+        fx = nameFixity   $ qnameName q+    freshAbstractName fx x++collectAndBindGeneralizables :: ScopeM a -> ScopeM (Map A.QName A.Name, a)+collectAndBindGeneralizables m = do+  fvBefore <- length <$> getLocalVars+  (s, res) <- collectGeneralizables m+  fvAfter  <- length <$> getLocalVars+  -- We should bind the named generalizable variables as fresh variables+  binds <- createBoundNamesForGeneralizables s+  -- Issue #3735: We need to bind the generalizable variables outside any variables bound by `m`.+  outsideLocalVars (fvAfter - fvBefore) $ bindGeneralizables binds+  return (binds, res)++bindGeneralizables :: Map A.QName A.Name -> ScopeM ()+bindGeneralizables vars =+  forM_ (Map.toList vars) $ \ (q, y) ->+    bindVariable LambdaBound (nameConcrete $ qnameName q) y++-- | Bind generalizable variables if data or record decl was split by the system+--   (origin == Inserted)+bindGeneralizablesIfInserted :: Origin -> AbstractName -> ScopeM (Set A.Name)+bindGeneralizablesIfInserted Inserted y = bound <$ bindGeneralizables gvars+  where gvars = case anameMetadata y of+          GeneralizedVarsMetadata gvars -> gvars+          NoMetadata                    -> Map.empty+        bound = Set.fromList (Map.elems gvars)+bindGeneralizablesIfInserted UserWritten _ = return Set.empty+bindGeneralizablesIfInserted _ _           = __IMPOSSIBLE__++newtype GenTel = GenTel C.Telescope+data GenTelAndType = GenTelAndType C.Telescope C.Expr++instance ToAbstract GenTel where+  type AbsOfCon GenTel = A.GeneralizeTelescope+  toAbstract (GenTel tel) =+    uncurry A.GeneralizeTel <$> collectAndBindGeneralizables (catMaybes <$> toAbstract tel)++instance ToAbstract GenTelAndType where+  type AbsOfCon GenTelAndType = (A.GeneralizeTelescope, A.Expr)++  toAbstract (GenTelAndType tel t) = do+    (binds, (tel, t)) <- collectAndBindGeneralizables $+                          (,) <$> toAbstract tel <*> toAbstract t+    return (A.GeneralizeTel binds (catMaybes tel), t)++-- ** Record directives+------------------------------------------------------------------------++-- | Check for duplicate record directives.+gatherRecordDirectives :: [C.RecordDirective] -> ScopeM C.RecordDirectives+gatherRecordDirectives ds = mapM_ gatherRecordDirective ds `execStateT` empty++-- | Fill the respective field of 'C.RecordDirectives' by the given 'C.RecordDirective'.+--+-- Ignore it with a dead-code warning if the field is already filled.+--+gatherRecordDirective :: C.RecordDirective -> StateT C.RecordDirectives ScopeM ()+gatherRecordDirective d = do+  dir@RecordDirectives{ recInductive = ind, recHasEta = eta, recPattern = pat, recConstructor = con } <- get+  case d of+    Induction ri         -> assertNothing ind $ put dir{ recInductive   = Just ri }+    Eta re               -> assertNothing eta $ put dir{ recHasEta      = Just re }+    PatternOrCopattern r -> assertNothing pat $ put dir{ recPattern     = Just r  }+    C.Constructor x inst -> assertNothing con $ put dir{ recConstructor = Just (x, inst) }+  where+    assertNothing :: Maybe a -> StateT C.RecordDirectives ScopeM () -> StateT C.RecordDirectives ScopeM ()+    assertNothing Nothing cont = cont+    assertNothing Just{}  _    = lift $ setCurrentRange d $ warning $ DuplicateRecordDirective d++-- ** Helper functions for name clashes+------------------------------------------------------------------------++-- | Make sure definition is in same module as signature.+class LivesInCurrentModule a where+  livesInCurrentModule :: a -> ScopeM ()++instance LivesInCurrentModule AbstractName where+  livesInCurrentModule = livesInCurrentModule . anameName++instance LivesInCurrentModule A.QName where+  livesInCurrentModule x = do+    m <- getCurrentModule+    reportS "scope.data.def" 30+      [ "  A.QName of data type: " ++ prettyShow x+      , "  current module: " ++ prettyShow m+      ]+    unless (A.qnameModule x == m) $+      typeError $ DefinitionInDifferentModule x++-- | Unless the resolved 'AbstractName' has the given 'KindOfName',+--   report a 'ClashingDefinition' for the 'C.Name'.+clashUnless :: C.Name -> KindOfName -> AbstractName -> ScopeM ()+clashUnless x k ax = unless (anameKind ax == k) $+  typeError $ ClashingDefinition (C.QName x) (anameName ax) Nothing++-- | If a (data/record) module with the given name is already present in the current module,+--   we take this as evidence that a data/record with that name is already defined.+clashIfModuleAlreadyDefinedInCurrentModule :: C.Name -> AbstractName -> ScopeM ()+clashIfModuleAlreadyDefinedInCurrentModule x ax = do+  datRecMods <- catMaybes <$> do+    mapM (isDatatypeModule . amodName) =<< lookupModuleInCurrentModule x+  unlessNull datRecMods $ const $+    typeError $ ClashingDefinition (C.QName x) (anameName ax) Nothing++lookupModuleInCurrentModule :: C.Name -> ScopeM [AbstractModule]+lookupModuleInCurrentModule x =+  List1.toList' . Map.lookup x . nsModules . thingsInScope [PublicNS, PrivateNS] <$> getCurrentScope++-- ** Helper functions for constructor declarations+------------------------------------------------------------------------++data DataConstrDecl = DataConstrDecl A.ModuleName IsAbstract Access C.NiceDeclaration++-- | Bind a @data@ constructor.+bindConstructorName+  :: ModuleName      -- ^ Name of @data@/@record@ module.+  -> C.Name          -- ^ Constructor name.+  -> IsAbstract+  -> Access+  -> ScopeM A.QName+bindConstructorName m x a p = do+  f <- getConcreteFixity x+  -- The abstract name is the qualified one+  y <- withCurrentModule m $ freshAbstractQName f x+  -- Bind it twice, once unqualified and once qualified+  bindName p' ConName x y+  withCurrentModule m $ bindName p'' ConName x y+  return y+  where+    -- An abstract constructor is private (abstract constructor means+    -- abstract datatype, so the constructor should not be exported).+    p' = case a of+           AbstractDef -> privateAccessInserted+           _           -> p+    p'' = case a of+            AbstractDef -> privateAccessInserted+            _           -> PublicAccess++-- | Record constructors do not live in the record module (as it is parameterized).+--   Abstract constructors are bound privately, so that they are not exported.+bindRecordConstructorName :: C.Name -> KindOfName -> IsAbstract -> Access -> ScopeM A.QName+bindRecordConstructorName x kind a p = do+  y <- freshAbstractQName' x+  bindName p' kind x y+  return y+  where+    -- An abstract constructor is private (abstract constructor means+    -- abstract datatype, so the constructor should not be exported).+    p' = case a of+           AbstractDef -> privateAccessInserted+           _           -> p++bindUnquoteConstructorName :: ModuleName -> Access -> C.Name -> TCM A.QName+bindUnquoteConstructorName m p c = do++  r <- resolveName (C.QName c)+  fc <- getConcreteFixity c+  c' <- withCurrentModule m $ freshAbstractQName fc c+  let aname qn = AbsName qn QuotableName Defined NoMetadata+      addName = modifyCurrentScope $ addNameToScope (localNameSpace p) c $ aname c'+      success = addName >> (withCurrentModule m $ addName)+      failure y = typeError $ ClashingDefinition (C.QName c) y Nothing+  case r of+    _ | isNoName c       -> success+    UnknownName          -> success+    ConstructorName i ds -> if all (isJust . isConName . anameKind) ds+      then success+      else failure $ anameName $ List1.head ds+    DefinedName _ d _    -> failure $ anameName d+    FieldName ds         -> failure $ anameName $ List1.head ds+    PatternSynResName ds -> failure $ anameName $ List1.head ds+    VarName y _          -> failure $ qualify_ y+  return c'++instance ToAbstract DataConstrDecl where+  type AbsOfCon DataConstrDecl = A.Declaration++  toAbstract (DataConstrDecl m a p d) = traceCall (ScopeCheckDeclaration d) do+    case d of+      C.Axiom r p1 a1 i ai x t -> do+        -- unless (p1 == p) __IMPOSSIBLE__  -- This invariant is currently violated by test/Succeed/Issue282.agda+        unless (a1 == a) __IMPOSSIBLE__+        ai <- checkConstructorArgInfo ai+        t' <- toAbstractCtx TopCtx t+        -- The abstract name is the qualified one+        -- Bind it twice, once unqualified and once qualified+        f <- getConcreteFixity x+        y <- bindConstructorName m x a p+        printScope "con" 25 "bound constructor"+        let defInfo = mkDefInfoInstance x f p a i NotMacroDef r+        return $ A.Axiom ConName defInfo ai Nothing y t'+      _ -> errorNotConstrDecl d++-- | Delete (with warning) attributes that are illegal for constructor declarations.+checkConstructorArgInfo :: ArgInfo -> ScopeM ArgInfo+checkConstructorArgInfo =+    ensureRelevant msg >=>+    ensureNotLinear msg >=>+    ensureContinuous msg >=>+    ensureMixedPolarity msg+  where+    msg = Just "of constructor"++errorNotConstrDecl :: C.NiceDeclaration -> ScopeM a+errorNotConstrDecl d = setCurrentRange d $+  typeError $ IllegalDeclarationInDataDefinition $ notSoNiceDeclarations d++ensureRelevant :: LensRelevance a => Maybe String -> a -> ScopeM a+ensureRelevant ms info = do+  if isRelevant info then return info else do+    whenJust ms \ s -> warning $ FixingRelevance s (getRelevance info) relevant+    return $ setRelevance relevant info++ensureNotLinear :: LensQuantity a => Maybe String -> a -> ScopeM a+ensureNotLinear s info = do+  case getQuantity info of+    Quantityω{} -> return info+    Quantity0{} -> return info+    q@Quantity1{} -> do+      -- Andreas, 2024-08-24, "@1" is still not parsed, so this is impossible.+      __IMPOSSIBLE__+      -- TODO: linearity+      -- let q' = Quantityω QωInferred+      -- warning $ FixingQuantity s q q'+      -- return $ setQuantity q' info++ensureContinuous :: LensCohesion a => Maybe String -> a -> ScopeM a+ensureContinuous ms info+  | isContinuous info = return info+  | otherwise = setCohesion Continuous info <$ do+      whenJust ms \ s -> warning $ FixingCohesion s (getCohesion info) Continuous++ensureMixedPolarity :: LensModalPolarity a => Maybe String -> a -> ScopeM a+ensureMixedPolarity ms info+  | splittablePolarity info = return info+  | otherwise = setModalPolarity mixedPolarity info <$ do+      whenJust ms \ s -> warning $ FixingPolarity s (getModalPolarity info) mixedPolarity++-- ** More scope checking+------------------------------------------------------------------------++instance ToAbstract C.Pragma where+  type AbsOfCon C.Pragma = [A.Pragma]++  toAbstract (C.ImpossiblePragma _ strs) =+    case strs of+      "ReduceM" : _ -> impossibleTestReduceM strs+      _ -> impossibleTest strs++  toAbstract (C.OptionsPragma _ opts) = return [ A.OptionsPragma opts ]++  toAbstract (C.RewritePragma _ _ []) = [] <$ warning EmptyRewritePragma+  toAbstract (C.RewritePragma _ r xs) = singleton . A.RewritePragma r . catMaybes <$> do+    forM xs \ x -> setCurrentRange x $ unambiguousConOrDef NotARewriteRule x++  toAbstract (C.ForeignPragma _ rb s) = [] <$ addForeignCode (rangedThing rb) s++  toAbstract (C.CompilePragma _ rb x s) =+    maybe [] (\ y -> [ A.CompilePragma rb y s ]) <$>+      unambiguousConOrDef PragmaCompileWrongName x++  toAbstract (C.StaticPragma _ x) = do+    map A.StaticPragma . maybeToList <$> do+      unambiguousDef (PragmaExpectsUnambiguousProjectionOrFunction "STATIC") x++  toAbstract (C.InjectivePragma _ x) = do+    map A.InjectivePragma . maybeToList <$> do+      unambiguousDef (PragmaExpectsUnambiguousProjectionOrFunction "INJECTIVE") x++  toAbstract (C.InjectiveForInferencePragma _ x) = do+    map A.InjectiveForInferencePragma . maybeToList <$> do+      scopeCheckDef (PragmaExpectsDefinedSymbol "INJECTIVE_FOR_INFERENCE") x++  toAbstract pragma@(C.InlinePragma _ b x) = do+      caseMaybeM (toAbstract $ MaybeOldQName $ OldQName x Nothing) notInScope \case+        A.Con (AmbQ xs)                -> concatMapM ret $ List1.toList xs+        A.Def x                        -> ret x+        A.Proj _ p+          | Just x <- getUnambiguous p -> ret x+          | otherwise                  -> uselessPragma pragma $ sINLINE ++ " used on ambiguous name " ++ prettyShow x+        _ -> uselessPragma pragma $ "Target of " ++ sINLINE ++ " pragma should be a function or constructor"+    where+      sINLINE    = if b then "INLINE" else "NOINLINE"+      notInScope = [] <$ notInScopeWarning x+      ret y      = return [ A.InlinePragma b y ]++  toAbstract (C.NotProjectionLikePragma _ x) = do+    map A.NotProjectionLikePragma . maybeToList <$> do+      unambiguousDef (PragmaExpectsUnambiguousProjectionOrFunction "NOT_PROJECTION_LIKE") x++  toAbstract (C.OverlapPragma _ xs i) = do+    map (flip A.OverlapPragma i) . catMaybes <$> do+      mapM (unambiguousConOrDef $ PragmaExpectsUnambiguousConstructorOrFunction pragma) xs+    where+      pragma = case i of+        Overlappable -> "OVERLAPPABLE"+        Overlapping  -> "OVERLAPPING"+        Overlaps     -> "OVERLAPS"+        Incoherent   -> "INCOHERENT"+        -- Never written by the user:+        DefaultOverlap -> __IMPOSSIBLE__+        FieldOverlap   -> __IMPOSSIBLE__++  toAbstract pragma@(C.BuiltinPragma _ rb qx)+    | Just b' <- b, isUntypedBuiltin b' = do+        q <- resolveQName qx+        bindUntypedBuiltin b' q+        return [ A.BuiltinPragma rb q ]+        -- Andreas, 2015-02-14+        -- Some builtins cannot be given a valid Agda type,+        -- thus, they do not come with accompanying postulate or definition.+    | Just b' <- b, isBuiltinNoDef b' = do+          case qx of+            C.QName x -> do+              -- The name shouldn't exist yet. If it does, we raise a warning+              -- and drop the existing definition.+              unlessM ((UnknownName ==) <$> resolveName qx) $ do+                warning $ BuiltinDeclaresIdentifier b'+                modifyCurrentScope $ removeNameFromScope PublicNS x+              -- We then happily bind the name+              y <- freshAbstractQName' x+              let kind = fromMaybe __IMPOSSIBLE__ $ builtinKindOfName b'+              bindName PublicAccess kind x y+              return [ A.BuiltinNoDefPragma rb kind y ]+            _ -> uselessPragma pragma $+              "Pragma BUILTIN " ++ getBuiltinId b' ++ ": expected unqualified identifier, " +++              "but found " ++ prettyShow qx+    | otherwise = do+          q0 <- resolveQName qx++          -- Andreas, 2020-04-12, pr #4574.  For highlighting purposes:+          -- Rebind 'BuiltinPrim' as 'PrimName' and similar.+          q <- case (q0, b >>= builtinKindOfName, qx) of+            (DefinedName acc y suffix, Just kind, C.QName x)+              | anameKind y /= kind+              , kind `elem` [ PrimName, AxiomName ] -> do+                  rebindName acc kind x $ anameName y+                  return $ DefinedName acc y{ anameKind = kind } suffix+            _ -> return q0++          return [ A.BuiltinPragma rb q ]+    where b = builtinById (rangedThing rb)++  toAbstract (C.EtaPragma _ x) = do+    map A.EtaPragma . maybeToList <$> do+      scopeCheckDef (PragmaExpectsDefinedSymbol "ETA") x++  toAbstract pragma@(C.DisplayPragma _ lhs rhs) = do+    maybeToList <$> do+      withLocalVars $ runMaybeT do+        let err = failure "DISPLAY pragma left-hand side must have form 'f e1 .. en'"+            getHead (C.IdentP _ x)              = return x+            getHead (C.RawAppP _ (List2 p _ _)) = getHead p+            getHead _ = err++        top <- getHead lhs++        (isPatSyn, hd) <- do+          qx <- liftTCM $ resolveName' allKindsOfNames Nothing top+          case qx of+            VarName x' _                -> return . (False,) $ A.qnameFromList $ singleton x'+            DefinedName _ d NoSuffix    -> return . (False,) $ anameName d+            DefinedName _ d Suffix{}    -> failure $ "Invalid pattern " ++ prettyShow top+            FieldName     (d :| [])     -> return . (False,) $ anameName d+            FieldName ds                -> failure $ "Ambiguous projection " ++ prettyShow top ++ ": " ++ prettyShow (AmbQ $ fmap anameName ds)+            ConstructorName _ (d :| []) -> return . (False,) $ anameName d+            ConstructorName _ ds        -> failure $ "Ambiguous constructor " ++ prettyShow top ++ ": " ++ prettyShow (AmbQ $ fmap anameName ds)+            UnknownName                 -> do liftTCM $ notInScopeWarning top; mzero+            PatternSynResName (d :| []) -> return . (True,) $ anameName d+            PatternSynResName ds        -> failure $ "Ambiguous pattern synonym" ++ prettyShow top ++ ": " ++ prettyShow (fmap anameName ds)++        lhs <- liftTCM $ toAbstract $ LeftHandSide top lhs YesDisplayLHS+        ps  <- case lhs of+                 A.LHS _ (A.LHSHead _ ps) -> return ps+                 _ -> err++        -- Andreas, 2016-08-08, issue #2132+        -- Remove pattern synonyms on lhs+        (hd, ps) <- do+          p <- liftTCM $ expandPatternSynonyms $+            (if isPatSyn then A.PatternSynP else A.DefP) (PatRange $ getRange lhs) (unambiguous hd) ps+          case p of+            A.DefP _ f ps | Just hd <- getUnambiguous f -> return (hd, ps)+            A.ConP _ c ps | Just hd <- getUnambiguous c -> return (hd, ps)+            A.PatternSynP{} -> __IMPOSSIBLE__+            _ -> err++        rhs <- liftTCM $ toAbstract rhs++        -- Andreas, 2024-10-06, issue #7533:+        -- Check that all pattern variables occur on the rhs.+        -- Otherwise, there might be a misunderstanding of what display forms do.+        let used = allUsedNames rhs+        List1.unlessNull (filter (not . (isNoName || (`Set.member` used))) $ patternVars ps) $+          warning . UnusedVariablesInDisplayForm++        return $ A.DisplayPragma hd ps rhs+    where+      failure :: forall a. String -> MaybeT ScopeM a+      failure msg = do warning (UselessPragma (getRange pragma) $ P.fwords msg); mzero++  -- A warning attached to an ambiguous name shall apply to all disambiguations.+  toAbstract pragma@(C.WarningOnUsage _ x str) = do+    ys <- resolveName x >>= \case+      ConstructorName _ ds     -> return $ List1.toList ds+      FieldName ds             -> return $ List1.toList ds+      PatternSynResName ds     -> return $ List1.toList ds+      DefinedName _ d NoSuffix -> return $ singleton d+      DefinedName _ d Suffix{} -> [] <$ notInScopeWarning x+      UnknownName              -> [] <$ notInScopeWarning x+      VarName x _              -> [] <$ do+        uselessPragma pragma $ "Not a defined name: " ++ prettyShow x+    forM_ ys $ \ y -> stLocalUserWarnings `modifyTCLens` Map.insert (anameName y) str+    return []++  toAbstract (C.WarningOnImport _ str) = do+    stWarningOnImport `setTCLens` Just str+    pure []++  -- Termination, Coverage, Positivity, Universe, and Catchall+  -- pragmes are handled by the nicifier+  toAbstract C.TerminationCheckPragma{}  = __IMPOSSIBLE__+  toAbstract C.NoCoverageCheckPragma{}   = __IMPOSSIBLE__+  toAbstract C.NoPositivityCheckPragma{} = __IMPOSSIBLE__+  toAbstract C.NoUniverseCheckPragma{}   = __IMPOSSIBLE__+  toAbstract C.CatchallPragma{}          = __IMPOSSIBLE__++  -- Polarity pragmas are handled by the niceifier.+  toAbstract C.PolarityPragma{} = __IMPOSSIBLE__++uselessPragma :: HasRange p => p -> String -> ScopeM [a]+uselessPragma pragma = ([] <$) . warning . UselessPragma (getRange pragma) . P.fwords++unambiguousConOrDef :: (C.QName -> IsAmbiguous -> Warning) -> C.QName -> ScopeM (Maybe A.QName)+unambiguousConOrDef warn x = do+    caseMaybeM (toAbstract $ MaybeOldQName $ OldQName x Nothing) notInScope $ \case+      A.Def' y NoSuffix              -> ret y+      A.Def' y Suffix{}              -> failure NotAmbiguous+      A.Proj _ p+        | Just y <- getUnambiguous p -> ret y+        | otherwise                  -> failure $ YesAmbiguous p+      A.Con c+        | Just y <- getUnambiguous c -> ret y+        | otherwise                  -> failure $ YesAmbiguous c+      A.Var{}                        -> failure NotAmbiguous+      A.PatternSyn{}                 -> failure NotAmbiguous+      _ -> __IMPOSSIBLE__+  where+    notInScope = Nothing <$ notInScopeWarning x+    failure = (Nothing <$) . warning . warn x+    ret = return . Just++unambiguousDef :: (C.QName -> IsAmbiguous -> Warning) -> C.QName -> ScopeM (Maybe A.QName)+unambiguousDef warn x = do+    caseMaybeM (toAbstract $ MaybeOldQName $ OldQName x Nothing) notInScope $ \case+      A.Def' y NoSuffix              -> ret y+      A.Def' y Suffix{}              -> failure NotAmbiguous+      A.Proj _ p+        | Just y <- getUnambiguous p -> ret y+        | otherwise                  -> failure $ YesAmbiguous p+      A.Con{}                        -> failure NotAmbiguous+      A.Var{}                        -> failure NotAmbiguous+      A.PatternSyn{}                 -> failure NotAmbiguous+      _ -> __IMPOSSIBLE__+  where+    notInScope = Nothing <$ notInScopeWarning x+    failure = (Nothing <$) . warning . warn x+    ret = return . Just++scopeCheckDef :: (C.QName -> Warning) -> C.QName -> ScopeM (Maybe A.QName)+scopeCheckDef warn x = do+    caseMaybeM (toAbstract $ MaybeOldQName $ OldQName x Nothing) notInScope $ \case+      A.Def' y NoSuffix -> ret y+      A.Def' y Suffix{} -> failure+      A.Proj{}          -> failure+      A.Con{}           -> failure+      A.Var{}           -> failure+      A.PatternSyn{}    -> failure+      _ -> __IMPOSSIBLE__+  where+    notInScope = Nothing <$ notInScopeWarning x+    failure = Nothing <$ do warning $ warn x+    ret = return . Just++instance ToAbstract C.Clause where+  type AbsOfCon C.Clause = A.Clause++  toAbstract (C.Clause top catchall lhs@(C.LHS p eqs with) rhs wh wcs) = withLocalVars $ do+    -- Jesper, 2018-12-10, #3095: pattern variables bound outside the+    -- module are locally treated as module parameters+    modifyScope_ $ updateScopeLocals $ map $ second patternToModuleBound+    -- Andreas, 2012-02-14: need to reset local vars before checking subclauses+    vars0 <- getLocalVars+    lhs' <- toAbstract $ LeftHandSide (C.QName top) p NoDisplayLHS+    printLocals 30 "after lhs:"+    vars1 <- getLocalVars+    eqs <- mapM (toAbstractCtx TopCtx) eqs+    vars2 <- getLocalVars+    let vars = dropEnd (length vars1) vars2 ++ vars0+    let wcs' = (vars, wcs)++    -- Handle rewrite equations first.+    if not (null eqs)+      then do+        rhs <- toAbstractCtx TopCtx $ RightHandSide eqs with wcs' rhs wh+        rhs <- toAbstract rhs+        return $ A.Clause lhs' [] rhs A.noWhereDecls catchall+      else do+        -- the right hand side is checked with the module of the local definitions opened+        (rhs, ds) <- whereToAbstract (getRange wh) wh $+                       toAbstractCtx TopCtx $ RightHandSide [] with wcs' rhs NoWhere+        rhs <- toAbstract rhs+        return $ A.Clause lhs' [] rhs ds catchall+++whereToAbstract+  :: Range                            -- ^ The range of the @where@ block.+  -> C.WhereClause                    -- ^ The @where@ block.+  -> ScopeM a                         -- ^ The scope-checking task to be run in the context of the @where@ module.+  -> ScopeM (a, A.WhereDeclarations)  -- ^ Additionally return the scope-checked contents of the @where@ module.+whereToAbstract r wh inner = do+  case wh of+    NoWhere       -> ret+    AnyWhere _ [] -> warnEmptyWhere+    AnyWhere _ ds -> enter do+      -- Andreas, 2016-07-17 issues #2081 and #2101+      -- where-declarations are automatically private.+      -- Andreas, 2025-03-29+      -- While since PR #5192 (Feb 2021, issue #481) it is no longer the case+      -- that we check their type signatures in abstract mode,+      -- we still need to mark the declaration as private+      -- e.g. to avoid spurious UnknownFixityInMixfixDecl warnings (issue #2889).+      whereToAbstract1 r defaultErased Nothing+        (singleton $ C.Private empty Inserted ds) inner+    SomeWhere _ e m a ds0 -> enter $+      List1.ifNull ds0 warnEmptyWhere {-else-} \ ds ->+      -- Named where-modules do not default to private.+      whereToAbstract1 r e (Just (m, a)) ds inner+  where+  enter = localTC \ env -> env { envCheckingWhere = C.whereClause_ wh }+  ret = (,A.noWhereDecls) <$> inner+  warnEmptyWhere = do+    setCurrentRange r $ warning EmptyWhere+    ret++whereToAbstract1+  :: Range                            -- ^ The range of the @where@-block.+  -> Erased                           -- ^ Is the where module erased?+  -> Maybe (C.Name, Access)           -- ^ The name of the @where@ module (if any).+  -> List1 C.Declaration              -- ^ The contents of the @where@ module.+  -> ScopeM a                         -- ^ The scope-checking task to be run in the context of the @where@ module.+  -> ScopeM (a, A.WhereDeclarations)  -- ^ Additionally return the scope-checked contents of the @where@ module.+whereToAbstract1 r e whname whds inner = do+  -- ASR (16 November 2015) Issue 1137: We ban termination+  -- pragmas inside `where` clause.+  checkNoTerminationPragma InWhereBlock whds++  -- Create a fresh concrete name if there isn't (a proper) one.+  (m, acc) <- do+    case whname of+      Just (m, acc) | not (isNoName m) -> return (m, acc)+      _ -> fresh <&> \ x -> (C.NoName (getRange whname) x, privateAccessInserted)+           -- unnamed where's are private+  old <- getCurrentModule+  am  <- toAbstract (NewModuleName m)+  (scope, d) <- scopeCheckModule r e (C.QName m) am [] $+                toAbstract $ Declarations $ List1.toList whds+  setScope scope+  x <- inner+  setCurrentModule old+  bindModule acc m am+  -- Issue 848: if the module was anonymous (module _ where) open it public+  let anonymousSomeWhere = maybe False (isNoName . fst) whname+  when anonymousSomeWhere $+   void $ -- We can ignore the returned default A.ImportDirective.+    openModule TopOpenModule (Just am) (C.QName m) $+      defaultImportDir { publicOpen = Just empty }+  return (x, A.WhereDecls (Just am) (isNothing whname) $ singleton d)++data TerminationOrPositivity = Termination | Positivity+  deriving (Show)++data WhereOrRecord = InWhereBlock | InRecordDef++checkNoTerminationPragma :: FoldDecl a => WhereOrRecord -> a -> ScopeM ()+checkNoTerminationPragma b ds =+  -- foldDecl traverses into all sub-declarations.+  forM_ (foldDecl (isPragma >=> isTerminationPragma) ds) \ (p, r) ->+    setCurrentRange r $ warning $ UselessPragma r $ P.vcat+      [ P.text $ show p ++ " pragmas are ignored in " ++ what b+      , P.text $ "(see " ++ issue b ++ ")"+      ]+  where+    what InWhereBlock = "where clauses"+    what InRecordDef  = "record definitions"+    github n = "https://github.com/agda/agda/issues/" ++ show n+    issue InWhereBlock = github 3355+    issue InRecordDef  = github 3008++    isTerminationPragma :: C.Pragma -> [(TerminationOrPositivity, Range)]+    isTerminationPragma = \case+      C.TerminationCheckPragma r _  -> [(Termination, r)]+      C.NoPositivityCheckPragma r   -> [(Positivity, r)]+      C.OptionsPragma _ _           -> []+      C.BuiltinPragma _ _ _         -> []+      C.RewritePragma _ _ _         -> []+      C.ForeignPragma _ _ _         -> []+      C.CompilePragma _ _ _ _       -> []+      C.StaticPragma _ _            -> []+      C.InlinePragma _ _ _          -> []+      C.ImpossiblePragma _ _        -> []+      C.EtaPragma _ _               -> []+      C.WarningOnUsage _ _ _        -> []+      C.WarningOnImport _ _         -> []+      C.InjectivePragma _ _         -> []+      C.InjectiveForInferencePragma{} -> []+      C.DisplayPragma _ _ _         -> []+      C.CatchallPragma _            -> []+      C.NoCoverageCheckPragma _     -> []+      C.PolarityPragma _ _ _        -> []+      C.NoUniverseCheckPragma _     -> []+      C.NotProjectionLikePragma _ _ -> []+      C.OverlapPragma _ _ _         -> []++data RightHandSide = RightHandSide+  { _rhsRewriteEqn :: [RewriteEqn' () A.BindName A.Pattern A.Expr]+    -- ^ @rewrite e | with p <- e in eq@ (many)+  , _rhsWithExpr   :: [C.WithExpr]+    -- ^ @with e@ (many)+  , _rhsSubclauses :: (LocalVars, [C.Clause])+    -- ^ the subclauses spawned by a with (monadic because we need to reset the local vars before checking these clauses)+  , _rhs           :: C.RHS+  , _rhsWhere      :: WhereClause+      -- ^ @where@ module.+  }++data AbstractRHS+  = AbsurdRHS'+  | WithRHS' (List1 A.WithExpr) (List1 (ScopeM C.Clause))+    -- ^ The with clauses haven't been translated yet+  | RHS' A.Expr C.Expr+  | RewriteRHS' [RewriteEqn' () A.BindName A.Pattern A.Expr] AbstractRHS A.WhereDeclarations++qualifyName_ :: A.Name -> ScopeM A.QName+qualifyName_ x = do+  m <- getCurrentModule+  return $ A.qualify m x++withFunctionName :: String -> ScopeM A.QName+withFunctionName s = do+  NameId i _ <- fresh+  qualifyName_ =<< freshName_ (s ++ show i)++instance ToAbstract (RewriteEqn' () A.BindName A.Pattern A.Expr) where+  type AbsOfCon (RewriteEqn' () A.BindName A.Pattern A.Expr) = A.RewriteEqn+  toAbstract = \case+    Rewrite es -> fmap Rewrite $ forM es $ \ (_, e) -> do+      qn <- withFunctionName "-rewrite"+      pure (qn, e)+    Invert _ pes -> do+      qn <- withFunctionName "-invert"+      pure $ Invert qn pes+    LeftLet pes -> pure $ LeftLet pes++instance ToAbstract C.RewriteEqn where+  type AbsOfCon C.RewriteEqn = RewriteEqn' () A.BindName A.Pattern A.Expr+  toAbstract = \case+    Rewrite es   -> Rewrite <$> mapM toAbstract es+    Invert _ npes -> Invert () <$> do+      -- Given a list of irrefutable with expressions of the form @p <- e in q@+      let (nps, es) = List1.unzip+                    $ fmap (\ (Named nm (p, e)) -> ((nm, p), e)) npes+      -- we first check the expressions @e@: the patterns may shadow some of the+      -- variables mentioned in them!+      es <- toAbstract es+      -- we then parse the pairs of patterns @p@ and names @q@ for the equality+      -- constraints of the form @p ≡ e@.+      nps <- forM nps $ \ (n, p) -> do+        -- first the pattern+        p <- toAbsPat p+        -- and then the name+        n <- toAbstract $ fmap (NewName WithBound . C.mkBoundName_) n+        pure (n, p)+      -- we finally reassemble the telescope+      pure $ List1.zipWith (\ (n,p) e -> Named n (p, e)) nps es+    LeftLet pes -> fmap LeftLet $ forM pes $ \ (p, e) -> do+      -- first check the expression: the pattern may shadow+      -- some of the variables mentioned in it!+      e <- toAbstract e+      p <- toAbsPat p+      pure (p, e)+    where+      toAbsPat p = do+        -- Expand puns if optHiddenArgumentPuns is True.+        p <- expandPunsOpt p+        p <- parsePattern p+        p <- toAbstract p+        checkPatternLinearity p (typeError . RepeatedVariablesInPattern)+        bindVarsToBind+        toAbstract p++instance ToAbstract AbstractRHS where+  type AbsOfCon AbstractRHS = A.RHS++  toAbstract AbsurdRHS'            = return A.AbsurdRHS+  toAbstract (RHS' e c)            = return $ A.RHS e $ Just c+  toAbstract (RewriteRHS' eqs rhs wh) = do+    eqs <- toAbstract eqs+    rhs <- toAbstract rhs+    return $ RewriteRHS eqs [] rhs wh+  toAbstract (WithRHS' es cs) = do+    aux <- withFunctionName "with-"+    A.WithRHS aux es <$> do toAbstract =<< sequence cs++instance ToAbstract RightHandSide where+  type AbsOfCon RightHandSide = AbstractRHS+  toAbstract (RightHandSide eqs@(_:_) es cs rhs wh)               = do+    (rhs, ds) <- whereToAbstract (getRange wh) wh $+                   toAbstract (RightHandSide [] es cs rhs NoWhere)+    return $ RewriteRHS' eqs rhs ds+  toAbstract (RightHandSide [] []    (_  , _:_) _          _)  = __IMPOSSIBLE__+  toAbstract (RightHandSide [] (_:_) _         (C.RHS _)   _)  = typeError BothWithAndRHS -- issue #7760+  toAbstract (RightHandSide [] []    (_  , []) rhs         NoWhere) = toAbstract rhs+  toAbstract (RightHandSide [] (z:zs)(lv , c:cs) C.AbsurdRHS NoWhere) = do+    let (ns, es) = List1.unzipWith (\ (Named nm e) -> (NewName WithBound . C.mkBoundName_ <$> nm, e)) $ z :| zs+    es <- toAbstractCtx TopCtx es+    lvars0 <- getLocalVars+    ns <- toAbstract ns+    lvars1 <- getLocalVars+    let lv' = dropEnd (length lvars0) lvars1 ++ lv+    let cs' = for (c :| cs) $ \ c -> setLocalVars lv' $> c+    let nes = List1.zipWith Named ns es+    return $ WithRHS' nes cs'+  -- TODO: some of these might be possible+  toAbstract (RightHandSide [] (_ : _) _ C.AbsurdRHS  AnyWhere{}) = __IMPOSSIBLE__+  toAbstract (RightHandSide [] (_ : _) _ C.AbsurdRHS SomeWhere{}) = __IMPOSSIBLE__+  toAbstract (RightHandSide [] (_ : _) _ C.AbsurdRHS   NoWhere{}) = __IMPOSSIBLE__+  toAbstract (RightHandSide [] []     (_, []) C.AbsurdRHS  AnyWhere{}) = __IMPOSSIBLE__+  toAbstract (RightHandSide [] []     (_, []) C.AbsurdRHS SomeWhere{}) = __IMPOSSIBLE__+  toAbstract (RightHandSide [] []     (_, []) C.RHS{}      AnyWhere{}) = __IMPOSSIBLE__+  toAbstract (RightHandSide [] []     (_, []) C.RHS{}     SomeWhere{}) = __IMPOSSIBLE__++instance ToAbstract C.RHS where+    type AbsOfCon C.RHS = AbstractRHS++    toAbstract C.AbsurdRHS = return $ AbsurdRHS'+    toAbstract (C.RHS e)   = RHS' <$> toAbstract e <*> pure e++-- | Wrapper to check lhs (possibly of a 'C.DisplayPragma').+--+data LeftHandSide = LeftHandSide+  C.QName+    -- ^ Name of the definition we are checking.+  C.Pattern+    -- ^ Full left hand side.+  DisplayLHS+    -- ^ Are we checking a 'C.DisplayPragma'?++instance ToAbstract LeftHandSide where+    type AbsOfCon LeftHandSide = A.LHS++    toAbstract (LeftHandSide top lhs displayLhs) =+      traceCall (ScopeCheckLHS top lhs) $ do+        reportSLn "scope.lhs" 25 $ "original lhs: " ++ prettyShow lhs+        reportSLn "scope.lhs" 60 $ "patternQNames: " ++ prettyShow (patternQNames lhs)+        reportSLn "scope.lhs" 60 $ "original lhs (raw): " ++ show lhs++        -- Expand puns if optHiddenArgumentPuns is True. Note that pun+        -- expansion should happen before the left-hand side is+        -- parsed, because {(x)} is not treated as a pun, whereas {x}+        -- is.+        lhs  <- expandPunsOpt lhs+        reportSLn "scope.lhs" 25 $+          "lhs with expanded puns: " ++ prettyShow lhs+        reportSLn "scope.lhs" 60 $+          "lhs with expanded puns (raw): " ++ show lhs++        lhscore <- parseLHS displayLhs top lhs+        let ell = hasExpandedEllipsis lhscore+        reportSLn "scope.lhs" 25 $ "parsed lhs: " ++ prettyShow lhscore+        reportSLn "scope.lhs" 60 $ "parsed lhs (raw): " ++ show lhscore+        printLocals 30 "before lhs:"+        -- error if copattern parsed but --no-copatterns option+        unlessM (optCopatterns <$> pragmaOptions) $+          when (hasCopatterns lhscore) $+            typeError $ NeedOptionCopatterns+        -- scope check patterns except for dot patterns+        lhscore <- toAbstract $ CLHSCore displayLhs lhscore+        bindVarsToBind+        -- reportSLn "scope.lhs" 25 $ "parsed lhs patterns: " ++ prettyShow lhscore  -- TODO: Pretty A.LHSCore'+        reportSLn "scope.lhs" 60 $ "parsed lhs patterns: " ++ show lhscore+        printLocals 30 "checked pattern:"+        -- scope check dot patterns+        lhscore <- toAbstract lhscore+        -- reportSLn "scope.lhs" 25 $ "parsed lhs dot patterns: " ++ prettyShow lhscore  -- TODO: Pretty A.LHSCore'+        reportSLn "scope.lhs" 60 $ "parsed lhs dot patterns: " ++ show lhscore+        printLocals 30 "checked dots:"+        return $ A.LHS (LHSInfo (getRange lhs) ell) lhscore++-- | Expands hidden argument puns when option 'optHiddenArgumentPuns' is set.++expandPunsOpt :: C.Pattern -> ScopeM C.Pattern+expandPunsOpt p = do+  pragmaOptions <&> optHiddenArgumentPuns <&> \case+    True  -> expandPuns p+    False -> p++-- | Expands hidden argument puns.++expandPuns :: C.Pattern -> C.Pattern+expandPuns = mapCPattern \case+  C.HiddenP   r p -> C.HiddenP   r $ expand p+  C.InstanceP r p -> C.InstanceP r $ expand p+  p -> p+  where+  -- Only patterns of the form {x} or ⦃ x ⦄, where x is an unqualified+  -- name (not @_@), are interpreted as puns.+  expand :: Named_ C.Pattern -> Named_ C.Pattern+  expand+   (Named { namedThing = C.IdentP _ q@(C.QName x@C.Name{})+          , nameOf     = Nothing+          }) =+    Named { namedThing = C.IdentP False q+          , nameOf     = Just $+                         WithOrigin+                           { woOrigin = ExpandedPun+                           , woThing  = unranged (prettyShow x)+                           }+          }+  expand p = p++hasExpandedEllipsis :: C.LHSCore -> ExpandedEllipsis+hasExpandedEllipsis core = case core of+  C.LHSHead{}       -> NoEllipsis+  C.LHSProj{}       -> hasExpandedEllipsis $ namedArg $ C.lhsFocus core -- can this ever be ExpandedEllipsis?+  C.LHSWith{}       -> hasExpandedEllipsis $ C.lhsHead core+  C.LHSEllipsis r p -> case p of+    C.LHSWith p wps _ -> hasExpandedEllipsis p <> ExpandedEllipsis r (length wps)+    C.LHSHead{}       -> ExpandedEllipsis r 0+    C.LHSProj{}       -> ExpandedEllipsis r 0+    C.LHSEllipsis{}   -> __IMPOSSIBLE__++-- | Merges adjacent EqualP patterns into one:+-- type checking expects only one pattern for each domain in the telescope.+mergeEqualPs :: [NamedArg (Pattern' e)] -> ScopeM [NamedArg (Pattern' e)]+mergeEqualPs = go (empty, [])+  where+    go acc (p@(Arg ai (Named mn (A.EqualP r es))) : ps) = setCurrentRange p $ do+      -- Face constraint patterns must be defaultNamedArg; check this:+      unless (getModality ai == defaultModality) __IMPOSSIBLE__+      when (notVisible ai) $+        warning $ FaceConstraintCannotBeHidden ai+      whenJust mn $ \ x -> setCurrentRange x $+        warning $ FaceConstraintCannotBeNamed x+      go (acc `mappend` (r, List1.toList es)) ps+    go (r, (e:es))   ps = (defaultNamedArg (A.EqualP r $ e :| es) :) <$> mergeEqualPs ps+    go (_, [])       [] = return []+    go (_, []) (p : ps) = (p :) <$> mergeEqualPs ps+++-- | Scope-check a 'C.LHSCore' (of possibly a 'C.DisplayForm').++data CLHSCore = CLHSCore+  DisplayLHS+    -- ^ Are we checking the left hand side of a 'C.DisplayForm'?+  C.LHSCore+    -- ^ The lhs to scope-check.++-- | Scope-check a 'C.LHSCore' not of a 'C.DisplayForm'.++instance ToAbstract C.LHSCore where+  type AbsOfCon C.LHSCore = A.LHSCore' C.Expr++  toAbstract = toAbstract . CLHSCore NoDisplayLHS++-- does not check pattern linearity+instance ToAbstract CLHSCore where+  type AbsOfCon CLHSCore = A.LHSCore' C.Expr++  toAbstract (CLHSCore displayLhs core0) = case core0 of++    C.LHSHead x ps -> do+        x <- withLocalVars do+          setLocalVars []+          toAbstract (OldName x)+        ps <- toAbstract $ (fmap . fmap . fmap) (CPattern displayLhs) ps+        A.LHSHead x <$> mergeEqualPs ps++    C.LHSProj d ps1 core ps2 -> do+        unless (null ps1) $ typeError $ IllformedProjectionPatternConcrete (foldl C.AppP (C.IdentP True d) ps1)+        ds <- resolveName d >>= \case+          FieldName ds -> return $ fmap anameName ds+          UnknownName  -> notInScopeError d+          _            -> typeError $ CopatternHeadNotProjection d+        core <- toAbstract $ (fmap . fmap) (CLHSCore displayLhs) core+        ps2  <- toAbstract $ (fmap . fmap . fmap) (CPattern displayLhs) ps2+        A.LHSProj (AmbQ ds) core <$> mergeEqualPs ps2++    C.LHSWith core wps ps -> do+      -- DISPLAY pragmas cannot have @with@, so no need to pass on @displayLhs@.+      core <- toAbstract core+      wps  <- fmap defaultArg <$> toAbstract wps+      ps   <- toAbstract ps+      return $ A.lhsCoreApp (A.lhsCoreWith core wps) ps++    -- In case of a part of the LHS which was expanded from an ellipsis,+    -- we flush the @scopeVarsToBind@ in order to allow variables bound+    -- in the ellipsis to be shadowed.+    C.LHSEllipsis _ core -> do+      core <- toAbstract core  -- Cannot come from a DISPLAY pragma.+      bindVarsToBind+      return core++instance ToAbstract c => ToAbstract (WithHiding c) where+  type AbsOfCon (WithHiding c) = WithHiding (AbsOfCon c)+  toAbstract (WithHiding h a) = WithHiding h <$> toAbstractHiding h a++instance ToAbstract c => ToAbstract (Arg c) where+    type AbsOfCon (Arg c) = Arg (AbsOfCon c)+    toAbstract (Arg info e) =+        Arg info <$> toAbstractHiding info e++instance ToAbstract c => ToAbstract (Named name c) where+    type AbsOfCon (Named name c) = Named name (AbsOfCon c)+    toAbstract = traverse toAbstract++instance ToAbstract c => ToAbstract (Ranged c) where+    type AbsOfCon (Ranged c) = Ranged (AbsOfCon c)+    toAbstract = traverse toAbstract++{- DOES NOT WORK ANYMORE with pattern synonyms+instance ToAbstract c a => ToAbstract (A.LHSCore' c) (A.LHSCore' a) where+    toAbstract = mapM toAbstract+-}++instance ToAbstract (A.LHSCore' C.Expr) where+    type AbsOfCon (A.LHSCore' C.Expr) = A.LHSCore' A.Expr+    toAbstract (A.LHSHead f ps)         = A.LHSHead f <$> mapM toAbstract ps+    toAbstract (A.LHSProj d lhscore ps) = A.LHSProj d <$> mapM toAbstract lhscore <*> mapM toAbstract ps+    toAbstract (A.LHSWith core wps ps)  = liftA3 A.LHSWith (toAbstract core) (toAbstract wps) (toAbstract ps)++-- Patterns are done in two phases. First everything but the dot patterns, and+-- then the dot patterns. This is because dot patterns can refer to variables+-- bound anywhere in the pattern.++instance ToAbstract (A.Pattern' C.Expr) where+  type AbsOfCon (A.Pattern' C.Expr) = A.Pattern' A.Expr+  toAbstract = traverse $ insideDotPattern . toAbstractCtx DotPatternCtx  -- Issue #3033++resolvePatternIdentifier ::+     Bool+       -- ^ Is the identifier allowed to refer to a constructor (or a pattern synonym)?+       --+       --   Value 'False' is only used when 'optHiddenArgumentPuns' is 'True'.+       --   In this case, error 'InvalidPun' is thrown on identifiers that are not variables.+  -> DisplayLHS+       -- ^ Are definitions to be treated as constructors?+       --   'True' when we are checking a 'C.DisplayForm'.+  -> Hiding+       -- ^ Is the pattern variable hidden?+  -> C.QName+       -- ^ Identifier.+  -> Maybe (Set1 A.Name)+       -- ^ Possibly precomputed resolutions of the identifier (from the operator parser).+  -> ScopeM (A.Pattern' C.Expr)+resolvePatternIdentifier canBeConstructor displayLhs h x ns = do+  reportSLn "scope.pat" 60 $ "resolvePatternIdentifier " ++ prettyShow x ++ " at source position " ++ prettyShow r+  toAbstract (PatName x ns h displayLhs) >>= \case++    VarPatName y -> do+      reportSLn "scope.pat" 60 $ "  resolved to VarPatName " ++ prettyShow y ++ " with range " ++ prettyShow (getRange y)+      return $ VarP $ A.mkBindName y++    ConPatName ds -> do+      unless canBeConstructor $ err IsConstructor+      return $ ConP (ConPatInfo ConOCon info ConPatEager) (AmbQ $ fmap anameName ds) []++    PatternSynPatName ds -> do+      unless canBeConstructor $ err IsPatternSynonym+      return $ PatternSynP info (AmbQ $ fmap anameName ds) []++    DefPatName d -> do+      unless displayLhs __IMPOSSIBLE__+      return $ DefP info (AmbQ $ singleton $ anameName d) []++  where+  r = getRange x+  info = PatRange r+  err s = setCurrentRange r $ typeError $ InvalidPun s x++-- | Apply an abstract syntax pattern head to pattern arguments.+--+--   Fails with 'InvalidPattern' if head is not a constructor pattern+--   (or similar) that can accept arguments.+--+applyAPattern+  :: C.Pattern            -- ^ The application pattern in concrete syntax.+  -> A.Pattern' C.Expr    -- ^ Head of application.+  -> NAPs1 C.Expr         -- ^ Arguments of application.+  -> ScopeM (A.Pattern' C.Expr)+applyAPattern p0 p ps1 = do+  let ps = List1.toList ps1+  setRange (getRange p0) <$> do+    case p of+      A.ConP i x as        -> return $ A.ConP        i x (as ++ ps)+      A.DefP i x as        -> return $ A.DefP        i x (as ++ ps)+      A.PatternSynP i x as -> return $ A.PatternSynP i x (as ++ ps)+      -- Dotted constructors are turned into "lazy" constructor patterns.+      A.DotP i (Ident x)   -> resolveName x >>= \case+        ConstructorName _ ds -> do+          let cpi = ConPatInfo ConOCon i ConPatLazy+              c   = AmbQ (fmap anameName ds)+          return $ A.ConP cpi c ps+        _ -> failure+      A.DotP{}    -> failure+      A.VarP{}    -> failure+      A.ProjP{}   -> failure+      A.WildP{}   -> failure+      A.AsP{}     -> failure+      A.AbsurdP{} -> failure+      A.LitP{}    -> failure+      A.RecP{}    -> failure+      A.EqualP{}  -> failure+      A.WithP{}   -> failure+  where+    failure = typeError $ InvalidPattern p0++-- | Throw-away wrapper type for pattern translation.+data WithHidingInfo a = WithHidingInfo Hiding a++propagateHidingInfo :: NamedArg a -> NamedArg (WithHidingInfo a)+propagateHidingInfo a = fmap (fmap $ WithHidingInfo $ getHiding a) a++-- | Hiding info is only used for pattern variables.+instance ToAbstract (WithHidingInfo C.Pattern) where+    type AbsOfCon (WithHidingInfo C.Pattern) = A.Pattern' C.Expr++    toAbstract (WithHidingInfo h (C.IdentP canBeConstructor x)) =+      resolvePatternIdentifier canBeConstructor NoDisplayLHS h x Nothing++    toAbstract (WithHidingInfo _ p) = toAbstract p++-- | Scope check a 'C.Pattern' (of possibly a 'C.DisplayForm').+--+data CPattern = CPattern+  DisplayLHS+    -- ^ Are we checking a 'C.DisplayForm'?+  C.Pattern+    -- ^ The pattern to scope-check.++-- | Scope check a 'C.Pattern' not belonging to a 'C.DisplayForm'.+--+instance ToAbstract C.Pattern where+  type AbsOfCon C.Pattern = A.Pattern' C.Expr++  toAbstract = toAbstract . CPattern NoDisplayLHS++instance ToAbstract CPattern where+  type AbsOfCon CPattern = A.Pattern' C.Expr++  toAbstract (CPattern displayLhs p0) = case p0 of++    C.IdentP canBeConstructor x ->+      resolvePatternIdentifier canBeConstructor displayLhs empty x Nothing++    QuoteP _r ->+      typeError $ CannotQuote CannotQuoteNothing++    AppP (QuoteP _) p+      | IdentP _ x <- namedArg p -> do+          if visible p then do+            e <- toAbstract (OldQName x Nothing)+            A.LitP (PatRange $ getRange x) . LitQName <$> quotedName e+          else typeError $ CannotQuote CannotQuoteHidden+      | otherwise -> typeError $ CannotQuote $ CannotQuotePattern p++    AppP p q -> do+        reportSLn "scope.pat" 50 $ "distributeDots before = " ++ show p+        p <- distributeDots p+        reportSLn "scope.pat" 50 $ "distributeDots after  = " ++ show p+        p' <- toAbstract (wrap p)+        -- Remember hiding info in argument to propagate to 'PatternBound'.+        q' <- ifThenElse displayLhs+          {-then-} (toAbstract $ (fmap . fmap) wrap q)+          {-else-} (toAbstract $ propagateHidingInfo q)+        applyAPattern p0 p' $ singleton q'++        where+            distributeDots :: C.Pattern -> ScopeM C.Pattern+            distributeDots p@(C.DotP kwr r e) = distributeDotsExpr kwr r e+            distributeDots p = return p++            distributeDotsExpr :: KwRange -> Range -> C.Expr -> ScopeM C.Pattern+            distributeDotsExpr kwr r e = parseRawApp e >>= \case+              C.App r e a     ->+                AppP <$> distributeDotsExpr empty r e+                     <*> (traverse . traverse) (distributeDotsExpr empty r) a+              OpApp r q ns as ->+                case (traverse . traverse . traverse) fromNoPlaceholder as of+                  Just as -> OpAppP r q ns <$>+                    (traverse . traverse . traverse) (distributeDotsExpr empty r) as+                  Nothing -> return $ C.DotP empty r e+              Paren r e -> ParenP r <$> distributeDotsExpr empty r e+              _ -> return $ C.DotP kwr r e++            fromNoPlaceholder :: MaybePlaceholder (OpApp a) -> Maybe a+            fromNoPlaceholder (NoPlaceholder _ (Ordinary e)) = Just e+            fromNoPlaceholder _ = Nothing++            parseRawApp :: C.Expr -> ScopeM C.Expr+            parseRawApp (RawApp r es) = parseApplication es+            parseRawApp e             = return e++    OpAppP r op ns ps -> do+        reportSLn "scope.pat" 60 $ "ConcreteToAbstract.toAbstract OpAppP{}: " ++ show p0+        p  <- resolvePatternIdentifier True displayLhs empty op (Just ns)+        -- Remember hiding info in arguments to propagate to 'PatternBound'.+        ps <- ifThenElse displayLhs+          {-then-} (toAbstract $ (fmap . fmap . fmap) wrap ps)+          {-else-} (toAbstract $ fmap propagateHidingInfo ps)+        applyAPattern p0 p ps++    EllipsisP _ mp -> maybe __IMPOSSIBLE__ toAbstract mp  -- Not in DISPLAY pragma++    -- Removed when parsing+    HiddenP _ _    -> __IMPOSSIBLE__+    InstanceP _ _  -> __IMPOSSIBLE__+    RawAppP _ _    -> __IMPOSSIBLE__++    C.WildP r      -> return $ A.WildP $ PatRange r+    -- Andreas, 2015-05-28 futile attempt to fix issue 819: repeated variable on lhs "_"+    -- toAbstract p@(C.WildP r)    = A.VarP <$> freshName r "_"+    C.ParenP _ p   -> toAbstract $ wrap p  -- Andreas, 2024-09-27 not impossible+    C.LitP r l     -> setCurrentRange r $ A.LitP (PatRange r) l <$ checkLiteral l++    C.AsP r x p -> do+        -- Andreas, 2018-06-30, issue #3147: as-variables can be non-linear a priori!+        -- x <- toAbstract (NewName PatternBound x)+        -- Andreas, 2020-05-01, issue #4631: as-variables should not shadow constructors.+        -- x <- bindPatternVariable x+      toAbstract (PatName (C.QName x) Nothing empty NoDisplayLHS) >>= \case+        VarPatName x        -> A.AsP (PatRange r) (A.mkBindName x) <$> toAbstract (wrap p)+        ConPatName{}        -> ignoreAsPat IsConstructor+        PatternSynPatName{} -> ignoreAsPat IsPatternSynonym+        DefPatName{}        -> __IMPOSSIBLE__  -- because of @False@ in @PatName@+      where+      -- An @-bound name which shadows a constructor is illegal and becomes dead code.+      ignoreAsPat b = do+        setCurrentRange x $ warning $ AsPatternShadowsConstructorOrPatternSynonym b+        toAbstract $ wrap p++    C.EqualP r es -> return $ A.EqualP (PatRange r) es++    -- We have to do dot patterns at the end since they can+    -- refer to the variables bound by the other patterns.+    C.DotP _kwr r e -> do+      let fallback = return $ A.DotP (PatRange r) e+      case e of+        C.Ident x -> resolveName x >>= \case+          -- Andreas, 2018-06-19, #3130+          -- We interpret .x as postfix projection if x is a field name in scope+          FieldName xs -> return $ A.ProjP (PatRange r) ProjPostfix $ AmbQ $+            fmap anameName xs+          _ -> fallback+        _ -> fallback++    C.AbsurdP r -> return $ A.AbsurdP $ PatRange r+    C.RecP kwr r fs -> A.RecP kwr (ConPatInfo ConORec (PatRange r) ConPatEager) <$> mapM (traverse $ toAbstract . wrap) fs+    C.WithP r p -> A.WithP (PatRange r) <$> toAbstract p  -- not in DISPLAY pragma++    where+      -- Pass on @displayLhs@ context+      wrap = CPattern displayLhs++-- | An argument @OpApp C.Expr@ to an operator can have binders,+--   in case the operator is some @syntax@-notation.+--   For these binders, we have to create lambda-abstractions.+toAbstractOpArg :: Precedence -> OpApp C.Expr -> ScopeM A.Expr+toAbstractOpArg ctx (Ordinary e)                 = toAbstractCtx ctx e+toAbstractOpArg ctx (SyntaxBindingLambda r bs e) = toAbstractLam r bs e ctx++-- | Turn an operator application into abstract syntax. Make sure to+-- record the right precedences for the various arguments.+toAbstractOpApp :: C.QName -> Set1 A.Name -> OpAppArgs -> ScopeM A.Expr+toAbstractOpApp op ns es = do+    -- Replace placeholders with bound variables.+    (binders, es) <- replacePlaceholders $ List1.toList es+    -- Get the notation for the operator.+    nota <- getNotation op ns+    let parts = notation nota+    -- We can throw away the @VarPart@s, since binders+    -- have been preprocessed into @OpApp C.Expr@.+    let nonBindingParts = filter (not . isBinder) parts+    -- We should be left with as many holes as we have been given args @es@.+    -- If not, crash.+    unless (length (filter isAHole nonBindingParts) == length es) __IMPOSSIBLE__+    -- Translate operator and its arguments (each in the right context).+    op <- toAbstract (OldQName op (Just ns))+    es <- left (notaFixity nota) nonBindingParts es+    -- Prepend the generated section binders (if any).+    let body = List.foldl' app op es+    return $ foldr (A.Lam (ExprRange (getRange body))) body binders+  where+    -- Build an application in the abstract syntax, with correct Range.+    app e (pref, arg) = A.App info e arg+      where info = (defaultAppInfo r) { appOrigin = getOrigin arg+                                      , appParens = pref }+            r = fuseRange e arg++    inferParenPref :: NamedArg (Either A.Expr (OpApp C.Expr)) -> ParenPreference+    inferParenPref e =+      case namedArg e of+        Right (Ordinary e) -> inferParenPreference e+        Left{}             -> PreferParenless  -- variable inserted by section expansion+        Right{}            -> PreferParenless  -- syntax lambda++    -- Translate an argument. Returns the paren preference for the argument, so+    -- we can build the correct info for the A.App node.+    toAbsOpArg :: Precedence ->+                  NamedArg (Either A.Expr (OpApp C.Expr)) ->+                  ScopeM (ParenPreference, NamedArg A.Expr)+    toAbsOpArg cxt e = (pref,) <$> (traverse . traverse) (either return (toAbstractOpArg cxt)) e+      where pref = inferParenPref e++    -- The hole left to the first @IdPart@ is filled with an expression in @LeftOperandCtx@.+    left :: Fixity+         -> [NotationPart]+         -> [NamedArg (Either A.Expr (OpApp C.Expr))]+         -> ScopeM [(ParenPreference, NamedArg A.Expr)]+    left f (IdPart _ : xs) es = inside f xs es+    left f (_ : xs) (e : es) = do+        e  <- toAbsOpArg (LeftOperandCtx f) e+        es <- inside f xs es+        return (e : es)+    left f (_  : _)  [] = __IMPOSSIBLE__+    left f []        _  = __IMPOSSIBLE__++    -- The holes in between the @IdPart@s are filled with an expression in @InsideOperandCtx@.+    inside :: Fixity+           -> [NotationPart]+           -> [NamedArg (Either A.Expr (OpApp C.Expr))]+           -> ScopeM [(ParenPreference, NamedArg A.Expr)]+    inside f [x]             es = right f x es+    inside f (IdPart _ : xs) es = inside f xs es+    inside f (_  : xs) (e : es) = do+        e  <- toAbsOpArg InsideOperandCtx e+        es <- inside f xs es+        return (e : es)+    inside _ []      [] = return []+    inside _ (_ : _) [] = __IMPOSSIBLE__+    inside _ [] (_ : _) = __IMPOSSIBLE__++    -- The hole right of the last @IdPart@ is filled with an expression in @RightOperandCtx@.+    right :: Fixity+          -> NotationPart+          -> [NamedArg (Either A.Expr (OpApp C.Expr))]+          -> ScopeM [(ParenPreference, NamedArg A.Expr)]+    right _ (IdPart _)  [] = return []+    right f _          [e] = do+        let pref = inferParenPref e+        e <- toAbsOpArg (RightOperandCtx f pref) e+        return [e]+    right _ _     _  = __IMPOSSIBLE__++    replacePlaceholders ::+      OpAppArgs0 e ->+      ScopeM ([A.LamBinding], [NamedArg (Either A.Expr (OpApp e))])+    replacePlaceholders []       = return ([], [])+    replacePlaceholders (a : as) = case namedArg a of+      NoPlaceholder _ x -> mapSnd (set (Right x) a :) <$>+                             replacePlaceholders as+      Placeholder _     -> do+        x <- freshName noRange "section"+        let i = setOrigin Inserted $ argInfo a+        (ls, ns) <- replacePlaceholders as+        return ( A.mkDomainFree (unnamedArg i $ A.insertedBinder_ x) : ls+               , set (Left (Var x)) a : ns+               )+      where+      set :: a -> NamedArg b -> NamedArg a+      set x arg = fmap (fmap (const x)) arg++-- | Raises an error if the list of attributes contains an unsupported+-- attribute.++checkAttributes :: Attributes -> ScopeM ()+checkAttributes []                     = return ()+checkAttributes (Attr r s attr : attrs) =+  case attr of+    RelevanceAttribute{}    -> cont+    CA.TacticAttribute{}    -> cont+    LockAttribute IsNotLock -> cont+    LockAttribute IsLock{}  -> do+      unlessM (optGuarded <$> pragmaOptions) $+        setCurrentRange r $ typeError $ AttributeKindNotEnabled "Lock" "--guarded" s+      cont+    QuantityAttribute Quantityω{} -> cont+    QuantityAttribute Quantity1{} -> __IMPOSSIBLE__+    QuantityAttribute Quantity0{} -> do+      unlessM (optErasure <$> pragmaOptions) $+        setCurrentRange r $ typeError $ AttributeKindNotEnabled "Erasure" "--erasure" s+      cont+    CohesionAttribute{} -> do+      unlessM (optCohesion <$> pragmaOptions) $+        setCurrentRange r $ typeError $ AttributeKindNotEnabled "Cohesion" "--cohesion" s+      cont+    PolarityAttribute{} -> do+      unlessM (optPolarity <$> pragmaOptions) $+        setCurrentRange r $ typeError $ AttributeKindNotEnabled "Polarity" "--polarity" s+      cont+  where+  cont = checkAttributes attrs  {--------------------------------------------------------------------------     Things we parse but are not part of the Agda file syntax
src/full/Agda/Syntax/Translation/InternalToAbstract.hs view
@@ -40,12 +40,13 @@ import Agda.Syntax.Position import Agda.Syntax.Common import qualified Agda.Syntax.Concrete.Name as C-import Agda.Syntax.Concrete (FieldAssignment'(..))+import Agda.Syntax.Concrete (FieldAssignment'(..), TacticAttribute'(..)) import Agda.Syntax.Info as Info import Agda.Syntax.Abstract as A hiding (Binder) import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Pattern import Agda.Syntax.Abstract.Pretty+import Agda.Syntax.Abstract.UsedNames import Agda.Syntax.Internal as I import Agda.Syntax.Internal.Pattern as I import Agda.Syntax.Scope.Base (inverseScopeLookupName)@@ -59,6 +60,7 @@ import {-# SOURCE #-} Agda.TypeChecking.Datatypes import Agda.TypeChecking.Free import Agda.TypeChecking.Substitute+import Agda.TypeChecking.SyntacticEquality import Agda.TypeChecking.Telescope  import Agda.Interaction.Options@@ -74,7 +76,7 @@ import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Permutation-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Tuple@@ -93,12 +95,14 @@ --napps :: Expr -> [NamedArg Expr] -> TCM Expr --napps e = nelims e . map I.Apply +{-# SPECIALIZE apps :: Expr -> [Arg Expr] -> TCM Expr #-} -- | Drops hidden arguments unless --show-implicit. apps :: MonadReify m => Expr -> [Arg Expr] -> m Expr apps e = elims e . map I.Apply  -- Composition of reified eliminations ------------------------------------ +{-# SPECIALIZE nelims :: Expr -> [I.Elim' (Named_ Expr)] -> TCM Expr #-} -- | Drops hidden arguments unless --show-implicit. nelims :: MonadReify m => Expr -> [I.Elim' (Named_ Expr)] -> m Expr nelims e [] = return e@@ -115,6 +119,7 @@                                     | otherwise =   nelims (A.App defaultAppInfo_ e (defaultNamedArg $ A.Proj o $ unambiguous d)) es +{-# SPECIALIZE nelimsProjPrefix :: Expr -> QName -> [I.Elim' (Named_ Expr)] -> TCM Expr #-} nelimsProjPrefix :: MonadReify m => Expr -> QName -> [I.Elim' (Named_ Expr)] -> m Expr nelimsProjPrefix e d es =   nelims (A.App defaultAppInfo_ (A.Proj ProjPrefix $ unambiguous d) $ defaultNamedArg e) es@@ -126,6 +131,7 @@   A.Var n -> nameIsRecordName n   _ -> False +{-# SPECIALIZE elims :: Expr -> [I.Elim' Expr] -> TCM Expr #-} -- | Drops hidden arguments unless --show-implicit. elims :: MonadReify m => Expr -> [I.Elim' Expr] -> m Expr elims e = nelims e . map (fmap unnamed)@@ -137,6 +143,7 @@  -- Conditional reification to omit terms that are not shown -------------- +{-# INLINE reifyWhenE #-} reifyWhenE :: (Reify i, MonadReify m, Underscore (ReifiesTo i)) => Bool -> i -> m (ReifiesTo i) reifyWhenE True  i = reify i reifyWhenE False t = return underscore@@ -163,6 +170,10 @@     type ReifiesTo Bool = Bool     reify = return +instance Reify Char where+    type ReifiesTo Char = Char+    reify = return+ instance Reify Name where     type ReifiesTo Name = Name     reify = return@@ -177,14 +188,16 @@     type ReifiesTo MetaId = Expr      reifyWhen = reifyWhenE-    reify x@(MetaId n) = do+    reify x = do       b <- asksTC envPrintMetasBare-      mi  <- mvInfo <$> lookupMeta x+      mvar <- lookupLocalMeta x+      let mi  = mvInfo mvar       let mi' = Info.MetaInfo                  { metaRange          = getRange $ miClosRange mi                  , metaScope          = clScope $ miClosRange mi                  , metaNumber         = if b then Nothing else Just x                  , metaNameSuggestion = if b then "" else miNameSuggestion mi+                 , metaKind           =  metaInstantiationToMetaKind (mvInstantiation mvar)                  }           underscore = return $ A.Underscore mi'       -- If we are printing a term that will be pasted into the user@@ -198,25 +211,23 @@         Just ii | b -> underscore         Nothing     -> underscore         Just ii     -> return $ A.QuestionMark mi' ii---- Does not print with-applications correctly:--- instance Reify DisplayTerm Expr where---   reifyWhen = reifyWhenE---   reify d = reifyTerm False $ dtermToTerm d+{-# SPECIALIZE reify :: MetaId -> TCM (ReifiesTo MetaId) #-}  instance Reify DisplayTerm where   type ReifiesTo DisplayTerm = Expr    reifyWhen = reifyWhenE   reify = \case-    DTerm v -> reifyTerm False v-    DDot  v -> reify v-    DCon c ci vs -> recOrCon (conName c) ci =<< reify vs-    DDef f es -> elims (A.Def f) =<< reify es+    DTerm' v es       -> elims ==<< (reifyTerm False v, reify es)+    DDot'  v es       -> elims ==<< (reify v, reify es)+    DCon c ci vs      -> recOrCon (conName c) ci =<< reify vs+    DDef f es         -> elims (A.Def f) =<< reify es     DWithApp u us es0 -> do       (e, es) <- reify (u, us)-      elims (if null es then e else A.WithApp noExprInfo e es) =<< reify es0+      elims (A.WithApp noExprInfo e es) =<< reify es0+{-# SPECIALIZE reify :: DisplayTerm -> TCM (ReifiesTo DisplayTerm) #-} +{-# SPECIALIZE reifyDisplayForm :: QName -> I.Elims -> TCM A.Expr -> TCM A.Expr #-} -- | @reifyDisplayForm f vs fallback@ --   tries to rewrite @f vs@ with a display form for @f@. --   If successful, reifies the resulting display term,@@ -226,12 +237,14 @@   ifNotM displayFormsEnabled fallback $ {- else -}     caseMaybeM (displayForm f es) fallback reify +{-# SPECIALIZE reifyDisplayFormP :: QName -> A.Patterns -> A.Patterns -> TCM (QName, A.Patterns) #-} -- | @reifyDisplayFormP@ tries to recursively --   rewrite a lhs with a display form. -- --   Note: we are not necessarily in the empty context upon entry!-reifyDisplayFormP-  :: MonadReify m+reifyDisplayFormP ::+     forall m.+     MonadReify m   => QName         -- ^ LHS head symbol   -> A.Patterns    -- ^ Patterns to be taken into account to find display form.   -> A.Patterns    -- ^ Remaining trailing patterns ("with patterns").@@ -275,22 +288,24 @@     -- defined name applied to valid lhs eliminators (projections or     -- applications to constructor patterns).     okDisplayForm :: DisplayTerm -> Bool-    okDisplayForm (DWithApp d ds es) =-      okDisplayForm d && all okDisplayTerm ds  && all okToDropE es-      -- Andreas, 2016-05-03, issue #1950.-      -- We might drop trailing hidden trivial (=variable) patterns.-    okDisplayForm (DTerm (I.Def f vs)) = all okElim vs-    okDisplayForm (DDef f es)          = all okDElim es-    okDisplayForm DDot{}               = False-    okDisplayForm DCon{}               = False-    okDisplayForm DTerm{}              = False+    okDisplayForm = \case+      DWithApp d ds es ->+        okDisplayForm d && all okDisplayTerm ds  && all okToDropE es+        -- Andreas, 2016-05-03, issue #1950.+        -- We might drop trailing hidden trivial (=variable) patterns.+      DTerm' (I.Def f es') es -> all okElim es' && all okElim es+      DDef f es               -> all okDElim es+      DDot'{}                 -> False+      DCon{}                  -> False+      DTerm'{}                -> False      okDisplayTerm :: DisplayTerm -> Bool-    okDisplayTerm (DTerm v) = okTerm v-    okDisplayTerm DDot{}    = True-    okDisplayTerm DCon{}    = True-    okDisplayTerm DDef{}    = False-    okDisplayTerm _         = False+    okDisplayTerm = \case+      DTerm' v es -> null es && okTerm v+      DDot'{}     -> True+      DCon{}      -> True+      DDef{}      -> False+      DWithApp{}  -> False      okDElim :: Elim' DisplayTerm -> Bool     okDElim (I.IApply x y r) = okDisplayTerm r@@ -327,9 +342,9 @@     flattenWith :: DisplayTerm -> (QName, [I.Elim' DisplayTerm], [I.Elim' DisplayTerm])     flattenWith (DWithApp d ds1 es2) =       let (f, es, ds0) = flattenWith d-      in  (f, es, ds0 ++ map (I.Apply . defaultArg) ds1 ++ map (fmap DTerm) es2)+      in  (f, es, ds0 ++ map (I.Apply . defaultArg) (List1.toList ds1) ++ map (fmap DTerm) es2)     flattenWith (DDef f es) = (f, es, [])     -- .^ hacky, but we should only hit this when printing debug info-    flattenWith (DTerm (I.Def f es)) = (f, map (fmap DTerm) es, [])+    flattenWith (DTerm' (I.Def f es') es) = (f, map (fmap DTerm) $ es' ++ es, [])     flattenWith _ = __IMPOSSIBLE__      displayLHS@@ -355,22 +370,27 @@         termToPat :: MonadReify m => DisplayTerm -> m (Named_ A.Pattern)          -- Main action HERE:-        termToPat (DTerm (I.Var n [])) = return $ unArg $ fromMaybe __IMPOSSIBLE__ $ ps !!! n+        termToPat (DTerm (I.Var n [])) =+          return $ unArg $ fromMaybe __IMPOSSIBLE__ $ ps !!! n          termToPat (DCon c ci vs)          = fmap unnamed <$> tryRecPFromConP =<< do            A.ConP (ConPatInfo ci patNoRange ConPatEager) (unambiguous (conName c)) <$> mapM argToPat vs -        termToPat (DTerm (I.Con c ci vs)) = fmap unnamed <$> tryRecPFromConP =<< do-           A.ConP (ConPatInfo ci patNoRange ConPatEager) (unambiguous (conName c)) <$> mapM (elimToPat . fmap DTerm) vs+        termToPat (DTerm' (I.Con c ci vs) es) = fmap unnamed <$> tryRecPFromConP =<< do+           A.ConP (ConPatInfo ci patNoRange ConPatEager) (unambiguous (conName c)) <$>+             mapM (elimToPat . fmap DTerm) (vs ++ es)          termToPat (DTerm (I.Def _ [])) = return $ unnamed $ A.WildP patNoRange         termToPat (DDef _ [])          = return $ unnamed $ A.WildP patNoRange          termToPat (DTerm (I.Lit l))    = return $ unnamed $ A.LitP patNoRange l -        termToPat (DDot v)             = unnamed . A.DotP patNoRange <$> termToExpr v-        termToPat v                    = unnamed . A.DotP patNoRange <$> reify v+        termToPat (DDot' v es) =+          unnamed . A.DotP patNoRange <$> do elims ==<< (termToExpr v, reify es) +        termToPat v =+          unnamed . A.DotP patNoRange <$> reify v+         len = length ps          argsToExpr :: MonadReify m => I.Args -> m [Arg A.Expr]@@ -395,7 +415,7 @@               -- even the pattern variables @n < len@ can be               -- applied to some args @vs@.               e <- if n < len-                   then return $ A.patternToExpr $ namedArg $ indexWithDefault __IMPOSSIBLE__ ps n+                   then return $ patternToExpr $ namedArg $ indexWithDefault __IMPOSSIBLE__ ps n                    else reify (I.var (n - len))               apps e =<< argsToExpr vs             _ -> return underscore@@ -404,14 +424,15 @@   type ReifiesTo Literal = Expr    reifyWhen = reifyWhenE-  reify l = return $ A.Lit empty l+  reify l = return $ A.Lit empty l; {-# INLINE reify #-}  instance Reify Term where   type ReifiesTo Term = Expr    reifyWhen = reifyWhenE-  reify v = reifyTerm True v+  reify v = reifyTerm True v; {-# INLINE reify #-} +{-# SPECIALIZE reifyPathPConstAsPath :: QName -> Elims -> TCM (QName, Elims) #-} reifyPathPConstAsPath :: MonadReify m => QName -> Elims -> m (QName, Elims) reifyPathPConstAsPath x es@[I.Apply l, I.Apply t, I.Apply lhs, I.Apply rhs] = do    reportSLn "reify.def" 100 $ "reifying def path " ++ show (x,es)@@ -431,21 +452,57 @@      _ -> fallback reifyPathPConstAsPath x es = return (x,es) -reifyTerm :: MonadReify m => Bool -> Term -> m Expr-reifyTerm expandAnonDefs0 v0 = do+{-# SPECIALIZE tryReifyAsLetBinding :: Term -> TCM Expr -> TCM Expr #-}+-- | Check if the term matches an existing let-binding, in that case use the corresponding variable,+--   otherwise reify using the continuation.+tryReifyAsLetBinding :: MonadReify m => Term -> m Expr -> m Expr+tryReifyAsLetBinding v fallback = ifM (asksTC $ not . envFoldLetBindings) fallback $ do+  letBindings <- do+    binds  <- asksTC (Map.toAscList . envLetBindings)+    opened <- forM binds $ \ (name, open) -> (,name) <$> getOpen open+    return [ (body, name) | (LetBinding UserWritten body _, name) <- opened, not $ isNoName name ]  -- Only fold user-written lets+  matchingBindings <- filterM (\t -> checkSyntacticEquality v (fst t) (\_ _ -> return True) (\_ _ -> return False)) letBindings+  case matchingBindings of+    (_, name) : _ -> return $ A.Var name+    []            -> fallback++{-# SPECIALIZE reifyTerm :: Bool -> Term -> TCM Expr #-}+reifyTerm ::+      MonadReify m+   => Bool           -- ^ Try to expand away anonymous definitions?+   -> Term+   -> m Expr+reifyTerm expandAnonDefs0 v0 = tryReifyAsLetBinding v0 $ do   -- Jesper 2018-11-02: If 'PrintMetasBare', drop all meta eliminations.   metasBare <- asksTC envPrintMetasBare+  reportSDoc "reify.term" 80 $ pure $ "reifyTerm v0 = " <+> pretty v0   v <- instantiate v0 >>= \case     I.MetaV x _ | metasBare -> return $ I.MetaV x []     v -> return v+  reportSDoc "reify.term" 80 $ pure $ "reifyTerm v = " <+> pretty v   -- Ulf 2014-07-10: Don't expand anonymous when display forms are disabled   -- (i.e. when we don't care about nice printing)   expandAnonDefs <- return expandAnonDefs0 `and2M` displayFormsEnabled+   -- Andreas, 2016-07-21 if --postfix-projections   -- then we print system-generated projections as postfix, else prefix.   havePfp <- optPostfixProjections <$> pragmaOptions-  let pred = if havePfp then (== ProjPrefix) else (/= ProjPostfix)-  case unSpine' pred v of++  -- Amy, 2024-01-07: postfix and system projections should still be+  -- turned into head symbols *if* they have display forms attached.+  hasDisplay <- liftReduce $ unKleisli hasDisplayForms+  let+    prefixize :: ProjOrigin -> QName -> Bool+    prefixize orig name = or+      [ if havePfp then orig == ProjPrefix else orig /= ProjPostfix+      , isOperator name+          -- Andreas, 2024-06-13, issue #7318:+          -- print e.g. G .|_| as | G |+      , hasDisplay name+      ]+  reportSDoc "reify.term" 80 $ pure $ "reifyTerm (unSpine v) = " <+> pretty (unSpine' prefixize v)++  case unSpine' prefixize v of     -- Hack to print generalized field projections with nicer names. Should     -- only show up in errors. Check the spined form!     _ | I.Var n (I.Proj _ p : es) <- v,@@ -459,18 +516,33 @@       reportSDoc "reify.def" 80 $ return $ "reifying def" <+> pretty x       (x, es) <- reifyPathPConstAsPath x es       reifyDisplayForm x es $ reifyDef expandAnonDefs x es-    I.Con c ci vs -> do-      let x = conName c-      isR <- isGeneratedRecordConstructor x-      if isR || ci == ConORec-        then do++    I.Con c ci es -> do++      -- If the origin is a record expression, print a record expression.+      if ci == ConORec then recordExpression Nothing else do+        isRecordConstructor x >>= \case++          -- If it is a generated constructor, print a record expression.+          Just (r, def) | not (_recNamedCon def) -> recordExpression $ Just (r, def)++          -- Otherwise, print a constructor application.+          _ -> constructorApplication+      where+        x = conName c++        recordExpression mrdef = do+          (r, def) <- maybe (fromMaybe __IMPOSSIBLE__ <$> isRecordConstructor x) pure mrdef           showImp <- showImplicitArguments           let keep (a, v) = showImp || visible a-          r <- getConstructorData x-          xs <- fromMaybe __IMPOSSIBLE__ <$> getRecordFieldNames_ r-          vs <- map unArg <$> reify (fromMaybe __IMPOSSIBLE__ $ allApplyElims vs)-          return $ A.Rec noExprInfo $ map (Left . uncurry FieldAssignment . mapFst unDom) $ filter keep $ zip xs vs-        else reifyDisplayForm x vs $ do+          A.Rec empty noExprInfo+            . map (Left . uncurry FieldAssignment . mapFst unDom)+            . filter keep+            . zip (recordFieldNames def)+            . map unArg+            <$> reify (fromMaybe __IMPOSSIBLE__ $ allApplyElims es)++        constructorApplication = reifyDisplayForm x es $ do           def <- getConstInfo x           let Constructor {conPars = np} = theDef def           -- if we are the the module that defines constructor x@@ -480,10 +552,10 @@           -- extra parameters) or equal (if not) to n           when (n > np) __IMPOSSIBLE__           let h = A.Con (unambiguous x)-          if null vs+          if null es             then return h             else do-              es <- reify (map (fromMaybe __IMPOSSIBLE__ . isApplyElim) vs)+              es <- reify $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es               -- Andreas, 2012-04-20: do not reify parameter arguments of constructor               -- if the first regular constructor argument is hidden               -- we turn it into a named argument, in order to avoid confusion@@ -528,35 +600,44 @@     I.Level l      -> reify l     I.Pi a b       -> case b of         NoAbs _ b'-          | visible a   -> uncurry (A.Fun $ noExprInfo) <$> reify (a, b')+          | visible a, not (domIsFinite a) -> uncurry (A.Fun $ noExprInfo) <$> reify (a, b')             -- Andreas, 2013-11-11 Hidden/Instance I.Pi must be A.Pi             -- since (a) the syntax {A} -> B or {{A}} -> B is not legal             -- and (b) the name of the binder might matter.             -- See issue 951 (a) and 952 (b).+            --+            -- Amy, 2022-09-05: Can't be finite either, since otherwise+            -- we say ".(IsOne φ) → A ≠ .(IsOne φ) → A" with no+            -- indication of which is finite and which isn't           | otherwise   -> mkPi b =<< reify a         b               -> mkPi b =<< do           ifM (domainFree a (absBody b))             {- then -} (pure $ Arg (domInfo a) underscore)             {- else -} (reify a)       where-        mkPi b (Arg info a') = do-          tac <- traverse reify $ domTactic a+        mkPi b (Arg info a') = ifM (skipGeneralizedParameter info) (snd <$> reify b) $ do+          tac <- TacticAttribute <$> do traverse (Ranged noRange <.> reify) $ domTactic a           (x, b) <- reify b           let xs = singleton $ Arg info $ Named (domName a) $ mkBinder_ x-          return $ A.Pi noExprInfo (singleton $ TBind noRange tac xs a') b+          return $ A.Pi noExprInfo+            (singleton $ TBind noRange (TypedBindingInfo tac (domIsFinite a)) xs a')+            b         -- We can omit the domain type if it doesn't have any free variables         -- and it's mentioned in the target type.         domainFree a b = do           df <- asksTC envPrintDomainFreePi           return $ df && freeIn 0 b && closed a +        skipGeneralizedParameter :: MonadReify m => ArgInfo -> m Bool+        skipGeneralizedParameter info = (not <$> showGeneralizedArguments) <&> (&& (argInfoOrigin info == Generalization))+     I.Sort s     -> reify s     I.MetaV x es -> do           x' <- reify x            es' <- reify es -          mv <- lookupMeta x+          mv <- lookupLocalMeta x           (msub1,meta_tel,msub2) <- do             local_chkpt <- viewTC eCurrentCheckpoint             (chkpt, tel, msub2) <- enterClosure mv $ \ _ ->@@ -689,21 +770,31 @@         alreadyPrinting <- viewTC ePrintingPatternLambdas          extLam <- case def of-          Function{ funExtLam = Just{}, funProjection = Just{} } -> __IMPOSSIBLE__+          Function{ funExtLam = Just{}, funProjection = Right{} } -> __IMPOSSIBLE__           Function{ funExtLam = Just (ExtLamInfo m b sys) } ->             Just . (,Strict.toLazy sys) . size <$> lookupSection m           _ -> return Nothing++        -- Amy, 2023-04-12: Don't reify clauses generated by the cubical+        -- coverage checker when printing an extended lambda. We can+        -- identify these clauses by looking for patterns headed by DefP+        -- (either transpX or hcomp associated with a data type).+        --+        -- Since these are always automatically derived, printing them+        -- is noise, and shows up even in non-cubical modules, as long+        -- as an imported extended lambda is defined cubical-compatibly.+        let insClause = hasDefP . namedClausePats         case extLam of           Just (pars, sys) | df, x `notElem` alreadyPrinting ->             locallyTC ePrintingPatternLambdas (x :) $             reifyExtLam x (defArgInfo defn) pars sys-              (defClauses defn) es+              (filter (not . insClause) (defClauses defn)) es          -- Otherwise (ordinary function call):           _ -> do            (pad, nes :: [Elim' (Named_ Term)]) <- case def of -            Function{ funProjection = Just Projection{ projIndex = np } } | np > 0 -> do+            Function{ funProjection = Right Projection{ projIndex = np } } | np > 0 -> do               reportSLn "reify.def" 70 $ "  def. is a projection with projIndex = " ++ show np                -- This is tricky:@@ -795,7 +886,7 @@       :: MonadReify m       => QName -> ArgInfo -> Int -> Maybe System -> [I.Clause]       -> I.Elims -> m Expr-    reifyExtLam x i npars msys cls es = do+    reifyExtLam x ai npars msys cls es = do       reportSLn "reify.def" 10 $ "reifying extended lambda " ++ prettyShow x       reportSLn "reify.def" 50 $ render $ nest 2 $ vcat         [ "npars =" <+> pretty npars@@ -815,13 +906,14 @@       let cx     = nameConcrete $ qnameName x           dInfo  = mkDefInfo cx noFixity' PublicAccess ConcreteDef                      (getRange x)-          erased = case getQuantity i of+          erased = case getQuantity ai of             Quantity0 o -> Erased o             Quantityω o -> NotErased o             Quantity1 o -> __IMPOSSIBLE__-      elims (A.ExtendedLam exprNoRange dInfo erased x $-             List1.fromList cls)-        =<< reify rest+          lam = case cls of+            []       -> A.AbsurdLam exprNoRange NotHidden+            (cl:cls) -> A.ExtendedLam exprNoRange dInfo erased x (cl :| cls)+      elims lam =<< reify rest  -- | @nameFirstIfHidden (x:a) ({e} es) = {x = e} es@ nameFirstIfHidden :: Dom (ArgName, t) -> [Elim' a] -> [Elim' (Named_ a)]@@ -843,8 +935,9 @@    reify (Arg info i) = Arg info <$> (flip reifyWhen i =<< condition)     where condition = (return (argInfoHiding info /= Hidden) `or2M` showImplicitArguments)-              `and2M` (return (getRelevance info /= Irrelevant) `or2M` showIrrelevantArguments)+              `and2M` (return (not $ isIrrelevant info) `or2M` showIrrelevantArguments)   reifyWhen b i = traverse (reifyWhen b) i+{-# SPECIALIZE reify :: Reify i => Arg i -> TCM (ReifiesTo (Arg i)) #-}  -- instance Reify Elim Expr where --   reifyWhen = reifyWhenE@@ -876,12 +969,14 @@   | (getOrigin <$> getNameOf a) == Just UserWritten = a   | otherwise = setNameOf Nothing a -+{-# SPECIALIZE stripImplicits :: Set Name  -> A.Patterns -> A.Patterns -> TCM A.Patterns #-} -- | Removes implicit arguments that are not needed, that is, that don't bind --   any variables that are actually used and doesn't do pattern matching. --   Doesn't strip any arguments that were written explicitly by the user.-stripImplicits :: MonadReify m => A.Patterns -> A.Patterns -> m A.Patterns-stripImplicits params ps = do+stripImplicits :: MonadReify m+  => Set Name -- ^ Variables to always include (occurs on RHS of clause)+  -> A.Patterns -> A.Patterns -> m A.Patterns+stripImplicits toKeep params ps = do   -- if --show-implicit we don't need the names   ifM showImplicitArguments (return $ map (fmap removeNameUnlessUserWritten) ps) $ do     reportSDoc "reify.implicit" 100 $ return $ vcat@@ -923,8 +1018,12 @@             , getOrigin a `notElem` [ UserWritten , CaseSplit ]             , (getOrigin <$> getNameOf a) /= Just UserWritten             , varOrDot (namedArg a)+            , not $ mustKeepVar (namedArg a)             ] +          mustKeepVar (A.VarP (A.BindName x)) = Set.member x toKeep+          mustKeepVar _                       = False+           isUnnamedHidden x = notVisible x && isNothing (getNameOf x) && isNothing (isProjP x)            stripArg a = fmap (fmap stripPat) a@@ -940,10 +1039,9 @@             p@(A.LitP _ _)      -> p             A.AsP i x p         -> A.AsP i x $ stripPat p             A.PatternSynP _ _ _ -> __IMPOSSIBLE__-            A.RecP i fs         -> A.RecP i $ map (fmap stripPat) fs  -- TODO Andreas: is this right?+            A.RecP kwr i fs     -> A.RecP kwr i $ map (fmap stripPat) fs  -- TODO Andreas: is this right?             p@A.EqualP{}        -> p -- EqualP cannot be blanked.             A.WithP i p         -> A.WithP i $ stripPat p -- TODO #2822: right?-            A.AnnP i a p        -> A.AnnP i a $ stripPat p            varOrDot A.VarP{}      = True           varOrDot A.WildP{}     = True@@ -952,11 +1050,16 @@                                  = conPatLazy cpi == ConPatLazy || all (varOrDot . namedArg) ps           varOrDot _             = False +{-# SPECIALIZE blankNotInScope :: BlankVars a => a -> TCM a #-}+{-# SPECIALIZE blankNotInScope :: Expr -> TCM Expr #-} -- | @blankNotInScope e@ replaces variables in expression @e@ with @_@ -- if they are currently not in scope.-blankNotInScope :: (MonadTCEnv m, BlankVars a) => a -> m a+blankNotInScope :: (MonadTCEnv m, MonadDebug m, BlankVars a) => a -> m a blankNotInScope e = do-  names <- Set.fromList . filter ((== C.InScope) . C.isInScope) <$> getContextNames+  ctxNames <- getContextNames+  letNames <- map fst <$> getLetBindings+  let names = Set.fromList . filter ((== C.InScope) . C.isInScope) $ ctxNames ++ letNames+  reportSDoc "reify.blank" 80 . pure $ "names in scope for blanking:" <+> pretty names   return $ blank names e  @@ -1017,10 +1120,9 @@     A.LitP _ _    -> p     A.AsP i n p   -> A.AsP i n $ blank bound p     A.PatternSynP _ _ _ -> __IMPOSSIBLE__-    A.RecP i fs   -> A.RecP i $ blank bound fs+    A.RecP kwr i fs -> A.RecP kwr i $ blank bound fs     A.EqualP{}    -> p     A.WithP i p   -> A.WithP i (blank bound p)-    A.AnnP i a p  -> A.AnnP i (blank bound a) (blank bound p)  instance BlankVars A.Expr where   blank bound e = case e of@@ -1045,9 +1147,8 @@     A.Generalized {}         -> __IMPOSSIBLE__     A.Fun i a b              -> uncurry (A.Fun i) $ blank bound (a, b)     A.Let _ _ _              -> __IMPOSSIBLE__-    A.Rec i es               -> A.Rec i $ blank bound es-    A.RecUpdate i e es       -> uncurry (A.RecUpdate i) $ blank bound (e, es)-    A.ETel _                 -> __IMPOSSIBLE__+    A.Rec kwr i es           -> A.Rec kwr i $ blank bound es+    A.RecUpdate kwr i e es   -> uncurry (A.RecUpdate kwr i) $ blank bound (e, es)     A.Quote {}               -> __IMPOSSIBLE__     A.QuoteTerm {}           -> __IMPOSSIBLE__     A.Unquote {}             -> __IMPOSSIBLE__@@ -1101,13 +1202,12 @@     A.AbsurdP{}         -> empty     A.LitP{}            -> empty     A.PatternSynP _ _ _ -> empty-    A.RecP _ _          -> empty+    A.RecP _ _ _        -> empty     A.EqualP{}          -> empty     A.WithP _ _         -> empty-    A.AnnP{}            -> empty  instance Binder a => Binder (A.Binder' a) where-  varsBoundIn (A.Binder p n) = varsBoundIn (p, n)+  varsBoundIn (A.Binder p _ n) = varsBoundIn (p, n)  instance Binder A.LamBinding where   varsBoundIn (A.DomainFree _ x) = varsBoundIn x@@ -1120,12 +1220,12 @@ instance Binder BindName where   varsBoundIn x = singleton (unBind x) -instance Binder LetBinding where+instance Binder A.LetBinding where   varsBoundIn (LetBind _ _ x _ _) = varsBoundIn x+  varsBoundIn (LetAxiom _ _ x _)  = varsBoundIn x   varsBoundIn (LetPatBind _ p _)  = varsBoundIn p   varsBoundIn LetApply{}          = empty   varsBoundIn LetOpen{}           = empty-  varsBoundIn LetDeclaredVariable{} = empty  instance Binder a => Binder (FieldAssignment' a) instance Binder a => Binder (Arg a)@@ -1137,7 +1237,7 @@ instance (Binder a, Binder b) => Binder (a, b) where   varsBoundIn (x, y) = varsBoundIn x `Set.union` varsBoundIn y -+{-# SPECIALIZE reifyPatterns :: [NamedArg I.DeBruijnPattern] -> TCM [NamedArg A.Pattern] #-} -- | Assumes that pattern variables have been added to the context already. --   Picks pattern variable names from context. reifyPatterns :: MonadReify m => [NamedArg I.DeBruijnPattern] -> m [NamedArg A.Pattern]@@ -1220,6 +1320,7 @@     reifyDotP o v = do       keepVars <- optKeepPatternVariables <$> pragmaOptions       if | PatOVar x <- o , keepVars       -> return $ A.VarP $ mkBindName x+         | PatOSplitArg x <- o , keepVars  -> A.VarP . mkBindName <$> freshName noRange x          | otherwise                       -> A.DotP patNoRange <$> reify v      reifyConP :: MonadReify m@@ -1236,7 +1337,7 @@     addAsBindings :: Functor m => [A.Name] -> m A.Pattern -> m A.Pattern     addAsBindings xs p = foldr (fmap . AsP patNoRange . mkBindName) p xs -+{-# SPECIALIZE tryRecPFromConP :: A.Pattern -> TCM A.Pattern #-} -- | If the record constructor is generated or the user wrote a record pattern, --   turn constructor pattern into record pattern. --   Otherwise, keep constructor pattern.@@ -1250,14 +1351,15 @@           -- If the record constructor is generated or the user wrote a record pattern,           -- print record pattern.           -- Otherwise, print constructor pattern.-          if recNamedCon def && conPatOrigin ci /= ConORec then fallback else do-            fs <- fromMaybe __IMPOSSIBLE__ <$> getRecordFieldNames_ r+          if _recNamedCon def && conPatOrigin ci /= ConORec then fallback else do+            let fs = recordFieldNames def             unless (length fs == length ps) __IMPOSSIBLE__-            return $ A.RecP patNoRange $ zipWith mkFA fs ps+            return $ A.RecP empty ci $ zipWith mkFA fs ps         where           mkFA ax nap = FieldAssignment (unDom ax) (namedArg nap)     _ -> __IMPOSSIBLE__ +{-# SPECIALIZE recOrCon :: QName -> ConOrigin -> [Arg Expr] -> TCM A.Expr #-} -- | If the record constructor is generated or the user wrote a record expression, --   turn constructor expression into record expression. --   Otherwise, keep constructor expression.@@ -1268,10 +1370,10 @@     -- If the record constructor is generated or the user wrote a record expression,     -- print record expression.     -- Otherwise, print constructor expression.-    if recNamedCon def && co /= ConORec then fallback else do-      fs <- fromMaybe __IMPOSSIBLE__ <$> getRecordFieldNames_ r+    if _recNamedCon def && co /= ConORec then fallback else do+      let fs = recordFieldNames def       unless (length fs == length es) __IMPOSSIBLE__-      return $ A.Rec empty $ zipWith mkFA fs es+      return $ A.Rec empty empty $ zipWith mkFA fs es   where   fallback = apps (A.Con (unambiguous c)) es   mkFA ax  = Left . FieldAssignment (unDom ax) . unArg@@ -1279,7 +1381,7 @@ instance Reify (QNamed I.Clause) where   type ReifiesTo (QNamed I.Clause) = A.Clause -  reify (QNamed f cl) = reify (NamedClause f True cl)+  reify (QNamed f cl) = reify (NamedClause f True cl); {-# INLINE reify #-}  instance Reify NamedClause where   type ReifiesTo NamedClause = A.Clause@@ -1291,6 +1393,21 @@       , "  toDrop =" <+> pshow toDrop       , "  cl     =" <+> pretty cl       ]++    let clBody = clauseBody cl+        rhsVars = maybe [] freeVars clBody++    rhsBody     <- traverse reify clBody+    rhsVarNames <- mapM nameOfBV' rhsVars+    let rhsUsedNames = maybe mempty allUsedNames rhsBody+        rhsUsedVars  = [i | (i, Just n) <- zip rhsVars rhsVarNames, n `Set.member` rhsUsedNames]++    reportSDoc "reify.clause" 60 $ return $ "RHS:" <+> pretty clBody+    reportSDoc "reify.clause" 60 $ return $ "variables occurring on RHS:" <+> pretty rhsVars+      <+> "variable names:" <+> pretty rhsVarNames+      <+> parens (maybe "no clause body" (const "there was a clause body") clBody)+    reportSDoc "reify.clause" 60 $ return $ "names occurring on RHS" <+> pretty (Set.toList rhsUsedNames)+     let ell = clauseEllipsis cl     ps  <- reifyPatterns $ namedClausePats cl     lhs <- uncurry (SpineLHS $ empty { lhsEllipsis = ell }) <$> reifyDisplayFormP f ps []@@ -1303,20 +1420,17 @@         Left _  -> return 0         Right m -> size <$> lookupSection m       return $ splitParams nfv lhs-    lhs <- stripImps params lhs-    reportSDoc "reify.clause" 100 $ return $ "reifying NamedClause, lhs =" <?> pshow lhs-    rhs <- caseMaybe (clauseBody cl) (return AbsurdRHS) $ \ e ->-      RHS <$> reify e <*> pure Nothing-    reportSDoc "reify.clause" 100 $ return $ "reifying NamedClause, rhs =" <?> pshow rhs-    let result = A.Clause (spineToLhs lhs) [] rhs A.noWhereDecls (I.clauseCatchall cl)-    reportSDoc "reify.clause" 100 $ return $ "reified NamedClause, result =" <?> pshow result+    lhs <- stripImps rhsUsedNames params lhs+    let rhs    = caseMaybe rhsBody AbsurdRHS $ \ e -> RHS e Nothing+        result = A.Clause (spineToLhs lhs) [] rhs A.noWhereDecls (I.clauseCatchall cl)     return result     where       splitParams n (SpineLHS i f ps) =         let (params , pats) = splitAt n ps         in  (params , SpineLHS i f pats)-      stripImps :: MonadReify m => [NamedArg A.Pattern] -> SpineLHS -> m SpineLHS-      stripImps params (SpineLHS i f ps) =  SpineLHS i f <$> stripImplicits params ps+      stripImps :: MonadReify m => Set Name -> [NamedArg A.Pattern] -> SpineLHS -> m SpineLHS+      stripImps rhsUsedNames params (SpineLHS i f ps) =  SpineLHS i f <$> stripImplicits rhsUsedNames params ps+{-# SPECIALIZE reify :: NamedClause -> TCM (ReifiesTo NamedClause) #-}  instance Reify (QNamed System) where   type ReifiesTo (QNamed System) = [A.Clause]@@ -1326,63 +1440,61 @@     view <- intervalView'     unview <- intervalUnview'     sys <- flip filterM sys $ \ (phi,t) -> do-      allM phi $ \ (u,b) -> do+      forallM phi $ \ (u,b) -> do         u <- reduce u         return $ case (view u, b) of           (IZero, True) -> False           (IOne, False) -> False           _ -> True     forM sys $ \ (alpha,u) -> do-      rhs <- RHS <$> reify u <*> pure Nothing-      ep <- fmap (A.EqualP patNoRange) . forM alpha $ \ (phi,b) -> do-        let-            d True = unview IOne-            d False = unview IZero-        reify (phi, d b)-       ps <- reifyPatterns $ teleNamedArgs tel-      ps <- stripImplicits [] $ ps ++ [defaultNamedArg ep]-      let-        lhs = SpineLHS empty f ps-        result = A.Clause (spineToLhs lhs) [] rhs A.noWhereDecls False-      return result+      ps <- List1.ifNull alpha (pure ps) {-else-} \ alpha -> do+        ep <- fmap (A.EqualP patNoRange) . forM alpha $ \ (phi,b) -> do+          let+              d True = unview IOne+              d False = unview IZero+          reify (phi, d b)+        pure $ ps ++ [defaultNamedArg ep] -instance Reify Type where-    type ReifiesTo Type = Expr+      lhs <- SpineLHS empty f <$> stripImplicits mempty [] ps+      rhs <- reify u <&> (`RHS` Nothing)+      return $ A.Clause (spineToLhs lhs) [] rhs A.noWhereDecls empty+{-# SPECIALIZE reify :: QNamed System -> TCM (ReifiesTo (QNamed System)) #-} -    reifyWhen = reifyWhenE-    reify (I.El _ t) = reify t+instance Reify I.Type where+    type ReifiesTo I.Type = A.Type +    reifyWhen = reifyWhenE; {-# INLINE reifyWhen #-}+    reify (I.El _ t) = reify t; {-# INLINE reify #-}+ instance Reify Sort where     type ReifiesTo Sort = Expr      reifyWhen = reifyWhenE+     reify s = do       s <- instantiateFull s-      SortKit{..} <- sortKit+      SortKit{..} <- infallibleSortKit       case s of-        I.Type (I.ClosedLevel 0) -> return $ A.Def' nameOfSet A.NoSuffix-        I.Type (I.ClosedLevel n) -> return $ A.Def' nameOfSet (A.Suffix n)-        I.Type a -> do-          a <- reify a-          return $ A.App defaultAppInfo_ (A.Def nameOfSet) (defaultNamedArg a)-        I.Prop (I.ClosedLevel 0) -> return $ A.Def' nameOfProp A.NoSuffix-        I.Prop (I.ClosedLevel n) -> return $ A.Def' nameOfProp (A.Suffix n)-        I.Prop a -> do-          a <- reify a-          return $ A.App defaultAppInfo_ (A.Def nameOfProp) (defaultNamedArg a)-        I.Inf f 0 -> return $ A.Def' (nameOfSetOmega f) A.NoSuffix-        I.Inf f n -> return $ A.Def' (nameOfSetOmega f) (A.Suffix n)-        I.SSet a  -> do-          I.Def sset [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinStrictSet+        I.Univ u (I.ClosedLevel 0) -> return $ A.Def' (nameOfUniv USmall u) A.NoSuffix+        I.Univ u (I.ClosedLevel n) -> return $ A.Def' (nameOfUniv USmall u) (A.Suffix n)+        I.Univ u a -> do           a <- reify a-          return $ A.App defaultAppInfo_ (A.Def sset) (defaultNamedArg a)+          return $ A.App defaultAppInfo_ (A.Def $ nameOfUniv USmall u) (defaultNamedArg a)+        I.Inf u 0 -> return $ A.Def' (nameOfUniv ULarge u) A.NoSuffix+        I.Inf u n -> return $ A.Def' (nameOfUniv ULarge u) (A.Suffix n)         I.SizeUniv  -> do-          I.Def sizeU [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSizeUniv+          sizeU <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSizeUniv           return $ A.Def sizeU         I.LockUniv  -> do           lockU <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinLockUniv           return $ A.Def lockU+        I.LevelUniv -> do+          levelU <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinLevelUniv+          return $ A.Def levelU+        I.IntervalUniv -> do+          intervalU <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinIntervalUniv+          return $ A.Def intervalU         I.PiSort a s1 s2 -> do           pis <- freshName_ ("piSort" :: String) -- TODO: hack           (e1,e2) <- reify (s1, I.Lam defaultArgInfo $ fmap Sort s2)@@ -1400,6 +1512,7 @@         I.MetaS x es -> reify $ I.MetaV x es         I.DefS d es -> reify $ I.Def d es         I.DummyS s -> return $ A.Lit empty $ LitString $ T.pack s+{-# SPECIALIZE reify :: Sort -> TCM (ReifiesTo Sort) #-}  instance Reify Level where   type ReifiesTo Level = Expr@@ -1411,6 +1524,7 @@     -- available for debug printing.  Thus, print some garbage instead.     name <- freshName_ (".#Lacking_Level_Builtins#" :: String)     return $ A.Var name+{-# SPECIALIZE reify :: Level -> TCM (ReifiesTo Level) #-}  instance (Free i, Reify i) => Reify (Abs i) where   type ReifiesTo (Abs i) = (Name, ReifiesTo i)@@ -1426,6 +1540,7 @@     e <- addContext x -- type doesn't matter          $ reify v     return (x,e)+{-# SPECIALIZE reify :: (Free i, Reify i) -> Abs i -> TCM (ReifiesTo (Abs i)) #-}  instance Reify I.Telescope where   type ReifiesTo I.Telescope = A.Telescope@@ -1436,15 +1551,29 @@     (x, bs)  <- reify tel     let r    = getRange e         name = domName arg-    tac <- traverse reify $ domTactic arg+    tac <- TacticAttribute <$> do traverse (Ranged noRange <.> reify) $ domTactic arg     let xs = singleton $ Arg info $ Named name $ A.mkBinder_ x-    return $ TBind r tac xs e : bs+    return $ TBind r (TypedBindingInfo tac (domIsFinite arg)) xs e : bs+{-# SPECIALIZE reify :: I.Telescope -> TCM (ReifiesTo I.Telescope) #-}  instance Reify i => Reify (Dom i) where     type ReifiesTo (Dom i) = Arg (ReifiesTo i)      reify (Dom{domInfo = info, unDom = i}) = Arg info <$> reify i+    {-# INLINE reify #-} ++instance Reify ContextEntry where+  type ReifiesTo ContextEntry = A.TypedBinding++  reify (CtxVar x a) = do+    Arg info (y,t) <- reify $ (x,) <$> a+    let r = getRange x+        name = domName a+        xs = singleton $ Arg info $ Named name $ A.mkBinder_ y+    tac <- TacticAttribute <$> do traverse (Ranged noRange <.> reify) $ domTactic a+    return $ TBind r (TypedBindingInfo tac (domIsFinite a)) xs t+ instance Reify i => Reify (I.Elim' i)  where   type ReifiesTo (I.Elim' i) = I.Elim' (ReifiesTo i) @@ -1453,6 +1582,12 @@  instance Reify i => Reify [i] where   type ReifiesTo [i] = [ReifiesTo i]++  reify = traverse reify+  reifyWhen b = traverse (reifyWhen b)++instance Reify i => Reify (List1 i) where+  type ReifiesTo (List1 i) = List1 (ReifiesTo i)    reify = traverse reify   reifyWhen b = traverse (reifyWhen b)
src/full/Agda/Syntax/Translation/ReflectedToAbstract.hs view
@@ -17,7 +17,11 @@ import Agda.Syntax.Position import Agda.Syntax.Info import Agda.Syntax.Common-import Agda.Syntax.Abstract as A hiding (Apply)+import Agda.Syntax.Abstract+  ( Name, QName, QNamed(QNamed)+  , isNoName, nameConcrete, nextName, qualify, unambiguous+  )+import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Pattern import Agda.Syntax.Reflected as R import Agda.Syntax.Internal (Dom,Dom'(..))@@ -33,7 +37,7 @@ import Agda.Utils.List1 (List1, pattern (:|)) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Null-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.Functor import Agda.Utils.Singleton import Agda.Utils.Size@@ -65,7 +69,7 @@   let freshNameMode = case glyphMode of         UnicodeOk -> A.UnicodeSubscript         AsciiOnly -> A.AsciiCounter-  let name' = head $ filter (notTaken ctx) $ iterate (nextName freshNameMode) name+  let name' = headWithDefault __IMPOSSIBLE__ $ filter (notTaken ctx) $ iterate (nextName freshNameMode) name   local ((name,t):) $ f name'   where     notTaken xs x = isNoName x || nameConcrete x `notElem` xs@@ -119,7 +123,7 @@   , HasConstInfo m   ) => r -> m (AbsOfRef r) toAbstractWithoutImplicit x = do-  xs <- killRange <$> getContextNames+  xs <- killRange <$> getContextNames'   let ctx = zip xs $ repeat R.Unknown   runReaderT (toAbstract x) ctx @@ -133,37 +137,42 @@ instance ToAbstract r => ToAbstract [Arg r] where   type AbsOfRef [Arg r] = [NamedArg (AbsOfRef r)] --- instance ToAbstract r Expr => ToAbstract (Dom r, Name) (A.TypedBinding) where-instance (ToAbstract r, AbsOfRef r ~ Expr) => ToAbstract (Dom r, Name) where+-- instance ToAbstract r A.Expr => ToAbstract (Dom r, Name) (A.TypedBinding) where+instance (ToAbstract r, AbsOfRef r ~ A.Expr) => ToAbstract (Dom r, Name) where   type AbsOfRef (Dom r, Name) = A.TypedBinding-  toAbstract (Dom{domInfo = i,unDom = x, domTactic = tac}, name) = do+  toAbstract (Dom{domInfo = i, domIsFinite = isfin, unDom = x, domTactic = tac}, name) = do     dom <- toAbstract x-    return $ mkTBind noRange (singleton $ unnamedArg i $ mkBinder_ name) dom+    -- TODO(Amy): Anyone know why this discards the tactic? It was like+    -- that when I got here!+    return $ A.TBind noRange+      (A.TypedBindingInfo empty isfin)+      (singleton $ unnamedArg i $ A.mkBinder_ name)+      dom -instance ToAbstract (Expr, Elim) where-  type AbsOfRef (Expr, Elim) = Expr+instance ToAbstract (A.Expr, Elim) where+  type AbsOfRef (A.Expr, Elim) = A.Expr   toAbstract (f, Apply arg) = do     arg     <- toAbstract arg     showImp <- showImplicitArguments     return $ if showImp || visible arg-             then App (setOrigin Reflected defaultAppInfo_) f arg+             then A.App (setOrigin Reflected defaultAppInfo_) f arg              else f -instance ToAbstract (Expr, Elims) where-  type AbsOfRef (Expr, Elims) = Expr+instance ToAbstract (A.Expr, Elims) where+  type AbsOfRef (A.Expr, Elims) = A.Expr   toAbstract (f, elims) = foldM (curry toAbstract) f elims  instance ToAbstract r => ToAbstract (R.Abs r) where   type AbsOfRef (R.Abs r) = (AbsOfRef r, Name)-  toAbstract (Abs s x) = withName s' $ \name -> (,) <$> toAbstract x <*> return name+  toAbstract (Abs s x) = withName s' $ \name -> (,name) <$> toAbstract x     where s' = if (isNoName s) then "z" else s -- TODO: only do this when var is free  instance ToAbstract Literal where-  type AbsOfRef Literal = Expr+  type AbsOfRef Literal = A.Expr   toAbstract l = return $ A.Lit empty l  instance ToAbstract Term where-  type AbsOfRef Term = Expr+  type AbsOfRef Term = A.Expr   toAbstract = \case     R.Var i es -> do       name <- mkVarName i@@ -175,7 +184,7 @@     R.Lam h t  -> do       (e, name) <- toAbstract t       let info  = setHiding h $ setOrigin Reflected defaultArgInfo-      return $ A.Lam exprNoRange (mkDomainFree $ unnamedArg info $ mkBinder_ name) e+      return $ A.Lam exprNoRange (A.mkDomainFree $ unnamedArg info $ A.mkBinder_ name) e     R.ExtLam cs es -> do       name <- freshName_ extendedLambdaName       m    <- getCurrentModule@@ -195,7 +204,7 @@       info <- mkMetaInfo       let info' = info{ metaNumber = Just x }       toAbstract (A.Underscore info', es)-    R.Unknown      -> Underscore <$> mkMetaInfo+    R.Unknown      -> A.Underscore <$> mkMetaInfo  mkMetaInfo :: ReadTCState m => m MetaInfo mkMetaInfo = do@@ -203,15 +212,23 @@   return $ emptyMetaInfo { metaScope = scope }  mkDef :: HasConstInfo m => QName -> m A.Expr-mkDef f =-  ifM (isMacro . theDef <$> getConstInfo f)-      (return $ A.Macro f)-      (return $ A.Def f)+mkDef f = getConstInfo f <&> theDef <&> \case -mkApp :: Expr -> Expr -> Expr-mkApp e1 e2 = App (setOrigin Reflected defaultAppInfo_) e1 $ defaultNamedArg e2+  Constructor{}+    -> A.Con $ unambiguous f +  Function{ funProjection = Right Projection{ projProper = Just{} } }+    -> A.Proj ProjSystem $ unambiguous f +  d@Function{} | isMacro d+    -> A.Macro f++  _ -> A.Def f++mkApp :: A.Expr -> A.Expr -> A.Expr+mkApp e1 e2 = A.App (setOrigin Reflected defaultAppInfo_) e1 $ defaultNamedArg e2++ mkVar :: MonadReflectedToAbstract m => Int -> m (Name, R.Type) mkVar i = ifJustM (askVar i) return $ do   cxt   <- getContextTelescope@@ -221,14 +238,9 @@ mkVarName :: MonadReflectedToAbstract m => Int -> m Name mkVarName i = fst <$> mkVar i -annotatePattern :: MonadReflectedToAbstract m => Int -> R.Type -> A.Pattern -> m A.Pattern-annotatePattern _ R.Unknown p = return p-annotatePattern i t p = local (drop $ i + 1) $ do-  t <- toAbstract t  -- go into the right context for translating the type-  return $ A.AnnP patNoRange t p  instance ToAbstract Sort where-  type AbsOfRef Sort = Expr+  type AbsOfRef Sort = A.Expr   toAbstract s = do     setName <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSet     propName <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinProp@@ -239,7 +251,7 @@       PropS x -> mkApp (A.Def propName) <$> toAbstract x       PropLitS x -> return $ A.Def' propName $ A.Suffix x       InfS x -> return $ A.Def' infName $ A.Suffix x-      UnknownS -> mkApp (A.Def setName) . Underscore <$> mkMetaInfo+      UnknownS -> mkApp (A.Def setName) . A.Underscore <$> mkMetaInfo  instance ToAbstract R.Pattern where   type AbsOfRef R.Pattern = A.Pattern@@ -249,12 +261,10 @@       return $ A.ConP (ConPatInfo ConOCon patNoRange ConPatEager) (unambiguous $ killRange c) args     R.DotP t -> A.DotP patNoRange <$> toAbstract t     R.VarP i -> do-      (x, t) <- mkVar i-      annotatePattern i t $ A.VarP $ mkBindName x+      (x, _t) <- mkVar i+      return $ A.VarP $ A.mkBindName x     R.LitP l  -> return $ A.LitP patNoRange l-    R.AbsurdP i -> do-      (_, t) <- mkVar i-      annotatePattern i t $ A.AbsurdP patNoRange+    R.AbsurdP _i -> return $ A.AbsurdP patNoRange     R.ProjP d -> return $ A.ProjP patNoRange ProjSystem $ unambiguous $ killRange d  instance ToAbstract (QNamed R.Clause) where@@ -264,13 +274,13 @@     checkClauseTelescopeBindings tel pats     pats <- toAbstract pats     rhs  <- toAbstract rhs-    let lhs = spineToLhs $ SpineLHS empty name pats-    return $ A.Clause lhs [] (RHS rhs Nothing) noWhereDecls False+    let lhs = spineToLhs $ A.SpineLHS empty name pats+    return $ A.Clause lhs [] (A.RHS rhs Nothing) A.noWhereDecls empty   toAbstract (QNamed name (R.AbsurdClause tel pats)) = withVars (map (Text.unpack *** unArg) tel) $ \_ -> do     checkClauseTelescopeBindings tel pats     pats <- toAbstract pats-    let lhs = spineToLhs $ SpineLHS empty name pats-    return $ A.Clause lhs [] AbsurdRHS noWhereDecls False+    let lhs = spineToLhs $ A.SpineLHS empty name pats+    return $ A.Clause lhs [] A.AbsurdRHS A.noWhereDecls empty  instance ToAbstract [QNamed R.Clause] where   type AbsOfRef [QNamed R.Clause] = [A.Clause]@@ -289,11 +299,11 @@ checkClauseTelescopeBindings tel pats =   case reverse [ x | ((x, _), i) <- zip (reverse tel) [0..], not $ Set.member i bs ] of     [] -> return ()-    xs -> genericDocError $ ("Missing bindings for telescope variable" <> s) <?>-                              (fsep (punctuate ", " $ map (text . Text.unpack) xs) <> ".") $$-                             "All variables in the clause telescope must be bound in the left-hand side."-      where s | length xs == 1 = empty-              | otherwise      = "s"+    xs -> genericDocError $ vcat+      [ fsep (pwords "Missing bindings for telescope" ++ [ pluralS xs "variable" ])+        <?> (fsep (punctuate ", " $ map (text . Text.unpack) xs) <> ".")+      , "All variables in the clause telescope must be bound in the left-hand side."+      ]   where     bs = boundVars pats
src/full/Agda/Syntax/Treeless.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE PatternSynonyms #-}  -- | The treeless syntax is intended to be used as input for the compiler backends.@@ -14,7 +16,6 @@ import Control.Arrow (first, second) import Control.DeepSeq -import Data.Data (Data) import Data.Word  import GHC.Generics (Generic)@@ -29,13 +30,13 @@   , cArgUsage :: Maybe [ArgUsage]       -- ^ 'Nothing' if treeless usage analysis has not run yet.   }-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  -- | Usage status of function arguments in treeless code. data ArgUsage   = ArgUsed   | ArgUnused-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  -- | The treeless compiler can behave differently depending on the target --   language evaluation strategy. For instance, more aggressive erasure for@@ -48,7 +49,7 @@ -- this currently assumes that TApp is translated in a lazy/cbn fashion. -- The AST should also support strict translation. ----- All local variables are using de Bruijn indices.+-- | Treeless Term. All local variables are using de Bruijn indices. data TTerm = TVar Int            | TPrim TPrim            | TDef QName@@ -57,7 +58,7 @@            | TLit Literal            | TCon QName            | TLet TTerm TTerm-           -- ^ introduces a new local binding. The bound term+           -- ^ introduces a new (non-recursive) local binding. The bound term            -- MUST only be evaluated if it is used inside the body.            -- Sharing may happen, but is optional.            -- It is also perfectly valid to just inline the bound term in the body.@@ -72,7 +73,7 @@            | TCoerce TTerm  -- ^ Used by the GHC backend            | TError TError            -- ^ A runtime error, something bad has happened.-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  -- | Compiler-related primitives. This are NOT the same thing as primitives -- in Agda's surface or internal syntax!@@ -100,7 +101,7 @@   | PIf   | PSeq   | PITo64 | P64ToI-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  isPrimEq :: TPrim -> Bool isPrimEq p = p `elem` [PEqI, PEqF, PEqS, PEqC, PEqQ, PEq64]@@ -195,21 +196,22 @@ tIfThenElse c i e = TApp (TPrim PIf) [c, i, e]  data CaseType-  = CTData Quantity QName-    -- Case on datatype. The 'Quantity' is zero for matches on erased-    -- arguments.+  = CTData QName+    -- Case on datatype.   | CTNat   | CTInt   | CTChar   | CTString   | CTFloat   | CTQName-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  data CaseInfo = CaseInfo   { caseLazy :: Bool+  , caseErased :: Erased+    -- ^ Is this a match on an erased argument?   , caseType :: CaseType }-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  data TAlt   = TACon    { aCon  :: QName, aArity :: Int, aBody :: TTerm }@@ -218,8 +220,11 @@   -- (pushes all existing variables aArity steps further away)   | TAGuard  { aGuard :: TTerm, aBody :: TTerm }   -- ^ Binds no variables+  --+  -- The guard must only use the variable that the case expression+  -- matches on.   | TALit    { aLit :: Literal,   aBody:: TTerm }-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  data TError   = TUnreachable@@ -231,7 +236,7 @@   -- ^ Code which could not be obtained because of a hole in the program.   -- This should throw a runtime error.   -- The string gives some information about the meta variable that got compiled.-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)   class Unreachable a where
src/full/Agda/Termination/CallGraph.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE CPP                        #-}+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE ImplicitParams             #-}  -- | Call graphs and related concepts, more or less as defined in@@ -26,9 +27,6 @@ import Prelude hiding (null)  import qualified Data.List as List-#if __GLASGOW_HASKELL__ < 804-import Data.Semigroup-#endif import Data.Set (Set)  import Agda.Termination.CallMatrix (CallMatrix, CallMatrixAug(..), CMSet(..), CallComb(..))@@ -44,7 +42,7 @@  import Agda.Utils.Null import Agda.Utils.PartialOrd-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.Singleton import Agda.Utils.Tuple
src/full/Agda/Termination/CallMatrix.hs view
@@ -1,5 +1,6 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE ImplicitParams             #-}-{-# LANGUAGE CPP                        #-}  module Agda.Termination.CallMatrix where @@ -10,9 +11,6 @@ --   , tests --   ) where -#if __GLASGOW_HASKELL__ < 804-import Data.Semigroup-#endif  import Agda.Termination.CutOff import Agda.Termination.Order as Order@@ -24,7 +22,7 @@  import Agda.Utils.Null import Agda.Utils.PartialOrd-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.Singleton  ------------------------------------------------------------------------
src/full/Agda/Termination/CutOff.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Defines 'CutOff' type which is used in "Agda.Interaction.Options". --   This module's purpose is to eliminate the dependency of
src/full/Agda/Termination/Monad.hs view
@@ -11,14 +11,14 @@  import Control.Applicative hiding (empty) -import qualified Control.Monad.Fail as Fail--import Control.Monad          ( forM ) import Control.Monad.IO.Class ( MonadIO(..) )-import Control.Monad.Except-import Control.Monad.Reader+import Control.Monad.Except   ( MonadError(..) )+import Control.Monad.Reader   ( MonadReader(..), ReaderT(..) ) +import Data.DList (DList)+import qualified Data.DList as DL import Data.Semigroup ( Semigroup(..) )+import Data.Set (Set) import qualified Data.Set as Set  import Agda.Interaction.Options (optTerminationDepth)@@ -27,11 +27,10 @@ import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern import Agda.Syntax.Literal-import Agda.Syntax.Position (noRange)  import Agda.Termination.CutOff import Agda.Termination.Order (Order,le,unknown)-import Agda.Termination.RecCheck (anyDefs)+import Agda.Termination.RecCheck (MutualNames, anyDefs)  import Agda.TypeChecking.Monad import Agda.TypeChecking.Monad.Benchmark@@ -49,23 +48,23 @@ import Agda.Utils.Monad import Agda.Utils.Monoid import Agda.Utils.Null-import Agda.Utils.Pretty (Pretty, prettyShow)-import qualified Agda.Utils.Pretty as P+import Agda.Syntax.Common.Pretty (Pretty, prettyShow)+import qualified Agda.Syntax.Common.Pretty as P import Agda.Utils.VarSet (VarSet) import qualified Agda.Utils.VarSet as VarSet  import Agda.Utils.Impossible --- | The mutual block we are checking.------   The functions are numbered according to their order of appearance---   in this list.--type MutualNames = [QName]- -- | The target of the function we are checking. -type Target = QName+data Target+  = TargetDef QName+      -- ^ The target of recursion is a @record@, @data@, or unreducible @Def@.+  | TargetRecord+      -- ^ We are termination-checking a record.+  | TargetOther+      -- ^ None of the above two or unknown.+  deriving (Eq, Show)  -- | The current guardedness level. @@ -94,17 +93,15 @@     -- ^ The names of the functions in the mutual block we are checking.     --   This includes the internally generated functions     --   (with, extendedlambda, coinduction).-  , terUserNames :: [QName]+  , terUserNames :: Set QName     -- ^ The list of name actually appearing in the file (abstract syntax).     --   Excludes the internally generated functions.   , terHaveInlinedWith :: Bool     -- ^ Does the actual clause result from with-inlining?     --   (If yes, it may be ill-typed.)-  , terTarget  :: Maybe Target+  , terTarget  :: Target     -- ^ Target type of the function we are currently termination checking.     --   Only the constructors of 'Target' are considered guarding.-  , terDelayed :: Delayed-    -- ^ Are we checking a delayed definition?   , terMaskArgs :: [Bool]     -- ^ Only consider the 'notMasked' 'False' arguments for establishing termination.     --   See issue #1023.@@ -153,8 +150,7 @@   , terMutual                   = __IMPOSSIBLE__ -- needs to be set!   , terCurrent                  = __IMPOSSIBLE__ -- needs to be set!   , terHaveInlinedWith          = False-  , terTarget                   = Nothing-  , terDelayed                  = NotDelayed+  , terTarget                   = TargetOther   , terMaskArgs                 = repeat False   -- use all arguments (mask none)   , terMaskResult               = False          -- use result (do not mask)   , _terSizeDepth               = __IMPOSSIBLE__ -- needs to be set!@@ -180,7 +176,6 @@   deriving ( Functor            , Applicative            , Monad-           , Fail.MonadFail            , MonadError TCErr            , MonadStatistics            , HasOptions@@ -279,13 +274,13 @@ terGetMutual :: TerM MutualNames terGetMutual = terAsks terMutual -terGetUserNames :: TerM [QName]+terGetUserNames :: TerM (Set QName) terGetUserNames = terAsks terUserNames -terGetTarget :: TerM (Maybe Target)+terGetTarget :: TerM Target terGetTarget = terAsks terTarget -terSetTarget :: Maybe Target -> TerM a -> TerM a+terSetTarget :: Target -> TerM a -> TerM a terSetTarget t = terLocal $ \ e -> e { terTarget = t }  terGetHaveInlinedWith :: TerM Bool@@ -294,12 +289,6 @@ terSetHaveInlinedWith :: TerM a -> TerM a terSetHaveInlinedWith = terLocal $ \ e -> e { terHaveInlinedWith = True } -terGetDelayed :: TerM Delayed-terGetDelayed = terAsks terDelayed--terSetDelayed :: Delayed -> TerM a -> TerM a-terSetDelayed b = terLocal $ \ e -> e { terDelayed = b }- terGetMaskArgs :: TerM [Bool] terGetMaskArgs = terAsks terMaskArgs @@ -338,7 +327,7 @@  -- | Lens for '_terSizeDepth'. -terSizeDepth :: Lens' Int TerEnv+terSizeDepth :: Lens' TerEnv Int terSizeDepth f e = f (_terSizeDepth e) <&> \ i -> e { _terSizeDepth = i }  -- | Lens for 'terUsableVars'.@@ -434,11 +423,11 @@       Just Projection{ projProper = Just{}, projFromType = Arg _ r, projIndex = n } ->         caseMaybeM (isRecord r) __IMPOSSIBLE__ $ \ rdef -> do           -- no for inductive or non-recursive record-          if recInduction rdef /= Just CoInductive then return False else do+          if _recInduction rdef /= Just CoInductive then return False else do             reportSLn "term.guardedness" 40 $ prettyShow q ++ " is coinductive; record type is " ++ prettyShow r             if not mustBeRecursive then return True else do               reportSLn "term.guardedness" 40 $ prettyShow q ++ " must be recursive"-              if not (safeRecRecursive rdef) then return False else do+              if notSafeRecRecursive rdef then return False else do                 reportSLn "term.guardedness" 40 $ prettyShow q ++ " has been declared recursive, doing actual check now..."                 -- TODO: the following test for recursiveness of a projection should be cached.                 -- E.g., it could be stored in the @Projection@ component.@@ -446,7 +435,7 @@                 -- Get the type of the field by dropping record parameters and record argument.                 let TelV tel core = telView' (defType pdef)                     (pars, tel') = splitAt n $ telToList tel-                    mut = fromMaybe __IMPOSSIBLE__ $ recMutual rdef+                    mut = fromMaybe __IMPOSSIBLE__ $ _recMutual rdef                 -- Check if any recursive symbols appear in the record type.                 -- Q (2014-07-01): Should we normalize the type?                 -- A (2017-01-13): Yes, since we also normalize during positivity check?@@ -483,9 +472,9 @@   -- that has not happened.  To avoid crashing (as in Agda 2.5.3),   -- we rather give the possibly wrong answer here,   -- restoring the behavior of Agda 2.5.2.  TODO: fix record declaration checking.-  safeRecRecursive :: Defn -> Bool-  safeRecRecursive (Record { recMutual = Just qs }) = not $ null qs-  safeRecRecursive _ = False+  notSafeRecRecursive :: RecordData -> Bool+  notSafeRecRecursive = maybe True null . _recMutual+    -- @_recMutual@ should be something (@Just (_:_)@) to be safe  -- * De Bruijn pattern stuff @@ -575,7 +564,11 @@  -- * Call pathes --- | The call information is stored as free monoid+-- | Call paths.++-- An old comment:+--+--   The call information is stored as free monoid --   over 'CallInfo'.  As long as we never look at it, --   only accumulate it, it does not matter whether we use --   'Set', (nub) list, or 'Tree'.@@ -584,16 +577,24 @@ --   Since we define no order on 'CallInfo' (expensive), --   we cannot use a 'Set' or nub list. --   Performance-wise, I could not see a difference between Set and list.+--+-- If the binary tree is balanced "incorrectly", then forcing it could+-- be expensive, so a switch was made to difference lists. -newtype CallPath = CallPath { callInfos :: [CallInfo] }+newtype CallPath = CallPath (DList CallInfo)   deriving (Show, Semigroup, Monoid) +-- | The calls making up the call path.++callInfos :: CallPath -> [CallInfo]+callInfos (CallPath cs) = DL.toList cs+ -- | Only show intermediate nodes.  (Drop last 'CallInfo'). instance Pretty CallPath where-  pretty (CallPath cis0) = if null cis then empty else+  pretty cis0 = if null cis then empty else     P.hsep (map (\ ci -> arrow P.<+> P.pretty ci) cis) P.<+> arrow     where-      cis   = init cis0+      cis   = init (callInfos cis0)       arrow = "-->"  -- * Size depth estimation@@ -601,16 +602,23 @@ -- | A very crude way of estimating the @SIZELT@ chains --   @i > j > k@ in context.  Returns 3 in this case. --   Overapproximates.+class TerSetSizeDepth b where+  terSetSizeDepth :: b -> TerM a -> TerM a +instance TerSetSizeDepth Telescope where+  terSetSizeDepth = terSetSizeDepth . telToList+ -- TODO: more precise analysis, constructing a tree -- of relations between size variables.-terSetSizeDepth :: Telescope -> TerM a -> TerM a-terSetSizeDepth tel cont = do-  n <- liftTCM $ sum <$> do-    forM (telToList tel) $ \ dom -> do-      a <- reduce $ snd $ unDom dom-      ifM (isJust <$> isSizeType a) (return 1) {- else -} $-        case unEl a of-          MetaV{} -> return 1-          _       -> return 0-  terLocal (set terSizeDepth n) cont+instance TerSetSizeDepth ListTel where+  terSetSizeDepth doms cont = do+    n <- liftTCM $ sum <$> do+      forM doms $ \ dom -> do+        -- Andreas, 2022-03-12, TODO:+        -- use ifBlocked?  Shouldn't blocked types be treated like metas?+        a <- reduce $ snd $ unDom dom+        ifM (isJust <$> isSizeType a) (return 1) {- else -} $+          case unEl a of+            MetaV{} -> return 1+            _       -> return 0+    terLocal (set terSizeDepth n) cont
src/full/Agda/Termination/Order.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE ImplicitParams    #-}  -- | An Abstract domain of relative sizes, i.e., differences@@ -26,7 +28,7 @@ import qualified Agda.Termination.Semiring as Semiring  import Agda.Utils.PartialOrd-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty  import Agda.Utils.Impossible
src/full/Agda/Termination/RecCheck.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  {- | Checking for recursion: @@ -13,30 +14,38 @@   module Agda.Termination.RecCheck-    ( recursive+    ( MutualNames+    , recursive     , anyDefs     )  where -import Control.Monad (forM, forM_)+import Control.Monad (forM)+import Data.Foldable import Data.Graph import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import qualified Data.Map as Map+import qualified Data.Map.Strict as MapS import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set  import Agda.Syntax.Internal import Agda.Syntax.Internal.Defs+import Agda.Syntax.Common.Pretty  (prettyShow)  import Agda.TypeChecking.Monad -import Agda.Utils.List    (hasElem)-import Agda.Utils.Pretty  (prettyShow)- import Agda.Utils.Impossible +-- | The mutual block we are checking.+--+--   The functions are numbered according to their order of appearance+--   in this set.++type MutualNames = Set QName+ -- | We compute for each clause the set of potentially recursive names. type NamesPerClause = IntMap (Set QName) @@ -46,16 +55,21 @@ -- --   As a side effect, update the 'clauseRecursive' field in the --   clauses belonging to the given functions.-recursive :: [QName] -> TCM [[QName]]+recursive :: Set QName -> TCM [MutualNames] recursive names = do+  let names' = toList names   -- For each function, get names per clause and total.-  (perClauses, nss) <- unzip <$> mapM (recDef (names `hasElem`)) names+  (perClauses, nss) <- unzip <$> mapM (recDef (`Set.member` names)) names'   -- Create graph suitable for stronglyConnComp.   -- Nodes are identical to node keys.-  let graph  = zipWith (\ x ns -> (x, x, Set.toList ns)) names nss+  let graph  = zipWith (\ x ns -> (x, x, Set.toList ns)) names' nss   let sccs   = stronglyConnComp graph-  let nonRec = mapMaybe (\case{ AcyclicSCC x -> Just x ; _ -> Nothing}) sccs-  let recs   = mapMaybe (\case{ CyclicSCC xs -> Just xs; _ -> Nothing}) sccs+  let nonRec = mapMaybe (\case AcyclicSCC x -> Just x+                               _            -> Nothing)+                 sccs+  let recs   = mapMaybe (\case CyclicSCC xs -> Just (Set.fromList xs)+                               _            -> Nothing)+                 sccs    reportSLn "rec.graph" 60 $ show graph @@ -65,7 +79,7 @@   -- Mark individual clauses of recursive functions:   --------------------------------------------------   -- Map names to clause numbers to sets of mentioned names.-  let clMap = Map.fromListWith __IMPOSSIBLE__ $ zip names perClauses+  let clMap = Map.fromListWith __IMPOSSIBLE__ $ zip names' perClauses   -- Walk through SCCs.   forM_ recs $ \ scc -> do     -- Does a set of names have an overlap with the current scc?@@ -88,6 +102,9 @@    { funTerminates = Just True    , funClauses    = map (\ cl -> cl { clauseRecursive = Just False }) $ funClauses def    }+  def@Record{} -> def+   { recTerminates = Just True+   }   def -> def  -- | Mark all clauses of a function as recursive or non-recursive.@@ -112,11 +129,23 @@    -- Get names in body   (perClause, ns2) <- case theDef def of+     Function{ funClauses = cls } -> do       perClause <- do         forM (zip [0..] cls) $ \ (i, cl) ->           (i,) <$> anyDefs include cl       return (IntMap.fromList perClause, mconcat $ map snd perClause)++    Datatype{ dataClause = Just cl } -> do+      ns <- anyDefs include cl+      return (IntMap.singleton 0 ns, ns)++    Record{ recClause, recTel } -> do+      ns1 <- anyDefs include recClause+      ns2 <- anyDefs include recTel+      let ns = ns1 `mappend` ns2+      return (IntMap.singleton 0 ns, ns)+     _ -> return (mempty, mempty)    reportS "rec.graph" 20@@ -131,14 +160,15 @@ anyDefs :: GetDefs a => (QName -> Bool) -> a -> TCM (Set QName) anyDefs include a = do   -- Prepare function to lookup metas outside of TCM-  st <- getMetaStore-  let lookup (MetaId x) = (mvInstantiation <$> IntMap.lookup x st) >>= \case-        InstV _ v                      -> Just v    -- TODO: ignoring the lambdas might be bad?-        Open                           -> Nothing-        OpenInstance                   -> Nothing-        BlockedConst{}                 -> Nothing-        PostponedTypeCheckingProblem{} -> Nothing+  st <- useR stSolvedMetaStore+  let lookup x = inst . mvInstantiation <$> MapS.lookup x st       -- we collect only those used definitions that are in @names@       emb d = if include d then Set.singleton d else Set.empty   -- get all the Defs that are in names   return $ getDefs' lookup emb a+  where+  -- TODO: Is it bad to ignore the lambdas?+  inst (InstV i)                      = instBody i+  inst OpenMeta{}                     = __IMPOSSIBLE__+  inst BlockedConst{}                 = __IMPOSSIBLE__+  inst PostponedTypeCheckingProblem{} = __IMPOSSIBLE__
src/full/Agda/Termination/Semiring.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Semirings.  module Agda.Termination.Semiring
src/full/Agda/Termination/SparseMatrix.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  {- | Sparse matrices. @@ -48,7 +49,7 @@   ) where  import Data.Array-import Data.Function+import Data.Function (on) import qualified Data.List as List import Data.Maybe @@ -65,7 +66,7 @@ import Agda.Utils.Maybe  import Agda.Utils.PartialOrd-import Agda.Utils.Pretty hiding (isEmpty)+import Agda.Syntax.Common.Pretty hiding (isEmpty) import Agda.Utils.Tuple  import Agda.Utils.Impossible@@ -237,7 +238,7 @@ instance (Integral i, HasZero b) => Diagonal (Matrix i b) b where   diagonal (Matrix (Size r c) m) =     blowUpSparseVec zeroElement (min r c) $-      mapMaybe (\ ((MIx i j), b) -> if i==j then Just (i,b) else Nothing) m+      mapMaybe (\ (MIx i j, b) -> if i == j then Just (i, b) else Nothing) m  -- | Transposable things. @@ -399,7 +400,7 @@       both    = comparable       -- The zero element of the result sparse matrix is the       -- neutral element of the monoid.-      trivial = (==mempty)+      trivial = (== mempty)  ------------------------------------------------------------------------ -- Modifying matrices
src/full/Agda/Termination/TermCheck.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE GADTs                      #-}  {-# LANGUAGE ImplicitParams             #-} {-# LANGUAGE NondecreasingIndentation   #-}@@ -24,6 +23,7 @@ import Data.Foldable (toList) import qualified Data.List as List import Data.Monoid hiding ((<>))+import Data.Set (Set) import qualified Data.Set as Set  import qualified Agda.Syntax.Abstract as A@@ -42,7 +42,7 @@ import Agda.Termination.CallMatrix hiding (toList) import Agda.Termination.Order     as Order import qualified Agda.Termination.SparseMatrix as Matrix-import Agda.Termination.Termination (endos, idempotent)+import Agda.Termination.Termination (Terminates(..), GuardednessHelps(..), endos, idempotent) import qualified Agda.Termination.Termination  as Term import Agda.Termination.RecCheck @@ -50,6 +50,7 @@ import Agda.TypeChecking.Functions import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Forcing import Agda.TypeChecking.Records -- (isRecordConstructor, isInductiveRecord) import Agda.TypeChecking.Reduce (reduce, normalise, instantiate, instantiateFull, appDefE') import Agda.TypeChecking.SizedTypes@@ -68,7 +69,7 @@ import Agda.Utils.Maybe import Agda.Utils.Monad -- (mapM', forM', ifM, or2M, and2M) import Agda.Utils.Null-import Agda.Utils.Pretty (prettyShow)+import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Utils.Singleton import Agda.Utils.Size import qualified Agda.Utils.SmallSet as SmallSet@@ -102,7 +103,7 @@     A.Field {}            -> return mempty     A.Primitive {}        -> return mempty     A.Mutual i ds         -> termMutual $ getNames ds-    A.Section _ _ _ ds    -> termDecls ds+    A.Section _ _ _ _ ds  -> termDecls ds         -- section structure can be ignored as we are termination checking         -- definitions lifted to the top-level     A.Apply {}            -> return mempty@@ -110,28 +111,33 @@     A.Pragma {}           -> return mempty     A.Open {}             -> return mempty     A.PatternSynDef {}    -> return mempty+    A.UnfoldingDecl{}     -> return mempty     A.Generalize {}       -> return mempty         -- open, pattern synonym and generalize defs are just artifacts from the concrete syntax     A.ScopedDecl scope ds -> {- withScope_ scope $ -} termDecls ds         -- scope is irrelevant as we are termination checking Syntax.Internal     A.RecSig{}            -> return mempty-    A.RecDef _ r _ _ _ _ ds -> termDecls ds-    -- These should all be wrapped in mutual blocks+    A.RecDef _ x _ _ _ _ ds -> termMutual [x] <> termDecls ds+        -- Andreas, 2022-10-23, issue #5823+        -- Also check record types for termination.+        -- They are unfolded during construction of unique inhabitants of eta-records.+    -- These should all be wrapped in mutual blocks:     A.FunDef{}      -> __IMPOSSIBLE__     A.DataSig{}     -> __IMPOSSIBLE__     A.DataDef{}     -> __IMPOSSIBLE__     A.UnquoteDecl{} -> __IMPOSSIBLE__     A.UnquoteDef{}  -> __IMPOSSIBLE__+    A.UnquoteData{} -> __IMPOSSIBLE__   where     termDecls ds = concat <$> mapM termDecl' ds      -- The mutual names mentioned in the abstract syntax     -- for symbols that need to be termination-checked.     getNames = concatMap getName-    getName (A.FunDef i x delayed cs)   = [x]-    getName (A.RecDef _ _ _ _ _ _ ds)   = getNames ds+    getName (A.FunDef i x cs)   = [x]+    getName (A.RecDef _ x _ _ _ _ ds)   = x : getNames ds     getName (A.Mutual _ ds)             = getNames ds-    getName (A.Section _ _ _ ds)        = getNames ds+    getName (A.Section _ _ _ _ ds)      = getNames ds     getName (A.ScopedDecl _ ds)         = getNames ds     getName (A.UnquoteDecl _ _ xs _)    = xs     getName (A.UnquoteDef _ xs _)       = xs@@ -153,8 +159,9 @@   -- during type-checking.   mid <- fromMaybe __IMPOSSIBLE__ <$> asksTC envMutualBlock   mutualBlock <- lookupMutualBlock mid-  let allNames = filter (not . isAbsurdLambdaName) $ Set.elems $ mutualNames mutualBlock-      names    = if null names0 then allNames else names0+  let allNames = Set.filter (not . isAbsurdLambdaName) $+                 mutualNames mutualBlock+      names    = if null names0 then allNames else Set.fromList names0       i        = mutualInfo mutualBlock    -- We set the range to avoid panics when printing error messages.@@ -163,7 +170,7 @@   -- The following debug statement is part of a test case for Issue   -- #3590.   reportSLn "term.mutual.id" 40 $-    "Termination checking mutual block " ++ show mid+    "Termination checking mutual block " ++ prettyShow mid   reportSLn "term.mutual" 10 $ "Termination checking " ++ prettyShow allNames    -- NO_TERMINATION_CHECK@@ -183,7 +190,7 @@       ignoreAbstractMode $ do         billTo [Benchmark.Termination, Benchmark.RecCheck] $ recursive allNames       -- -- Andreas, 2017-03-24, use positivity info to skip non-recursive functions-      -- skip = ignoreAbstractMode $ allM allNames $ \ x -> do+      -- skip = ignoreAbstractMode $ forallM allNames $ \ x -> do       --   null <$> getMutual x       -- PROBLEMS with test/Succeed/AbstractCoinduction.agda @@ -196,7 +203,7 @@      forM sccs $ \ allNames -> do       -- Set the mutual names in the termination environment.-     let namesSCC = filter (allNames `hasElem`) names+     let namesSCC = Set.filter (`Set.member` allNames) names      let setNames e = e            { terMutual    = allNames            , terUserNames = namesSCC@@ -207,23 +214,53 @@              " with cutoff=" ++ show cutoff ++ "..."            terLocal setNames cont -     -- New check currently only makes a difference for copatterns.+     -- New check currently only makes a difference for copatterns and record types.      -- Since it is slow, only invoke it if-     -- any of the definitions uses copatterns.-     res <- ifM (orM $ map usesCopatterns allNames)+     -- any of the definitions uses copatterns or is a record type.+     ifM (existsM allNames $ \ q -> usesCopatterns q `or2M` (isJust <$> isRecord q))          -- Then: New check, one after another.          (runTerm $ forM' allNames $ termFunction)          -- Else: Old check, all at once.          (runTerm $ termMutual') -     -- Record result of termination check in signature.-     -- If there are some termination errors, we collect them in-     -- the state and mark the definition as non-terminating so-     -- that it does not get unfolded-     let terminates = null res-     forM_ allNames $ \ q -> setTerminates q terminates-     return res+-- | Run the termination checker possibly twice and take the best result.+--   Run it first without extracting descent information from dot patterns.+--   If this proves termination, we are done.+--   If this did not manage to prove termination, try with dot patterns.+--   If this did not manage to prove termination either, return the offending paths.+--   Otherwise, if the first run proved termination subject to (deactivated) guardedness,+--   return this result.+--   Otherwise, return the second result.+withOrWithoutDotPatterns ::+     (Node -> Bool)+  -> TerM Calls+  -> TerM (Terminates CallPath)+withOrWithoutDotPatterns filt collect = do+    useGuardedness <- liftTCM guardednessOption+    cutoff <- terGetCutOff+    let ?cutoff = cutoff+    -- Run the continuation @k@ with the result of @m@ unless @m@ already certifies termination.+    let unlessTerminates m k = m >>= \case+          Terminates+            -> return Terminates+          TerminatesNot GuardednessHelpsYes _ | useGuardedness+            -> return Terminates+          r -> k r +    -- First try to termination check ignoring the dot patterns+    calls1 <- terSetUseDotPatterns False collect+    reportCalls "no " calls1+    unlessTerminates (billToTerGraph $ Term.terminatesFilter filt calls1) \ r1 -> do+      -- Try again, but include the dot patterns this time.+      calls2 <- terSetUseDotPatterns True collect+      reportCalls "" calls2+      unlessTerminates (billToTerGraph $ Term.terminatesFilter filt calls2) \ r2 -> do+        case r1 of+          TerminatesNot GuardednessHelpsNot _ -> return r2+            -- We might terminate with guardedness and dot patterns (r2).+          _              -> return r1+            -- Since r2 did not certify termination, the simpler r1 is preferable.+ -- | @termMutual'@ checks all names of the current mutual block, --   henceforth called @allNames@, for termination. --@@ -235,52 +272,34 @@    -- collect all recursive calls in the block   allNames <- terGetMutual-  let collect = forM' allNames termDef--  -- first try to termination check ignoring the dot patterns-  calls1 <- collect-  reportCalls "no " calls1+  let collect :: TerM Calls+      collect = forM' allNames termDef -  cutoff <- terGetCutOff-  let ?cutoff = cutoff-  r <- billToTerGraph $ Term.terminates calls1-  r <--       -- Andrea: 22/04/2020.-       -- With cubical we will always have a clause where the dot-       -- patterns are instead replaced with a variable, so they-       -- cannot be relied on for termination.-       -- See issue #4606 for a counterexample involving HITs.-       ---       -- Without the presence of HITs I conjecture that dot patterns-       -- could be turned into actual splits, because no-confusion-       -- would make the other cases impossible, so I do not disable-       -- this for --without-K entirely.-       ifM (isJust . optCubical <$> pragmaOptions) (return r) {- else -} $-       case r of-         r@Right{} -> return r-         Left{}    -> do-           -- Try again, but include the dot patterns this time.-           calls2 <- terSetUseDotPatterns True $ collect-           reportCalls "" calls2-           billToTerGraph $ Term.terminates calls2+  r <- withOrWithoutDotPatterns (const True) collect    -- @names@ is taken from the 'Abstract' syntax, so it contains only   -- the names the user has declared.  This is for error reporting.   names <- terGetUserNames   case r of-    Left calls -> return $ singleton $ terminationError names $ callInfos calls-    Right{} -> do++    TerminatesNot guardednessHelps calls -> do+      mapM_ (`setTerminates` False) allNames+      return $ singleton $ terminationError names calls guardednessHelps++    Terminates -> do       liftTCM $ reportSLn "term.warn.yes" 2 $         prettyShow (names) ++ " does termination check"+      mapM_ (`setTerminates` True) allNames       return mempty  -- | Smart constructor for 'TerminationError'. --   Removes 'termErrFunctions' that are not mentioned in 'termErrCalls'.-terminationError :: [QName] -> [CallInfo] -> TerminationError-terminationError names calls = TerminationError names' calls+terminationError :: Set QName -> CallPath -> GuardednessHelps -> TerminationError+terminationError names calls guardednessHelps = TerminationError names' calls' guardednessHelps   where-  names'    = filter (hasElem mentioned) names-  mentioned = map callInfoTarget calls+  calls'    = callInfos calls+  mentioned = map callInfoTarget calls'+  names'    = filter (hasElem mentioned) $ toList names  billToTerGraph :: a -> TerM a billToTerGraph a = liftTCM $ billPureTo [Benchmark.Termination, Benchmark.Graph] a@@ -343,20 +362,27 @@     return ()  -- | @termFunction name@ checks @name@ for termination.+-- If it passes the termination check it is marked as "terminates" in the signature.  termFunction :: QName -> TerM Result-termFunction name = do+termFunction name = inConcreteOrAbstractMode name $ \ def -> do    -- Function @name@ is henceforth referred to by its @index@   -- in the list of @allNames@ of the mutual block.    allNames <- terGetMutual-  let index = fromMaybe __IMPOSSIBLE__ $ List.elemIndex name allNames+  let index = fromMaybe __IMPOSSIBLE__ $ Set.lookupIndex name allNames    -- Retrieve the target type of the function to check.   -- #4256: Don't use typeOfConst (which instantiates type with module params), since termination   -- checking is running in the empty context, but with the current module unchanged.-  target <- liftTCM $ do typeEndsInDef . defType =<< getConstInfo name+  target <- case theDef def of+    -- We are termination-checking a record (calls to record will not be guarding):+    Record{} -> return TargetRecord+    -- We are termination-checking a definition:+    _ -> typeEndsInDef (defType def) <&> \case+           Just d  -> TargetDef d+           Nothing -> TargetOther   reportTarget target   terSetTarget target $ do @@ -368,7 +394,10 @@           if null todo then return $ Left calls else do             -- Extract calls originating from indices in @todo@.             new <- forM' todo $ \ i ->-              termDef $ fromMaybe __IMPOSSIBLE__ $ allNames !!! i+              termDef $+              if i < 0 || i >= Set.size allNames+              then __IMPOSSIBLE__+              else Set.elemAt i allNames             -- Mark those functions as processed and add the calls to the result.             let done'  = done `mappend` todo                 calls' = new  `mappend` calls@@ -377,34 +406,43 @@             -- Jump the trampoline.             return $ Right (todo', done', calls') -    -- First try to termination check ignoring the dot patterns-    calls1 <- terSetUseDotPatterns False $ collect-    reportCalls "no " calls1--    r <- do-     cutoff <- terGetCutOff-     let ?cutoff = cutoff-     r <- billToTerGraph $ Term.terminatesFilter (== index) calls1-     case r of-       Right () -> return $ Right ()-       Left{}    -> do-         -- Try again, but include the dot patterns this time.-         calls2 <- terSetUseDotPatterns True $ collect-         reportCalls "" calls2-         billToTerGraph $ mapLeft callInfos $ Term.terminatesFilter (== index) calls2+    r <- withOrWithoutDotPatterns (== index) collect      names <- terGetUserNames     case r of-      Left calls -> return $ singleton $ terminationError ([name] `List.intersect` names) calls-      Right () -> do-        liftTCM $ reportSLn "term.warn.yes" 2 $++      TerminatesNot guardednessHelps callpaths -> do+        let calls = callInfos callpaths+        -- Mark as non-terminating.+        setTerminates name False++        -- Functions must be terminating, records types need not...+        case theDef def of++          -- Records need not terminate, so we just put the error on the debug log.+          Record{} -> do+            reportSDoc "term.warn.no" 10 $ vcat $+              hsep [ "Record type", prettyTCM name, "does not termination check.", "Problematic calls:" ] :+              map (nest 2 . prettyTCM) (List.sortOn getRange calls)+            mempty++          -- Functions must terminate, so we report the error.+          _ -> do+            let err = TerminationError [name | name `elem` names] calls guardednessHelps+            return $ singleton err++      Terminates -> do+        reportSLn "term.warn.yes" 2 $           prettyShow name ++ " does termination check"+        setTerminates name True         return mempty    where-     reportTarget r = liftTCM $-       reportSLn "term.target" 20 $ "  target type " ++-         caseMaybe r "not recognized" (\ q ->-           "ends in " ++ prettyShow q)+     reportTarget :: MonadDebug m => Target -> m ()+     reportTarget tgt = reportSLn "term.target" 20 $ ("  " ++) $+       case tgt of+         TargetRecord -> "termination checking a record type"+         TargetDef q  -> unwords [ "target type ends in", prettyShow q ]+         TargetOther  -> "target type not recognized"  -- | To process the target type. typeEndsInDef :: MonadTCM tcm => Type -> tcm (Maybe QName)@@ -427,6 +465,13 @@ termDef :: QName -> TerM Calls termDef name = terSetCurrent name $ inConcreteOrAbstractMode name $ \ def -> do + -- Skip calls to record types unless we are checking a record type in the first place.+ let isRecord_ = case theDef def of { Record{} -> True; _ -> False }+ let notTargetRecord = terGetTarget <&> \case+       TargetRecord -> False+       _ -> True+ ifM (pure isRecord_ `and2M` notTargetRecord) mempty {-else-} $ do+   -- Retrieve definition   let t = defType def @@ -452,21 +497,34 @@     applyWhenM terGetMaskResult terUnguarded $ do        case theDef def of-        Function{ funClauses = cls, funDelayed = delayed } ->-          terSetDelayed delayed $ forM' cls $ \ cl -> do-            if hasDefP (namedClausePats cl) -- generated hcomp clause, should be safe.-                                            -- TODO find proper strategy.-              then return empty-              else termClause cl+        Function{ funClauses = cls  } -> forM' cls $ \ cl -> do+          if hasDefP (namedClausePats cl) -- generated hcomp clause, should be safe.+                                          -- TODO find proper strategy.+            then return empty+            else termClause cl +        -- @record R pars : Set where field tel@+        -- is treated like function @R pars = tel@.+        Record{ recPars, recTel } -> termRecTel recPars recTel+         _ -> return empty-  where-    hasDefP :: [NamedArg DeBruijnPattern] -> Bool-    hasDefP ps = getAny $ flip foldPattern ps $ \ (x :: DeBruijnPattern) ->-                  case x of-                    DefP{} -> Any True-                    _      -> Any False +-- | Extract "calls" to the field types from a record constructor telescope.+-- Does not extract from the parameters, but treats these as the "pattern variables"+-- (the lhs of the "function").+termRecTel :: Nat -> Telescope -> TerM Calls+termRecTel npars tel = do+  -- Set up the record parameters like function parameters.+  let (pars, fields) = splitAt npars $ telToList tel+  addContext pars $ do+    ps <- mkPats npars+    terSetPatterns ps $ terSetSizeDepth pars $ do+      -- Treat the record fields like the body of a function.+      extract $ telFromList fields+  where+  -- create n variable patterns+  mkPats n  = map mkPat <$> getContextVars+  mkPat (i, x) = notMasked $ VarP defaultPatternInfo $ DBPatVar (prettyShow x) i  -- | Collect calls in type signature @f : (x1:A1)...(xn:An) -> B@. --   It is treated as if there were the additional function clauses.@@ -494,8 +552,8 @@         extract dom `mappend` underAbstractionAbs dom absB (loop $! n + 1)    -- create n variable patterns-  mkPats n  = zipWith mkPat (downFrom n) <$> getContextNames-  mkPat i x = notMasked $ VarP defaultPatternInfo $ DBPatVar (prettyShow x) i+  mkPats n  = map mkPat <$> getContextVars+  mkPat (i, x) = notMasked $ VarP defaultPatternInfo $ DBPatVar (prettyShow x) i  -- | Mask arguments and result for termination checking --   according to type of function.@@ -505,44 +563,37 @@   (ds, d) <- liftTCM $ do     TelV tel core <- telViewPath t     -- Check argument types-    ds <- forM (telToList tel) $ \ t -> do-      TelV _ t <- telViewPath $ snd $ unDom t-      d <- (isNothing <$> isDataOrRecord (unEl t)) `or2M` (isJust <$> isSizeType t)-      when d $-        reportSDoc "term.mask" 20 $ do-          "argument type "-            <+> prettyTCM t-            <+> " is not data or record type, ignoring structural descent for --without-K"-      return d+    ds <- checkArgumentTypes tel     -- Check result types-    d  <- isNothing <.> isDataOrRecord . unEl $ core+    d  <- addContext tel $ isNothing <.> isDataOrRecord . unEl $ core     when d $       reportSLn "term.mask" 20 $ "result type is not data or record type, ignoring guardedness for --without-K"     return (ds, d)   terSetMaskArgs (ds ++ repeat True) $ terSetMaskResult d $ cont +  where+    checkArgumentTypes :: Telescope -> TCM [Bool]+    checkArgumentTypes EmptyTel = return []+    checkArgumentTypes (ExtendTel dom atel) = do+      TelV tel2 t <- telViewPath $ unDom dom+      d <- addContext tel2 $+        (isNothing <$> isDataOrRecord (unEl t)) `or2M` (isJust <$> isSizeType t)+      when d $+        reportSDoc "term.mask" 20 $ do+          "argument type "+            <+> prettyTCM t+            <+> " is not data or record type, ignoring structural descent for --without-K"+      underAbstraction dom atel $ \tel -> (d:) <$> checkArgumentTypes tel  -- | Is the current target type among the given ones? -targetElem :: [Target] -> TerM Bool-targetElem ds = maybe False (`elem` ds) <$> terGetTarget+targetElem :: [QName] -> TerM Bool+targetElem ds = terGetTarget <&> \case+  TargetDef d  -> d `elem` ds+  TargetRecord -> False+  TargetOther  -> False -{---- | The target type of the considered recursive definition.-data Target-  = Set        -- ^ Constructing a Set (only meaningful with 'guardingTypeConstructors').-  | Data QName -- ^ Constructing a coinductive or mixed type (could be data or record).-  deriving (Eq, Show) --- | Check wether a 'Target" corresponds to the current one.-matchingTarget :: DBPConf -> Target -> TCM Bool-matchingTarget conf t = maybe (return True) (match t) (currentTarget conf)-  where-    match Set      Set       = return True-    match (Data d) (Data d') = mutuallyRecursive d d'-    match _ _                = return False--}- -- | Convert a term (from a dot pattern) to a DeBruijn pattern. -- --   The term is first normalized and stripped of all non-coinductive projections.@@ -572,18 +623,36 @@ instance TermToPattern Term DeBruijnPattern where   termToPattern t = liftTCM (constructorForm t) >>= \case     -- Constructors.-    Con c _ args -> ConP c noConPatternInfo . map (fmap unnamed) <$> termToPattern (fromMaybe __IMPOSSIBLE__ $ allApplyElims args)+    Con c _ args -> ifNotConsOfHIT c $+      ConP c noConPatternInfo . map (fmap unnamed) <$> termToPattern (fromMaybe __IMPOSSIBLE__ $ allApplyElims args)     Def s [Apply arg] -> do       suc <- terGetSizeSuc       if Just s == suc then ConP (ConHead s IsData Inductive []) noConPatternInfo . map (fmap unnamed) <$> termToPattern [arg]-       else return $ dotP t+       else fallback     DontCare t  -> termToPattern t -- OR: __IMPOSSIBLE__  -- removed by stripAllProjections     -- Leaves.     Var i []    -> varP . (`DBPatVar` i) . prettyShow <$> nameOfBV i     Lit l       -> return $ litP l     Dummy s _   -> __IMPOSSIBLE_VERBOSE__ s-    t           -> return $ dotP t-+    t           -> fallback+    where+    -- Andrea: 22/04/2020.+    -- With cubical we will always have a clause where the dot+    -- patterns are instead replaced with a variable, so they+    -- cannot be relied on for termination.+    -- See issue #4606 for a counterexample involving HITs.+    --+    -- Without the presence of HITs I conjecture that dot patterns+    -- could be turned into actual splits, because no-confusion+    -- would make the other cases impossible, so I do not disable+    -- this for --without-K entirely.+    --+    -- Szumi, 2025-03-11:+    -- Instead of completely turning off dot-pattern termination for cubical,+    -- it should be enough to only ignore constructors of HITs in dot patterns.+    -- This way, the issues #5953 and #4725 are also avoided.+    ifNotConsOfHIT c    = ifM (consOfHIT (conName c)) fallback+    fallback            = return $ dotP t  -- | Masks all non-data/record type patterns if --without-K. --   See issue #1023.@@ -593,6 +662,18 @@     mask p@ProjP{} _ = Masked False p     mask p         d = Masked d     p +-- | Drop elements of the list which correspond to arguments forced by+-- the constructor with the given QName.+mapForcedArguments :: QName -> [a] -> (IsForced -> a -> Maybe b) -> TerM [b]+mapForcedArguments c xs k = do+  forcedArgs <- getForcedArgs c+  let go xs (p:ps) = do+        let (f, xs') = nextIsForced xs+        case k f p of+          Just b  -> b:go xs' ps+          Nothing -> go xs' ps+      go _ [] = []+  pure $ go forcedArgs xs  -- | Extract recursive calls from one clause. termClause :: Clause -> TerM Calls@@ -620,22 +701,15 @@     parseDotP = \case       DotP o t -> termToDBP t       p        -> return p-    stripCoCon p = case p of-      ConP (ConHead c _ _ _) _ _ -> do-        ifM ((Just c ==) <$> terGetSizeSuc) (return p) $ {- else -} do-        whatInduction c >>= \case-          Inductive   -> return p-          CoInductive -> return unusedVar-      _ -> return p+    stripCoCon = \case+      ConP (ConHead c _ CoInductive _) _ _ -> return unusedVar+      p -> return p     reportBody :: Term -> TerM ()     reportBody v = verboseS "term.check.clause" 6 $ do       f       <- terGetCurrent-      delayed <- terGetDelayed       pats    <- terGetPatterns       liftTCM $ reportSDoc "term.check.clause" 6 $ do-        sep [ text ("termination checking " ++-                    (if delayed == Delayed then "delayed " else "") ++-                    "clause of")+        sep [ text ("termination checking clause of")                 <+> prettyTCM f             , nest 2 $ "lhs:" <+> sep (map prettyTCM pats)             , nest 2 $ "rhs:" <+> prettyTCM v@@ -683,12 +757,12 @@       reportSDoc "term.sort" 50 $         text ("s = " ++ show s)     case s of-      Inf f n    -> return empty+      Inf _ _    -> return empty       SizeUniv   -> return empty       LockUniv   -> return empty-      Type t     -> terUnguarded $ extract t  -- no guarded levels-      Prop t     -> terUnguarded $ extract t-      SSet t     -> terUnguarded $ extract t+      LevelUniv  -> return empty+      IntervalUniv -> return empty+      Univ _ t       -> terUnguarded $ extract t  -- no guarded levels       PiSort a s1 s2 -> extract (a, s1, s2)       FunSort s1 s2 -> extract (s1, s2)       UnivSort s -> extract s@@ -701,6 +775,11 @@ instance ExtractCalls Type where   extract (El s t) = extract (s, t) +instance ExtractCalls a => ExtractCalls (Tele a) where+  extract = \case+    EmptyTel        -> mempty+    ExtendTel a tel -> extract a <> extract tel+ -- | Extract recursive calls from a constructor application.  constructor@@ -756,14 +835,16 @@           ]      -- insert this call into the call list-    case List.elemIndex g names of+    case Set.lookupIndex g names of         -- call leads outside the mutual block and can be ignored        Nothing   -> return calls -       -- call is to one of the mutally recursive functions+       -- call is to one of the mutally recursive functions/record        Just gInd -> do-         delayed <- terGetDelayed+         cutoff <- terGetCutOff+         let ?cutoff = cutoff+          -- Andreas, 2017-02-14, issue #2458:          -- If we have inlined with-functions, we could be illtyped,          -- hence, do not reduce anything.@@ -798,15 +879,30 @@          -- spent on call matrix generation          (nrows, ncols, matrix) <- billTo [Benchmark.Termination, Benchmark.Compare] $            compareArgs es-         -- only a delayed definition can be guarded-         let ifDelayed o | Order.decreasing o && delayed == NotDelayed = Order.le-                         | otherwise                                  = o++         -- Andreas, 2022-03-21, #5823:+         -- If we are "calling" a record type we are guarded unless the origin+         -- of the termination analysis is itself a record.+         -- This is because we usually do not "unfold" record types into their+         -- field telescope.  We only do so when trying to construct the+         -- unique inhabitant of record type (singleton analysis).+         -- In the latter case, a call to a record type is not guarding.+         guarded' <- isRecord g >>= \case+           Just{} -> terGetTarget >>= \case+             TargetRecord+               -> return guarded+             _ -> return (guarded .*. Order.lt)+                    -- guarding when we call a record and not termination checking a record+           Nothing+             -- only a delayed definition can be guarded+             | Order.decreasing guarded+               -> return Order.le+             | otherwise+               -> return guarded          liftTCM $ reportSLn "term.guardedness" 20 $            "composing with guardedness " ++ prettyShow guarded ++-           " counting as " ++ prettyShow (ifDelayed guarded)-         cutoff <- terGetCutOff-         let ?cutoff = cutoff-         let matrix' = composeGuardedness (ifDelayed guarded) matrix+           " counting as " ++ prettyShow guarded'+         let matrix' = composeGuardedness guarded' matrix           -- Andreas, 2013-04-26 FORBIDDINGLY expensive!          -- This PrettyTCM QName cost 50% of the termination time for std-lib!!@@ -830,14 +926,14 @@            -- Andreas, 2017-01-05, issue #2376            -- Remove arguments inserted by etaExpandClause. -         let src  = fromMaybe __IMPOSSIBLE__ $ List.elemIndex f names+         let src  = fromMaybe __IMPOSSIBLE__ $ Set.lookupIndex f names              tgt  = gInd              cm   = makeCM ncols nrows matrix'-             info = CallPath [CallInfo+             info = CallPath $ singleton $+                    CallInfo                       { callInfoTarget = g-                      , callInfoRange  = getRange g                       , callInfoCall   = doc-                      }]+                      }          verboseS "term.kept.call" 5 $ do            pats <- terGetPatterns            reportSDoc "term.kept.call" 5 $ vcat@@ -878,16 +974,18 @@   ifM (notElem g <$> terGetMutual) fallback {-else-} $ do   reportSLn "term.reduce" 40 $ "This call is in the current SCC!" -  -- Then, collect its non-recursive clauses.-  cls <- liftTCM $ getNonRecursiveClauses g-  reportSLn "term.reduce" 40 $ unwords [ "Function has", show (length cls), "non-recursive exact clauses"]+  -- Then, collect its clauses.+  cls <- defClauses <$> getConstInfo g+  reportSLn "term.reduce" 40 $ unwords [ "Function has", show (length cls), "clauses"]   reportSDoc "term.reduce" 80 $ vcat $ map (prettyTCM . NamedClause g True) cls   reportSLn  "term.reduce" 80 . ("allowed reductions = " ++) . show . SmallSet.elems     =<< asksTC envAllowedReductions    -- Finally, try to reduce with the non-recursive clauses (and no rewrite rules).-  r <- liftTCM $ modifyAllowedReductions (SmallSet.delete UnconfirmedReductions) $-    runReduceM $ appDefE' v0 cls [] (map notReduced es)+  r <- liftTCM $+    modifyAllowedReductions (SmallSet.delete UnconfirmedReductions) $+    localTC (\e -> e { envTermCheckReducing = True }) $+    runReduceM $ appDefE' g v0 cls [] (map notReduced es)   case r of     NoReduction{}    -> fallback     YesReduction _ v -> do@@ -898,41 +996,41 @@       verboseS "term.reduce" 5 $ tick "termination-checker-reduced-nonrecursive-call"       continue v -getNonRecursiveClauses :: QName -> TCM [Clause]-getNonRecursiveClauses q =-  filter (liftA2 (&&) nonrec exact) . defClauses <$> getConstInfo q-  where-  nonrec = maybe False not . clauseRecursive-  exact  = fromMaybe False . clauseExact- -- | Extract recursive calls from a term.  instance ExtractCalls Term where   extract t = do-    liftTCM $ reportSDoc "term.check.term" 50 $ do+    reportSDoc "term.check.term" 50 $ do       "looking for calls in" <+> prettyTCM t      -- Instantiate top-level MetaVar.-    t <- liftTCM $ instantiate t-    case t of+    instantiate t >>= \case        -- Constructed value.       Con ConHead{conName = c, conDataRecord = dataOrRec} _ es -> do         let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es         -- A constructor preserves the guardedness of all its arguments.-        let argsg = zip args $ repeat True+        -- Andreas, 2022-09-19, issue #6108:+        -- A higher constructor does not.  So check if there is an @IApply@ amoung @es@.+        let argsg = zip args $ repeat $ all isProperApplyElim es          -- If we encounter a coinductive record constructor         -- in a type mutual with the current target         -- then we count it as guarding.-        let inductive   = return Inductive-            coinductive = return CoInductive+        let inductive   = return Inductive    -- not guarding, but preserving+            coinductive = return CoInductive  -- guarding+        -- ♯ is guarding         ind <- ifM ((Just c ==) <$> terGetSharp) coinductive $ {-else-} do+          -- data constructors are not guarding           if dataOrRec == IsData then inductive else do-          caseMaybeM (liftTCM $ isRecordConstructor c) inductive $ \ (q, def) -> do+          -- abstract constructors are not guarding+          caseMaybeM (isRecordConstructor c) inductive $ \ (q, def) -> do             reportSLn "term.check.term" 50 $ "constructor " ++ prettyShow c ++ " has record type " ++ prettyShow q-            if recInduction def /= Just CoInductive then inductive else do-            ifM (targetElem . fromMaybe __IMPOSSIBLE__ $ recMutual def)+            -- inductive record constructors are not guarding+            if _recInduction def /= Just CoInductive then inductive else do+            -- coinductive constructors unrelated to the mutually+            -- constructed inhabitants of coinductive types are not guarding+            ifM (targetElem . fromMaybe __IMPOSSIBLE__ $ _recMutual def)                {-then-} coinductive                {-else-} inductive         constructor c ind argsg@@ -946,17 +1044,16 @@       -- Neutral term. Destroys guardedness.       Var i es -> terUnguarded $ extract es -      -- Dependent function space. Destroys guardedness.+      -- Dependent function space.       Pi a (Abs x b) ->-        terUnguarded $         CallGraph.union <$>         extract a <*> do           a <- maskSizeLt a  -- OR: just do not add a to the context!           addContext (x, a) $ terRaise $ extract b -      -- Non-dependent function space. Destroys guardedness.+      -- Non-dependent function space.       Pi a (NoAbs _ b) ->-        terUnguarded $ CallGraph.union <$> extract a <*> extract b+        CallGraph.union <$> extract a <*> extract b        -- Literal.       Lit l -> return empty@@ -1031,11 +1128,7 @@     filterM (isCoinductiveProjection True) $ mapMaybe (fmap snd . isProjElim) es   cutoff <- terGetCutOff   let ?cutoff = cutoff-  useGuardedness <- liftTCM guardednessOption-  let guardedness =-        if useGuardedness-        then decr True $ projsCaller - projsCallee-        else Order.Unknown+  let guardedness = decr True $ projsCaller - projsCallee   liftTCM $ reportSDoc "term.guardedness" 30 $ sep     [ "compareArgs:"     , nest 2 $ text $ "projsCaller = " ++ prettyShow projsCaller@@ -1113,7 +1206,7 @@           case def of             Record{ recFields = fs } -> do               fs <- return $ map unDom fs-              case (List.find (d==) fs, List.find (d'==) fs) of+              case (List.find (d ==) fs, List.find (d' ==) fs) of                 (Just i, Just i')                   -- earlier field is smaller                   | i < i'    -> return Order.lt@@ -1328,14 +1421,17 @@ compareConArgs ts ps = do   cutoff <- terGetCutOff   let ?cutoff = cutoff-  -- we may assume |ps| >= |ts|, otherwise c ps would be of functional type-  -- which is impossible-  case (length ts, length ps) of-    (0,0) -> return Order.le        -- c <= c-    (0,1) -> return Order.unknown   -- c not<= c x-    (1,0) -> __IMPOSSIBLE__-    (1,1) -> compareTerm' (unArg (head ts)) (notMasked $ namedArg $ head ps)-    (_,_) -> foldl (Order..*.) Order.le <$>+  case compare (length ts) (length ps) of++    -- We may assume |ps| >= |ts|, otherwise c ps would be of functional type+    -- which is impossible.+    GT -> __IMPOSSIBLE__++    -- Andreas, 2022-08-31, issue #6059: doing anything smarter than+    -- @unknown@ here can lead to non-termination.+    LT -> return Order.unknown++    EQ -> List.foldl' (Order..*.) Order.le <$>                zipWithM compareTerm' (map unArg ts) (map (notMasked . namedArg) ps)        -- corresponds to taking the size, not the height        -- allows examples like (x, y) < (Succ x, y)@@ -1369,7 +1465,13 @@     ConP s _ [p] | Just (conName s) == suc ->       setUsability True . decrease 1 <$> compareVar i (notMasked $ namedArg p) -    ConP c _ ps -> if m then no else setUsability True <$> do+    ConP c pi ps -> if m then no else setUsability True <$> do+      let+        dropit Forced _ = Nothing+        dropit NotForced x = Just x+      ps <- ifM (optForcedArgumentRecursion <$> pragmaOptions)+        {- then -} (pure ps)+        {- else -} (mapForcedArguments (conName c) ps dropit)       decrease <$> offsetFromConstructor (conName c)                <*> (Order.supremum <$> mapM (compareVar i . notMasked . namedArg) ps)     DefP _ c ps -> if m then no else setUsability True <$> do
src/full/Agda/Termination/Termination.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE ImplicitParams #-}  -- | Termination checker, based on@@ -8,12 +10,19 @@ --     Chin Soon Lee, Neil Jones, and Amir Ben-Amram (POPL'01).  module Agda.Termination.Termination-  ( terminates+  ( Terminates(..)+  , GuardednessHelps(..)+  , terminates   , terminatesFilter   , endos   , idempotent   ) where +import Prelude hiding ((&&), null)++import Control.DeepSeq (NFData)+import GHC.Generics (Generic)+ import Agda.Termination.CutOff import Agda.Termination.CallGraph import Agda.Termination.CallMatrix hiding (toList)@@ -21,26 +30,30 @@ import Agda.Termination.Order import Agda.Termination.SparseMatrix -import Agda.Utils.Maybe+import Agda.Utils.Boolean+import Agda.Utils.Null+import Agda.Utils.Three +-- | Would termination go through with guardedness?+data GuardednessHelps+  = GuardednessHelpsYes  -- ^ Guardedness would provide termination evidence.+  | GuardednessHelpsNot  -- ^ Guardedness does not help with termination.+  deriving (Eq, Show, Generic, Enum, Bounded) +-- | Result of running the termination checker.+data Terminates cinfo+  = Terminates+      -- ^ Termination proved without considering guardedness.+  | TerminatesNot GuardednessHelps cinfo+      -- ^ Termination could not be proven,+      --   witnessed by the supplied problematic call path.+      --   Guardedness could help, though. --- | TODO: This comment seems to be partly out of date.------ @'terminates' cs@ checks if the functions represented by @cs@++-- | @'terminates' cs@ checks if the functions represented by @cs@ -- terminate. The call graph @cs@ should have one entry ('Call') per -- recursive function application. ----- @'Right' perms@ is returned if the functions are size-change terminating.------ If termination can not be established, then @'Left' problems@ is--- returned instead. Here @problems@ contains an--- indication of why termination cannot be established. See 'lexOrder'--- for further details.------ Note that this function assumes that all data types are strictly--- positive.--- -- The termination criterion is taken from Jones et al. -- In the completed call graph, each idempotent call-matrix -- from a function to itself must have a decreasing argument.@@ -49,29 +62,35 @@ -- This criterion is strictly more liberal than searching for a -- lexicographic order (and easier to implement, but harder to justify). -terminates :: (Monoid cinfo, ?cutoff :: CutOff) => CallGraph cinfo -> Either cinfo ()-terminates cs = checkIdems $ endos $ toList $ complete cs+terminates :: (Monoid cinfo, ?cutoff :: CutOff) => CallGraph cinfo -> Terminates cinfo+terminates = terminatesFilter $ const True -terminatesFilter :: (Monoid cinfo, ?cutoff :: CutOff) =>-  (Node -> Bool) -> CallGraph cinfo -> Either cinfo ()-terminatesFilter f cs = checkIdems $ endos $ filter f' $ toList $ complete cs-  where f' c = f (source c) && f (target c)+terminatesFilter ::+     (Monoid cinfo, ?cutoff :: CutOff)+  => (Node -> Bool)    -- ^ Only consider calls whose source and target satisfy this predicate.+  -> CallGraph cinfo   -- ^ Callgraph augmented with @cinfo@.+  -> Terminates cinfo  -- ^ A bad call path of type @cinfo@, if termination could not be proven.+terminatesFilter f cs+  | cm:_ <- bad             = TerminatesNot GuardednessHelpsNot $ augCallInfo cm+  | cm:_ <- needGuardedness = TerminatesNot GuardednessHelpsYes $ augCallInfo cm+  | otherwise               = Terminates+  where+    f' = f . source && f . target+    -- Every idempotent call must have decrease in the diagonal.+    idems = filter idempotent $ endos $ filter f' $ toList $ complete cs+    hasDecr cm = case diagonal cm of+      g : xs+        | any isDecr xs -> In1 ()        -- Evidence found without guardedness.+        | isDecr g      -> In2 cm        -- Evidence found in guardedness.+        | otherwise     -> In3 cm        -- No evidence found.+      []                -> In3 cm        -- No information means no evidence for termination.+    (good, needGuardedness, bad) = partitionEithers3 $ map hasDecr idems  endos :: [Call cinfo] -> [CallMatrixAug cinfo] endos cs = [ m | c <- cs, source c == target c                , m <- CMSet.toList $ callMatrixSet c            ] -checkIdems :: (?cutoff :: CutOff) => [CallMatrixAug cinfo] -> Either cinfo ()-checkIdems calls = caseMaybe (listToMaybe offending) (Right ()) $ Left . augCallInfo-  where-    -- Every idempotent call must have decrease, otherwise it offends us.-    offending = filter (not . hasDecrease) $ filter idempotent calls---- UNUSED Liang-Ting 2019-07-15---checkIdem :: (?cutoff :: CutOff) => CallMatrixAug cinfo -> Bool---checkIdem c = if idempotent c then hasDecrease c else True- -- | A call @c@ is idempotent if it is an endo (@'source' == 'target'@) --   of order 1. --   (Endo-calls of higher orders are e.g. argument permutations).@@ -81,5 +100,19 @@ idempotent  :: (?cutoff :: CutOff) => CallMatrixAug cinfo -> Bool idempotent (CallMatrixAug m _) = (m >*< m) `notWorse` m -hasDecrease :: CallMatrixAug cinfo -> Bool-hasDecrease = any isDecr . diagonal+-- Instances++instance Null GuardednessHelps where+  empty = GuardednessHelpsNot++instance Boolean GuardednessHelps where+  fromBool = \case+    True  -> GuardednessHelpsYes+    False -> GuardednessHelpsNot++instance IsBool GuardednessHelps where+  toBool = \case+    GuardednessHelpsYes -> True+    GuardednessHelpsNot -> False++instance NFData GuardednessHelps
src/full/Agda/TheTypeChecker.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TheTypeChecker   ( checkDecls, checkDecl, checkDeclCached   , inferExpr, checkExpr
src/full/Agda/TypeChecking/Abstract.hs view
@@ -1,19 +1,24 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Functions for abstracting terms over other terms.+ module Agda.TypeChecking.Abstract where +import Prelude hiding ( null )+ import Control.Monad import Control.Monad.Except -import Data.Function+import Data.Function ( on ) import qualified Data.HashMap.Strict as HMap  import Agda.Syntax.Common+import Agda.Syntax.Position ( Range ) import Agda.Syntax.Internal +import Agda.TypeChecking.Free ( freeIn ) import Agda.TypeChecking.MetaVars import Agda.TypeChecking.Monad-import Agda.TypeChecking.Monad.Builtin ( equalityUnview, primEqualityName ) import Agda.TypeChecking.Substitute import Agda.TypeChecking.CheckInternal import Agda.TypeChecking.Conversion@@ -21,20 +26,35 @@ import Agda.TypeChecking.Pretty import Agda.TypeChecking.Sort import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Warnings ( warning )  import Agda.Utils.Functor import Agda.Utils.List ( splitExactlyAt, dropEnd )+import Agda.Utils.Null+ import Agda.Utils.Impossible --- | @abstractType a v b[v] = b@ where @a : v@.-abstractType :: Type -> Term -> Type -> TCM Type-abstractType a v (El s b) = El (absTerm v s) <$> abstractTerm a v (sort s) b+-- | @abstractType r a v b[v] = b@ where @a : v@.+abstractType ::+     Range     -- ^ Range of the @rewrite@ expression, if any, otherwise empty.+  -> Type      -- ^ Type of the term to abstract.+  -> Term      -- ^ Term to abstract.+  -> Type      -- ^ Type to abstract in.+  -> TCM Type  -- ^ Type with hole (de Bruijn index 0) for the abstracted term.+abstractType r a v (El s b) = do +  c <- El (absTerm 0 v s) <$> abstractTerm a v (sort s) b+  unless (null r || 0 `freeIn` c) do+    -- Andreas, 2025-07-03, issue #7973+    -- If with abstraction did not abstract anything, warn the user.+    setCurrentRange r $ warning RewritesNothing+  return c+ -- | @piAbstractTerm NotHidden v a b[v] = (w : a) -> b[w]@ --   @piAbstractTerm Hidden    v a b[v] = {w : a} -> b[w]@ piAbstractTerm :: ArgInfo -> Term -> Type -> Type -> TCM Type piAbstractTerm info v a b = do-  fun <- mkPi (setArgInfo info $ defaultDom ("w", a)) <$> abstractType a v b+  fun <- mkPi (setArgInfo info $ defaultDom ("w", a)) <$> abstractType empty a v b   reportSDoc "tc.abstract" 50 $     sep [ "piAbstract" <+> sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM a ]         , nest 2 $ "from" <+> prettyTCM b@@ -56,14 +76,14 @@ piAbstract :: Arg (Term, EqualityView) -> Type -> TCM Type piAbstract (Arg info (v, OtherType a)) b = piAbstractTerm info v a b piAbstract (Arg info (v, IdiomType a)) b = do-  b  <- raise 1 <$> abstractType a v b+  b  <- raise 1 <$> abstractType empty a v b   eq <- addContext ("w" :: String, defaultDom a) $ do     -- manufacture the type @w ≡ v@     eqName <- primEqualityName     eqTy <- defType <$> getConstInfo eqName     -- E.g. @eqTy = eqTel → Set a@ where @eqTel = {a : Level} {A : Set a} (x y : A)@.     TelV eqTel _ <- telView eqTy-    tel  <- newTelMeta (telFromList $ dropEnd 2 $ telToList eqTel)+    tel  <- newTelMeta (telFromList $ dropEnd 3 $ telToList eqTel)     let eq = Def eqName $ map Apply                  $ map (setHiding Hidden) tel                  -- we write `v ≡ w` because this equality is typically used to@@ -71,29 +91,40 @@                  -- in a with-clause.                  -- If we were to write `w ≡ v`, we would often need to take the                  -- symmetric of the proof we get to make use of `rewrite`.-                 ++ [ defaultArg (raise 1 v)+                 ++ [ setHiding Hidden $ defaultArg $ raise 1 $ unEl a+                    , defaultArg (raise 1 v)                     , defaultArg (var 0)                     ]+    -- Since the result of this function will be type-checked in+    -- `withFunctionType`, we can be a little lazy here and put+    -- a meta for the sort.     sort <- newSortMeta-    let ty = El sort eq-    ty <$ checkType ty+    return $ El sort eq    pure $ mkPi (setHiding (getHiding info) $ defaultDom ("w", a))        $ mkPi (setHiding NotHidden        $ defaultDom ("eq", eq))        $ b-piAbstract (Arg info (prf, eqt@(EqualityType _ _ _ (Arg _ a) v _))) b = do+piAbstract (Arg info (prf, EqualityViewType eqt@(EqualityTypeData r _ _ _ (Arg _ a) v _))) b = do   s <- sortOf a-  let prfTy = equalityUnview eqt+  let prfTy :: Type+      prfTy = equalityUnview eqt       vTy   = El s a-  b <- abstractType prfTy prf b+  -- Andreas, 2025-07-03, issue #7973+  -- We alert the user when the lhs of the equality proof could not be abstracted+  -- but not when the equality proof itself could not be abstracted.+  -- Only the former means that the rewrite did not fire.+  b <- abstractType empty prfTy prf b  -- @empty@ means do not warn   b <- addContext ("w" :: String, defaultDom prfTy) $-         abstractType (raise 1 vTy) (unArg $ raise 1 v) b+         -- Passing range @r@ here means warn if abstraction failed to abstract anything.+         abstractType r (raise 1 vTy) (unArg $ raise 1 v) b   return . funType "lhs" vTy . funType "equality" eqTy' . swap01 $ b   where     funType str a = mkPi $ setArgInfo info $ defaultDom (str, a)     -- Abstract the lhs (@a@) of the equality only.+    eqt1 :: EqualityTypeData     eqt1  = raise 1 eqt-    eqTy' = equalityUnview $ eqt1 { eqtLhs = eqtLhs eqt1 $> var 0 }+    eqTy' :: Type+    eqTy' = equalityUnview $ eqt1{ _eqtLhs = _eqtLhs eqt1 $> var 0 }   -- | @isPrefixOf u v = Just es@ if @v == u `applyE` es@.@@ -136,7 +167,7 @@         , nest 2 $ sep [ (text . show) v <+> ":", nest 2 $ (text . show) b ] ]    hole <- qualify <$> currentModule <*> freshName_ ("hole" :: String)-  noMutualBlock $ addConstant' hole defaultArgInfo hole a defaultAxiom+  noMutualBlock $ addConstant' hole defaultArgInfo a defaultAxiom    args <- map Apply <$> getContextArgs   let n = length args@@ -168,21 +199,26 @@         return v   reportSDoc "tc.abstract" 50 $ "Resulting abstraction" <?> prettyTCM res   modifySignature $ updateDefinitions $ HMap.delete hole-  return $ absTerm (Def hole args) res+  return $ absTerm 0 (Def hole args) res -abstractTerm _ u _ v = return $ absTerm u v -- Non-constructors can use untyped abstraction+abstractTerm _ u _ v = return $ absTerm 0 u v -- Non-constructors can use untyped abstraction  class AbsTerm a where-  -- | @subst u . absTerm u == id@-  absTerm :: Term -> a -> a+  -- | @subst j u . absTerm j u == id@+  absTerm ::+       Nat   -- ^ De Bruijn index that should be the placeholder for the abstracted term.+    -> Term  -- ^ Term to abstract.+    -> a     -- ^ Where to abstract.+    -> a     -- ^ If the given de Bruijn index is free in the result, abstraction actually happened.  instance AbsTerm Term where-  absTerm u v | Just es <- u `isPrefixOf` v = Var 0 $ absT es-              | otherwise                   =+  absTerm j u v+    | Just es <- u `isPrefixOf` v = Var j $ absT es+    | otherwise                   =     case v of -- Andreas, 2013-10-20: the original impl. works only at base types---    v | u == v  -> Var 0 []  -- incomplete see succeed/WithOfFunctionType-      Var i vs    -> Var (i + 1) $ absT vs+--    v | u == v  -> Var j []  -- incomplete see succeed/WithOfFunctionType+      Var i vs    -> Var (if i < j then i else i + 1) $ absT vs       Lam h b     -> Lam h $ absT b       Def c vs    -> Def c $ absT vs       Con c ci vs -> Con c ci $ absT vs@@ -195,19 +231,19 @@       Dummy s es   -> Dummy s $ absT es       where         absT :: AbsTerm b => b -> b-        absT x = absTerm u x+        absT x = absTerm j u x  instance AbsTerm Type where-  absTerm u (El s v) = El (absTerm u s) (absTerm u v)+  absTerm j u (El s v) = El (absTerm j u s) (absTerm j u v)  instance AbsTerm Sort where-  absTerm u = \case-    Type n     -> Type $ absS n-    Prop n     -> Prop $ absS n-    s@(Inf f n)-> s-    SSet n     -> SSet $ absS n+  absTerm j u = \case+    Univ u n   -> Univ u $ absS n+    s@Inf{}    -> s     SizeUniv   -> SizeUniv     LockUniv   -> LockUniv+    LevelUniv  -> LevelUniv+    IntervalUniv -> IntervalUniv     PiSort a s1 s2 -> PiSort (absS a) (absS s1) (absS s2)     FunSort s1 s2 -> FunSort (absS s1) (absS s2)     UnivSort s -> UnivSort $ absS s@@ -216,35 +252,35 @@     s@DummyS{} -> s     where       absS :: AbsTerm b => b -> b-      absS x = absTerm u x+      absS x = absTerm j u x  instance AbsTerm Level where-  absTerm u (Max n as) = Max n $ absTerm u as+  absTerm j u (Max n as) = Max n $ absTerm j u as  instance AbsTerm PlusLevel where-  absTerm u (Plus n l) = Plus n $ absTerm u l+  absTerm j u (Plus n l) = Plus n $ absTerm j u l  instance AbsTerm a => AbsTerm (Elim' a) where-  absTerm = fmap . absTerm+  absTerm j = fmap . absTerm j  instance AbsTerm a => AbsTerm (Arg a) where-  absTerm = fmap . absTerm+  absTerm j = fmap . absTerm j  instance AbsTerm a => AbsTerm (Dom a) where-  absTerm = fmap . absTerm+  absTerm j = fmap . absTerm j  instance AbsTerm a => AbsTerm [a] where-  absTerm = fmap . absTerm+  absTerm j = fmap . absTerm j  instance AbsTerm a => AbsTerm (Maybe a) where-  absTerm = fmap . absTerm+  absTerm j = fmap . absTerm j  instance (TermSubst a, AbsTerm a) => AbsTerm (Abs a) where-  absTerm u (NoAbs x v) = NoAbs x $ absTerm u v-  absTerm u (Abs   x v) = Abs x $ swap01 $ absTerm (raise 1 u) v+  absTerm j u (NoAbs x v) = NoAbs x $ absTerm j u v+  absTerm j u (Abs   x v) = Abs x $ absTerm (j + 1) (raise 1 u) v  instance (AbsTerm a, AbsTerm b) => AbsTerm (a, b) where-  absTerm u (x, y) = (absTerm u x, absTerm u y)+  absTerm j u (x, y) = (absTerm j u x, absTerm j u y)  -- | This swaps @var 0@ and @var 1@. swap01 :: TermSubst a => a -> a@@ -288,11 +324,10 @@  instance EqualSy Sort where   equalSy = curry $ \case-    (Type l    , Type l'     ) -> equalSy l l'-    (Prop l    , Prop l'     ) -> equalSy l l'-    (Inf f m   , Inf f' n    ) -> f == f' && m == n-    (SSet l    , SSet l'     ) -> equalSy l l'+    (Univ u l  , Univ u' l'  ) -> u == u' && equalSy l l'+    (Inf u m   , Inf u' n    ) -> u == u' && m == n     (SizeUniv  , SizeUniv    ) -> True+    (LevelUniv , LevelUniv   ) -> True     (PiSort a b c, PiSort a' b' c') -> equalSy a a' && equalSy b b' && equalSy c c'     (FunSort a b, FunSort a' b') -> equalSy a a' && equalSy b b'     (UnivSort a, UnivSort a' ) -> equalSy a a'@@ -329,9 +364,9 @@  -- | Ignore the tactic. instance EqualSy a => EqualSy (Dom a) where-  equalSy d@(Dom ai b x _tac a) d'@(Dom ai' b' x' _tac' a') = and+  equalSy d@(Dom ai x f _tac a) d'@(Dom ai' x' f' _tac' a') = and     [ x == x'-    , b == b'+    , f == f'     , equalSy ai ai'     , equalSy a a'     ]
src/full/Agda/TypeChecking/CheckInternal.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- Initially authored by Andreas, 2013-10-22. @@ -9,107 +10,45 @@  module Agda.TypeChecking.CheckInternal   ( MonadCheckInternal-  , checkType-  , checkType'-  , checkSort-  , checkInternal-  , checkInternal'-  , checkInternalType'+  , checkType, infer, inferSpine+  , CheckInternal(..)   , Action(..), defaultAction, eraseUnusedAction-  , infer-  , inferSpine'-  , shouldBeSort   ) where -import Control.Arrow (first) import Control.Monad  import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.Common.Pretty (prettyShow)  import Agda.TypeChecking.Conversion-import Agda.TypeChecking.Datatypes -- (getConType, getFullyAppliedConType)+import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Level import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty import Agda.TypeChecking.ProjectionLike (elimView, ProjEliminator(..))-import Agda.TypeChecking.Records (getDefType)-import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Records (shouldBeProjectible) import Agda.TypeChecking.Substitute import Agda.TypeChecking.Sort import Agda.TypeChecking.Telescope -+import Agda.Utils.Function (applyWhen, applyWhenM) import Agda.Utils.Functor (($>))+import Agda.Utils.Maybe import Agda.Utils.Size  import Agda.Utils.Impossible +import Agda.Interaction.Options+ -- * Bidirectional rechecker  type MonadCheckInternal m = MonadConversion m --- -- | Entry point for e.g. checking WithFunctionType.--- checkType :: Type -> TCM ()--- checkType t = -- dontAssignMetas $ ignoreSorts $---   checkInternal (unEl t) (sort Inf)-+{-# SPECIALIZE checkType :: Type -> TCM () #-} -- | Entry point for e.g. checking WithFunctionType. checkType :: (MonadCheckInternal m) => Type -> m ()-checkType t = catchConstraint (CheckType t) $ do-  inferred <- checkType' t-  equalSort (getSort t) inferred---- | Check a type and infer its sort.------   Necessary because of PTS rule @(SizeUniv, Set i, Set i)@---   but @SizeUniv@ is not included in any @Set i@.------   This algorithm follows---     Abel, Coquand, Dybjer, MPC 08,---     Verifying a Semantic βη-Conversion Test for Martin-Löf Type Theory----checkType' :: (MonadCheckInternal m) => Type -> m Sort-checkType' t = do-  reportSDoc "tc.check.internal" 20 $ sep-    [ "checking internal type "-    , prettyTCM t-    ]-  v <- elimView EvenLone $ unEl t -- bring projection-like funs in post-fix form-  case v of-    Pi a b -> do-      s1 <- checkType' $ unDom a-      s2 <- (b $>) <$> do-        let goInside = case b of Abs{}   -> addContext (absName b, a)-                                 NoAbs{} -> id-        goInside $ checkType' $ unAbs b-      inferPiSort a s2-    Sort s -> do-      _ <- checkSort defaultAction s-      inferUnivSort s-    Var i es   -> do-      a <- typeOfBV i-      checkTypeSpine a (Var i   []) es-    Def f es   -> do  -- not a projection-like fun-      a <- defType <$> getConstInfo f-      checkTypeSpine a (Def f   []) es-    MetaV x es -> do -- we assume meta instantiations to be well-typed-      a <- metaType x-      checkTypeSpine a (MetaV x []) es-    v@Lam{}    -> typeError $ InvalidType v-    v@Con{}    -> typeError $ InvalidType v-    v@Lit{}    -> typeError $ InvalidType v-    v@Level{}  -> typeError $ InvalidType v-    DontCare v -> checkType' $ t $> v-    Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s--checkTypeSpine :: (MonadCheckInternal m) => Type -> Term -> Elims -> m Sort-checkTypeSpine a self es = shouldBeSort =<< do snd <$> inferSpine a self es--checkInternalType' :: (MonadCheckInternal m) => Action m -> Type -> m Type-checkInternalType' act El{_getSort=s, unEl=t} = do-  tAfterAct <- checkInternal' act t CmpLeq (sort s)-  return El{_getSort=s, unEl=tAfterAct}+checkType t = catchConstraint (CheckType t) $ inferInternal t  -- | 'checkInternal' traverses the whole 'Term', and we can use this --   traversal to modify the term.@@ -152,147 +91,141 @@     eraseIfNonvariant (Nonvariant : pols) (e : es) = (fmap dontCare e) : eraseIfNonvariant pols es     eraseIfNonvariant (_          : pols) (e : es) = e : eraseIfNonvariant pols es --- | Entry point for term checking.-checkInternal :: (MonadCheckInternal m) => Term -> Comparison -> Type -> m ()-checkInternal v cmp t = void $ checkInternal' defaultAction v cmp t+class CheckInternal a where+  checkInternal' :: (MonadCheckInternal m) => Action m -> a -> Comparison -> TypeOf a -> m a -checkInternal' :: (MonadCheckInternal m) => Action m -> Term -> Comparison -> Type -> m Term-checkInternal' action v cmp t = verboseBracket "tc.check.internal" 20 "" $ do-  reportSDoc "tc.check.internal" 20 $ sep-    [ "checking internal "-    , nest 2 $ sep [ prettyTCM v <+> ":"-                   , nest 2 $ prettyTCM t ] ]-  reportSDoc "tc.check.internal" 30 $ sep-    [ "checking internal with DB indices"-    , nest 2 $ sep [ pretty v <+> ":"-                   , nest 2 $ pretty t ] ]-  ctx <- getContextTelescope-  reportSDoc "tc.check.internal" 30 $ sep-    [ "In context"-    , nest 2 $ sep [ prettyTCM ctx ] ]-  -- Bring projection-like funs in post-fix form,-  -- (even lone ones by default).-  v <- elimViewAction action =<< preAction action t v-  postAction action t =<< case v of-    Var i es   -> do-      a <- typeOfBV i-      reportSDoc "tc.check.internal" 30 $ fsep-        [ "variable" , prettyTCM (var i) , "has type" , prettyTCM a ]-      checkSpine action a (Var i []) es cmp t-    Def f es   -> do  -- f is not projection(-like)!-      a <- defType <$> getConstInfo f-      checkSpine action a (Def f []) es cmp t-    MetaV x es -> do -- we assume meta instantiations to be well-typed-      a <- metaType x-      reportSDoc "tc.check.internal" 30 $ "metavariable" <+> prettyTCM x <+> "has type" <+> prettyTCM a-      checkSpine action a (MetaV x []) es cmp t-    Con c ci vs -> do-      -- We need to fully apply the constructor to make getConType work!-      fullyApplyCon c vs t $ \ _d _dt _pars a vs' tel t -> do-        Con c ci vs2 <- checkSpine action a (Con c ci []) vs' cmp t-        -- Strip away the extra arguments-        return $ applySubst (strengthenS impossible (size tel))-          $ Con c ci $ take (length vs) vs2-    Lit l      -> do-      lt <- litType l-      compareType cmp lt t-      return $ Lit l-    Lam ai vb  -> do-      (a, b) <- maybe (shouldBePi t) return =<< isPath t-      ai <- checkArgInfo action ai $ domInfo a-      let name = suggests [ Suggestion vb , Suggestion b ]-      addContext (name, a) $ do-        Lam ai . Abs (absName vb) <$> checkInternal' action (absBody vb) cmp (absBody b)-    Pi a b     -> do-      s <- shouldBeSort t-      when (s == SizeUniv) $ typeError $ FunctionTypeInSizeUniv v-      let sa  = getSort a-          sb  = getSort (unAbs b)-          mkDom v = El sa v <$ a-          mkRng v = fmap (v <$) b-          -- Preserve NoAbs-          goInside = case b of Abs{}   -> addContext (absName b, a)-                               NoAbs{} -> id-      a <- mkDom <$> checkInternal' action (unEl $ unDom a) CmpLeq (sort sa)-      v' <- goInside $ Pi a . mkRng <$> checkInternal' action (unEl $ unAbs b) CmpLeq (sort sb)-      s' <- sortOf v'-      compareSort cmp s' s-      return v'-    Sort s     -> do-      reportSDoc "tc.check.internal" 30 $ "checking sort" <+> prettyTCM s-      s <- checkSort action s-      s' <- inferUnivSort s-      s'' <- shouldBeSort t-      compareSort cmp s' s''-      return $ Sort s-    Level l    -> do-      l <- checkLevel action l-      lt <- levelType-      compareType cmp lt t-      return $ Level l-    DontCare v -> DontCare <$> checkInternal' action v cmp t-    Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s+  checkInternal :: (MonadCheckInternal m) => a -> Comparison -> TypeOf a -> m ()+  checkInternal v cmp t = void $ checkInternal' defaultAction v cmp t --- | Make sure a constructor is fully applied---   and infer the type of the constructor.---   Raises a type error if the constructor does not belong to the given type.-fullyApplyCon-  :: (MonadCheckInternal m)-  => ConHead -- ^ Constructor.-  -> Elims    -- ^ Constructor arguments.-  -> Type    -- ^ Type of the constructor application.-  -> (QName -> Type -> Args -> Type -> Elims -> Telescope -> Type -> m a)-       -- ^ Name of the data/record type,-       --   type of the data/record type,-       --   reconstructed parameters,-       --   type of the constructor (applied to parameters),-       --   full application arguments,-       --   types of missing arguments (already added to context),-       --   type of the full application.-  -> m a-fullyApplyCon c vs t0 ret = do-  (TelV tel t, boundary) <- telViewPathBoundaryP t0-  -- The type of the constructor application may still be a function-  -- type.  In this case, we introduce the domains @tel@ into the context-  -- and apply the constructor to these fresh variables.-  addContext tel $ do-    t <- abortIfBlocked t-    getFullyAppliedConType c t >>= \case-      Nothing ->-        typeError $ DoesNotConstructAnElementOf (conName c) t-      Just ((d, dt, pars), a) ->-        ret d dt pars a (raise (size tel) vs ++ teleElims tel boundary) tel t+  inferInternal' :: (MonadCheckInternal m, TypeOf a ~ ()) => Action m -> a -> m a+  inferInternal' act v = checkInternal' act v CmpEq () -checkSpine-  :: (MonadCheckInternal m)-  => Action m-  -> Type       -- ^ Type of the head @self@.-  -> Term       -- ^ The head @self@.-  -> Elims      -- ^ The eliminations @es@.-  -> Comparison -- ^ Check (@CmpLeq@) or infer (@CmpEq@) the final type.-  -> Type       -- ^ Expected type of the application @self es@.-  -> m Term     -- ^ The application after modification by the @Action@.-checkSpine action a self es cmp t = do-  reportSDoc "tc.check.internal" 20 $ sep-    [ "checking spine "-    , nest 2 $ sep [ parens (sep [ prettyTCM self <+> ":"-                                 , nest 2 $ prettyTCM a ])-                   , nest 4 $ prettyTCM es <+> ":"-                   , nest 2 $ prettyTCM t ] ]-  ((v, v'), t') <- inferSpine' action a self self es-  t' <- reduce t'-  v' <$ coerceSize (compareType cmp) v t' t---UNUSED Liang-Ting Chen 2019-07-16---checkArgs---  :: (MonadCheckInternal m)---  => Action m---  -> Type      -- ^ Type of the head.---  -> Term      -- ^ The head.---  -> Args      -- ^ The arguments.---  -> Type      -- ^ Expected type of the application.---  -> m Term    -- ^ The application after modification by the @Action@.---checkArgs action a self vs t = checkSpine action a self (map Apply vs) t+  inferInternal :: (MonadCheckInternal m, TypeOf a ~ ()) => a -> m ()+  inferInternal v = checkInternal v CmpEq () +{-# SPECIALIZE checkInternal' :: Action TCM -> Term  -> Comparison -> TypeOf Term -> TCM Term #-}+{-# SPECIALIZE checkInternal' :: Action TCM -> Type  -> Comparison -> TypeOf Type -> TCM Type #-}+{-# SPECIALIZE checkInternal' :: Action TCM -> Elims -> Comparison -> TypeOf Type -> TCM Elims #-}+{-# SPECIALIZE checkInternal  :: Term -> Comparison -> TypeOf Term -> TCM () #-}+{-# SPECIALIZE checkInternal  :: Type -> Comparison -> TypeOf Type -> TCM () #-}++instance CheckInternal Type where+  checkInternal' action (El s t) cmp _ = do+    t' <- checkInternal' action t cmp (sort s)+    s' <- sortOf t'+    compareSort cmp s' s+    return (El s t')++instance CheckInternal Term where+  checkInternal' :: (MonadCheckInternal m) => Action m -> Term -> Comparison -> Type -> m Term+  checkInternal' action v cmp t = verboseBracket "tc.check.internal" 20 "" $ do++    -- Debug print+    verboseS "tc.check.internal" 20 do+      reportSDoc "tc.check.internal" 20 $ sep+        [ "checking internal "+        , nest 2 $ sep [ prettyTCM v <+> ":"+                      , nest 2 $ prettyTCM t ] ]+      reportSDoc "tc.check.internal" 60 $ sep+        [ "checking internal with DB indices"+        , nest 2 $ sep [ pretty v <+> ":"+                      , nest 2 $ pretty t ] ]+      ctx <- getContextTelescope+      unless (null ctx) $ reportSDoc "tc.check.internal" 30 $ sep+        [ "In context"+        , nest 2 $ sep [ prettyTCM ctx ] ]++    -- Bring projection-like funs in post-fix form,+    -- (even lone ones by default).+    v <- elimViewAction action =<< preAction action t v+    postAction action t =<< case v of+      Var i es   -> do+        d <- domOfBV i+        n <- nameOfBV i++        -- Lucas, 23-11-2022:+        -- For now we only check if pure modalities are respected.+        -- In the future we SHOULD also be doing the same checks for every modality, as in Rules/Applications.hs+        -- (commented below)+        -- but this will break stuff that is allowed right now++        unless (usableCohesion d) $+          typeError $ VariableIsOfUnusableCohesion n (getCohesion d)++        unless (usablePolarity d) $+          typeError $ VariableIsOfUnusablePolarity n (getModalPolarity d)++        reportSDoc "tc.check.internal" 30 $ fsep+          [ "variable" , prettyTCM (var i) , "has type" , prettyTCM (unDom d)+          , "and modality", pretty (getModality d) ]+        checkSpine action (unDom d) (Var i) es cmp t+      Def f es   -> do  -- f is not projection(-like)!+        -- There is no "implicitely applied module telescope" at this stage, so no+        -- need to check it for modal errors, everything is covered by the+        -- variable rule!+        a <- defType <$> getConstInfo f+        checkSpine action a (Def f) es cmp t+      MetaV x es -> do -- we assume meta instantiations to be well-typed+        a <- metaType x+        reportSDoc "tc.check.internal" 30 $ "metavariable" <+> prettyTCM x <+> "has type" <+> prettyTCM a+        checkSpine action a (MetaV x) es cmp t+      Con c ci vs -> do+        -- We need to fully apply the constructor to make getConType work!+        fullyApplyCon c vs t $ \ _d _dt _pars a vs' tel t -> do+          checkSpine action a (Con c ci) vs' cmp t >>= \case+            Con c ci vs2 ->+              -- Strip away the extra arguments+              return $ applySubst (strengthenS impossible (size tel))+                $ Con c ci $ take (length vs) vs2+            _ -> __IMPOSSIBLE__+      Lit l      -> do+        lt <- litType l+        compareType cmp lt t+        return $ Lit l+      Lam ai vb  -> do+        (a, b) <- shouldBePiOrPath t+        ai <- checkArgInfo action ai $ domInfo a+        let name = suggests [ Suggestion vb , Suggestion b ]+        addContext (name, a) $ do+          Lam ai . Abs (absName vb) <$> checkInternal' action (absBody vb) cmp (absBody b)+      Pi a b     -> do+        s <- shouldBeSort t+        reportSDoc "tc.check.internal" 30 $ "pi type should have sort" <+> prettyTCM s+        when (s == SizeUniv) $ typeError $ FunctionTypeInSizeUniv v+        experimental <- optExperimentalIrrelevance <$> pragmaOptions+        let sa  = getSort a+            sb  = getSort (unAbs b)+            mkDom v = El sa v <$ a+            mkRng v = fmap (v <$) b+            -- Preserve NoAbs+            goInside = case b of+              Abs{}   -> addContext $ (absName b,) $+                inverseApplyPolarity (withStandardLock UnusedPolarity) $+                applyWhen experimental (mapRelevance irrelevantToShapeIrrelevant) a+              NoAbs{} -> id+        a <- applyWhenM (optPolarity <$> pragmaOptions) (applyPolarityToContext negativePolarity) $+               mkDom <$> checkInternal' action (unEl $ unDom a) CmpLeq (sort sa)+        v' <- goInside $ Pi a . mkRng <$> checkInternal' action (unEl $ unAbs b) CmpLeq (sort sb)+        s' <- sortOf v -- Issue #6205: do not use v' since it might not be valid syntax+        compareSort cmp s' s+        return v'+      Sort s     -> do+        reportSDoc "tc.check.internal" 30 $ "checking sort" <+> prettyTCM s+        s <- inferInternal' action s+        s' <- inferUnivSort s+        s'' <- shouldBeSort t+        compareSort cmp s' s''+        return $ Sort s+      Level l    -> do+        l <- inferInternal' action l+        lt <- levelType'+        compareType cmp lt t+        return $ Level l+      DontCare v -> DontCare <$> checkInternal' action v cmp t+      -- Jesper, 2023-02-23: these can appear because of eta-expansion of+      -- records with irrelevant fields+      Dummy s _ -> return v -- __IMPOSSIBLE_VERBOSE__ s+ -- | @checkArgInfo actual expected@. -- --   The @expected@ 'ArgInfo' comes from the type.@@ -304,8 +237,8 @@   mod <- checkModality action (getModality ai)  (getModality ai')   return $ setModality mod ai -checkHiding    :: (MonadCheckInternal m) => Hiding -> Hiding -> m ()-checkHiding    h h' = unless (sameHiding h h') $ typeError $ HidingMismatch h h'+checkHiding :: (MonadCheckInternal m) => Hiding -> Hiding -> m ()+checkHiding h h' = unless (sameHiding h h') $ typeError $ HidingMismatch h h'  -- | @checkRelevance action term type@. --@@ -320,157 +253,126 @@     | otherwise -> __IMPOSSIBLE__ -- add more cases when adding new modalities   return $ modalityAction action mod' mod  -- Argument order for actions: @type@ @term@ +{-# SPECIALIZE infer :: Term -> TCM Type #-} -- | Infer type of a neutral term. infer :: (MonadCheckInternal m) => Term -> m Type-infer v = do-  case v of-    Var i es   -> do+infer u = do+  reportSDoc "tc.check.internal" 20 $ "CheckInternal.infer" <+> prettyTCM u+  case u of+    Var i es -> do       a <- typeOfBV i-      snd <$> inferSpine a (Var i   []) es-    Def f (Apply a : es) -> inferDef' f a es -- possibly proj.like-    Def f es             -> inferDef  f   es -- not a projection-like fun+      fst <$> inferSpine defaultAction a (Var i) es+    Def f es -> do+      whenJustM (isRelevantProjection f) $ \_ -> nonInferable+      a <- defType <$> getConstInfo f+      fst <$> inferSpine defaultAction a (Def f) es     MetaV x es -> do -- we assume meta instantiations to be well-typed       a <- metaType x-      snd <$> inferSpine a (MetaV x []) es-    _ -> __IMPOSSIBLE__---- | Infer ordinary function application.-inferDef :: (MonadCheckInternal m) => QName -> Elims -> m Type-inferDef f es = do-  a <- defType <$> getConstInfo f-  snd <$> inferSpine a (Def f []) es---- | Infer possibly projection-like function application-inferDef' :: (MonadCheckInternal m) => QName -> Arg Term -> Elims -> m Type-inferDef' f a es = do-  -- Andreas, 2022-03-07, issue #5809: don't drop parameters of irrelevant projections.-  isRelevantProjection f >>= \case-    Just Projection{ projIndex = n } | n > 0 -> do-      let self = unArg a-      b <- infer self-      snd <$> inferSpine b self (Proj ProjSystem f : es)-    _ -> inferDef f (Apply a : es)----- | @inferSpine t self es@ checks that spine @es@ eliminates---   value @self@ of type @t@ and returns the remaining type---   (target of elimination) and the final self (has that type).-inferSpine :: (MonadCheckInternal m) => Type -> Term -> Elims -> m (Term, Type)-inferSpine a v es = first fst <$> inferSpine' defaultAction a v v es---- | Returns both the real term (first) and the transformed term (second). The---   transformed term is not necessarily a valid term, so it must not be used---   in types.-inferSpine' :: (MonadCheckInternal m)-            => Action m -> Type -> Term -> Term -> Elims -> m ((Term, Term), Type)-inferSpine' action t self self' [] = return ((self, self'), t)-inferSpine' action t self self' (e : es) = do-  reportSDoc "tc.infer.internal" 30 $ sep-    [ "inferSpine': "-    , "type t = " <+> pretty t-    , "self  = " <+> pretty self-    , "self' = " <+> pretty self'-    , "eliminated by e = " <+> text (show e)-    ]-  case e of-    IApply x y r -> do-      (a, b) <- shouldBePath t-      r' <- checkInternal' action r CmpLeq (unDom a)-      izero <- primIZero-      ione  <- primIOne-      x' <- checkInternal' action x CmpLeq (b `absApp` izero)-      y' <- checkInternal' action y CmpLeq (b `absApp` ione)-      inferSpine' action (b `absApp` r) (self `applyE` [e]) (self' `applyE` [IApply x' y' r']) es-    Apply (Arg ai v) -> do-      (a, b) <- shouldBePi t-      ai <- checkArgInfo action ai $ domInfo a-      v' <- checkInternal' action v CmpLeq $ unDom a-      inferSpine' action (b `absApp` v) (self `applyE` [e]) (self' `applyE` [Apply (Arg ai v')]) es-    -- case: projection or projection-like-    Proj o f -> do-      (a, b) <- shouldBePi =<< shouldBeProjectible t f-      u  <- applyDef o f (argFromDom a $> self)-      u' <- applyDef o f (argFromDom a $> self')-      inferSpine' action (b `absApp` self) u u' es+      fst <$> inferSpine defaultAction a (MetaV x) es+    _ -> nonInferable+  where+    nonInferable :: MonadDebug m => m a+    nonInferable = __IMPOSSIBLE_VERBOSE__ $ unlines+      [ "CheckInternal.infer: non-inferable term:"+      , "  " ++ prettyShow u+      ] --- | Type should either be a record type of a type eligible for---   the principal argument of projection-like functions.-shouldBeProjectible :: (MonadCheckInternal m) => Type -> QName -> m Type--- shouldBeProjectible t f = maybe failure return =<< projectionType t f-shouldBeProjectible t f = do-    t <- abortIfBlocked t-    maybe failure return =<< getDefType f t-  where failure = typeError $ ShouldBeRecordType t-    -- TODO: more accurate error that makes sense also for proj.-like funs.+instance CheckInternal Elims where+  checkInternal' action es cmp (t , hd) = snd <$> inferSpine action t hd es -shouldBePath :: (MonadCheckInternal m) => Type -> m (Dom Type, Abs Type)-shouldBePath t = do-  t <- abortIfBlocked t-  m <- isPath t-  case m of-    Just p  -> return p-    Nothing -> typeError $ ShouldBePath t+{-# SPECIALIZE inferSpine :: Action TCM -> Type -> (Elims -> Term) -> Elims -> TCM (Type, Elims) #-}+-- | @inferSpine action t hd es@ checks that spine @es@ eliminates+--   value @hd []@ of type @t@ and returns the remaining type+--   (target of elimination) and the transformed eliminations.+inferSpine :: (MonadCheckInternal m) => Action m -> Type -> (Elims -> Term) -> Elims -> m (Type, Elims)+inferSpine action t hd es = loop t hd id es+  where+  loop t hd acc = \case+    [] -> return (t , acc [])+    (e : es) -> do+      let self = hd []+      reportSDoc "tc.check.internal" 30 $ sep+        [ "inferring spine: "+        , "type t = " <+> prettyTCM t+        , "self  = " <+> prettyTCM self+        , "eliminated by e = " <+> prettyTCM e+        ]+      case e of+        IApply x y r -> do+          (a, b) <- shouldBePath t+          r' <- checkInternal' action r CmpLeq (unDom a)+          izero <- primIZero+          ione  <- primIOne+          x' <- checkInternal' action x CmpLeq (b `absApp` izero)+          y' <- checkInternal' action y CmpLeq (b `absApp` ione)+          let e' = IApply x' y' r'+          loop (b `absApp` r) (hd . (e:)) (acc . (e':)) es+        Apply (Arg ai v) -> do+          (a, b) <- shouldBePi t+          ai <- checkArgInfo action ai $ domInfo a+          v' <- applyModalityToContext (getModality a) $ checkInternal' action v CmpLeq $ unDom a+          let e' = Apply (Arg ai v')+          loop (b `absApp` v) (hd . (e:)) (acc . (e':)) es+        -- case: projection or projection-like+        Proj o f -> do+          t' <- shouldBeProjectible self t o f+          loop t' (hd . (e:)) (acc . (e:)) es -shouldBePi :: (MonadCheckInternal m) => Type -> m (Dom Type, Abs Type)-shouldBePi t = abortIfBlocked t >>= \ case-  El _ (Pi a b) -> return (a, b)-  _             -> typeError $ ShouldBePi t+{-# SPECIALIZE checkSpine :: Action TCM -> Type -> (Elims -> Term) -> Elims -> Comparison -> Type -> TCM Term #-}+checkSpine+  :: (MonadCheckInternal m)+  => Action m+  -> Type       -- ^ Type of the head @self@.+  -> (Elims -> Term) -- ^ The head @hd@.+  -> Elims      -- ^ The eliminations @es@.+  -> Comparison -- ^ Check (@CmpLeq@) or infer (@CmpEq@) the final type.+  -> Type       -- ^ Expected type of the application @self es@.+  -> m Term     -- ^ The application after modification by the @Action@.+checkSpine action a hd es cmp t = do+  reportSDoc "tc.check.internal" 20 $ sep+    [ "checking spine "+    , nest 2 $ sep [ parens (sep [ prettyTCM (hd []) <+> ":"+                                 , nest 2 $ prettyTCM a ])+                   , nest 4 $ prettyTCM es <+> ":"+                   , nest 2 $ prettyTCM t ] ]+  (t' , es') <- inferSpine action a hd es+  coerceSize (compareType cmp) (hd es) t' t+  return $ hd es' --- | Check if sort is well-formed.-checkSort :: (MonadCheckInternal m) => Action m -> Sort -> m Sort-checkSort action s =-  case s of-    Type l   -> Type <$> checkLevel action l-    Prop l   -> Prop <$> checkLevel action l-    Inf f n  -> return $ Inf f n-    SSet l   -> SSet <$> checkLevel action l+instance CheckInternal Sort where+  checkInternal' action s cmp _ = case s of+    Univ u l -> Univ u <$> inferInternal' action l+    Inf u n  -> return $ Inf u n     SizeUniv -> return SizeUniv     LockUniv -> return LockUniv+    LevelUniv -> return LevelUniv+    IntervalUniv -> return IntervalUniv     PiSort dom s1 s2 -> do       let a = unDom dom-      s1' <- checkSort action s1+      s1' <- inferInternal' action s1       a' <- checkInternal' action a CmpLeq $ sort s1'       let dom' = dom $> a'-      s2' <- mapAbstraction (El s1' <$> dom') (checkSort action) s2+      s2' <- mapAbstraction (El s1' <$> dom') (inferInternal' action) s2       return $ PiSort dom' s1' s2'     FunSort s1 s2 -> do-      s1' <- checkSort action s1-      s2' <- checkSort action s2+      s1' <- inferInternal' action s1+      s2' <- inferInternal' action s2       return $ FunSort s1' s2'-    UnivSort s -> UnivSort <$> checkSort action s+    UnivSort s -> UnivSort <$> inferInternal' action s     MetaS x es -> do -- we assume sort meta instantiations to be well-formed       a <- metaType x-      let self = Sort $ MetaS x []-      ((_,v),_) <- inferSpine' action a self self es-      case v of-        Sort s     -> return s-        MetaV x es -> return $ MetaS x es-        Def d es   -> return $ DefS d es-        _          -> __IMPOSSIBLE__+      MetaS x <$> checkInternal' action es cmp (a , Sort . MetaS x)     DefS d es -> do       a <- defType <$> getConstInfo d-      let self = Sort $ DefS d []-      ((_,v),_) <- inferSpine' action a self self es-      case v of-        Sort s     -> return s-        MetaV x es -> return $ MetaS x es-        Def d es   -> return $ DefS d es-        _          -> __IMPOSSIBLE__+      DefS d <$> checkInternal' action es cmp (a , Sort . DefS d)     DummyS s -> __IMPOSSIBLE_VERBOSE__ s --- | Check if level is well-formed.-checkLevel :: (MonadCheckInternal m) => Action m -> Level -> m Level-checkLevel action (Max n ls) = Max n <$> mapM checkPlusLevel ls-  where-    checkPlusLevel (Plus k l)      = Plus k <$> checkLevelAtom l+instance CheckInternal Level where+  checkInternal' action (Max n ls) _ _ = Max n <$> mapM (inferInternal' action) ls +instance CheckInternal PlusLevel where+  checkInternal' action (Plus k l) _ _ = Plus k <$> checkLevelAtom l+    where     checkLevelAtom l = do-      lvl <- levelType+      lvl <- levelType'       checkInternal' action l CmpLeq lvl---- | Universe subsumption and type equality (subtyping for sizes, resp.).-cmptype :: (MonadCheckInternal m) => Comparison -> Type -> Type -> m ()-cmptype cmp t1 t2 = do-    -- Andreas, 2017-03-09, issue #2493-    -- Only check subtyping, do not solve any metas!-    dontAssignMetas $ compareType cmp t1 t2
src/full/Agda/TypeChecking/CheckInternal.hs-boot view
@@ -1,9 +1,10 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE KindSignatures #-}  module Agda.TypeChecking.CheckInternal where  import Control.Monad.Except-import qualified Control.Monad.Fail as Fail  import qualified Data.Kind as Hs @@ -20,7 +21,6 @@   , MonadStatistics m   , MonadFresh ProblemId m   , MonadFresh Int m-  , Fail.MonadFail m   )  data Action (m :: Hs.Type -> Hs.Type)@@ -28,9 +28,23 @@ defaultAction :: PureTCM m => Action m eraseUnusedAction :: Action TCM +class CheckInternal a where+  checkInternal' :: (MonadCheckInternal m) => Action m -> a -> Comparison -> TypeOf a -> m a++  checkInternal :: (MonadCheckInternal m) => a -> Comparison -> TypeOf a -> m ()+  checkInternal v cmp t = void $ checkInternal' defaultAction v cmp t++  inferInternal' :: (MonadCheckInternal m, TypeOf a ~ ()) => Action m -> a -> m a+  inferInternal' act v = checkInternal' act v CmpEq ()++  inferInternal :: (MonadCheckInternal m, TypeOf a ~ ()) => a -> m ()+  inferInternal v = checkInternal v CmpEq ()++instance CheckInternal Term+instance CheckInternal Type+instance CheckInternal Sort+instance CheckInternal Level+instance CheckInternal Elims+ checkType :: (MonadCheckInternal m) => Type -> m ()-checkType' :: (MonadCheckInternal m) => Type -> m Sort-checkSort :: (MonadCheckInternal m) => Action m -> Sort -> m Sort-checkInternal :: (MonadCheckInternal m) => Term -> Comparison -> Type -> m ()-checkInternal' :: (MonadCheckInternal m) => Action m -> Term -> Comparison -> Type -> m Term infer :: (MonadCheckInternal m) => Term -> m Type
src/full/Agda/TypeChecking/CompiledClause.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Case trees. -- --   After coverage checking, pattern matching is translated@@ -14,11 +16,6 @@ import Data.Map (Map) import Data.Semigroup hiding (Arg(..)) ----import Data.Data (Data)- import GHC.Generics (Generic)  import Agda.Syntax.Common@@ -28,12 +25,12 @@ import Agda.Syntax.Position  import Agda.Utils.Null-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty  import Agda.Utils.Impossible  data WithArity c = WithArity { arity :: Int, content :: c }-  deriving (Data, Functor, Foldable, Traversable, Show, Generic)+  deriving (Functor, Foldable, Traversable, Show, Generic)  -- | Branches in a case tree. @@ -49,15 +46,15 @@     --   present, there should not be any conBranches or litBranches.   , litBranches    :: Map Literal c     -- ^ Map from literal to case subtree.-  , catchAllBranch :: Maybe c+  , catchallBranch :: Maybe c     -- ^ (Possibly additional) catch-all clause.   , fallThrough :: Maybe Bool-    -- ^ (if True) In case of non-canonical argument use catchAllBranch.+    -- ^ (if True) In case of non-canonical argument use catchallBranch.   , lazyMatch :: Bool     -- ^ Lazy pattern match. Requires single (non-copattern) branch with no lit     --   branches and no catch-all.   }-  deriving (Data, Functor, Foldable, Traversable, Show, Generic)+  deriving (Functor, Foldable, Traversable, Show, Generic)  -- | Case tree with bodies. @@ -75,7 +72,7 @@   | Fail [Arg ArgName]     -- ^ Absurd case. Add the free variables here as well so we can build correct     --   number of lambdas for strict backends. (#4280)-  deriving (Data, Functor, Traversable, Foldable, Show, Generic)+  deriving (Functor, Traversable, Foldable, Show, Generic)  type CompiledClauses = CompiledClauses' Term @@ -91,8 +88,8 @@ projCase :: QName -> c -> Case c projCase c x = Branches True (Map.singleton c $ WithArity 0 x) Nothing Map.empty Nothing (Just False) False -catchAll :: c -> Case c-catchAll x = Branches False Map.empty Nothing Map.empty (Just x) (Just True) False+catchall :: c -> Case c+catchall x = Branches False Map.empty Nothing Map.empty (Just x) (Just True) False  -- | Check that the requirements on lazy matching (single inductive case) are --   met, and set lazy to False otherwise.@@ -100,19 +97,19 @@ checkLazyMatch b = b { lazyMatch = lazyMatch b && requirements }   where     requirements = and-      [ null (catchAllBranch b)+      [ null (catchallBranch b)       , Map.size (conBranches b) <= 1       , null (litBranches b)       , not $ projPatterns b ]  -- | Check whether a case tree has a catch-all clause.-hasCatchAll :: CompiledClauses -> Bool-hasCatchAll = getAny . loop+hasCatchall :: CompiledClauses -> Bool+hasCatchall = getAny . loop   where   loop cc = case cc of     Fail{}    -> mempty     Done{}    -> mempty-    Case _ br -> maybe (foldMap loop br) (const $ Any True) $ catchAllBranch br+    Case _ br -> maybe (foldMap loop br) (const $ Any True) $ catchallBranch br  -- | Check whether a case tree has any projection patterns hasProjectionPatterns :: CompiledClauses -> Bool@@ -201,9 +198,9 @@     b lazy  instance KillRange CompiledClauses where-  killRange (Case i br) = killRange2 Case i br-  killRange (Done xs v) = killRange2 Done xs v-  killRange (Fail xs)   = killRange1 Fail xs+  killRange (Case i br) = killRangeN Case i br+  killRange (Done xs v) = killRangeN Done xs v+  killRange (Fail xs)   = killRangeN Fail xs  -- * TermLike instances
src/full/Agda/TypeChecking/CompiledClause/Compile.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.CompiledClause.Compile where @@ -8,6 +9,7 @@ import Control.Monad.Trans.Identity  import Data.Maybe+import Data.List (partition) import qualified Data.Map as Map  import Agda.Syntax.Common@@ -26,7 +28,8 @@ import Agda.Utils.Functor import Agda.Utils.Maybe import Agda.Utils.List-import qualified Agda.Utils.Pretty as P+import qualified Agda.Syntax.Common.Pretty as P+import Agda.Utils.Size import Agda.Utils.Update  import Agda.Utils.Impossible@@ -34,14 +37,14 @@ data RunRecordPatternTranslation = RunRecordPatternTranslation | DontRunRecordPatternTranslation   deriving (Eq) -compileClauses' :: RunRecordPatternTranslation -> [Clause] -> Maybe SplitTree -> TCM CompiledClauses-compileClauses' recpat cs mSplitTree = do+compileClauses' :: QName -> RunRecordPatternTranslation -> [Clause] -> Maybe SplitTree -> TCM CompiledClauses+compileClauses' q recpat cs mSplitTree = do    -- Throw away the unreachable clauses (#2723).   let notUnreachable = (Just True /=) . clauseUnreachable   cs <- map unBruijn <$> normaliseProjP (filter notUnreachable cs) -  let translate | recpat == RunRecordPatternTranslation = runIdentityT . translateCompiledClauses+  let translate | recpat == RunRecordPatternTranslation = runIdentityT . translateCompiledClauses q                 | otherwise                             = return    translate $ caseMaybe mSplitTree (compile cs) $ \splitTree ->@@ -84,12 +87,15 @@           map (prettyTCM . map unArg . clPats) cls       reportSDoc "tc.cc" 50 $         "clauses of " <+> prettyTCM q <+> " before compilation" <?> pretty cs+       let cc = compileWithSplitTree splitTree cls       reportSDoc "tc.cc" 20 $ sep         [ "compiled clauses of " <+> prettyTCM q <+> " (still containing record splits)"         , nest 2 $ return $ P.pretty cc         ]-      (cc, becameCopatternLHS) <- runChangeT $ translateCompiledClauses cc++      (cc, becameCopatternLHS) <- runChangeT $ translateCompiledClauses q cc+       reportSDoc "tc.cc" 12 $ sep         [ "compiled clauses of " <+> prettyTCM q         , nest 2 $ return $ P.pretty cc@@ -119,13 +125,12 @@  compileWithSplitTree :: SplitTree -> Cls -> CompiledClauses compileWithSplitTree t cs = case t of-  SplitAt i lz ts -> Case i $ compiles lz ts $ splitOn (length ts == 1) (unArg i) cs+  SplitAt i lz ts -> Case i $ compiles lz ts $ splitOn (natSize ts == 1) (unArg i) cs         -- if there is just one case, we force expansion of catch-alls         -- this is needed to generate a sound tree on which we can         -- collapse record pattern splits   SplittingDone n -> compile cs     -- after end of split tree, continue with left-to-right strategy-   where     compiles :: LazySplit -> SplitTrees -> Case Cls -> Case CompiledClauses     compiles lz ts br@Branches{ projPatterns = cop@@ -133,13 +138,13 @@                               , etaBranch   = Nothing                               , litBranches = lits                               , fallThrough = fT-                              , catchAllBranch = catchAll+                              , catchallBranch = catchall                               , lazyMatch = lazy }       = br{ conBranches    = updCons cons           , etaBranch      = Nothing           , litBranches    = updLits lits           , fallThrough    = fT-          , catchAllBranch = updCatchall catchAll+          , catchallBranch = updCatchall catchall           , lazyMatch      = lazy || lz == LazySplit           }       where@@ -218,8 +223,8 @@ --   if @single@. splitOn :: Bool -> Int -> Cls -> Case Cls splitOn single n cs = mconcat $ map (fmap (:[]) . splitC n) $-  -- (\ cs -> trace ("splitting on " ++ show n ++ " after expandCatchAlls " ++ show single ++ ": " ++ prettyShow (P.prettyList cs)) cs) $-    expandCatchAlls single n cs+  -- (\ cs -> trace ("splitting on " ++ show n ++ " after expandCatchalls " ++ show single ++ ": " ++ prettyShow (P.prettyList cs)) cs) $+    expandCatchalls single n cs  splitC :: Int -> Cl -> Case Cl splitC n (Cl ps b) = caseMaybe mp fallback $ \case@@ -236,7 +241,7 @@     (ps0, rest) = splitAt n ps     mp          = unArg <$> listToMaybe rest     ps1         = drop 1 rest-    fallback    = catchAll $ Cl ps b+    fallback    = catchall $ Cl ps b  -- | Expand catch-alls that appear before actual matches. --@@ -306,36 +311,60 @@ --     _  -> case j of --             i1 -> base -- @-expandCatchAlls :: Bool -> Int -> Cls -> Cls-expandCatchAlls single n cs =-  -- Andreas, 2013-03-22-  -- if there is a single case (such as for record splits)-  -- we force expansion-  if single then doExpand =<< cs else+expandCatchalls :: Bool -> Int -> Cls -> Cls+expandCatchalls single n cs =   case cs of-  _                | all (isCatchAllNth . clPats) cs -> cs-  c@(Cl ps b) : cs | not (isCatchAllNth ps) -> c : expandCatchAlls False n cs-                   | otherwise -> map (expand c) expansions ++ c : expandCatchAlls False n cs-  _ -> __IMPOSSIBLE__+    _ -- Andreas, 2013-03-22+      -- if there is a single case (such as for record splits)+      -- we force expansion+      | single -> doExpand =<< cs++      -- If all clauses have a variable at the nth argument, expansion+      -- would have no effect+      | all (isCatchallNth . clPats) cs -> cs++    c@(Cl ps b):cs+      -- If the head clause does not have a catch-all pattern for the+      -- nth argument, we can keep it at the head and do no expansion+      | not (isCatchallNth ps) -> c : expandCatchalls False n cs++      -- If there's a DefP clause for this argument later on, then it+      -- should take priority over catch-all clauses, so we rotate them+      -- out of the way.+      -- DefP clauses are always inserted by the system and should+      -- "defeat" user-written inexact patterns.+      | (defps@(_:_), rest) <- partition isDefPNth (c:cs)+      -> defps ++ expandCatchalls False n rest++      -- If the head clause *does* have an irrefutable pattern for the+      -- nth argument, and there's nothing more important after, then we+      -- duplicate the subsequent overlapping clauses with c's RHS+      -- instead.+      | otherwise -> map (expand c) expansions ++ c : expandCatchalls False n cs+    _ -> __IMPOSSIBLE__   where     -- In case there is only one branch in the split tree, we expand all     -- catch-alls for this position     -- The @expansions@ are collected from all the clauses @cs@ then.     -- Note: @expansions@ could be empty, so we keep the orignal clause.     doExpand c@(Cl ps _)-      | exCatchAllNth ps = map (expand c) expansions ++ [c]+      | exCatchallNth ps = map (expand c) expansions ++ [c]       | otherwise = [c]      -- True if nth pattern is variable or there are less than n patterns.-    isCatchAllNth ps = all (isVar . unArg) $ take 1 $ drop n ps+    isCatchallNth ps = all (isVar . unArg) $ take 1 $ drop n ps      -- True if nth pattern exists and is variable.-    exCatchAllNth ps = any (isVar . unArg) $ take 1 $ drop n ps+    exCatchallNth ps = any (isVar . unArg) $ take 1 $ drop n ps      classify (LitP _ l)   = Left l     classify (ConP c _ _) = Right (Left c)     classify (DefP _ q _) = Right (Right q)     classify _            = __IMPOSSIBLE__++    isDefPNth cl = case unArg <$> listToMaybe (drop n (clPats cl)) of+      Just DefP{} -> True+      _ -> False      -- All non-catch-all patterns following this one (at position n).     -- These are the cases the wildcard needs to be expanded into.
src/full/Agda/TypeChecking/CompiledClause/Compile.hs-boot view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.CompiledClause.Compile where  import Agda.Syntax.Internal
src/full/Agda/TypeChecking/CompiledClause/Match.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.CompiledClause.Match where @@ -16,7 +17,7 @@  import Agda.Utils.Maybe import Agda.Utils.Monad-import Agda.Utils.Pretty (prettyShow)+import Agda.Syntax.Common.Pretty (prettyShow)  import Agda.Utils.Impossible @@ -88,13 +89,13 @@           lam x t        = Lam (argInfo x) (Abs (unArg x) t)        -- splitting on an eta-record constructor-      Case (Arg _ n) Branches{etaBranch = Just (c, cc), catchAllBranch = ca} ->+      Case (Arg _ n) Branches{etaBranch = Just (c, cc), catchallBranch = ca} ->         case splitAt n es of           (_, []) -> no (NotBlocked Underapplied) es           (es0, MaybeRed _ e@(Apply (Arg _ v0)) : es1) ->               let projs = [ MaybeRed NotReduced $ Apply $ Arg ai $ relToDontCare ai $ v0 `applyE` [Proj ProjSystem f] | Arg ai f <- fs ]-                  catchAllFrame stack = maybe stack (\c -> (c, es, patch) : stack) ca in-              match' $ (content cc, es0 ++ projs ++ es1, patchEta) : catchAllFrame stack+                  catchallFrame stack = maybe stack (\c -> (c, es, patch) : stack) ca in+              match' $ (content cc, es0 ++ projs ++ es1, patchEta) : catchallFrame stack             where               fs = conFields c               patchEta es = patch (es0 ++ [e] ++ es1)@@ -118,7 +119,7 @@                 -- replace the @n@th argument by its reduced form                 es' = es0 ++ [MaybeRed (Reduced $ () <$ eb) e] ++ es1                 -- if a catch-all clause exists, put it on the stack-                catchAllFrame stack = maybe stack (\c -> (c, es', patch) : stack) (catchAllBranch bs)+                catchallFrame stack = maybe stack (\c -> (c, es', patch) : stack) (catchallBranch bs)                 -- If our argument is @Lit l@, we push @litFrame l@ onto the stack.                 litFrame l stack =                   case Map.lookup l (litBranches bs) of@@ -155,7 +156,7 @@             --    mo <- getBuiltinName' builtinIOne             --    return $ Set.fromList $ catMaybes [mi,mo] -            fallThrough <- return $ (Just True ==) (fallThrough bs) && isJust (catchAllBranch bs)+            fallThrough <- return $ Just True == fallThrough bs && isJust (catchallBranch bs)              let               isCon b =@@ -170,21 +171,21 @@                 let cFrame stack = case cv of                       Con c ci vs -> conFrame c ci vs stack                       _        -> stack-                match' $ litFrame l $ cFrame $ catchAllFrame stack+                match' $ litFrame l $ cFrame $ catchallFrame stack                NotBlocked _ (Apply (Arg info v@(Def q vs))) | Just{} <- Map.lookup q (conBranches bs) -> performedSimplification $ do-                match' $ conFrame' q (Def q) vs $ catchAllFrame $ stack+                match' $ conFrame' q (Def q) vs $ catchallFrame $ stack                -- In case of a constructor, push the conFrame               b | Just (Con c ci vs) <- isCon b -> performedSimplification $-                match' $ conFrame c ci vs $ catchAllFrame $ stack+                match' $ conFrame c ci vs $ catchallFrame $ stack                -- In case of a projection, push the projFrame               NotBlocked _ (Proj _ p) -> performedSimplification $-                match' $ projFrame p $ stack -- catchAllFrame $ stack+                match' $ projFrame p $ stack -- catchallFrame $ stack                 -- Issue #1986: no catch-all for copattern matching! -              _ | fallThrough -> match' $ catchAllFrame $ stack+              _ | fallThrough -> match' $ catchallFrame $ stack                Blocked x _            -> no (Blocked x) es' @@ -198,7 +199,7 @@   caseMaybeM (asksTC envAppDef) __IMPOSSIBLE__ $ \ f -> do     pds <- getPartialDefs     if f `elem` pds-    then return (NoReduction $ NotBlocked MissingClauses [])+    then return (NoReduction $ NotBlocked (MissingClauses f) [])     else do       ifM (optRewriting <$> pragmaOptions)       {-then-} (return (NoReduction $ NotBlocked ReallyNotBlocked [])) -- See #5396
src/full/Agda/TypeChecking/CompiledClause/Match.hs-boot view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.CompiledClause.Match where
src/full/Agda/TypeChecking/Constraints.hs view
@@ -1,17 +1,19 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE NondecreasingIndentation #-}  module Agda.TypeChecking.Constraints where  import Prelude hiding (null) -import Control.Monad-import Control.Monad.Except+import Control.Monad.Except ( MonadError )  import qualified Data.List as List import qualified Data.Set as Set import Data.Either  import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty ( prettyShow ) import Agda.Syntax.Internal  import Agda.TypeChecking.Monad@@ -21,11 +23,11 @@ import Agda.TypeChecking.LevelConstraints import Agda.TypeChecking.SizedTypes import Agda.TypeChecking.Sort-import Agda.TypeChecking.MetaVars.Mention import Agda.TypeChecking.Warnings  import Agda.TypeChecking.Irrelevance import {-# SOURCE #-} Agda.TypeChecking.Rules.Application+import {-# SOURCE #-} Agda.TypeChecking.Rules.Data ( checkDataSort ) import {-# SOURCE #-} Agda.TypeChecking.Rules.Def import {-# SOURCE #-} Agda.TypeChecking.Rules.Term import {-# SOURCE #-} Agda.TypeChecking.Conversion@@ -35,11 +37,12 @@ import {-# SOURCE #-} Agda.TypeChecking.CheckInternal ( checkType )  import Agda.Utils.CallStack ( withCurrentCallStack )-import Agda.Utils.Functor+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Pretty (prettyShow)+import Agda.Utils.Null ()+import qualified Agda.Utils.ProfileOptions as Profile+import Agda.Utils.Singleton  import Agda.Utils.Impossible @@ -58,7 +61,15 @@       pids <- asksTC envActiveProblems       reportSDoc "tc.constr.add" 20 $ hsep         [ "adding constraint"-        , prettyTCM . PConstr pids unblock =<< buildClosure c ]+        , prettyTCM . PConstr pids unblock =<< buildClosure c+        , "unblocker: " , prettyTCM unblock+        ]+      -- Jesper, 2022-10-22: We should never block on a meta that is+      -- already solved.+      forM_ (allBlockingMetas unblock) $ \ m ->+        whenM (isInstantiatedMeta m) $ do+          reportSDoc "tc.constr.add" 5 $ "Attempted to block on solved meta" <+> prettyTCM m+          __IMPOSSIBLE__       -- Need to reduce to reveal possibly blocking metas       c <- reduce =<< instantiateFull c       caseMaybeM (simpl c) {-no-} (addConstraint' unblock c) $ {-yes-} \ cs -> do@@ -86,13 +97,13 @@           -- Get all level constraints.           lvlcs <- instantiateFull =<< do             List.filter (isLvl . clValue) . map theConstraint <$> getAllConstraints-          unless (null lvlcs) $ do+          List1.ifNull lvlcs (return Nothing) $ {-else-} \ lvlcs -> do             reportSDoc "tc.constr.lvl" 40 $ vcat               [ "simplifying level constraint" <+> prettyTCM c               , nest 2 $ hang "using" 2 $ prettyTCM lvlcs               ]-          -- Try to simplify @c@ using the other constraints.-          return $ simplifyLevelConstraint c $ map clValue lvlcs+            -- Try to simplify @c@ using the other constraints.+            return $ simplifyLevelConstraint c $ fmap clValue lvlcs         | otherwise = return Nothing  wakeConstraintsTCM :: (ProblemConstraint-> WakeUp) -> TCM ()@@ -124,6 +135,7 @@   modifySleepingConstraints $ List.map rename  +{-# SPECIALIZE noConstraints :: TCM a -> TCM a #-} -- | Don't allow the argument to produce any blocking constraints. -- -- WARNING: this does not mean that the given computation cannot@@ -132,13 +144,26 @@ noConstraints   :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m)   => m a -> m a-noConstraints problem = do+noConstraints = noConstraints' False++-- | As noConstraints but also fail for non-blocking constraints.+reallyNoConstraints+  :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m)+  => m a -> m a+reallyNoConstraints = noConstraints' True++noConstraints'+  :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m)+  => Bool -> m a -> m a+noConstraints' includingNonBlocking problem = do   (pid, x) <- newProblem problem-  cs <- getConstraintsForProblem pid-  unless (null cs) $ do-    withCurrentCallStack $ \loc -> do-      w <- warning'_ loc (UnsolvedConstraints cs)-      typeError' loc $ NonFatalErrors [ w ]+  let counts | includingNonBlocking = const True+             | otherwise            = isBlockingConstraint . clValue . theConstraint+  cs <- List.filter counts <$> getConstraintsForProblem pid+  List1.ifNull cs (pure ()) \ cs -> do+    withCurrentCallStack \ loc -> do+      w <- warning'_ loc $ UnsolvedConstraints cs+      typeError' loc $ NonFatalErrors $ singleton w   return x  -- | Run a computation that should succeeds without constraining@@ -154,6 +179,7 @@   ) => m a -> m a nonConstraining = dontAssignMetas . noConstraints +{-# SPECIALIZE newProblem :: TCM a -> TCM (ProblemId, a) #-} -- | Create a fresh problem for the given action. newProblem   :: (MonadFresh ProblemId m, MonadConstraint m)@@ -166,6 +192,7 @@   solveAwakeConstraints   return (pid, x) +{-# SPECIALIZE newProblem_ :: TCM a -> TCM ProblemId #-} newProblem_   :: (MonadFresh ProblemId m, MonadConstraint m)   => m a -> m ProblemId@@ -192,16 +219,9 @@     stealConstraints pid     handler --- | Wake constraints matching the given predicate (and aren't instance---   constraints if 'shouldPostponeInstanceSearch').-wakeConstraints' :: (ProblemConstraint -> WakeUp) -> TCM ()-wakeConstraints' p = do-  skipInstance <- shouldPostponeInstanceSearch-  let skip c = skipInstance && isInstanceConstraint (clValue $ theConstraint c)-  wakeConstraints $ wakeUpWhen (not . skip) p-+{-# SPECIALIZE wakeupConstraints :: MetaId -> TCM () #-} -- | Wake up the constraints depending on the given meta.-wakeupConstraints :: MetaId -> TCM ()+wakeupConstraints :: MonadMetaSolver m => MetaId -> m () wakeupConstraints x = do   wakeConstraints' (wakeIfBlockedOnMeta x . constraintUnblocker)   solveAwakeConstraints@@ -215,17 +235,11 @@     wakeup u | Set.null $ allBlockingProblems u = WakeUp              | otherwise                        = DontWakeUp Nothing -solveAwakeConstraints :: (MonadConstraint m) => m ()-solveAwakeConstraints = solveAwakeConstraints' False--solveAwakeConstraints' :: (MonadConstraint m) => Bool -> m ()-solveAwakeConstraints' = solveSomeAwakeConstraints (const True)- -- | Solve awake constraints matching the predicate. If the second argument is --   True solve constraints even if already 'isSolvingConstraints'. solveSomeAwakeConstraintsTCM :: (ProblemConstraint -> Bool) -> Bool -> TCM () solveSomeAwakeConstraintsTCM solveThis force = do-    verboseS "profile.constraints" 10 $ liftTCM $ tickMax "max-open-constraints" . List.genericLength =<< getAllConstraints+    whenProfile Profile.Constraints $ liftTCM $ tickMax "max-open-constraints" . List.genericLength =<< getAllConstraints     whenM ((force ||) . not <$> isSolvingConstraints) $ nowSolvingConstraints $ do      -- solveSizeConstraints -- Andreas, 2012-09-27 attacks size constrs too early      -- Ulf, 2016-12-06: Don't inherit problems here! Stored constraints@@ -242,7 +256,7 @@  solveConstraintTCM :: Constraint -> TCM () solveConstraintTCM c = do-    verboseS "profile.constraints" 10 $ liftTCM $ tick "attempted-constraints"+    whenProfile Profile.Constraints $ liftTCM $ tick "attempted-constraints"     verboseBracket "tc.constr.solve" 20 "solving constraint" $ do       pids <- asksTC envActiveProblems       reportSDoc "tc.constr.solve.constr" 20 $ text (show $ Set.toList pids) <+> prettyTCM c@@ -262,8 +276,8 @@         reportSDoc "tc.constr.unblock" 15 $ hsep ["not unblocking", prettyTCM m, "because",                                                   ifM (isFrozen m) "it's frozen" "meta assignments are turned off"]         addConstraint alwaysUnblock $ UnBlock m) $ do-    inst <- mvInstantiation <$> lookupMeta m-    reportSDoc "tc.constr.unblock" 65 $ text ("unblocking a metavar yields the constraint: " ++ show inst)+    inst <- lookupMetaInstantiation m+    reportSDoc "tc.constr.unblock" 65 $ "unblocking a metavar yields the constraint:" <+> pretty inst     case inst of       BlockedConst t -> do         reportSDoc "tc.constr.blocked" 15 $@@ -285,29 +299,30 @@       -- Ulf, 2018-04-30: The size solver shouldn't touch blocked terms! They have       -- a twin meta that it's safe to solve.       InstV{} -> __IMPOSSIBLE__-      -- Open (whatever that means)-      Open -> __IMPOSSIBLE__-      OpenInstance -> __IMPOSSIBLE__-solveConstraint_ (FindInstance m cands) = findInstance m cands-solveConstraint_ (CheckFunDef d i q cs _err) = withoutCache $+      OpenMeta{} -> __IMPOSSIBLE__+solveConstraint_ (FindInstance _ m cands) = findInstance m cands+solveConstraint_ (ResolveInstanceHead q) = resolveInstanceHead q+solveConstraint_ (CheckFunDef i q cs _err) = withoutCache $   -- re #3498: checking a fundef would normally be cached, but here it's   -- happening out of order so it would only corrupt the caching log.-  checkFunDef d i q cs+  checkFunDef i q cs solveConstraint_ (CheckLockedVars a b c d)   = checkLockedVars a b c d solveConstraint_ (HasBiggerSort a)      = hasBiggerSort a solveConstraint_ (HasPTSRule a b)       = hasPTSRule a b+solveConstraint_ (CheckDataSort q s)    = checkDataSort q s solveConstraint_ (CheckMetaInst m)      = checkMetaInst m solveConstraint_ (CheckType t)          = checkType t-solveConstraint_ (UsableAtModality mod t) = usableAtModality mod t+solveConstraint_ (UsableAtModality cc ms mod t) = usableAtModality' ms cc mod t  checkTypeCheckingProblem :: TypeCheckingProblem -> TCM Term checkTypeCheckingProblem = \case   CheckExpr cmp e t              -> checkExpr' cmp e t-  CheckArgs cmp eh r args t0 t1 k -> checkArguments cmp eh r args t0 t1 k-  CheckProjAppToKnownPrincipalArg cmp e o ds args t k v0 pt patm ->-    checkProjAppToKnownPrincipalArg cmp e o ds args t k v0 pt patm+  CheckArgs cmp eh hd args t0 t1 k -> checkArguments cmp eh hd args t0 t1 k+  CheckProjAppToKnownPrincipalArg cmp e o ds hd args t k v0 pt patm ->+    checkProjAppToKnownPrincipalArg cmp e o ds hd args t k v0 pt patm   CheckLambda cmp args body target -> checkPostponedLambda cmp args body target   DoQuoteTerm cmp et t           -> doQuoteTerm cmp et t+  DisambiguateConstructor bcd k  -> disambiguateConstructor' bcd k  debugConstraints :: TCM () debugConstraints = verboseS "tc.constr" 50 $ do@@ -317,3 +332,29 @@     [ "Current constraints"     , nest 2 $ vcat [ "awake " <+> vcat (map prettyTCM awake)                     , "asleep" <+> vcat (map prettyTCM sleeping) ] ]++-- Update the blocker after some instantiation or pruning might have happened.+updateBlocker :: (PureTCM m) => Blocker -> m Blocker+updateBlocker = instantiate++addAndUnblocker :: (PureTCM m, MonadBlock m) => Blocker -> m a -> m a+addAndUnblocker u+  | u == alwaysUnblock = id+  | otherwise          = catchPatternErr $ \ u' -> do+      u <- updateBlocker u+      patternViolation (unblockOnBoth u u')++addOrUnblocker :: (PureTCM m, MonadBlock m) => Blocker -> m a -> m a+addOrUnblocker u+  | u == neverUnblock = id+  | otherwise         = catchPatternErr $ \ u' -> do+      u <- updateBlocker u+      patternViolation (unblockOnEither u u')++-- Reduce a term and call the continuation. If the continuation is+-- blocked, the whole call is blocked either on what blocked the reduction+-- or on what blocked the continuation (using `blockedOnEither`).+withReduced+  :: (Reduce a, IsMeta a, PureTCM m, MonadBlock m)+  => a -> (a -> m b) -> m b+withReduced a cont = ifBlocked a (\b a' -> addOrUnblocker b $ cont a') (\_ a' -> cont a')
src/full/Agda/TypeChecking/Constraints.hs-boot view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.Constraints where  @@ -10,7 +12,6 @@  instance MonadConstraint TCM where -solveAwakeConstraints' :: MonadConstraint m => Bool -> m () noConstraints          :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m)                        => m a -> m a ifNoConstraints_       :: TCM () -> TCM a -> (ProblemId -> TCM a) -> TCM a
src/full/Agda/TypeChecking/Conversion.hs view
@@ -1,2025 +1,2249 @@-{-# LANGUAGE NondecreasingIndentation #-}--module Agda.TypeChecking.Conversion where--import Control.Arrow (second)-import Control.Monad-import Control.Monad.Except--- Control.Monad.Fail import is redundant since GHC 8.8.1-import Control.Monad.Fail (MonadFail)--import Data.Function-import Data.Semigroup ((<>))-import qualified Data.List as List-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.IntSet as IntSet--import Agda.Syntax.Common-import Agda.Syntax.Internal-import Agda.Syntax.Internal.MetaVars-import Agda.Syntax.Translation.InternalToAbstract (reify)--import Agda.TypeChecking.Monad-import Agda.TypeChecking.MetaVars-import Agda.TypeChecking.MetaVars.Occurs (killArgs,PruneResult(..),rigidVarsNotContainedIn)-import Agda.TypeChecking.Names-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Substitute-import qualified Agda.TypeChecking.SyntacticEquality as SynEq-import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Constraints-import Agda.TypeChecking.Conversion.Pure (pureCompareAs)-import {-# SOURCE #-} Agda.TypeChecking.CheckInternal (infer)-import Agda.TypeChecking.Forcing (isForced, nextIsForced)-import Agda.TypeChecking.Free-import Agda.TypeChecking.Datatypes (getConType, getFullyAppliedConType)-import Agda.TypeChecking.Records-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Injectivity-import Agda.TypeChecking.Polarity-import Agda.TypeChecking.SizedTypes-import Agda.TypeChecking.Level-import Agda.TypeChecking.Implicit (implicitArgs)-import Agda.TypeChecking.Irrelevance-import Agda.TypeChecking.Primitive-import Agda.TypeChecking.Warnings (MonadWarning)-import Agda.Interaction.Options--import Agda.Utils.Functor-import Agda.Utils.List1 (List1, pattern (:|))-import qualified Agda.Utils.List1 as List1-import Agda.Utils.Monad-import Agda.Utils.Maybe-import Agda.Utils.Permutation-import Agda.Utils.Pretty (prettyShow)-import Agda.Utils.Size-import Agda.Utils.Tuple-import Agda.Utils.WithDefault--import Agda.Utils.Impossible--type MonadConversion m =-  ( PureTCM m-  , MonadConstraint m-  , MonadMetaSolver m-  , MonadError TCErr m-  , MonadWarning m-  , MonadStatistics m-  , MonadFresh ProblemId m-  , MonadFresh Int m-  , MonadFail m-  )---- | Try whether a computation runs without errors or new constraints---   (may create new metas, though).---   Restores state upon failure.-tryConversion-  :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m)-  => m () -> m Bool-tryConversion = isJust <.> tryConversion'---- | Try whether a computation runs without errors or new constraints---   (may create new metas, though).---   Return 'Just' the result upon success.---   Return 'Nothing' and restore state upon failure.-tryConversion'-  :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m)-  => m a -> m (Maybe a)-tryConversion' m = tryMaybe $ noConstraints m---- | Check if to lists of arguments are the same (and all variables).---   Precondition: the lists have the same length.-sameVars :: Elims -> Elims -> Bool-sameVars xs ys = and $ zipWith same xs ys-    where-        same (Apply (Arg _ (Var n []))) (Apply (Arg _ (Var m []))) = n == m-        same _ _ = False---- | @intersectVars us vs@ checks whether all relevant elements in @us@ and @vs@---   are variables, and if yes, returns a prune list which says @True@ for---   arguments which are different and can be pruned.-intersectVars :: Elims -> Elims -> Maybe [Bool]-intersectVars = zipWithM areVars where-    -- ignore irrelevant args-    areVars (Apply u) v | isIrrelevant u = Just False -- do not prune-    areVars (Apply (Arg _ (Var n []))) (Apply (Arg _ (Var m []))) = Just $ n /= m -- prune different vars-    areVars _ _                                   = Nothing---- | Run the given computation but turn any errors into blocked computations with the given blocker-blockOnError :: MonadError TCErr m => Blocker -> m a -> m a-blockOnError blocker f-  | blocker == neverUnblock = f-  | otherwise               = f `catchError` \case-    TypeError{}         -> throwError $ PatternErr blocker-    PatternErr blocker' -> throwError $ PatternErr $ unblockOnEither blocker blocker'-    err@Exception{}     -> throwError err-    err@IOException{}   -> throwError err--equalTerm :: MonadConversion m => Type -> Term -> Term -> m ()-equalTerm = compareTerm CmpEq--equalAtom :: MonadConversion m => CompareAs -> Term -> Term -> m ()-equalAtom = compareAtom CmpEq--equalType :: MonadConversion m => Type -> Type -> m ()-equalType = compareType CmpEq--{- Comparing in irrelevant context always succeeds.--   However, we might want to dig for solutions of irrelevant metas.--   To this end, we can just ignore errors during conversion checking.- -}---- convError ::  MonadTCM tcm => TypeError -> tcm a--- | Ignore errors in irrelevant context.-convError :: TypeError -> TCM ()-convError err = ifM ((==) Irrelevant <$> asksTC getRelevance) (return ()) $ typeError err---- | Type directed equality on values.----compareTerm :: forall m. MonadConversion m => Comparison -> Type -> Term -> Term -> m ()-compareTerm cmp a u v = compareAs cmp (AsTermsOf a) u v---- | Type directed equality on terms or types.-compareAs :: forall m. MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m ()-  -- If one term is a meta, try to instantiate right away. This avoids unnecessary unfolding.-  -- Andreas, 2012-02-14: This is UNSOUND for subtyping!-compareAs cmp a u v = do-  reportSDoc "tc.conv.term" 20 $ sep $-    [ "compareTerm"-    , nest 2 $ prettyTCM u <+> prettyTCM cmp <+> prettyTCM v-    , nest 2 $ prettyTCM a-    ]-  -- Check syntactic equality. This actually saves us quite a bit of work.-  ((u, v), equal) <- SynEq.checkSyntacticEquality u v-  -- OLD CODE, traverses the *full* terms u v at each step, even if they-  -- are different somewhere.  Leads to infeasibility in issue 854.-  -- (u, v) <- instantiateFull (u, v)-  -- let equal = u == v-  if equal then verboseS "profile.sharing" 20 $ tick "equal terms" else do-      verboseS "profile.sharing" 20 $ tick "unequal terms"-      reportSDoc "tc.conv.term" 15 $ sep $-        [ "compareTerm (not syntactically equal)"-        , nest 2 $ prettyTCM u <+> prettyTCM cmp <+> prettyTCM v-        , nest 2 $ prettyTCM a-        ]-      -- If we are at type Size, we cannot short-cut comparison-      -- against metas by assignment.-      -- Andreas, 2014-04-12: this looks incomplete.-      -- It seems to assume we are never comparing-      -- at function types into Size.-      let fallback = compareAs' cmp a u v-          unlessSubtyping :: m () -> m ()-          unlessSubtyping cont =-              if cmp == CmpEq then cont else do-                -- Andreas, 2014-04-12 do not short cut if type is blocked.-                ifBlocked a (\ _ _ -> fallback) {-else-} $ \ _ a -> do-                  -- do not short circuit size comparison!-                  caseMaybeM (isSizeType a) cont (\ _ -> fallback)--          dir = fromCmp cmp-          rid = flipCmp dir     -- The reverse direction.  Bad name, I know.-      case (u, v) of-        (MetaV x us, MetaV y vs)-          | x /= y    -> unlessSubtyping $ solve1 `orelse` solve2 `orelse` fallback-          | otherwise -> fallback-          where-            (solve1, solve2) | x > y     = (assign dir x us v, assign rid y vs u)-                             | otherwise = (assign rid y vs u, assign dir x us v)-        (MetaV x us, _) -> unlessSubtyping $ assign dir x us v `orelse` fallback-        (_, MetaV y vs) -> unlessSubtyping $ assign rid y vs u `orelse` fallback-        (Def f es, Def f' es') | f == f' ->-          ifNotM (optFirstOrder <$> pragmaOptions) fallback $ {- else -} unlessSubtyping $ do-          def <- getConstInfo f-          -- We do not shortcut projection-likes,-          -- Andreas, 2022-03-07, issue #5809:-          -- but irrelevant projections since they are applied to their parameters.-          if isJust $ isRelevantProjection_ def then fallback else do-          pol <- getPolarity' cmp f-          compareElims pol [] (defType def) (Def f []) es es' `orelse` fallback-        _               -> fallback-  where-    assign :: CompareDirection -> MetaId -> Elims -> Term -> m ()-    assign dir x es v = do-      -- Andreas, 2013-10-19 can only solve if no projections-      reportSDoc "tc.conv.term.shortcut" 20 $ sep-        [ "attempting shortcut"-        , nest 2 $ prettyTCM (MetaV x es) <+> ":=" <+> prettyTCM v-        ]-      whenM (isInstantiatedMeta x) (patternViolation alwaysUnblock) -- Already instantiated, retry right away-      assignE dir x es v a $ compareAsDir dir a-      reportSDoc "tc.conv.term.shortcut" 50 $-        "shortcut successful" $$ nest 2 ("result:" <+> (pretty =<< instantiate (MetaV x es)))-    -- Should be ok with catchError_ but catchError is much safer since we don't-    -- rethrow errors.-    orelse :: m () -> m () -> m ()-    orelse m h = catchError m (\_ -> h)---- | Try to assign meta.  If meta is projected, try to eta-expand---   and run conversion check again.-assignE :: (MonadConversion m)-        => CompareDirection -> MetaId -> Elims -> Term -> CompareAs -> (Term -> Term -> m ()) -> m ()-assignE dir x es v a comp = assignWrapper dir x es v $ do-  case allApplyElims es of-    Just vs -> assignV dir x vs v a-    Nothing -> do-      reportSDoc "tc.conv.assign" 30 $ sep-        [ "assigning to projected meta "-        , prettyTCM x <+> sep (map prettyTCM es) <+> text (":" ++ show dir) <+> prettyTCM v-        ]-      etaExpandMeta [Records] x-      res <- isInstantiatedMeta' x-      case res of-        Just u  -> do-          reportSDoc "tc.conv.assign" 30 $ sep-            [ "seems like eta expansion instantiated meta "-            , prettyTCM x <+> text  (":" ++ show dir) <+> prettyTCM u-            ]-          let w = u `applyE` es-          comp w v-        Nothing ->  do-          reportSLn "tc.conv.assign" 30 "eta expansion did not instantiate meta"-          patternViolation (unblockOnAnyMetaIn (MetaV x es)) -- nothing happened, give up--compareAsDir :: MonadConversion m => CompareDirection -> CompareAs -> Term -> Term -> m ()-compareAsDir dir a = dirToCmp (`compareAs'` a) dir--compareAs' :: forall m. MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m ()-compareAs' cmp tt m n = case tt of-  AsTermsOf a -> compareTerm' cmp a m n-  AsSizes     -> compareSizes cmp m n-  AsTypes     -> compareAtom cmp AsTypes m n--compareTerm' :: forall m. MonadConversion m => Comparison -> Type -> Term -> Term -> m ()-compareTerm' cmp a m n =-  verboseBracket "tc.conv.term" 20 "compareTerm" $ do-  (ba, a') <- reduceWithBlocker a-  (catchConstraint (ValueCmp cmp (AsTermsOf a') m n) :: m () -> m ()) $ blockOnError ba $ do-    reportSDoc "tc.conv.term" 30 $ fsep-      [ "compareTerm", prettyTCM m, prettyTCM cmp, prettyTCM n, ":", prettyTCM a' ]-    propIrr  <- isPropEnabled-    isSize   <- isJust <$> isSizeType a'-    (bs, s)  <- reduceWithBlocker $ getSort a'-    mlvl     <- getBuiltin' builtinLevel-    reportSDoc "tc.conv.level" 60 $ nest 2 $ sep-      [ "a'   =" <+> pretty a'-      , "mlvl =" <+> pretty mlvl-      , text $ "(Just (unEl a') == mlvl) = " ++ show (Just (unEl a') == mlvl)-      ]-    blockOnError bs $ case s of-      Prop{} | propIrr -> compareIrrelevant a' m n-      _    | isSize   -> compareSizes cmp m n-      _               -> case unEl a' of-        a | Just a == mlvl -> do-          a <- levelView m-          b <- levelView n-          equalLevel a b-        a@Pi{}    -> equalFun s a m n-        Lam _ _   -> __IMPOSSIBLE__-        Def r es  -> do-          isrec <- isEtaRecord r-          if isrec-            then do-              sig <- getSignature-              let ps = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-              -- Andreas, 2010-10-11: allowing neutrals to be blocked things does not seem-              -- to change Agda's behavior-              --    isNeutral Blocked{}          = False-                  isNeutral (NotBlocked _ Con{}) = return False-              -- Andreas, 2013-09-18 / 2015-06-29: a Def by copatterns is-              -- not neutral if it is blocked (there can be missing projections-              -- to trigger a reduction.-                  isNeutral (NotBlocked r (Def q _)) = do    -- Andreas, 2014-12-06 optimize this using r !!-                    not <$> usesCopatterns q -- a def by copattern can reduce if projected-                  isNeutral _                   = return True-                  isMeta b = case ignoreBlocking b of-                               MetaV{} -> True-                               _       -> False--              reportSDoc "tc.conv.term" 30 $ prettyTCM a <+> "is eta record type"-              m <- reduceB m-              mNeutral <- isNeutral m-              n <- reduceB n-              nNeutral <- isNeutral n-              case (m, n) of-                _ | isMeta m || isMeta n ->-                    compareAtom cmp (AsTermsOf a') (ignoreBlocking m) (ignoreBlocking n)--                _ | mNeutral && nNeutral -> do-                    -- Andreas 2011-03-23: (fixing issue 396)-                    -- if we are dealing with a singleton record,-                    -- we can succeed immediately-                    ifM (isSingletonRecordModuloRelevance r ps) (return ()) $-                      -- do not eta-expand if comparing two neutrals-                      compareAtom cmp (AsTermsOf a') (ignoreBlocking m) (ignoreBlocking n)-                _ -> do-                  (tel, m') <- etaExpandRecord r ps $ ignoreBlocking m-                  (_  , n') <- etaExpandRecord r ps $ ignoreBlocking n-                  -- No subtyping on record terms-                  c <- getRecordConstructor r-                  -- Record constructors are covariant (see test/succeed/CovariantConstructors).-                  compareArgs (repeat $ polFromCmp cmp) [] (telePi_ tel __DUMMY_TYPE__) (Con c ConOSystem []) m' n'--            else (do pathview <- pathView a'-                     equalPath pathview a' m n)-        _ -> compareAtom cmp (AsTermsOf a') m n-  where-    -- equality at function type (accounts for eta)-    equalFun :: (MonadConversion m) => Sort -> Term -> Term -> Term -> m ()-    equalFun s a@(Pi dom b) m n | domFinite dom = do-       mp <- fmap getPrimName <$> getBuiltin' builtinIsOne-       case unEl $ unDom dom of-          Def q [Apply phi]-              | Just q == mp -> compareTermOnFace cmp (unArg phi) (El s (Pi (dom {domFinite = False}) b)) m n-          _                  -> equalFun s (Pi (dom{domFinite = False}) b) m n-    equalFun _ (Pi dom@Dom{domInfo = info} b) m n | not $ domFinite dom = do-        let name = suggests [ Suggestion b , Suggestion m , Suggestion n ]-        addContext (name, dom) $ compareTerm cmp (absBody b) m' n'-      where-        (m',n') = raise 1 (m,n) `apply` [Arg info $ var 0]-    equalFun _ _ _ _ = __IMPOSSIBLE__--    equalPath :: (MonadConversion m) => PathView -> Type -> Term -> Term -> m ()-    equalPath (PathType s _ l a x y) _ m n = do-        let name = "i" :: String-        interval <- el primInterval-        let (m',n') = raise 1 (m, n) `applyE` [IApply (raise 1 $ unArg x) (raise 1 $ unArg y) (var 0)]-        addContext (name, defaultDom interval) $ compareTerm cmp (El (raise 1 s) $ raise 1 (unArg a) `apply` [argN $ var 0]) m' n'-    equalPath OType{} a' m n = cmpDef a' m n--    cmpDef a'@(El s ty) m n = do-       mI     <- getBuiltinName'   builtinInterval-       mIsOne <- getBuiltinName'   builtinIsOne-       mGlue  <- getPrimitiveName' builtinGlue-       mHComp <- getPrimitiveName' builtinHComp-       mSub   <- getBuiltinName' builtinSub-       mUnglueU <- getPrimitiveTerm' builtin_unglueU-       mSubIn   <- getPrimitiveTerm' builtinSubIn-       case ty of-         Def q es | Just q == mIsOne -> return ()-         Def q es | Just q == mGlue, Just args@(l:_:a:phi:_) <- allApplyElims es -> do-              aty <- el' (pure $ unArg l) (pure $ unArg a)-              unglue <- prim_unglue-              let mkUnglue m = apply unglue $ map (setHiding Hidden) args ++ [argN m]-              reportSDoc "conv.glue" 20 $ prettyTCM (aty,mkUnglue m,mkUnglue n)-              compareTermOnFace cmp (unArg phi) a' m n-              compareTerm cmp aty (mkUnglue m) (mkUnglue n)-         Def q es | Just q == mHComp, Just (sl:s:args@[phi,u,u0]) <- allApplyElims es-                  , Sort (Type lvl) <- unArg s-                  , Just unglueU <- mUnglueU, Just subIn <- mSubIn-                  -> do-              let l = Level lvl-              ty <- el' (pure $ l) (pure $ unArg u0)-              let bA = subIn `apply` [sl,s,phi,u0]-              let mkUnglue m = apply unglueU $ [argH l] ++ map (setHiding Hidden) [phi,u]  ++ [argH bA,argN m]-              reportSDoc "conv.hcompU" 20 $ prettyTCM (ty,mkUnglue m,mkUnglue n)-              compareTermOnFace cmp (unArg phi) ty m n-              compareTerm cmp ty (mkUnglue m) (mkUnglue n)-         Def q es | Just q == mSub, Just args@(l:a:_) <- allApplyElims es -> do-              ty <- el' (pure $ unArg l) (pure $ unArg a)-              out <- primSubOut-              let mkOut m = apply out $ map (setHiding Hidden) args ++ [argN m]-              compareTerm cmp ty (mkOut m) (mkOut n)-         Def q [] | Just q == mI -> compareInterval cmp a' m n-         _ -> compareAtom cmp (AsTermsOf a') m n--compareAtomDir :: MonadConversion m => CompareDirection -> CompareAs -> Term -> Term -> m ()-compareAtomDir dir a = dirToCmp (`compareAtom` a) dir---- | Compute the head type of an elimination. For projection-like functions---   this requires inferring the type of the principal argument.-computeElimHeadType :: MonadConversion m => QName -> Elims -> Elims -> m Type-computeElimHeadType f es es' = do-  def <- getConstInfo f-  -- To compute the type @a@ of a projection-like @f@,-  -- we have to infer the type of its first argument.-  if projectionArgs def <= 0 then return $ defType def else do-    -- Find a first argument to @f@.-    let arg = case (es, es') of-              (Apply arg : _, _) -> arg-              (_, Apply arg : _) -> arg-              _ -> __IMPOSSIBLE__-    -- Infer its type.-    reportSDoc "tc.conv.infer" 30 $-      "inferring type of internal arg: " <+> prettyTCM arg-    targ <- infer $ unArg arg-    reportSDoc "tc.conv.infer" 30 $-      "inferred type: " <+> prettyTCM targ-    -- getDefType wants the argument type reduced.-    -- Andreas, 2016-02-09, Issue 1825: The type of arg might be-    -- a meta-variable, e.g. in interactive development.-    -- In this case, we postpone.-    targ <- abortIfBlocked targ-    fromMaybeM __IMPOSSIBLE__ $ getDefType f targ---- | Syntax directed equality on atomic values----compareAtom :: forall m. MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m ()-compareAtom cmp t m n =-  verboseBracket "tc.conv.atom" 20 "compareAtom" $-  -- if a PatternErr is thrown, rebuild constraint!-  (catchConstraint (ValueCmp cmp t m n) :: m () -> m ()) $ do-    reportSLn "tc.conv.atom.size" 50 $ "compareAtom term size:  " ++ show (termSize m, termSize n)-    reportSDoc "tc.conv.atom" 50 $-      "compareAtom" <+> fsep [ prettyTCM m <+> prettyTCM cmp-                             , prettyTCM n-                             , prettyTCM t-                             ]-    -- Andreas: what happens if I cut out the eta expansion here?-    -- Answer: Triggers issue 245, does not resolve 348-    (mb',nb') <- do-      mb' <- etaExpandBlocked =<< reduceB m-      nb' <- etaExpandBlocked =<< reduceB n-      return (mb', nb')-    let getBlocker (Blocked b _) = b-        getBlocker NotBlocked{}  = neverUnblock-        blocker = unblockOnEither (getBlocker mb') (getBlocker nb')-    reportSLn "tc.conv.atom.size" 50 $ "term size after reduce: " ++ show (termSize $ ignoreBlocking mb', termSize $ ignoreBlocking nb')--    -- constructorForm changes literal to constructors-    -- only needed if the other side is not a literal-    (mb'', nb'') <- case (ignoreBlocking mb', ignoreBlocking nb') of-      (Lit _, Lit _) -> return (mb', nb')-      _ -> (,) <$> traverse constructorForm mb'-               <*> traverse constructorForm nb'--    mb <- traverse unLevel mb''-    nb <- traverse unLevel nb''--    cmpBlocked <- viewTC eCompareBlocked--    let m = ignoreBlocking mb-        n = ignoreBlocking nb--        checkDefinitionalEquality = unlessM (pureCompareAs CmpEq t m n) notEqual--        notEqual = typeError $ UnequalTerms cmp m n t--        dir = fromCmp cmp-        rid = flipCmp dir     -- The reverse direction.  Bad name, I know.--        assign dir x es v = assignE dir x es v t $ compareAtomDir dir t--    reportSDoc "tc.conv.atom" 30 $-      "compareAtom" <+> fsep [ prettyTCM mb <+> prettyTCM cmp-                             , prettyTCM nb-                             , prettyTCM t-                             ]-    reportSDoc "tc.conv.atom" 80 $-      "compareAtom" <+> fsep [ (text . show) mb <+> prettyTCM cmp-                                  , (text . show) nb-                                  , ":" <+> (text . show) t ]-    case (mb, nb) of-      -- equate two metas x and y.  if y is the younger meta,-      -- try first y := x and then x := y-      _ | MetaV x xArgs <- ignoreBlocking mb,   -- Can be either Blocked or NotBlocked depending on-          MetaV y yArgs <- ignoreBlocking nb -> -- envCompareBlocked check above.-        if | x == y, cmpBlocked -> do-              a <- metaType x-              blockOnError (unblockOnMeta x) $-                compareElims [] [] a (MetaV x []) xArgs yArgs-           | x == y -> blockOnError (unblockOnMeta x) $-            case intersectVars xArgs yArgs of-              -- all relevant arguments are variables-              Just kills -> do-                -- kills is a list with 'True' for each different var-                killResult <- killArgs kills x-                case killResult of-                  NothingToPrune   -> return ()-                  PrunedEverything -> return ()-                  PrunedNothing    -> checkDefinitionalEquality-                  PrunedSomething  -> checkDefinitionalEquality-              -- not all relevant arguments are variables-              Nothing -> checkDefinitionalEquality -- Check definitional equality on meta-variables-                              -- (same as for blocked terms)-           | otherwise -> do-              [p1, p2] <- mapM getMetaPriority [x,y]-              -- First try the one with the highest priority. If that doesn't-              -- work, try the low priority one.-              let (solve1, solve2)-                    | (p1, x) > (p2, y) = (l1, r2)-                    | otherwise         = (r1, l2)-                    where l1 = assign dir x xArgs n-                          r1 = assign rid y yArgs m-                          -- Careful: the first attempt might prune the low-                          -- priority meta! (Issue #2978)-                          l2 = ifM (isInstantiatedMeta x) (compareAsDir dir t m n) l1-                          r2 = ifM (isInstantiatedMeta y) (compareAsDir rid t n m) r1--              -- Unblock on both unblockers of solve1 and solve2-              catchPatternErr (`addOrUnblocker` solve2) solve1--      -- one side a meta-      _ | MetaV x es <- ignoreBlocking mb -> assign dir x es n-      _ | MetaV x es <- ignoreBlocking nb -> assign rid x es m-      (Blocked{}, Blocked{}) | not cmpBlocked  -> checkDefinitionalEquality-      (Blocked b _, _) | not cmpBlocked -> useInjectivity (fromCmp cmp) b t m n   -- The blocked term  goes first-      (_, Blocked b _) | not cmpBlocked -> useInjectivity (flipCmp $ fromCmp cmp) b t n m-      _ -> blockOnError blocker $ do-        -- -- Andreas, 2013-10-20 put projection-like function-        -- -- into the spine, to make compareElims work.-        -- -- 'False' means: leave (Def f []) unchanged even for-        -- -- proj-like funs.-        -- m <- elimView False m-        -- n <- elimView False n-        -- Andreas, 2015-07-01, actually, don't put them into the spine.-        -- Polarity cannot be communicated properly if projection-like-        -- functions are post-fix.-        case (m, n) of-          (Pi{}, Pi{}) -> equalFun m n--          (Sort s1, Sort s2) ->-            ifM (optCumulativity <$> pragmaOptions)-              (compareSort cmp s1 s2)-              (equalSort s1 s2)--          (Lit l1, Lit l2) | l1 == l2 -> return ()-          (Var i es, Var i' es') | i == i' -> do-              a <- typeOfBV i-              -- Variables are invariant in their arguments-              compareElims [] [] a (var i) es es'--          -- The case of definition application:-          (Def f es, Def f' es') -> do--              -- 1. All absurd lambdas are equal.-              unlessM (bothAbsurd f f') $ do--              -- 2. If the heads are unequal, the only chance is subtyping between SIZE and SIZELT.-              if f /= f' then trySizeUniv cmp t m n f es f' es' else do--              -- 3. If the heads are equal:-              -- 3a. If there are no arguments, we are done.-              unless (null es && null es') $ do--              -- 3b. If some cubical magic kicks in, we are done.-              unlessM (compareEtaPrims f es es') $ do--              -- 3c. Oh no, we actually have to work and compare the eliminations!-               a <- computeElimHeadType f es es'-               -- The polarity vector of projection-like functions-               -- does not include the parameters.-               pol <- getPolarity' cmp f-               compareElims pol [] a (Def f []) es es'--          -- Due to eta-expansion, these constructors are fully applied.-          (Con x ci xArgs, Con y _ yArgs)-              | x == y -> do-                  -- Get the type of the constructor instantiated to the datatype parameters.-                  a' <- case t of-                    AsTermsOf a -> conType x a-                    AsSizes   -> __IMPOSSIBLE__-                    AsTypes   -> __IMPOSSIBLE__-                  forcedArgs <- getForcedArgs $ conName x-                  -- Constructors are covariant in their arguments-                  -- (see test/succeed/CovariantConstructors).-                  compareElims (repeat $ polFromCmp cmp) forcedArgs a' (Con x ci []) xArgs yArgs-          _ -> notEqual-    where-        -- returns True in case we handled the comparison already.-        compareEtaPrims :: MonadConversion m => QName -> Elims -> Elims -> m Bool-        compareEtaPrims q es es' = do-          munglue <- getPrimitiveName' builtin_unglue-          munglueU <- getPrimitiveName' builtin_unglueU-          msubout <- getPrimitiveName' builtinSubOut-          case () of-            _ | Just q == munglue -> compareUnglueApp q es es'-            _ | Just q == munglueU -> compareUnglueUApp q es es'-            _ | Just q == msubout -> compareSubApp q es es'-            _                     -> return False-        compareSubApp q es es' = do-          let (as,bs) = splitAt 5 es; (as',bs') = splitAt 5 es'-          case (allApplyElims as, allApplyElims as') of-            (Just [a,bA,phi,u,x], Just [a',bA',phi',u',x']) -> do-              tSub <- primSub-              -- Andrea, 28-07-16:-              -- comparing the types is most probably wasteful,-              -- since b and b' should be neutral terms, but it's a-              -- precondition for the compareAtom call to make-              -- sense.-              equalType (El (tmSSort $ unArg a) $ apply tSub $ a : map (setHiding NotHidden) [bA,phi,u])-                        (El (tmSSort $ unArg a) $ apply tSub $ a : map (setHiding NotHidden) [bA',phi',u'])-              compareAtom cmp (AsTermsOf $ El (tmSSort $ unArg a) $ apply tSub $ a : map (setHiding NotHidden) [bA,phi,u])-                              (unArg x) (unArg x')-              compareElims [] [] (El (tmSort (unArg a)) (unArg bA)) (Def q as) bs bs'-              return True-            _  -> return False-        compareUnglueApp q es es' = do-          let (as,bs) = splitAt 7 es; (as',bs') = splitAt 7 es'-          case (allApplyElims as, allApplyElims as') of-            (Just [la,lb,bA,phi,bT,e,b], Just [la',lb',bA',phi',bT',e',b']) -> do-              tGlue <- getPrimitiveTerm builtinGlue-              -- Andrea, 28-07-16:-              -- comparing the types is most probably wasteful,-              -- since b and b' should be neutral terms, but it's a-              -- precondition for the compareAtom call to make-              -- sense.-              -- equalType (El (tmSort (unArg lb)) $ apply tGlue $ [la,lb] ++ map (setHiding NotHidden) [bA,phi,bT,e])-              --           (El (tmSort (unArg lb')) $ apply tGlue $ [la',lb'] ++ map (setHiding NotHidden) [bA',phi',bT',e'])-              compareAtom cmp (AsTermsOf $ El (tmSort (unArg lb)) $ apply tGlue $ [la,lb] ++ map (setHiding NotHidden) [bA,phi,bT,e])-                              (unArg b) (unArg b')-              compareElims [] [] (El (tmSort (unArg la)) (unArg bA)) (Def q as) bs bs'-              return True-            _  -> return False-        compareUnglueUApp :: MonadConversion m => QName -> Elims -> Elims -> m Bool-        compareUnglueUApp q es es' = do-          let (as,bs) = splitAt 5 es; (as',bs') = splitAt 5 es'-          case (allApplyElims as, allApplyElims as') of-            (Just [la,phi,bT,bAS,b], Just [la',phi',bT',bA',b']) -> do-              tHComp <- primHComp-              tLSuc <- primLevelSuc-              tSubOut <- primSubOut-              iz <- primIZero-              let lsuc t = tLSuc `apply` [argN t]-                  s = tmSort $ unArg la-                  sucla = lsuc <$> la-              bA <- runNamesT [] $ do-                [la,phi,bT,bAS] <- mapM (open . unArg) [la,phi,bT,bAS]-                (pure tSubOut <#> (pure tLSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <#> (bT <@> primIZero) <@> bAS)-              compareAtom cmp (AsTermsOf $ El (tmSort . unArg $ sucla) $ apply tHComp $ [sucla, argH (Sort s), phi] ++ [argH (unArg bT), argH bA])-                              (unArg b) (unArg b')-              compareElims [] [] (El s bA) (Def q as) bs bs'-              return True-            _  -> return False-        -- Andreas, 2013-05-15 due to new postponement strategy, type can now be blocked-        conType c t = do-          t <- abortIfBlocked t-          let impossible = do-                reportSDoc "impossible" 10 $-                  "expected data/record type, found " <+> prettyTCM t-                reportSDoc "impossible" 70 $ nest 2 $ "raw =" <+> pretty t-                -- __IMPOSSIBLE__-                -- Andreas, 2013-10-20:  in case termination checking fails-                -- we might get some unreduced types here.-                -- In issue 921, this happens during the final attempt-                -- to solve left-over constraints.-                -- Thus, instead of crashing, just give up gracefully.-                patternViolation neverUnblock-          maybe impossible (return . snd) =<< getFullyAppliedConType c t-        equalFun t1 t2 = case (t1, t2) of-          (Pi dom1 b1, Pi dom2 b2) -> do-            verboseBracket "tc.conv.fun" 15 "compare function types" $ do-              reportSDoc "tc.conv.fun" 20 $ nest 2 $ vcat-                [ "t1 =" <+> prettyTCM t1-                , "t2 =" <+> prettyTCM t2-                ]-              compareDom cmp dom2 dom1 b1 b2 errH errR errQ errC $-                compareType cmp (absBody b1) (absBody b2)-            where-            errH = typeError $ UnequalHiding t1 t2-            errR = typeError $ UnequalRelevance cmp t1 t2-            errQ = typeError $ UnequalQuantity  cmp t1 t2-            errC = typeError $ UnequalCohesion cmp t1 t2-          _ -> __IMPOSSIBLE__---- | Check whether @a1 `cmp` a2@ and continue in context extended by @a1@.-compareDom :: (MonadConversion m , Free c)-  => Comparison -- ^ @cmp@ The comparison direction-  -> Dom Type   -- ^ @a1@  The smaller domain.-  -> Dom Type   -- ^ @a2@  The other domain.-  -> Abs b      -- ^ @b1@  The smaller codomain.-  -> Abs c      -- ^ @b2@  The bigger codomain.-  -> m ()     -- ^ Continuation if mismatch in 'Hiding'.-  -> m ()     -- ^ Continuation if mismatch in 'Relevance'.-  -> m ()     -- ^ Continuation if mismatch in 'Quantity'.-  -> m ()     -- ^ Continuation if mismatch in 'Cohesion'.-  -> m ()     -- ^ Continuation if comparison is successful.-  -> m ()-compareDom cmp0-  dom1@(Dom{domInfo = i1, unDom = a1})-  dom2@(Dom{domInfo = i2, unDom = a2})-  b1 b2 errH errR errQ errC cont = do-  hasSubtyping <- collapseDefault . optSubtyping <$> pragmaOptions-  let cmp = if hasSubtyping then cmp0 else CmpEq-  if | not $ sameHiding dom1 dom2 -> errH-     | not $ compareRelevance cmp (getRelevance dom1) (getRelevance dom2) -> errR-     | not $ compareQuantity  cmp (getQuantity  dom1) (getQuantity  dom2) -> errQ-     | not $ compareCohesion  cmp (getCohesion  dom1) (getCohesion  dom2) -> errC-     | otherwise -> do-      let r = max (getRelevance dom1) (getRelevance dom2)-              -- take "most irrelevant"-          dependent = (r /= Irrelevant) && isBinderUsed b2-      pid <- newProblem_ $ compareType cmp0 a1 a2-      dom <- if dependent-             then (\ a -> dom1 {unDom = a}) <$> blockTypeOnProblem a1 pid-             else return dom1-        -- We only need to require a1 == a2 if b2 is dependent-        -- If it's non-dependent it doesn't matter what we add to the context.-      let name = suggests [ Suggestion b1 , Suggestion b2 ]-      addContext (name, dom) $ cont-      stealConstraints pid-        -- Andreas, 2013-05-15 Now, comparison of codomains is not-        -- blocked any more by getting stuck on domains.-        -- Only the domain type in context will be blocked.-        -- But see issue #1258.--compareRelevance :: Comparison -> Relevance -> Relevance -> Bool-compareRelevance CmpEq  = (==)-compareRelevance CmpLeq = (<=)--compareQuantity :: Comparison -> Quantity -> Quantity -> Bool-compareQuantity CmpEq  = sameQuantity-compareQuantity CmpLeq = moreQuantity--compareCohesion :: Comparison -> Cohesion -> Cohesion -> Bool-compareCohesion CmpEq  = sameCohesion-compareCohesion CmpLeq = moreCohesion---- | When comparing argument spines (in compareElims) where the first arguments---   don't match, we keep going, substituting the anti-unification of the two---   terms in the telescope. More precisely:------  @@---    (u = v : A)[pid]   w = antiUnify pid A u v   us = vs : Δ[w/x]---    ----------------------------------------------------------------                    u us = v vs : (x : A) Δ---  @@------   The simplest case of anti-unification is to return a fresh metavariable---   (created by blockTermOnProblem), but if there's shared structure between---   the two terms we can expose that.------   This is really a crutch that lets us get away with things that otherwise---   would require heterogenous conversion checking. See for instance issue---   #2384.-antiUnify :: MonadConversion m => ProblemId -> Type -> Term -> Term -> m Term-antiUnify pid a u v = do-  ((u, v), eq) <- SynEq.checkSyntacticEquality u v-  if eq then return u else do-  (u, v) <- reduce (u, v)-  reportSDoc "tc.conv.antiUnify" 30 $ vcat-    [ "antiUnify"-    , "a =" <+> prettyTCM a-    , "u =" <+> prettyTCM u-    , "v =" <+> prettyTCM v-    ]-  case (u, v) of-    (Pi ua ub, Pi va vb) -> do-      wa0 <- antiUnifyType pid (unDom ua) (unDom va)-      let wa = wa0 <$ ua-      wb <- addContext wa $ antiUnifyType pid (absBody ub) (absBody vb)-      return $ Pi wa (mkAbs (absName ub) wb)-    (Lam i u, Lam _ v) ->-      reduce (unEl a) >>= \case-        Pi a b -> Lam i . (mkAbs (absName u)) <$> addContext a (antiUnify pid (absBody b) (absBody u) (absBody v))-        _      -> fallback-    (Var i us, Var j vs) | i == j -> maybeGiveUp $ do-      a <- typeOfBV i-      antiUnifyElims pid a (var i) us vs-    -- Andreas, 2017-07-27:-    -- It seems that nothing guarantees here that the constructors are fully-    -- applied!?  Thus, @a@ could be a function type and we need the robust-    -- @getConType@ here.-    -- (Note that @patternViolation@ swallows exceptions coming from @getConType@-    -- thus, we would not see clearly if we used @getFullyAppliedConType@ instead.)-    (Con x ci us, Con y _ vs) | x == y -> maybeGiveUp $ do-      a <- maybe abort (return . snd) =<< getConType x a-      antiUnifyElims pid a (Con x ci []) us vs-    (Def f [], Def g []) | f == g -> return (Def f [])-    (Def f us, Def g vs) | f == g, length us == length vs -> maybeGiveUp $ do-      a <- computeElimHeadType f us vs-      antiUnifyElims pid a (Def f []) us vs-    _ -> fallback-  where-    maybeGiveUp = catchPatternErr $ \ _ -> fallback-    abort = patternViolation neverUnblock -- caught by maybeGiveUp-    fallback = blockTermOnProblem a u pid--antiUnifyArgs :: MonadConversion m => ProblemId -> Dom Type -> Arg Term -> Arg Term -> m (Arg Term)-antiUnifyArgs pid dom u v-  | not (sameModality (getModality u) (getModality v))-              = patternViolation neverUnblock-  | otherwise = applyModalityToContext u $-    ifM (isIrrelevantOrPropM dom)-    {-then-} (return u)-    {-else-} ((<$ u) <$> antiUnify pid (unDom dom) (unArg u) (unArg v))--antiUnifyType :: MonadConversion m => ProblemId -> Type -> Type -> m Type-antiUnifyType pid (El s a) (El _ b) = workOnTypes $ El s <$> antiUnify pid (sort s) a b--antiUnifyElims :: MonadConversion m => ProblemId -> Type -> Term -> Elims -> Elims -> m Term-antiUnifyElims pid a self [] [] = return self-antiUnifyElims pid a self (Proj o f : es1) (Proj _ g : es2) | f == g = do-  res <- projectTyped self a o f-  case res of-    Just (_, self, a) -> antiUnifyElims pid a self es1 es2-    Nothing -> patternViolation neverUnblock -- can fail for projection like-antiUnifyElims pid a self (Apply u : es1) (Apply v : es2) = do-  reduce (unEl a) >>= \case-    Pi a b -> do-      w <- antiUnifyArgs pid a u v-      antiUnifyElims pid (b `lazyAbsApp` unArg w) (apply self [w]) es1 es2-    _ -> patternViolation neverUnblock-antiUnifyElims _ _ _ _ _ = patternViolation neverUnblock -- trigger maybeGiveUp in antiUnify---- | @compareElims pols a v els1 els2@ performs type-directed equality on eliminator spines.---   @t@ is the type of the head @v@.-compareElims :: forall m. MonadConversion m => [Polarity] -> [IsForced] -> Type -> Term -> [Elim] -> [Elim] -> m ()-compareElims pols0 fors0 a v els01 els02 =-  verboseBracket "tc.conv.elim" 20 "compareElims" $-  (catchConstraint (ElimCmp pols0 fors0 a v els01 els02) :: m () -> m ()) $ do-  let v1 = applyE v els01-      v2 = applyE v els02-      failure = typeError $ UnequalTerms CmpEq v1 v2 (AsTermsOf a)-        -- Andreas, 2013-03-15 since one of the spines is empty, @a@-        -- is the correct type here.-  unless (null els01) $ do-    reportSDoc "tc.conv.elim" 25 $ "compareElims" $$ do-     nest 2 $ vcat-      [ "a     =" <+> prettyTCM a-      , "pols0 (truncated to 10) =" <+> hsep (map prettyTCM $ take 10 pols0)-      , "fors0 (truncated to 10) =" <+> hsep (map prettyTCM $ take 10 fors0)-      , "v     =" <+> prettyTCM v-      , "els01 =" <+> prettyTCM els01-      , "els02 =" <+> prettyTCM els02-      ]-  case (els01, els02) of-    ([]         , []         ) -> return ()-    ([]         , Proj{}:_   ) -> failure -- not impossible, see issue 821-    (Proj{}  : _, []         ) -> failure -- could be x.p =?= x for projection p-    ([]         , Apply{} : _) -> failure -- not impossible, see issue 878-    (Apply{} : _, []         ) -> failure-    ([]         , IApply{} : _) -> failure-    (IApply{} : _, []         ) -> failure-    (Apply{} : _, Proj{}  : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True -- NB: popped up in issue 889-    (Proj{}  : _, Apply{} : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True -- but should be impossible (but again in issue 1467)-    (IApply{} : _, Proj{}  : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True-    (Proj{}  : _, IApply{} : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True-    (IApply{} : _, Apply{}  : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True-    (Apply{}  : _, IApply{} : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True-    (e@(IApply x1 y1 r1) : els1, IApply x2 y2 r2 : els2) -> do-      reportSDoc "tc.conv.elim" 25 $ "compareElims IApply"-       -- Andrea: copying stuff from the Apply case..-      let (pol, pols) = nextPolarity pols0-      a  <- abortIfBlocked a-      va <- pathView a-      reportSDoc "tc.conv.elim.iapply" 60 $ "compareElims IApply" $$ do-        nest 2 $ "va =" <+> text (show (isPathType va))-      case va of-        PathType s path l bA x y -> do-          b <- primIntervalType-          compareWithPol pol (flip compareTerm b)-                              r1 r2-          -- TODO: compare (x1,x2) and (y1,y2) ?-          let r = r1 -- TODO Andrea:  do blocking-          codom <- el' (pure . unArg $ l) ((pure . unArg $ bA) <@> pure r)-          compareElims pols [] codom -- Path non-dependent (codom `lazyAbsApp` unArg arg)-                            (applyE v [e]) els1 els2-        -- We allow for functions (i : I) -> ... to also be heads of a IApply,-        -- because @etaContract@ can produce such terms-        OType t@(El _ Pi{}) -> compareElims pols0 fors0 t v (Apply (defaultArg r1) : els1) (Apply (defaultArg r2) : els2)--        OType t -> patternViolation (unblockOnAnyMetaIn t) -- Can we get here? We know a is not blocked.--    (Apply arg1 : els1, Apply arg2 : els2) ->-      (verboseBracket "tc.conv.elim" 20 "compare Apply" :: m () -> m ()) $ do-      reportSDoc "tc.conv.elim" 10 $ nest 2 $ vcat-        [ "a    =" <+> prettyTCM a-        , "v    =" <+> prettyTCM v-        , "arg1 =" <+> prettyTCM arg1-        , "arg2 =" <+> prettyTCM arg2-        ]-      reportSDoc "tc.conv.elim" 50 $ nest 2 $ vcat-        [ "raw:"-        , "a    =" <+> pretty a-        , "v    =" <+> pretty v-        , "arg1 =" <+> pretty arg1-        , "arg2 =" <+> pretty arg2-        ]-      let (pol, pols) = nextPolarity pols0-          (for, fors) = nextIsForced fors0-      a <- abortIfBlocked a-      reportSLn "tc.conv.elim" 40 $ "type is not blocked"-      case unEl a of-        (Pi (Dom{domInfo = info, unDom = b}) codom) -> do-          reportSLn "tc.conv.elim" 40 $ "type is a function type"-          mlvl <- tryMaybe primLevel-          let freeInCoDom (Abs _ c) = 0 `freeInIgnoringSorts` c-              freeInCoDom _         = False-              dependent = (Just (unEl b) /= mlvl) && freeInCoDom codom-                -- Level-polymorphism (x : Level) -> ... does not count as dependency here-                   -- NB: we could drop the free variable test and still be sound.-                   -- It is a trade-off between the administrative effort of-                   -- creating a blocking and traversing a term for free variables.-                   -- Apparently, it is believed that checking free vars is cheaper.-                   -- Andreas, 2013-05-15---- NEW, Andreas, 2013-05-15--          -- compare arg1 and arg2-          pid <- newProblem_ $ applyModalityToContext info $-              if isForced for then-                reportSLn "tc.conv.elim" 40 $ "argument is forced"-              else if isIrrelevant info then do-                reportSLn "tc.conv.elim" 40 $ "argument is irrelevant"-                compareIrrelevant b (unArg arg1) (unArg arg2)-              else do-                reportSLn "tc.conv.elim" 40 $ "argument has polarity " ++ show pol-                compareWithPol pol (flip compareTerm b)-                  (unArg arg1) (unArg arg2)-          -- if comparison got stuck and function type is dependent, block arg-          solved <- isProblemSolved pid-          reportSLn "tc.conv.elim" 40 $ "solved = " ++ show solved-          arg <- if dependent && not solved-                 then applyModalityToContext info $ do-                  reportSDoc "tc.conv.elims" 50 $ vcat $-                    [ "Trying antiUnify:"-                    , nest 2 $ "b    =" <+> prettyTCM b-                    , nest 2 $ "arg1 =" <+> prettyTCM arg1-                    , nest 2 $ "arg2 =" <+> prettyTCM arg2-                    ]-                  arg <- (arg1 $>) <$> antiUnify pid b (unArg arg1) (unArg arg2)-                  reportSDoc "tc.conv.elims" 50 $ hang "Anti-unification:" 2 (prettyTCM arg)-                  reportSDoc "tc.conv.elims" 70 $ nest 2 $ "raw:" <+> pretty arg-                  return arg-                 else return arg1-          -- continue, possibly with blocked instantiation-          compareElims pols fors (codom `lazyAbsApp` unArg arg) (apply v [arg]) els1 els2-          -- any left over constraints of arg are associated to the comparison-          reportSLn "tc.conv.elim" 40 $ "stealing constraints from problem " ++ show pid-          stealConstraints pid-          {- Stealing solves this issue:--             Does not create enough blocked tc-problems,-             see test/fail/DontPrune.-             (There are remaining problems which do not show up as yellow.)-             Need to find a way to associate pid also to result of compareElims.-          -}-        a -> do-          reportSDoc "impossible" 10 $-            "unexpected type when comparing apply eliminations " <+> prettyTCM a-          reportSDoc "impossible" 50 $ "raw type:" <+> pretty a-          patternViolation (unblockOnAnyMetaIn a)-          -- Andreas, 2013-10-22-          -- in case of disabled reductions (due to failing termination check)-          -- we might get stuck, so do not crash, but fail gently.-          -- __IMPOSSIBLE__--    -- case: f == f' are projections-    (Proj o f : els1, Proj _ f' : els2)-      | f /= f'   -> typeError . GenericDocError =<< prettyTCM f <+> "/=" <+> prettyTCM f'-      | otherwise -> do-        a   <- abortIfBlocked a-        res <- projectTyped v a o f -- fails only if f is proj.like but parameters cannot be retrieved-        case res of-          Just (_, u, t) -> do-            -- Andreas, 2015-07-01:-            -- The arguments following the principal argument of a projection-            -- are invariant.  (At least as long as we have no explicit polarity-            -- annotations.)-            compareElims [] [] t u els1 els2-          Nothing -> do-            reportSDoc "tc.conv.elims" 30 $ sep-              [ text $ "projection " ++ prettyShow f-              , text   "applied to value " <+> prettyTCM v-              , text   "of unexpected type " <+> prettyTCM a-              ]-            patternViolation (unblockOnAnyMetaIn a)----- | "Compare" two terms in irrelevant position.  This always succeeds.---   However, we can dig for solutions of irrelevant metas in the---   terms we compare.---   (Certainly not the systematic solution, that'd be proof search...)-compareIrrelevant :: MonadConversion m => Type -> Term -> Term -> m ()-{- 2012-04-02 DontCare no longer present-compareIrrelevant t (DontCare v) w = compareIrrelevant t v w-compareIrrelevant t v (DontCare w) = compareIrrelevant t v w--}-compareIrrelevant t v0 w0 = do-  let v = stripDontCare v0-      w = stripDontCare w0-  reportSDoc "tc.conv.irr" 20 $ vcat-    [ "compareIrrelevant"-    , nest 2 $ "v =" <+> prettyTCM v-    , nest 2 $ "w =" <+> prettyTCM w-    ]-  reportSDoc "tc.conv.irr" 50 $ vcat-    [ nest 2 $ "v =" <+> pretty v-    , nest 2 $ "w =" <+> pretty w-    ]-  try v w $ try w v $ return ()-  where-    try (MetaV x es) w fallback = do-      mv <- lookupMeta x-      let rel  = getMetaRelevance mv-          inst = case mvInstantiation mv of-                   InstV{} -> True-                   _       -> False-      reportSDoc "tc.conv.irr" 20 $ vcat-        [ nest 2 $ text $ "rel  = " ++ show rel-        , nest 2 $ "inst =" <+> pretty inst-        ]-      if not (isIrrelevant rel) || inst-        then fallback-        -- Andreas, 2016-08-08, issue #2131:-        -- Mining for solutions for irrelevant metas is not definite.-        -- Thus, in case of error, leave meta unsolved.-        else assignE DirEq x es w (AsTermsOf t) (compareIrrelevant t) `catchError` \ _ -> fallback-        -- the value of irrelevant or unused meta does not matter-    try v w fallback = fallback--compareWithPol :: MonadConversion m => Polarity -> (Comparison -> a -> a -> m ()) -> a -> a -> m ()-compareWithPol Invariant     cmp x y = cmp CmpEq x y-compareWithPol Covariant     cmp x y = cmp CmpLeq x y-compareWithPol Contravariant cmp x y = cmp CmpLeq y x-compareWithPol Nonvariant    cmp x y = return ()--polFromCmp :: Comparison -> Polarity-polFromCmp CmpLeq = Covariant-polFromCmp CmpEq  = Invariant---- | Type-directed equality on argument lists----compareArgs :: MonadConversion m => [Polarity] -> [IsForced] -> Type -> Term -> Args -> Args -> m ()-compareArgs pol for a v args1 args2 =-  compareElims pol for a v (map Apply args1) (map Apply args2)-------------------------------------------------------------------------------- * Types-------------------------------------------------------------------------------- | Equality on Types-compareType :: MonadConversion m => Comparison -> Type -> Type -> m ()-compareType cmp ty1@(El s1 a1) ty2@(El s2 a2) =-    workOnTypes $-    verboseBracket "tc.conv.type" 20 "compareType" $ do-        reportSDoc "tc.conv.type" 50 $ vcat-          [ "compareType" <+> sep [ prettyTCM ty1 <+> prettyTCM cmp-                                       , prettyTCM ty2 ]-          , hsep [ "   sorts:", prettyTCM s1, " and ", prettyTCM s2 ]-          ]-        compareAs cmp AsTypes a1 a2--leqType :: MonadConversion m => Type -> Type -> m ()-leqType = compareType CmpLeq---- | @coerce v a b@ coerces @v : a@ to type @b@, returning a @v' : b@---   with maybe extra hidden applications or hidden abstractions.------   In principle, this function can host coercive subtyping, but---   currently it only tries to fix problems with hidden function types.----coerce :: (MonadConversion m, MonadTCM m) => Comparison -> Term -> Type -> Type -> m Term-coerce cmp v t1 t2 = blockTerm t2 $ do-  verboseS "tc.conv.coerce" 10 $ do-    (a1,a2) <- reify (t1,t2)-    let dbglvl = 30-    reportSDoc "tc.conv.coerce" dbglvl $-      "coerce" <+> vcat-        [ "term      v  =" <+> prettyTCM v-        , "from type t1 =" <+> prettyTCM a1-        , "to type   t2 =" <+> prettyTCM a2-        , "comparison   =" <+> prettyTCM cmp-        ]-    reportSDoc "tc.conv.coerce" 70 $-      "coerce" <+> vcat-        [ "term      v  =" <+> pretty v-        , "from type t1 =" <+> pretty t1-        , "to type   t2 =" <+> pretty t2-        , "comparison   =" <+> pretty cmp-        ]-  -- v <$ do workOnTypes $ leqType t1 t2-  -- take off hidden/instance domains from t1 and t2-  TelV tel1 b1 <- telViewUpTo' (-1) notVisible t1-  TelV tel2 b2 <- telViewUpTo' (-1) notVisible t2-  let n = size tel1 - size tel2-  -- the crude solution would be-  --   v' = λ {tel2} → v {tel1}-  -- however, that may introduce unneccessary many function types-  -- If n  > 0 and b2 is not blocked, it is safe to-  -- insert n many hidden args-  if n <= 0 then fallback else do-    ifBlocked b2 (\ _ _ -> fallback) $ \ _ _ -> do-      (args, t1') <- implicitArgs n notVisible t1-      let v' = v `apply` args-      v' <$ coerceSize (compareType cmp) v' t1' t2-  where-    fallback = v <$ coerceSize (compareType cmp) v t1 t2---- | Account for situations like @k : (Size< j) <= (Size< k + 1)@------   Actually, the semantics is---   @(Size<= k) ∩ (Size< j) ⊆ rhs@---   which gives a disjunctive constraint.  Mmmh, looks like stuff---   TODO.------   For now, we do a cheap heuristics.----coerceSize :: MonadConversion m => (Type -> Type -> m ()) -> Term -> Type -> Type -> m ()-coerceSize leqType v t1 t2 = verboseBracket "tc.conv.size.coerce" 45 "coerceSize" $-  workOnTypes $ do-    reportSDoc "tc.conv.size.coerce" 70 $-      "coerceSize" <+> vcat-        [ "term      v  =" <+> pretty v-        , "from type t1 =" <+> pretty t1-        , "to type   t2 =" <+> pretty t2-        ]-    let fallback = leqType t1 t2-        done = caseMaybeM (isSizeType =<< reduce t1) fallback $ \ _ -> return ()-    -- Andreas, 2015-07-22, Issue 1615:-    -- If t1 is a meta and t2 a type like Size< v2, we need to make sure we do not miss-    -- the constraint v < v2!-    caseMaybeM (isSizeType =<< reduce t2) fallback $ \ b2 -> do-      -- Andreas, 2017-01-20, issue #2329:-      -- If v is not a size suitable for the solver, like a neutral term,-      -- we can only rely on the type.-      mv <- sizeMaxView v-      if any (\case{ DOtherSize{} -> True; _ -> False }) mv then fallback else do-      -- Andreas, 2015-02-11 do not instantiate metas here (triggers issue 1203).-      unlessM (tryConversion $ dontAssignMetas $ leqType t1 t2) $ do-        -- A (most probably weaker) alternative is to just check syn.eq.-        -- ifM (snd <$> checkSyntacticEquality t1 t2) (return v) $ {- else -} do-        reportSDoc "tc.conv.size.coerce" 20 $ "coercing to a size type"-        case b2 of-          -- @t2 = Size@.  We are done!-          BoundedNo -> done-          -- @t2 = Size< v2@-          BoundedLt v2 -> do-            sv2 <- sizeView v2-            case sv2 of-              SizeInf     -> done-              OtherSize{} -> do-                -- Andreas, 2014-06-16:-                -- Issue 1203: For now, just treat v < v2 as suc v <= v2-                -- TODO: Need proper < comparison-                vinc <- sizeSuc 1 v-                compareSizes CmpLeq vinc v2-                done-              -- @v2 = a2 + 1@: In this case, we can try @v <= a2@-              SizeSuc a2 -> do-                compareSizes CmpLeq v a2-                done  -- to pass Issue 1136-------------------------------------------------------------------------------- * Sorts and levels------------------------------------------------------------------------------compareLevel :: MonadConversion m => Comparison -> Level -> Level -> m ()-compareLevel CmpLeq u v = leqLevel u v-compareLevel CmpEq  u v = equalLevel u v--compareSort :: MonadConversion m => Comparison -> Sort -> Sort -> m ()-compareSort CmpEq  = equalSort-compareSort CmpLeq = leqSort---- | Check that the first sort is less or equal to the second.------   We can put @SizeUniv@ below @Inf@, but otherwise, it is---   unrelated to the other universes.----leqSort :: forall m. MonadConversion m => Sort -> Sort -> m ()-leqSort s1 s2 = (catchConstraint (SortCmp CmpLeq s1 s2) :: m () -> m ()) $ do-  (s1,s2) <- reduce (s1,s2)-  let postpone = addConstraint (unblockOnAnyMetaIn (s1, s2)) (SortCmp CmpLeq s1 s2)-      no       = typeError $ NotLeqSort s1 s2-      yes      = return ()-      synEq    = ifNotM (optSyntacticEquality <$> pragmaOptions) postpone $ do-        ((s1,s2) , equal) <- SynEq.checkSyntacticEquality s1 s2-        if | equal     -> yes-           | otherwise -> postpone-  reportSDoc "tc.conv.sort" 30 $-    sep [ "leqSort"-        , nest 2 $ fsep [ prettyTCM s1 <+> "=<"-                        , prettyTCM s2 ]-        ]-  propEnabled <- isPropEnabled-  typeInTypeEnabled <- typeInType-  omegaInOmegaEnabled <- optOmegaInOmega <$> pragmaOptions--  let fvsRHS = (`IntSet.member` allFreeVars s2)-  badRigid <- s1 `rigidVarsNotContainedIn` fvsRHS--  case (s1, s2) of-      -- Andreas, 2018-09-03: crash on dummy sort-      (DummyS s, _) -> impossibleSort s-      (_, DummyS s) -> impossibleSort s--      -- The most basic rule: @Set l =< Set l'@ iff @l =< l'@-      (Type a  , Type b  ) -> leqLevel a b--      -- Likewise for @Prop@-      (Prop a  , Prop b  ) -> leqLevel a b--      -- Likewise for @SSet@-      (SSet a  , SSet b  ) -> leqLevel a b--      -- @Prop l@ is below @Set l@-      (Prop a  , Type b  ) -> leqLevel a b-      (Type a  , Prop b  ) -> no--      -- @Setωᵢ@ is above all small sorts (spelling out all cases-      -- for the exhaustiveness checker)-      (Inf f m , Inf f' n) ->-        if leqFib f f' && (m <= n || typeInTypeEnabled || omegaInOmegaEnabled) then yes else no-      (Type{}  , Inf f _) -> yes-      (Prop{}  , Inf f _) -> yes-      (Inf f _, Type{}  ) -> if f == IsFibrant && typeInTypeEnabled then yes else no-      (Inf f _, SSet{}  ) -> if f == IsStrict  && typeInTypeEnabled then yes else no-      (Inf _ _, Prop{}  ) -> no--      -- @Set l@ is below @SSet l@-      (Type a  , SSet b  ) -> leqLevel a b-      (SSet a  , Type b  ) -> no--      -- @Prop l@ is below @SSet l@-      (Prop a  , SSet b  ) -> leqLevel a b-      (SSet a  , Prop b  ) -> no--      -- @SSet@ is below @SSetω@-      (SSet{}  , Inf IsStrict _) -> yes-      (SSet{}  , Inf IsFibrant _) -> no--      -- @SizeUniv@ and @Prop0@ are bottom sorts.-      -- So is @Set0@ if @Prop@ is not enabled.-      (_       , LockUniv) -> equalSort s1 s2-      (_       , SizeUniv) -> equalSort s1 s2-      (_       , Prop (Max 0 [])) -> equalSort s1 s2-      (_       , Type (Max 0 []))-        | not propEnabled  -> equalSort s1 s2--      -- SizeUniv is unrelated to any @Set l@ or @Prop l@-      (SizeUniv, Type{}  ) -> no-      (SizeUniv, Prop{}  ) -> no-      (SizeUniv , Inf{}  ) -> no-      (SizeUniv, SSet{}  ) -> no-      (LockUniv, Type{}  ) -> no-      (LockUniv, Prop{}  ) -> no-      (LockUniv , Inf{}  ) -> no-      (LockUniv, SSet{}  ) -> no--      -- If the first sort is a small sort that rigidly depends on a-      -- variable and the second sort does not mention this variable,-      -- the second sort must be at least @Setω@.-      (_       , _       ) | Just (True,f) <- isSmallSort s1 , badRigid -> leqSort (Inf f 0) s2--      -- PiSort, FunSort, UnivSort and MetaS might reduce once we instantiate-      -- more metas, so we postpone.-      (PiSort{}, _       ) -> synEq-      (_       , PiSort{}) -> synEq-      (FunSort{}, _      ) -> synEq-      (_      , FunSort{}) -> synEq-      (UnivSort{}, _     ) -> synEq-      (_     , UnivSort{}) -> synEq-      (MetaS{} , _       ) -> synEq-      (_       , MetaS{} ) -> synEq--      -- DefS are postulated sorts, so they do not reduce.-      (DefS{} , _     ) -> synEq-      (_      , DefS{}) -> synEq--  where-  leqFib IsFibrant _ = True-  leqFib IsStrict IsStrict = True-  leqFib _ _ = False-  impossibleSort s = do-    reportS "impossible" 10-      [ "leqSort: found dummy sort with description:"-      , s-      ]-    __IMPOSSIBLE__--leqLevel :: MonadConversion m => Level -> Level -> m ()-leqLevel a b = catchConstraint (LevelCmp CmpLeq a b) $ do-      reportSDoc "tc.conv.level" 30 $-        "compareLevel" <+>-          sep [ prettyTCM a <+> "=<"-              , prettyTCM b ]--      (a, b) <- reduce (a, b)-      ((a, b), equal) <- SynEq.checkSyntacticEquality a b--      let notok    = unlessM typeInType $ typeError $ NotLeqSort (Type a) (Type b)-          postpone = patternViolation (unblockOnAnyMetaIn (a, b))--          wrap m = m `catchError` \case-            TypeError{} -> notok-            err         -> throwError err--      reportSDoc "tc.conv.level" 60 $-        "checkSyntacticEquality returns" <+> prettyTCM equal-      unless equal $ do--      cumulativity <- optCumulativity <$> pragmaOptions-      areWeComputingOverlap <- viewTC eConflComputingOverlap-      reportSDoc "tc.conv.level" 40 $-        "compareLevelView" <+>-          sep [ prettyList_ $ fmap (pretty . unSingleLevel) $ levelMaxView a-              , "=<"-              , prettyList_ $ fmap (pretty . unSingleLevel) $ levelMaxView b-              ]--      -- Extra reduce on level atoms, but should be cheap since they are already reduced.-      aB <- mapM reduceB a-      bB <- mapM reduceB b--      wrap $ case (levelMaxView aB, levelMaxView bB) of--        -- 0 ≤ any-        (SingleClosed 0 :| [] , _) -> return ()--        -- any ≤ 0-        (as , SingleClosed 0 :| []) ->-          forM_ as $ \ a' -> equalLevel (unSingleLevel $ fmap ignoreBlocking a') (ClosedLevel 0)--        -- closed ≤ closed-        (SingleClosed m :| [], SingleClosed n :| []) -> unless (m <= n) notok--        -- closed ≤ b-        (SingleClosed m :| [] , _)-          | m <= levelLowerBound b -> return ()--        -- as ≤ neutral/closed-        (as, bs)-          | all neutralOrClosed bs , levelLowerBound a > levelLowerBound b -> notok--        -- ⊔ as ≤ single-        (as@(_:|_:_), b :| []) ->-          forM_ as $ \ a' -> leqLevel (unSingleLevel $ ignoreBlocking <$> a')-                                      (unSingleLevel $ ignoreBlocking <$> b)--        -- reduce constants-        (as, bs)-          | let minN = min (fst $ levelPlusView a) (fst $ levelPlusView b)-                a'   = fromMaybe __IMPOSSIBLE__ $ subLevel minN a-                b'   = fromMaybe __IMPOSSIBLE__ $ subLevel minN b-          , minN > 0 -> leqLevel a' b'--        -- remove subsumed-        -- Andreas, 2014-04-07: This is ok if we do not go back to equalLevel-        (as, bs)-          | (subsumed@(_:_) , as') <- List1.partition (isSubsumed . fmap ignoreBlocking) as-          -> leqLevel (unSingleLevels $ (fmap . fmap) ignoreBlocking as') b-          where-            isSubsumed a = any (`subsumes` a) $ (fmap . fmap) ignoreBlocking bs--            subsumes :: SingleLevel -> SingleLevel -> Bool-            subsumes (SingleClosed m)        (SingleClosed n)        = m >= n-            subsumes (SinglePlus (Plus m _)) (SingleClosed n)        = m >= n-            subsumes (SinglePlus (Plus m a)) (SinglePlus (Plus n b)) = a == b && m >= n-            subsumes _ _ = False--        -- as ≤ _l x₁ .. xₙ ⊔ bs-        -- We can solve _l := λ x₁ .. xₙ -> as ⊔ (_l' x₁ .. xₙ)-        -- (where _l' is a new metavariable)-        (as , bs)-          | cumulativity-          , not areWeComputingOverlap-          , Just (mb@(MetaV x es) , bs') <- singleMetaView $ (map . fmap) ignoreBlocking (List1.toList bs)-          , null bs' || noMetas (Level a , unSingleLevels bs') -> do-            mv <- lookupMeta x-            -- Jesper, 2019-10-13: abort if this is an interaction-            -- meta or a generalizable meta-            abort <- (isJust <$> isInteractionMeta x) `or2M`-                     ((== YesGeneralizeVar) <$> isGeneralizableMeta x)-            if | abort -> postpone-               | otherwise -> do-                  x' <- case mvJudgement mv of-                    IsSort{} -> __IMPOSSIBLE__-                    HasType _ cmp t -> do-                      TelV tel t' <- telView t-                      newMeta Instantiable (mvInfo mv) normalMetaPriority (idP $ size tel) $ HasType () cmp t-                  reportSDoc "tc.conv.level" 20 $ fsep-                    [ "attempting to solve" , prettyTCM (MetaV x es) , "to the maximum of"-                    , prettyTCM (Level a) , "and the fresh meta" , prettyTCM (MetaV x' es)-                    ]-                  equalLevel (atomicLevel mb) $ levelLub a (atomicLevel $ MetaV x' es)---        -- Andreas, 2016-09-28: This simplification loses the solution lzero.-        -- Thus, it is invalid.-        -- See test/Succeed/LevelMetaLeqNeutralLevel.agda.-        -- -- [a] ≤ [neutral]-        -- ([a@(Plus n _)], [b@(Plus m NeutralLevel{})])-        --   | m == n -> equalLevel' (Max [a]) (Max [b])-        --   -- Andreas, 2014-04-07: This call to equalLevel is ok even if we removed-        --   -- subsumed terms from the lhs.--        -- anything else-        _ | noMetas (a, b) -> notok-          | otherwise      -> postpone-      where-        neutralOrClosed (SingleClosed _)                   = True-        neutralOrClosed (SinglePlus (Plus _ NotBlocked{})) = True-        neutralOrClosed _                                  = False--        -- Is there exactly one @MetaV@ in the list of single levels?-        singleMetaView :: [SingleLevel] -> Maybe (Term, [SingleLevel])-        singleMetaView (SinglePlus (Plus 0 l@(MetaV m es)) : ls)-          | all (not . isMetaLevel) ls = Just (l,ls)-        singleMetaView (l : ls)-          | not $ isMetaLevel l = second (l:) <$> singleMetaView ls-        singleMetaView _ = Nothing--        isMetaLevel :: SingleLevel -> Bool-        isMetaLevel (SinglePlus (Plus _ MetaV{})) = True-        isMetaLevel _                             = False--equalLevel :: forall m. MonadConversion m => Level -> Level -> m ()-equalLevel a b = do-  reportSDoc "tc.conv.level" 50 $ sep [ "equalLevel", nest 2 $ parens $ pretty a, nest 2 $ parens $ pretty b ]-  -- Andreas, 2013-10-31 remove common terms (that don't contain metas!)-  -- THAT's actually UNSOUND when metas are instantiated, because-  --     max a b == max a c  does not imply  b == c-  -- as <- return $ Set.fromList $ closed0 as-  -- bs <- return $ Set.fromList $ closed0 bs-  -- let cs = Set.filter (not . hasMeta) $ Set.intersection as bs-  -- as <- return $ Set.toList $ as Set.\\ cs-  -- bs <- return $ Set.toList $ bs Set.\\ cs--  reportSDoc "tc.conv.level" 40 $-    sep [ "equalLevel"-        , vcat [ nest 2 $ sep [ prettyTCM a <+> "=="-                              , prettyTCM b-                              ]-               ]-        ]--  (a, b) <- reduce (a, b)-  ((a, b), equal) <- SynEq.checkSyntacticEquality a b-  reportSDoc "tc.conv.level" 60 $-    "checkSyntacticEquality returns" <+> prettyTCM equal-  unless equal $ do--  -- Jesper, 2014-02-02 remove terms that certainly do not contribute-  -- to the maximum-  let (a', b') = removeSubsumed a b--  let notok    = unlessM typeInType notOk-      notOk    = typeError $ UnequalLevel CmpEq a' b'-      postpone = do-        reportSDoc "tc.conv.level" 30 $ hang "postponing:" 2 $ hang (pretty a' <+> "==") 0 (pretty b')-        patternViolation (unblockOnAnyMetaIn (a', b'))--  reportSDoc "tc.conv.level" 50 $-    sep [ "equalLevel (w/o subsumed)"-        , vcat [ nest 2 $ sep [ prettyTCM a' <+> "=="-                              , prettyTCM b'-                              ]-               ]-        ]--  let as  = levelMaxView a'-      bs  = levelMaxView b'-  reportSDoc "tc.conv.level" 50 $-    sep [ text "equalLevel"-        , vcat [ nest 2 $ sep [ prettyList_ $ fmap (pretty . unSingleLevel) as-                              , "=="-                              , prettyList_ $ fmap (pretty . unSingleLevel) bs-                              ]-               ]-        ]--  reportSDoc "tc.conv.level" 80 $-    sep [ text "equalLevel"-        , vcat [ nest 2 $ sep [ prettyList_ $ fmap (text . show . unSingleLevel) as-                              , "=="-                              , prettyList_ $ fmap (text . show . unSingleLevel) bs-                              ]-               ]-        ]--  -- Extra reduce on level atoms, but should be cheap since they are already reduced.-  as <- (mapM . mapM) reduceB as-  bs <- (mapM . mapM) reduceB bs--  catchConstraint (LevelCmp CmpEq a b) $ case (as, bs) of--        -- closed == closed-        (SingleClosed m :| [], SingleClosed n :| [])-          | m == n    -> return ()-          | otherwise -> notok--        -- closed == neutral-        (SingleClosed m :| [] , bs) | any isNeutral bs -> notok-        (as , SingleClosed n :| []) | any isNeutral as -> notok--        -- closed == b-        (SingleClosed m :| [] , _) | m < levelLowerBound b -> notok-        (_ , SingleClosed n :| []) | n < levelLowerBound a -> notok--        -- 0 == a ⊔ b-        (SingleClosed 0 :| [] , bs@(_:|_:_)) ->-          forM_ bs $ \ b' ->  equalLevel (ClosedLevel 0) (unSingleLevel $ ignoreBlocking <$> b')-        (as@(_:|_:_) , SingleClosed 0 :| []) ->-          forM_ as $ \ a' -> equalLevel (unSingleLevel $ ignoreBlocking <$> a') (ClosedLevel 0)--        -- meta == any-        (SinglePlus (Plus k a) :| [] , SinglePlus (Plus l b) :| [])-          -- there is only a potential choice when k == l-          | MetaV x as' <- ignoreBlocking a-          , MetaV y bs' <- ignoreBlocking b-          , k == l -> do-              lvl <- levelType-              equalAtom (AsTermsOf lvl) (MetaV x as') (MetaV y bs')-        (SinglePlus (Plus k a) :| [] , _)-          | MetaV x as' <- ignoreBlocking a-          , Just b' <- subLevel k b -> meta x as' b'-        (_ , SinglePlus (Plus l b) :| [])-          | MetaV y bs' <- ignoreBlocking b-          , Just a' <- subLevel l a -> meta y bs' a'--        -- a' ⊔ b == b-        _ | Just a' <- levelMaxDiff a b-          , b /= ClosedLevel 0 -> leqLevel a' b--        -- a == b' ⊔ a-        _ | Just b' <- levelMaxDiff b a-          , a /= ClosedLevel 0 -> leqLevel b' a--        -- neutral/closed == neutral/closed-        (as , bs)-          | all isNeutralOrClosed (as <> bs)-          -- Andreas, 2013-10-31: There could be metas in neutral levels (see Issue 930).-          -- Should not we postpone there as well?  Yes!-          , not (any hasMeta (as <> bs))-          , length as == length bs -> do-              reportSLn "tc.conv.level" 60 $ "equalLevel: all are neutral or closed"-              List1.zipWithM_ ((===) `on` levelTm . unSingleLevel . fmap ignoreBlocking) as bs--        -- more cases?-        _ | noMetas (Level a , Level b) -> notok-          | otherwise                   -> postpone--      where-        a === b = unlessM typeInType $ do-          lvl <- levelType-          equalAtom (AsTermsOf lvl) a b--        -- perform assignment (MetaV x as) := b-        meta x as b = do-          reportSLn "tc.meta.level" 30 $ "Assigning meta level"-          reportSDoc "tc.meta.level" 50 $ "meta" <+> sep [prettyList $ map pretty as, pretty b]-          lvl <- levelType-          assignE DirEq x as (levelTm b) (AsTermsOf lvl) (===) -- fallback: check equality as atoms--        isNeutral (SinglePlus (Plus _ NotBlocked{})) = True-        isNeutral _                                  = False--        isNeutralOrClosed (SingleClosed _)                   = True-        isNeutralOrClosed (SinglePlus (Plus _ NotBlocked{})) = True-        isNeutralOrClosed _                                  = False--        hasMeta (SinglePlus (Plus _ Blocked{})) = True-        hasMeta (SinglePlus (Plus _ a))         = isJust $ firstMeta $ ignoreBlocking a-        hasMeta (SingleClosed _)                = False--        removeSubsumed a b =-          let as = List1.toList $ levelMaxView a-              bs = List1.toList $ levelMaxView b-              a' = unSingleLevels $ filter (not . (`isStrictlySubsumedBy` bs)) as-              b' = unSingleLevels $ filter (not . (`isStrictlySubsumedBy` as)) bs-          in (a',b')--        x `isStrictlySubsumedBy` ys = any (`strictlySubsumes` x) ys--        SingleClosed m        `strictlySubsumes` SingleClosed n        = m > n-        SinglePlus (Plus m a) `strictlySubsumes` SingleClosed n        = m > n-        SinglePlus (Plus m a) `strictlySubsumes` SinglePlus (Plus n b) = a == b && m > n-        _                     `strictlySubsumes` _                     = False----- | Check that the first sort equal to the second.-equalSort :: forall m. MonadConversion m => Sort -> Sort -> m ()-equalSort s1 s2 = do-    catchConstraint (SortCmp CmpEq s1 s2) $ do-        (s1,s2) <- reduce (s1,s2)-        let yes      = return ()-            no       = typeError $ UnequalSorts s1 s2--        reportSDoc "tc.conv.sort" 30 $ sep-          [ "equalSort"-          , vcat [ nest 2 $ fsep [ prettyTCM s1 <+> "=="-                                 , prettyTCM s2 ]-                 , nest 2 $ fsep [ pretty s1 <+> "=="-                                 , pretty s2 ]-                 ]-          ]--        propEnabled <- isPropEnabled-        typeInTypeEnabled <- typeInType-        omegaInOmegaEnabled <- optOmegaInOmega <$> pragmaOptions--        case (s1, s2) of--            -- Andreas, 2018-09-03: crash on dummy sort-            (DummyS s, _) -> impossibleSort s-            (_, DummyS s) -> impossibleSort s--            -- one side is a meta sort: try to instantiate-            -- In case both sides are meta sorts, instantiate the-            -- bigger (i.e. more recent) one.-            (MetaS x es , MetaS y es')-              | x == y                 -> synEq s1 s2-              | x < y                  -> meta y es' s1-              | otherwise              -> meta x es s2-            (MetaS x es , _          ) -> meta x es s2-            (_          , MetaS x es ) -> meta x es s1--            -- diagonal cases for rigid sorts-            (Type a     , Type b     ) -> equalLevel a b `catchInequalLevel` no-            (SizeUniv   , SizeUniv   ) -> yes-            (LockUniv   , LockUniv   ) -> yes-            (Prop a     , Prop b     ) -> equalLevel a b `catchInequalLevel` no-            (Inf f m    , Inf f' n   ) ->-              if f == f' && (m == n || typeInTypeEnabled || omegaInOmegaEnabled) then yes else no-            (SSet a     , SSet b     ) -> equalLevel a b--            -- if --type-in-type is enabled, Setωᵢ is equal to any Set ℓ (see #3439)-            (Type{}     , Inf{}      )-              | typeInTypeEnabled      -> yes-            (Inf{}      , Type{}     )-              | typeInTypeEnabled      -> yes--            -- equating @PiSort a b@ to another sort-            (s1 , PiSort a b c) -> piSortEquals s1 a b c-            (PiSort a b c , s2) -> piSortEquals s2 a b c--            -- equating @FunSort a b@ to another sort-            (s1 , FunSort a b) -> funSortEquals s1 a b-            (FunSort a b , s2) -> funSortEquals s2 a b--            -- equating @UnivSort s@ to another sort-            (s1          , UnivSort s2) -> univSortEquals s1 s2-            (UnivSort s1 , s2         ) -> univSortEquals s2 s1--            -- postulated sorts can only be equal if they have the same head-            (DefS d es  , DefS d' es')-              | d == d'                -> synEq s1 s2-              | otherwise              -> no--            -- any other combinations of sorts are not equal-            (_          , _          ) -> no--    where-      -- perform assignment (MetaS x es) := s-      meta :: MetaId -> [Elim' Term] -> Sort -> m ()-      meta x es s = do-        reportSLn "tc.meta.sort" 30 $ "Assigning meta sort"-        reportSDoc "tc.meta.sort" 50 $ "meta" <+> sep [pretty x, prettyList $ map pretty es, pretty s]-        assignE DirEq x es (Sort s) AsTypes __IMPOSSIBLE__--      -- fall back to syntactic equality check, postpone if it fails-      synEq :: Sort -> Sort -> m ()-      synEq s1 s2 = do-        let postpone = addConstraint (unblockOnAnyMetaIn (s1, s2)) $ SortCmp CmpEq s1 s2-        doSynEq <- optSyntacticEquality <$> pragmaOptions-        if | doSynEq -> do-               ((s1,s2) , equal) <- SynEq.checkSyntacticEquality s1 s2-               if | equal     -> return ()-                  | otherwise -> postpone-           | otherwise -> postpone--      -- Equate a sort @s1@ to @univSort s2@-      -- Precondition: @s1@ and @univSort s2@ are already reduced.-      univSortEquals :: Sort -> Sort -> m ()-      univSortEquals s1 s2 = do-        reportSDoc "tc.conv.sort" 35 $ vcat-          [ "univSortEquals"-          , "  s1 =" <+> prettyTCM s1-          , "  s2 =" <+> prettyTCM s2-          ]-        let no = typeError $ UnequalSorts s1 (UnivSort s2)-        case s1 of-          -- @Set l1@ is the successor sort of either @Set l2@ or-          -- @Prop l2@ where @l1 == lsuc l2@.-          Type l1 -> do-            propEnabled <- isPropEnabled-               -- @s2@ is definitely not @Inf n@ or @SizeUniv@-            if | Inf _ n  <- s2 -> no-               | SizeUniv <- s2 -> no-               -- If @Prop@ is not used, then @s2@ must be of the form-               -- @Set l2@-               | not propEnabled -> do-                   l2 <- case subLevel 1 l1 of-                     Just l2 -> return l2-                     Nothing -> do-                       l2 <- newLevelMeta-                       equalLevel l1 (levelSuc l2)-                       return l2-                   equalSort (Type l2) s2-               -- Otherwise we postpone-               | otherwise -> synEq (Type l1) (UnivSort s2)-          -- @Setωᵢ@ is a successor sort if n > 0, or if-          -- --type-in-type or --omega-in-omega is enabled.-          Inf f n | n > 0 -> equalSort (Inf f $ n - 1) s2-          Inf f 0 -> do-            infInInf <- (optOmegaInOmega <$> pragmaOptions) `or2M` typeInType-            if | infInInf  -> equalSort (Inf f 0) s2-               | otherwise -> no-          -- @Prop l@ and @SizeUniv@ are not successor sorts-          Prop{}     -> no-          SizeUniv{} -> no-          -- Anything else: postpone-          _          -> synEq s1 (UnivSort s2)---      -- Equate a sort @s@ to @piSort a s1 s2@-      -- Precondition: @s@ and @piSort a s1 s2@ are already reduced.-      piSortEquals :: Sort -> Dom Term -> Sort -> Abs Sort -> m ()-      piSortEquals s a s1 NoAbs{} = __IMPOSSIBLE__-      piSortEquals s a s1 s2Abs@(Abs x s2) = do-        let adom = El s1 <$> a-        reportSDoc "tc.conv.sort" 35 $ vcat-          [ "piSortEquals"-          , "  s  =" <+> prettyTCM s-          , "  a  =" <+> prettyTCM adom-          , "  s1 =" <+> prettyTCM s1-          , "  s2 =" <+> addContext (x,adom) (prettyTCM s2)-          ]-        propEnabled <- isPropEnabled-           -- If @s2@ is dependent, then @piSort a s1 s2@ computes to-           -- @Setωi@. Hence, if @s@ is small, then @s2@-           -- cannot be dependent.-        if | Just (True,_) <- isSmallSort s -> do-               -- We force @s2@ to be non-dependent by unifying it with-               -- a fresh meta that does not depend on @x : a@-               s2' <- newSortMeta-               addContext (x , adom) $ equalSort s2 (raise 1 s2')-               funSortEquals s s1 s2'-           -- Otherwise: postpone-           | otherwise                  -> synEq (PiSort a s1 s2Abs) s--      -- Equate a sort @s@ to @funSort s1 s2@-      -- Precondition: @s@ and @funSort s1 s2@ are already reduced-      funSortEquals :: Sort -> Sort -> Sort -> m ()-      funSortEquals s0 s1 s2 = do-        reportSDoc "tc.conv.sort" 35 $ vcat-          [ "funSortEquals"-          , "  s0 =" <+> prettyTCM s0-          , "  s1 =" <+> prettyTCM s1-          , "  s2 =" <+> prettyTCM s2-          ]-        propEnabled <- isPropEnabled-        sizedTypesEnabled <- sizedTypesOption-        case s0 of-          -- If @Setωᵢ == funSort s1 s2@, then either @s1@ or @s2@ must-          -- be @Setωᵢ@.-          Inf f n | Just (True,_) <- isSmallSort s1, Just (True,_) <- isSmallSort s2 -> do-                    typeError $ UnequalSorts s0 (FunSort s1 s2)-                  | Just (True, IsFibrant) <- isSmallSort s1 -> equalSort (Inf f n) s2-                  | Just (True, IsFibrant) <- isSmallSort s2 -> equalSort (Inf f n) s1-                  -- TODO 2ltt: handle IsStrict cases.-                  | otherwise                   -> synEq s0 (FunSort s1 s2)-          -- If @Set l == funSort s1 s2@, then @s2@ must be of the-          -- form @Set l2@. @s1@ can be one of @Set l1@, @Prop l1@, or-          -- @SizeUniv@.-          Type l -> do-            l2 <- forceType s2-            -- We must have @l2 =< l@, this might help us to solve-            -- more constraints (in particular when @l == 0@).-            leqLevel l2 l-            -- Jesper, 2019-12-27: SizeUniv is disabled at the moment.-            if | {- sizedTypesEnabled || -} propEnabled -> case funSort' s1 (Type l2) of-                   -- If the work we did makes the @funSort@ compute,-                   -- continue working.-                   Just s  -> equalSort (Type l) s-                   -- Otherwise: postpone-                   Nothing -> synEq (Type l) (FunSort s1 $ Type l2)-               -- If both Prop and sized types are disabled, only the-               -- case @s1 == Set l1@ remains.-               | otherwise -> do-                   l1 <- forceType s1-                   equalLevel l (levelLub l1 l2)-          -- If @Prop l == funSort s1 s2@, then @s2@ must be of the-          -- form @Prop l2@, and @s1@ can be one of @Set l1@, Prop-          -- l1@, or @SizeUniv@.-          Prop l -> do-            l2 <- forceProp s2-            leqLevel l2 l-            case funSort' s1 (Prop l2) of-                   -- If the work we did makes the @funSort@ compute,-                   -- continue working.-                   Just s  -> equalSort (Prop l) s-                   -- Otherwise: postpone-                   Nothing -> synEq (Prop l) (FunSort s1 $ Prop l2)-          -- We have @SizeUniv == funSort s1 s2@ iff @s2 == SizeUniv@-          SizeUniv -> equalSort SizeUniv s2-          -- Anything else: postpone-          _        -> synEq s0 (FunSort s1 s2)--      -- check if the given sort @s0@ is a (closed) bottom sort-      -- i.e. @piSort a b == s0@ implies @b == s0@.-      isBottomSort :: Bool -> Sort -> Bool-      isBottomSort propEnabled (Prop (ClosedLevel 0)) = True-      isBottomSort propEnabled (Type (ClosedLevel 0)) = not propEnabled-      isBottomSort propEnabled _                      = False-      -- (NB: Defined but not currently used)--      forceType :: Sort -> m Level-      forceType (Type l) = return l-      forceType s = do-        l <- newLevelMeta-        equalSort s (Type l)-        return l--      forceProp :: Sort -> m Level-      forceProp (Prop l) = return l-      forceProp s = do-        l <- newLevelMeta-        equalSort s (Prop l)-        return l--      impossibleSort s = do-        reportS "impossible" 10-          [ "equalSort: found dummy sort with description:"-          , s-          ]-        __IMPOSSIBLE__--      catchInequalLevel m fail = m `catchError` \case-        TypeError{} -> fail-        err         -> throwError err----- -- This should probably represent face maps with a more precise type--- toFaceMaps :: Term -> TCM [[(Int,Term)]]--- toFaceMaps t = do---   view <- intervalView'---   iz <- primIZero---   io <- primIOne---   ineg <- (\ q t -> Def q [Apply $ Arg defaultArgInfo t]) <$> fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' "primINeg"----   let f IZero = mzero---       f IOne  = return []---       f (IMin x y) = do xs <- (f . view . unArg) x; ys <- (f . view . unArg) y; return (xs ++ ys)---       f (IMax x y) = msum $ map (f . view . unArg) [x,y]---       f (INeg x)   = map (id -*- not) <$> (f . view . unArg) x---       f (OTerm (Var i [])) = return [(i,True)]---       f (OTerm _) = return [] -- what about metas? we should suspend? maybe no metas is a precondition?---       isConsistent xs = all (\ xs -> length xs == 1) . map nub . Map.elems $ xs  -- optimize by not doing generate + filter---       as = map (map (id -*- head) . Map.toAscList) . filter isConsistent . map (Map.fromListWith (++) . map (id -*- (:[]))) $ (f (view t))---   xs <- mapM (mapM (\ (i,b) -> (,) i <$> intervalUnview (if b then IOne else IZero))) as---   return xs--forallFaceMaps :: MonadConversion m => Term -> (Map.Map Int Bool -> Blocker -> Term -> m a) -> (Substitution -> m a) -> m [a]-forallFaceMaps t kb k = do-  reportSDoc "conv.forall" 20 $-      fsep ["forallFaceMaps"-           , prettyTCM t-           ]-  as <- decomposeInterval t-  boolToI <- do-    io <- primIOne-    iz <- primIZero-    return (\b -> if b then io else iz)-  forM as $ \ (ms,ts) -> do-   ifBlockeds ts (kb ms) $ \ _ _ -> do-    let xs = map (second boolToI) $ Map.toAscList ms-    cxt <- getContext-    reportSDoc "conv.forall" 20 $-      fsep ["substContextN"-           , prettyTCM cxt-           , prettyTCM xs-           ]-    (cxt',sigma) <- substContextN cxt xs-    resolved <- forM xs (\ (i,t) -> (,) <$> lookupBV i <*> return (applySubst sigma t))-    updateContext sigma (const cxt') $-      addBindings resolved $ do-        cl <- buildClosure ()-        tel <- getContextTelescope-        m <- currentModule-        sub <- getModuleParameterSub m-        reportS "conv.forall" 10-          [ replicate 10 '-'-          , show (envCurrentModule $ clEnv cl)-          , show (envLetBindings $ clEnv cl)-          , show tel -- (toTelescope $ envContext $ clEnv cl)-          , show sigma-          , show m-          , show sub-          ]-        k sigma-  where-    -- TODO Andrea: inefficient because we try to reduce the ts which we know are in whnf-    ifBlockeds ts blocked unblocked = do-      and <- getPrimitiveTerm "primIMin"-      io  <- primIOne-      let t = foldr (\ x r -> and `apply` [argN x,argN r]) io ts-      ifBlocked t blocked unblocked-    addBindings [] m = m-    addBindings ((Dom{domInfo = info,unDom = (nm,ty)},t):bs) m = addLetBinding info nm t ty (addBindings bs m)--    substContextN :: MonadConversion m => Context -> [(Int,Term)] -> m (Context , Substitution)-    substContextN c [] = return (c, idS)-    substContextN c ((i,t):xs) = do-      (c', sigma) <- substContext i t c-      (c'', sigma')  <- substContextN c' (map (subtract 1 -*- applySubst sigma) xs)-      return (c'', applySubst sigma' sigma)---    -- assumes the term can be typed in the shorter telescope-    -- the terms we get from toFaceMaps are closed.-    substContext :: MonadConversion m => Int -> Term -> Context -> m (Context , Substitution)-    substContext i t [] = __IMPOSSIBLE__-    substContext i t (x:xs) | i == 0 = return $ (xs , singletonS 0 t)-    substContext i t (x:xs) | i > 0 = do-                                  reportSDoc "conv.forall" 20 $-                                    fsep ["substContext"-                                        , text (show (i-1))-                                        , prettyTCM t-                                        , prettyTCM xs-                                        ]-                                  (c,sigma) <- substContext (i-1) t xs-                                  let e = applySubst sigma x-                                  return (e:c, liftS 1 sigma)-    substContext i t (x:xs) = __IMPOSSIBLE__--compareInterval :: MonadConversion m => Comparison -> Type -> Term -> Term -> m ()-compareInterval cmp i t u = do-  reportSDoc "tc.conv.interval" 15 $-    sep [ "{ compareInterval" <+> prettyTCM t <+> "=" <+> prettyTCM u ]-  tb <- reduceB t-  ub <- reduceB u-  let t = ignoreBlocking tb-      u = ignoreBlocking ub-  it <- decomposeInterval' t-  iu <- decomposeInterval' u-  case () of-    _ | isBlocked tb || isBlocked ub -> do-      -- in case of metas we wouldn't be able to make progress by how we deal with de morgan laws.-      -- (because the constraints generated by decomposition are sufficient but not necessary).-      -- but we could still prune/solve some metas by comparing the terms as atoms.-      -- also if blocked we won't find the terms conclusively unequal(?) so compareAtom-      -- won't report type errors when we should accept.-      interval <- primIntervalType-      compareAtom CmpEq (AsTermsOf interval) t u-    _ | otherwise -> do-      x <- leqInterval it iu-      y <- leqInterval iu it-      let final = isCanonical it && isCanonical iu-      if x && y then reportSDoc "tc.conv.interval" 15 $ "Ok! }" else-        if final then typeError $ UnequalTerms cmp t u (AsTermsOf i)-                 else do-                   reportSDoc "tc.conv.interval" 15 $ "Giving up! }"-                   patternViolation (unblockOnAnyMetaIn (t, u))- where-   isBlocked Blocked{}    = True-   isBlocked NotBlocked{} = False---type Conj = (Map.Map Int (Set.Set Bool),[Term])--isCanonical :: [Conj] -> Bool-isCanonical = all (null . snd)---- | leqInterval r q = r ≤ q in the I lattice.--- (∨ r_i) ≤ (∨ q_j)  iff  ∀ i. ∃ j. r_i ≤ q_j-leqInterval :: MonadConversion m => [Conj] -> [Conj] -> m Bool-leqInterval r q =-  and <$> forM r (\ r_i ->-   or <$> forM q (\ q_j -> leqConj r_i q_j))  -- TODO shortcut---- | leqConj r q = r ≤ q in the I lattice, when r and q are conjuctions.--- ' (∧ r_i)   ≤ (∧ q_j)               iff--- ' (∧ r_i)   ∧ (∧ q_j)   = (∧ r_i)   iff--- ' {r_i | i} ∪ {q_j | j} = {r_i | i} iff--- ' {q_j | j} ⊆ {r_i | i}-leqConj :: MonadConversion m => Conj -> Conj -> m Bool-leqConj (rs, rst) (qs, qst) = do-  if toSet qs `Set.isSubsetOf` toSet rs-    then do-      interval <--        elSSet $ fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinInterval-      -- we don't want to generate new constraints here because-      -- 1. in some situations the same constraint would get generated twice.-      -- 2. unless things are completely accepted we are going to-      --    throw patternViolation in compareInterval.-      let eqT t u = tryConversion (compareAtom CmpEq (AsTermsOf interval) t u)-      let listSubset ts us =-            and <$> forM ts (\t -> or <$> forM us (\u -> eqT t u)) -- TODO shortcut-      listSubset qst rst-    else-      return False-  where-    toSet m = Set.fromList [(i, b) | (i, bs) <- Map.toList m, b <- Set.toList bs]---- | equalTermOnFace φ A u v = _ , φ ⊢ u = v : A-equalTermOnFace :: MonadConversion m => Term -> Type -> Term -> Term -> m ()-equalTermOnFace = compareTermOnFace CmpEq--compareTermOnFace :: MonadConversion m => Comparison -> Term -> Type -> Term -> Term -> m ()-compareTermOnFace = compareTermOnFace' compareTerm--compareTermOnFace' :: MonadConversion m => (Comparison -> Type -> Term -> Term -> m ()) -> Comparison -> Term -> Type -> Term -> Term -> m ()-compareTermOnFace' k cmp phi ty u v = do-  reportSDoc "tc.conv.face" 40 $-    text "compareTermOnFace:" <+> pretty phi <+> "|-" <+> pretty u <+> "==" <+> pretty v <+> ":" <+> pretty ty--  phi <- reduce phi-  _ <- forallFaceMaps phi postponed-         $ \ alpha -> k cmp (applySubst alpha ty) (applySubst alpha u) (applySubst alpha v)-  return ()- where-  postponed ms blocker psi = do-    phi <- runNamesT [] $ do-             imin <- cl $ getPrimitiveTerm "primIMin"-             ineg <- cl $ getPrimitiveTerm "primINeg"-             psi <- open psi-             let phi = foldr (\ (i,b) r -> do i <- open (var i); pure imin <@> (if b then i else pure ineg <@> i) <@> r)-                          psi (Map.toList ms) -- TODO Andrea: make a view?+{-# LANGUAGE CPP #-}+{-# LANGUAGE NondecreasingIndentation #-}++#if __GLASGOW_HASKELL__ >= 810+{-# OPTIONS_GHC -fmax-pmcheck-models=390 #-} -- Andreas, 2023-05-12, limit determined by binary search+#endif++module Agda.TypeChecking.Conversion where++import Control.Arrow (second)+import Control.Monad.Except ( MonadError(..) )++import Data.Function (on)+import Data.Semigroup ((<>))+import Data.IntMap (IntMap)++import qualified Data.List   as List+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Set    as Set++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.Syntax.Internal.MetaVars+import Agda.Syntax.Translation.InternalToAbstract (reify)++import Agda.TypeChecking.Monad+import Agda.TypeChecking.MetaVars+import Agda.TypeChecking.MetaVars.Occurs (killArgs,PruneResult(..),rigidVarsNotContainedIn)+import Agda.TypeChecking.Names+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Substitute+import qualified Agda.TypeChecking.SyntacticEquality as SynEq+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Constraints+import Agda.TypeChecking.Conversion.Pure (pureCompareAs, runPureConversion)+import Agda.TypeChecking.Forcing (isForced, nextIsForced)+import Agda.TypeChecking.Free+import Agda.TypeChecking.Datatypes (getConType, getFullyAppliedConType)+import Agda.TypeChecking.Records+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Injectivity+import Agda.TypeChecking.Polarity+import Agda.TypeChecking.SizedTypes+import Agda.TypeChecking.Level+import Agda.TypeChecking.Implicit (implicitArgs)+import Agda.TypeChecking.Irrelevance+import Agda.TypeChecking.Primitive+import Agda.TypeChecking.ProjectionLike+import Agda.TypeChecking.Warnings (MonadWarning)+import Agda.Interaction.Options++import Agda.Utils.Functor+import Agda.Utils.Lens+import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Monad+import Agda.Utils.Maybe+import Agda.Utils.Permutation+import Agda.Syntax.Common.Pretty (prettyShow)+import qualified Agda.Utils.ProfileOptions as Profile+import Agda.Utils.BoolSet (BoolSet)+import qualified Agda.Utils.BoolSet as BoolSet+import Agda.Utils.Size+import Agda.Utils.Tuple+import Agda.Utils.Unsafe ( unsafeComparePointers )++import Agda.Utils.Impossible++type MonadConversion m =+  ( PureTCM m+  , MonadConstraint m+  , MonadMetaSolver m+  , MonadError TCErr m+  , MonadWarning m+  , MonadStatistics m+  , MonadFresh ProblemId m+  , MonadFresh Int m+  )++-- | Try whether a computation runs without errors or new constraints+--   (may create new metas, though).+--   Restores state upon failure.+tryConversion+  :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m)+  => m () -> m Bool+tryConversion = isJust <.> tryConversion'++-- | Try whether a computation runs without errors or new constraints+--   (may create new metas, though).+--   Return 'Just' the result upon success.+--   Return 'Nothing' and restore state upon failure.+tryConversion'+  :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m)+  => m a -> m (Maybe a)+tryConversion' m = tryMaybe $ noConstraints m++-- | Check if to lists of arguments are the same (and all variables).+--   Precondition: the lists have the same length.+sameVars :: Elims -> Elims -> Bool+sameVars xs ys = and $ zipWith same xs ys+    where+        same (Apply (Arg _ (Var n []))) (Apply (Arg _ (Var m []))) = n == m+        same _ _ = False++-- | @intersectVars us vs@ checks whether all relevant elements in @us@ and @vs@+--   are variables, and if yes, returns a prune list which says @True@ for+--   arguments which are different and can be pruned.+intersectVars :: Elims -> Elims -> Maybe [Bool]+intersectVars = zipWithM areVars where+    -- ignore irrelevant args+    areVars (Apply u) v | isIrrelevant u = Just False -- do not prune+    areVars (Apply (Arg _ (Var n []))) (Apply (Arg _ (Var m []))) = Just $ n /= m -- prune different vars+    areVars _ _                                   = Nothing++-- | @guardPointerEquality x y s m@ behaves as @m@ if @x@ and @y@ are equal as pointers,+-- or does nothing otherwise.+-- Use with care, see the documentation for 'unsafeComparePointers'+guardPointerEquality :: MonadConversion m => a -> a -> String -> m () -> m ()+guardPointerEquality u v profileSection action =+  if unsafeComparePointers u v+  then whenProfile Profile.Conversion $ tick profileSection+  else action++{-# SPECIALIZE equalTerm :: Type -> Term -> Term -> TCM () #-}+equalTerm :: MonadConversion m => Type -> Term -> Term -> m ()+equalTerm = compareTerm CmpEq++{-# SPECIALIZE equalAtom :: CompareAs -> Term -> Term -> TCM () #-}+equalAtom :: MonadConversion m => CompareAs -> Term -> Term -> m ()+equalAtom = compareAtom CmpEq++{-# SPECIALIZE equalType :: Type -> Type -> TCM () #-}+equalType :: MonadConversion m => Type -> Type -> m ()+equalType = compareType CmpEq++{- Comparing in irrelevant context always succeeds.++   However, we might want to dig for solutions of irrelevant metas.++   To this end, we can just ignore errors during conversion checking.+ -}++-- convError ::  MonadTCM tcm => TypeError -> tcm a+-- | Ignore errors in irrelevant context.+convError :: TypeError -> TCM ()+convError err =+  ifM (isIrrelevant <$> viewTC eRelevance)+    (return ())+    (typeError err)+++-- | Type directed equality on values.+--+compareTerm :: forall m. MonadConversion m => Comparison -> Type -> Term -> Term -> m ()+compareTerm cmp a u v = compareAs cmp (AsTermsOf a) u v+++{-# SPECIALIZE compareAs :: Comparison -> CompareAs -> Term -> Term -> TCM ()  #-}+-- | Type directed equality on terms or types.+compareAs :: forall m. MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m ()+  -- If one term is a meta, try to instantiate right away. This avoids unnecessary unfolding.+  -- Andreas, 2012-02-14: This is UNSOUND for subtyping!+compareAs cmp a u v = do+  reportSDoc "tc.conv.term" 20 $ sep $+    [ "compareTerm"+    , nest 2 $ prettyTCM u <+> prettyTCM cmp <+> prettyTCM v+    , nest 2 $ prettyTCM a+    ]+  whenProfile Profile.Conversion $ tick "compare"++  -- OLD CODE, traverses the *full* terms u v at each step, even if they+  -- are different somewhere.  Leads to infeasibility in issue 854.+  -- (u, v) <- instantiateFull (u, v)+  -- let equal = u == v++  -- Check syntactic equality. This actually saves us quite a bit of work.+  guardPointerEquality u v "pointer equality: terms" $ SynEq.checkSyntacticEquality u v+    (\_ _ -> whenProfile Profile.Conversion $ tick "compare equal") $+    \u v -> do+      reportSDoc "tc.conv.term" 15 $ sep $+        [ "compareTerm (not syntactically equal)"+        , nest 2 $ prettyTCM u <+> prettyTCM cmp <+> prettyTCM v+        , nest 2 $ prettyTCM a+        ]+      -- If we are at type Size, we cannot short-cut comparison+      -- against metas by assignment.+      -- Andreas, 2014-04-12: this looks incomplete.+      -- It seems to assume we are never comparing+      -- at function types into Size.+      let fallback = compareAs' cmp a u v+          unlessSubtyping :: m () -> m ()+          unlessSubtyping cont =+              if cmp == CmpEq then cont else do+                -- Andreas, 2014-04-12 do not short cut if type is blocked.+                ifBlocked a (\ _ _ -> fallback) {-else-} $ \ _ a -> do+                  -- do not short circuit size comparison!+                  caseMaybeM (isSizeType a) cont (\ _ -> fallback)++          dir = fromCmp cmp+          rid = flipCmp dir     -- The reverse direction.  Bad name, I know.+      case (u, v) of+        (MetaV x us, MetaV y vs)+          | x /= y    -> unlessSubtyping $ solve1 `orelse` solve2 `orelse` fallback+          | otherwise -> fallback+          where+            (solve1, solve2) | x > y     = (assign dir x us v, assign rid y vs u)+                             | otherwise = (assign rid y vs u, assign dir x us v)+        (MetaV x us, _) -> unlessSubtyping $ assign dir x us v `orelse` fallback+        (_, MetaV y vs) -> unlessSubtyping $ assign rid y vs u `orelse` fallback+        (Def f es, Def f' es') | f == f' -> do+          def <- getConstInfo f+          opts <- pragmaOptions+          let shortcut = case theDef def of+                _ | optFirstOrder opts                       -> True+                d@Function{}+                  | not $ optRequireUniqueMetaSolutions opts -> d ^. funFirstOrder+                _                                            -> False+          if not shortcut then fallback else unlessSubtyping $ do+          -- We do not shortcut projection-likes,+          -- Andreas, 2022-03-07, issue #5809:+          -- but irrelevant projections since they are applied to their parameters.+          -- Amy, 2023-01-04, issue #6415: and not+          -- prim^unglue/prim^unglueU either! removing the unglue from a+          -- transport/hcomp may cause an infinite loop.+          cubicalProjs <- traverse getName' [builtin_unglue, builtin_unglueU]+          let+            notFirstOrder = isJust (isRelevantProjection_ def)+                         || (Just f) `elem` cubicalProjs+          if notFirstOrder then fallback else do+          pol <- getPolarity' cmp f+          whenProfile Profile.Conversion $ tick "compare first-order shortcut"+          compareElims pol [] (defType def) (Def f []) es es' `orelse` fallback+        _               -> fallback+  where+    assign :: CompareDirection -> MetaId -> Elims -> Term -> m ()+    assign dir x es v = do+      -- Andreas, 2013-10-19 can only solve if no projections+      reportSDoc "tc.conv.term.shortcut" 20 $ sep+        [ "attempting shortcut"+        , nest 2 $ prettyTCM (MetaV x es) <+> ":=" <+> prettyTCM v+        ]+      whenM (isInstantiatedMeta x) (patternViolation alwaysUnblock) -- Already instantiated, retry right away+      whenProfile Profile.Conversion $ tick "compare meta shortcut"+      assignE dir x es v a $ compareAsDir dir a+      reportSDoc "tc.conv.term.shortcut" 50 $+        "shortcut successful" $$ nest 2 ("result:" <+> (pretty =<< instantiate (MetaV x es)))+      whenProfile Profile.Conversion $ tick "compare meta shortcut successful"+    -- Should be ok with catchError_ but catchError is much safer since we don't+    -- rethrow errors.+    orelse :: m () -> m () -> m ()+    orelse m h = catchError m (\_ -> h)++-- | Try to assign meta.  If meta is projected, try to eta-expand+--   and run conversion check again.+assignE :: (MonadConversion m)+        => CompareDirection -> MetaId -> Elims -> Term -> CompareAs -> (Term -> Term -> m ()) -> m ()+assignE dir x es v a comp = do+  whenProfile Profile.Conversion $ tick "compare meta"+  case allApplyElims es of+    Just vs -> assignV dir x vs v a+    Nothing -> do+      reportSDoc "tc.conv.assign" 30 $ sep+        [ "assigning to projected meta "+        , prettyTCM x <+> sep (map prettyTCM es) <+> text (":" ++ show dir) <+> prettyTCM v+        ]+      etaExpandMeta [Records] x+      res <- isInstantiatedMeta' x+      case res of+        Just u  -> do+          reportSDoc "tc.conv.assign" 30 $ sep+            [ "seems like eta expansion instantiated meta "+            , prettyTCM x <+> text  (":" ++ show dir) <+> prettyTCM u+            ]+          let w = u `applyE` es+          comp w v+        Nothing ->  do+          reportSLn "tc.conv.assign" 30 "eta expansion did not instantiate meta"+          patternViolation $ unblockOnMeta x -- nothing happened, give up++compareAsDir :: MonadConversion m => CompareDirection -> CompareAs -> Term -> Term -> m ()+compareAsDir dir a = dirToCmp (`compareAs'` a) dir++compareAs' :: forall m. MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m ()+compareAs' cmp tt m n = case tt of+  AsTermsOf a -> compareTerm' cmp a m n+  AsSizes     -> compareSizes cmp m n+  AsTypes     -> compareAtom cmp AsTypes m n++compareTerm' :: forall m. MonadConversion m => Comparison -> Type -> Term -> Term -> m ()+compareTerm' cmp a m n =+  verboseBracket "tc.conv.term" 20 "compareTerm" $ do+  (ba, a') <- reduceWithBlocker a+  (catchConstraint (ValueCmp cmp (AsTermsOf a') m n) :: m () -> m ()) $ blockOnError ba $ do+    reportSDoc "tc.conv.term" 30 $ fsep+      [ "compareTerm", prettyTCM m, prettyTCM cmp, prettyTCM n, ":", prettyTCM a' ]+    propIrr  <- isPropEnabled+    isSize   <- isJust <$> isSizeType a'+    (bs, s)  <- reduceWithBlocker $ getSort a'+    mlvl     <- getBuiltin' builtinLevel+    reportSDoc "tc.conv.term" 40 $ fsep+      [ "compareTerm", prettyTCM m, prettyTCM cmp, prettyTCM n, ":", prettyTCM a'+      , "at sort", prettyTCM s]+    reportSDoc "tc.conv.level" 60 $ nest 2 $ sep+      [ "a'   =" <+> pretty a'+      , "mlvl =" <+> pretty mlvl+      , text $ "(Just (unEl a') == mlvl) = " ++ show (Just (unEl a') == mlvl)+      ]+    blockOnError bs+      case unEl a' of+        _ | propIrr+          , isProp s  -> compareIrrelevant a' m n+        _ | isSize    -> compareSizes cmp m n+        a | Just a == mlvl -> do+          a <- levelView m+          b <- levelView n+          equalLevel a b+        a@Pi{}    -> equalFun s a m n+        Lam _ _   -> do+          reportSDoc "tc.conv.term.sort" 10 $ fsep+            [ "compareTerm", prettyTCM m, prettyTCM cmp, prettyTCM n, ":", prettyTCM a'+            , "at sort", prettyTCM s+            ]+          __IMPOSSIBLE__+        Def r es  -> do+          isrec <- isEtaRecord r+          if isrec+            then do+              whenProfile Profile.Conversion $ tick "compare at eta record"+              sig <- getSignature++              transp <- getPrimitiveName' builtinTrans+              hcomp <- getPrimitiveName' builtinHComp++              let+                ps = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+                -- Andreas, 2010-10-11: allowing neutrals to be blocked things does not seem+                -- to change Agda's behavior+                --    isNeutral Blocked{}          = False+                isNeutral (NotBlocked _ Con{}) = return False++                -- Andreas, 2013-09-18 / 2015-06-29: a Def by copatterns is+                -- not neutral if it is blocked (there can be missing projections+                -- to trigger a reduction.+                isNeutral (NotBlocked r (Def q _)) = do    -- Andreas, 2014-12-06 optimize this using r !!+                  not <$> usesCopatterns q -- a def by copattern can reduce if projected+                isNeutral _                   = return True++                -- Amy, 2024-01-29: Is this blocked application headed by one of the+                -- cubical primitives that behave as though they are copattern matching?+                isCubicalPrimHead (NotBlocked r (Def q _)) -- Amy, 2024-01-29: optimise this using r !!+                  | Just q == transp || Just q == hcomp+                  = Just q+                isCubicalPrimHead _ = Nothing++                isMeta b = case ignoreBlocking b of+                  MetaV{} -> True+                  _       -> False++              reportSDoc "tc.conv.term" 30 $ prettyTCM a <+> "is eta record type"+              m <- reduceB m+              mNeutral <- isNeutral m+              n <- reduceB n+              nNeutral <- isNeutral n++              let+                h1 = isCubicalPrimHead m+                h2 = isCubicalPrimHead n++                mCub = isJust (isCubicalPrimHead m)+                nCub = isJust (isCubicalPrimHead n)++              when (mCub || nCub) $+                reportSDoc "tc.conv.term.cubical" 30 $ vcat+                  [ ("m (" <> prettyTCM mNeutral <> ", " <> prettyTCM mCub <> ", " <> prettyTCM h1 <> "):")+                  , nest 2 (prettyTCM m)+                  , ("n (" <> prettyTCM nNeutral <> ", " <> prettyTCM nCub <> ", " <> prettyTCM h2 <> "):")+                  , nest 2 (prettyTCM n)+                  , "at type"+                  , nest 2 (prettyTCM a')+                  , "same head:" <+> prettyTCM (h1 == h2)+                  ]++              if | isMeta m || isMeta n -> do+                     whenProfile Profile.Conversion $ tick "compare at eta-record: meta"+                     compareAtom cmp (AsTermsOf a') (ignoreBlocking m) (ignoreBlocking n)++                 -- Amy, 2024-01-29 (fixing issue pointed out by Tom Jack):+                 --+                 -- Cubical primitives reduce to something awful, so we would like to skip comparing them (causes+                 -- "timeout" in GroupPath).+                 --+                 -- We would also like to skip comparing a cubical primitive against something that is *small* and+                 -- actually neutral (causes "timeout" in KleinBottle cohomology groups, comparing a 93KiB(!) transport+                 -- against an application of set-truncation recursion to a metavariable)+                 --+                 -- The condition for skipping eta expansion is thus:+                 --   (a) both are neutrals (which in this case also includes a "suspended"/copattern transp/hcomp)+                 --   (b) if both are headed by a cubical primitive, then they are the same primitive.+                 --+                 -- So we will skip expanding transp A φ u0 = transp A' φ' u0', since it's definitionally injective; We+                 -- will skip expanding transp A φ u0 = f ?, since it's wasted work; but we will not skip+                 -- transp A φ u0 = hcomp u u0', since those must both compute if they are to be equal.+                 | mNeutral && nNeutral && (not (mCub && nCub) || h1 == h2) -> do+                     whenProfile Profile.Conversion $ tick "compare at eta-record: both neutral"+                     -- Andreas 2011-03-23: (fixing issue 396)+                     -- if we are dealing with a singleton record,+                     -- we can succeed immediately+                     let profUnitEta = whenProfile Profile.Conversion $ tick "compare at eta-record: both neutral at unit"+                     ifM (isSingletonRecordModuloRelevance r ps) profUnitEta $ do+                       -- do not eta-expand if comparing two neutrals+                       compareAtom cmp (AsTermsOf a') (ignoreBlocking m) (ignoreBlocking n)++                 | otherwise -> do+                     whenProfile Profile.Conversion $ tick "compare at eta-record: eta-expanding"+                     (tel, m') <- etaExpandRecord r ps $ ignoreBlocking m+                     (_  , n') <- etaExpandRecord r ps $ ignoreBlocking n+                     -- No subtyping on record terms+                     c <- getRecordConstructor r+                     -- Record constructors are covariant (see test/succeed/CovariantConstructors).+                     compareArgs (repeat $ polFromCmp cmp) [] (telePi_ tel __DUMMY_TYPE__) (Con c ConOSystem []) m' n'++            else (do pathview <- pathView a'+                     equalPath pathview a' m n)+        _ -> compareAtom cmp (AsTermsOf a') m n+  where+    -- equality at function type (accounts for eta)+    equalFun :: (MonadConversion m) => Sort -> Term -> Term -> Term -> m ()+    equalFun s a@(Pi dom b) m n | domIsFinite dom = do+       mp <- fmap getPrimName <$> getBuiltin' builtinIsOne+       let asFn = El s (Pi (dom { domIsFinite = False }) b)+       case unEl $ unDom dom of+          Def q [Apply phi]+              | Just q == mp -> compareTermOnFace cmp (unArg phi) asFn m n+          _                  -> equalFun s (unEl asFn) m n++    equalFun _ (Pi dom@Dom{domInfo = info} b) m n = do+        whenProfile Profile.Conversion $ tick "compare at function type"+        let name = suggests [ Suggestion b , Suggestion m , Suggestion n ]+        addContext (name, dom) $ compareTerm cmp (absBody b) m' n'+      where+        (m',n') = raise 1 (m,n) `apply` [Arg info $ var 0]++    equalFun _ _ _ _ = __IMPOSSIBLE__++    equalPath :: (MonadConversion m) => PathView -> Type -> Term -> Term -> m ()+    equalPath (PathType s _ l a x y) _ m n = do+        whenProfile Profile.Conversion $ tick "compare at path type"+        let name = "i" :: String+        interval <- el primInterval+        let (m',n') = raise 1 (m, n) `applyE` [IApply (raise 1 $ unArg x) (raise 1 $ unArg y) (var 0)]+        addContext (name, defaultDom interval) $ compareTerm cmp (El (raise 1 s) $ raise 1 (unArg a) `apply` [argN $ var 0]) m' n'+    equalPath OType{} a' m n = cmpDef a' m n++    cmpDef a'@(El s ty) m n = do+       mI     <- getBuiltinName'   builtinInterval+       mIsOne <- getBuiltinName'   builtinIsOne+       mGlue  <- getPrimitiveName' builtinGlue+       mHComp <- getPrimitiveName' builtinHComp+       mSub   <- getBuiltinName' builtinSub+       mUnglueU <- getPrimitiveTerm' builtin_unglueU+       mSubIn   <- getBuiltin' builtinSubIn+       case ty of+         Def q es | Just q == mIsOne -> return ()+         Def q es | Just q == mGlue, Just args@(l:_:a:phi:_) <- allApplyElims es -> do+              aty <- el' (pure $ unArg l) (pure $ unArg a)+              unglue <- prim_unglue+              let mkUnglue m = apply unglue $ map (setHiding Hidden) args ++ [argN m]+              reportSDoc "conv.glue" 20 $ prettyTCM (aty,mkUnglue m,mkUnglue n)++              -- Amy, 2023-01-04: Here and in hcompu below we *used to*+              -- also compare whatever the glued terms would evaluate to+              -- on φ. This is very loopy (consider φ = f i or φ = i0:+              -- both generate empty substitutions so get us back to+              -- exactly the same conversion problem)!+              --+              -- But is there a reason to do this comparison? The+              -- answer, it turns out, is no!+              --+              -- Suppose you had+              --    Γ ⊢ x = glue [φ → t] xb : Glue T S+              --    Γ ⊢ y = glue [φ → s] yb : Glue T S+              --    Γ ⊢ xb = yb : T+              -- Is there a need to check whether Γ φ ⊢ t = s : S? No!+              -- That's because the typing rule for glue is something like+              --   glue φ : (s : PartialP φ S) (t : T [ φ → s ]) → Glue T S+              -- where the bracket notation stands for an "implicit+              -- Sub"-type, i.e. Γ, φ ⊢ t = s (definitionally)+              --+              -- So if we have a glued element, and we have xb = yb, we+              -- can be sure that+              --   Γ , φ ⊢ t = xb = yb = s+              --+              -- But what about the general case, where we're not+              -- looking at a literal glue? Well, eta for Glue+              -- means x = glue [φ → x] (unglue x), so the logic above+              -- still applies. On φ, for the reducts to agree, it's+              -- enough for the bases to agree.++              compareTerm cmp aty (mkUnglue m) (mkUnglue n)+         Def q es | Just q == mHComp, Just (sl:s:args@[phi,u,u0]) <- allApplyElims es+                  , Sort (Type lvl) <- unArg s+                  , Just unglueU <- mUnglueU, Just subIn <- mSubIn+                  -> do+              let l = Level lvl+              ty <- el' (pure $ l) (pure $ unArg u0)+              let bA = subIn `apply` [sl,s,phi,u0]+              let mkUnglue m = apply unglueU $ [argH l] ++ map (setHiding Hidden) [phi,u]  ++ [argH bA,argN m]+              reportSDoc "conv.hcompU" 20 $ prettyTCM (ty,mkUnglue m,mkUnglue n)+              compareTerm cmp ty (mkUnglue m) (mkUnglue n)+         Def q es | Just q == mSub, Just args@(l:a:_) <- allApplyElims es -> do+              ty <- el' (pure $ unArg l) (pure $ unArg a)+              out <- primSubOut+              let mkOut m = apply out $ map (setHiding Hidden) args ++ [argN m]+              compareTerm cmp ty (mkOut m) (mkOut n)+         Def q [] | Just q == mI -> compareInterval cmp a' m n+         _ -> compareAtom cmp (AsTermsOf a') m n++compareAtomDir :: MonadConversion m => CompareDirection -> CompareAs -> Term -> Term -> m ()+compareAtomDir dir a = dirToCmp (`compareAtom` a) dir++-- | Compute the head type of an elimination. For projection-like functions+--   this requires inferring the type of the principal argument.+computeElimHeadType :: MonadConversion m => QName -> Elims -> Elims -> m Type+computeElimHeadType f [] es' = computeDefType f es'+computeElimHeadType f es _   = computeDefType f es++-- | Syntax directed equality on atomic values+--+compareAtom :: forall m. MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m ()+compareAtom cmp t m n =+  verboseBracket "tc.conv.atom" 20 "compareAtom" $+  -- if a PatternErr is thrown, rebuild constraint!+  (catchConstraint (ValueCmp cmp t m n) :: m () -> m ()) $ do+    reportSLn "tc.conv.atom.size" 50 $ "compareAtom term size:  " ++ show (termSize m, termSize n)+    reportSDoc "tc.conv.atom" 50 $+      "compareAtom" <+> fsep [ prettyTCM m <+> prettyTCM cmp+                             , prettyTCM n+                             , prettyTCM t+                             ]+    whenProfile Profile.Conversion $ tick "compare by reduction"+    -- Are we currently defining mutual functions? Which?+    currentMutuals <- maybe (pure Set.empty) (mutualNames <.> lookupMutualBlock) =<< asksTC envMutualBlock++    -- Andreas: what happens if I cut out the eta expansion here?+    -- Answer: Triggers issue 245, does not resolve 348+    (mb',nb') <- do+      mb' <- etaExpandBlocked =<< reduceB m+      nb' <- etaExpandBlocked =<< reduceB n+      return (mb', nb')+    let blocker = unblockOnEither (getBlocker mb') (getBlocker nb')+    reportSLn "tc.conv.atom.size" 50 $ "term size after reduce: " ++ show (termSize $ ignoreBlocking mb', termSize $ ignoreBlocking nb')++    -- constructorForm changes literal to constructors+    -- only needed if the other side is not a literal+    (mb'', nb'') <- case (ignoreBlocking mb', ignoreBlocking nb') of+      (Lit _, Lit _) -> return (mb', nb')+      _ -> (,) <$> traverse constructorForm mb'+               <*> traverse constructorForm nb'++    mb <- traverse unLevel mb''+    nb <- traverse unLevel nb''++    cmpBlocked <- viewTC eCompareBlocked++    let m = ignoreBlocking mb+        n = ignoreBlocking nb++        checkDefinitionalEquality = unlessM (pureCompareAs CmpEq t m n) notEqual++        notEqual = typeError $ UnequalTerms cmp m n t++        dir = fromCmp cmp+        rid = flipCmp dir     -- The reverse direction.  Bad name, I know.++        assign dir x es v = assignE dir x es v t $ compareAsDir dir t++    reportSDoc "tc.conv.atom" 30 $+      "compareAtom" <+> fsep [ prettyTCM mb <+> prettyTCM cmp+                             , prettyTCM nb+                             , prettyTCM t+                             , prettyTCM blocker+                             ]+    reportSDoc "tc.conv.atom" 80 $+      "compareAtom" <+> fsep [ pretty mb <+> prettyTCM cmp+                                  , pretty nb+                                  , ":" <+> pretty t ]+    case (mb, nb) of+      -- equate two metas x and y.  if y is the younger meta,+      -- try first y := x and then x := y+      _ | MetaV x xArgs <- ignoreBlocking mb,   -- Can be either Blocked or NotBlocked depending on+          MetaV y yArgs <- ignoreBlocking nb -> -- envCompareBlocked check above.+        compareMetas cmp t x xArgs y yArgs++      -- one side a meta+      _ | MetaV x es <- ignoreBlocking mb -> assign dir x es n+      _ | MetaV x es <- ignoreBlocking nb -> assign rid x es m+      (Blocked{}, Blocked{}) | not cmpBlocked  -> checkDefinitionalEquality+      (Blocked b _, _) | not cmpBlocked -> useInjectivity (fromCmp cmp) b t m n   -- The blocked term  goes first+      (_, Blocked b _) | not cmpBlocked -> useInjectivity (flipCmp $ fromCmp cmp) b t n m+      bs -> do+        blockOnError blocker $ do+        -- -- Andreas, 2013-10-20 put projection-like function+        -- -- into the spine, to make compareElims work.+        -- -- 'False' means: leave (Def f []) unchanged even for+        -- -- proj-like funs.+        -- m <- elimView False m+        -- n <- elimView False n+        -- Andreas, 2015-07-01, actually, don't put them into the spine.+        -- Polarity cannot be communicated properly if projection-like+        -- functions are post-fix.+        case (m, n) of+          (Pi{}, Pi{}) -> equalFun m n++          (Sort s1, Sort s2) ->+            ifM (optCumulativity <$> pragmaOptions)+              (compareSort cmp s1 s2)+              (equalSort s1 s2)++          (Lit l1, Lit l2) | l1 == l2 -> return ()+          (Var i es, Var i' es') | i == i' -> do+              a <- typeOfBV i+              -- Variables are invariant in their arguments+              compareElims [] [] a (var i) es es'++          -- The case of definition application:+          (Def f es, Def f' es') -> do++              -- 1. All absurd lambdas are equal.+              unlessM (bothAbsurd f f') $ do++              -- 2. If the heads are unequal, the only chance is subtyping between SIZE and SIZELT.+              if f /= f' then trySizeUniv cmp t m n f es f' es' else do++              -- 3. If the heads are equal:+              -- 3a. If there are no arguments, we are done.+              unless (null es && null es') $ do++              -- 3b. If some cubical magic kicks in, we are done.+              unlessM (compareEtaPrims f es es') $ do++              -- 3c. Oh no, we actually have to work and compare the eliminations!+               a <- computeElimHeadType f es es'+               -- The polarity vector of projection-like functions+               -- does not include the parameters.+               pol <- getPolarity' cmp f+               compareElims pol [] a (Def f []) es es'++          -- Due to eta-expansion, these constructors are fully applied.+          (Con x ci xArgs, Con y _ yArgs)+              | x == y -> do+                  -- Get the type of the constructor instantiated to the datatype parameters.+                  a' <- case t of+                    AsTermsOf a -> conType x a+                    AsSizes   -> __IMPOSSIBLE__+                    AsTypes   -> __IMPOSSIBLE__+                  forcedArgs <- getForcedArgs $ conName x+                  -- Constructors are covariant in their arguments+                  -- (see test/succeed/CovariantConstructors).+                  compareElims (repeat $ polFromCmp cmp) forcedArgs a' (Con x ci []) xArgs yArgs+          _ -> notEqual+    where+        -- returns True in case we handled the comparison already.+        compareEtaPrims :: MonadConversion m => QName -> Elims -> Elims -> m Bool+        compareEtaPrims q es es' = do+          munglue <- getPrimitiveName' builtin_unglue+          munglueU <- getPrimitiveName' builtin_unglueU+          msubout <- getPrimitiveName' builtinSubOut+          case () of+            _ | Just q == munglue -> compareUnglueApp q es es'+            _ | Just q == munglueU -> compareUnglueUApp q es es'+            _ | Just q == msubout -> compareSubApp q es es'+            _                     -> return False+        compareSubApp q es es' = do+          let (as,bs) = splitAt 5 es; (as',bs') = splitAt 5 es'+          case (allApplyElims as, allApplyElims as') of+            (Just [a,bA,phi,u,x], Just [a',bA',phi',u',x']) -> do+              tSub <- primSub+              -- Andrea, 28-07-16:+              -- comparing the types is most probably wasteful,+              -- since b and b' should be neutral terms, but it's a+              -- precondition for the compareAtom call to make+              -- sense.+              equalType (El (tmSSort $ unArg a) $ apply tSub $ a : map (setHiding NotHidden) [bA,phi,u])+                        (El (tmSSort $ unArg a) $ apply tSub $ a : map (setHiding NotHidden) [bA',phi',u'])+              compareAtom cmp (AsTermsOf $ El (tmSSort $ unArg a) $ apply tSub $ a : map (setHiding NotHidden) [bA,phi,u])+                              (unArg x) (unArg x')+              compareElims [] [] (El (tmSort (unArg a)) (unArg bA)) (Def q as) bs bs'+              return True+            _  -> return False+        compareUnglueApp q es es' = do+          let (as,bs) = splitAt 7 es; (as',bs') = splitAt 7 es'+          case (allApplyElims as, allApplyElims as') of+            (Just [la,lb,bA,phi,bT,e,b], Just [la',lb',bA',phi',bT',e',b']) -> do+              tGlue <- getPrimitiveTerm builtinGlue+              -- Andrea, 28-07-16:+              -- comparing the types is most probably wasteful,+              -- since b and b' should be neutral terms, but it's a+              -- precondition for the compareAtom call to make+              -- sense.+              -- equalType (El (tmSort (unArg lb)) $ apply tGlue $ [la,lb] ++ map (setHiding NotHidden) [bA,phi,bT,e])+              --           (El (tmSort (unArg lb')) $ apply tGlue $ [la',lb'] ++ map (setHiding NotHidden) [bA',phi',bT',e'])+              compareAtom cmp (AsTermsOf $ El (tmSort (unArg lb)) $ apply tGlue $ [la,lb] ++ map (setHiding NotHidden) [bA,phi,bT,e])+                              (unArg b) (unArg b')+              compareElims [] [] (El (tmSort (unArg la)) (unArg bA)) (Def q as) bs bs'+              return True+            _  -> return False+        compareUnglueUApp :: MonadConversion m => QName -> Elims -> Elims -> m Bool+        compareUnglueUApp q es es' = do+          let (as,bs) = splitAt 5 es; (as',bs') = splitAt 5 es'+          case (allApplyElims as, allApplyElims as') of+            (Just [la,phi,bT,bAS,b], Just [la',phi',bT',bA',b']) -> do+              tHComp <- primHComp+              tLSuc <- primLevelSuc+              tSubOut <- primSubOut+              iz <- primIZero+              let lsuc t = tLSuc `apply` [argN t]+                  s = tmSort $ unArg la+                  sucla = lsuc <$> la+              bA <- runNamesT [] $ do+                la  <- open . unArg $ la+                phi <- open . unArg $ phi+                bT  <- open . unArg $ bT+                bAS <- open . unArg $ bAS+                (pure tSubOut <#> (pure tLSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <#> (bT <@> primIZero) <@> bAS)+              compareAtom cmp (AsTermsOf $ El (tmSort . unArg $ sucla) $ apply tHComp $ [sucla, argH (Sort s), phi] ++ [argH (unArg bT), argH bA])+                              (unArg b) (unArg b')+              compareElims [] [] (El s bA) (Def q as) bs bs'+              return True+            _  -> return False+        -- Andreas, 2013-05-15 due to new postponement strategy, type can now be blocked+        conType c t = do+          t <- abortIfBlocked t+          let impossible = do+                reportSDoc "impossible" 10 $+                  "expected data/record type, found " <+> prettyTCM t+                reportSDoc "impossible" 70 $ nest 2 $ "raw =" <+> pretty t+                -- __IMPOSSIBLE__+                -- Andreas, 2013-10-20:  in case termination checking fails+                -- we might get some unreduced types here.+                -- In issue 921, this happens during the final attempt+                -- to solve left-over constraints.+                -- Thus, instead of crashing, just give up gracefully.+                patternViolation neverUnblock+          maybe impossible (return . snd) =<< getFullyAppliedConType c t+        equalFun t1 t2 = case (t1, t2) of+          (Pi dom1 b1, Pi dom2 b2) -> do+            verboseBracket "tc.conv.fun" 15 "compare function types" $ do+              reportSDoc "tc.conv.fun" 20 $ nest 2 $ vcat+                [ "t1 =" <+> prettyTCM t1+                , "t2 =" <+> prettyTCM t2+                ]+              compareDom cmp dom2 dom1 b1 b2 errH errR errQ errC errP errF $+                compareType cmp (absBody b1) (absBody b2)+            where+            errH = typeError $ UnequalHiding t1 t2+            errR = typeError $ UnequalRelevance cmp t1 t2+            errQ = typeError $ UnequalQuantity  cmp t1 t2+            errC = typeError $ UnequalCohesion cmp t1 t2+            errP = typeError $ UnequalPolarity cmp t1 t2+            errF = typeError $ UnequalFiniteness cmp t1 t2+          _ -> __IMPOSSIBLE__++-- | Check whether @x xArgs `cmp` y yArgs@+compareMetas :: MonadConversion m => Comparison -> CompareAs -> MetaId -> Elims -> MetaId -> Elims -> m ()+compareMetas cmp t x xArgs y yArgs | x == y = blockOnError (unblockOnMeta x) $ do+  cmpBlocked <- viewTC eCompareBlocked+  let ok    = return ()+      notOk = patternViolation neverUnblock+      fallback = do+        -- Fallback: check definitional equality+        a <- metaType x+        runPureConversion (compareElims [] [] a (MetaV x []) xArgs yArgs) >>= \case+          Just{}  -> ok+          Nothing -> notOk+  if | cmpBlocked -> do+         a <- metaType x+         compareElims [] [] a (MetaV x []) xArgs yArgs+     | otherwise -> case intersectVars xArgs yArgs of+         -- all relevant arguments are variables+         Just kills -> do+           -- kills is a list with 'True' for each different var+           killResult <- killArgs kills x+           case killResult of+             NothingToPrune   -> ok+             PrunedEverything -> ok+             PrunedNothing    -> fallback+             PrunedSomething  -> fallback+         -- not all relevant arguments are variables+         Nothing -> fallback+compareMetas cmp t x xArgs y yArgs = do+  p1 <- getMetaPriority x+  p2 <- getMetaPriority y+  let dir = fromCmp cmp+      rid = flipCmp dir     -- The reverse direction.  Bad name, I know.+      retry = patternViolation alwaysUnblock+  -- First try the one with the highest priority. If that doesn't+  -- work, try the low priority one.+  let (solve1, solve2)+        | (p1, x) > (p2, y) = (l1, r2)+        | otherwise         = (r1, l2)+        where l1 = assignE dir x xArgs (MetaV y yArgs) t $ \ _ _ -> retry+              r1 = assignE rid y yArgs (MetaV x xArgs) t $ \ _ _ -> retry+              -- Careful: the first attempt might prune the low+              -- priority meta! (Issue #2978)+              l2 = ifM (isInstantiatedMeta x) retry l1+              r2 = ifM (isInstantiatedMeta y) retry r1++  -- Unblock on both unblockers of solve1 and solve2+  catchPatternErr (`addOrUnblocker` solve2) solve1++-- | Check whether @a1 `cmp` a2@ and continue in context extended by @a1@.+compareDom :: (MonadConversion m , Free c)+  => Comparison -- ^ @cmp@ The comparison direction+  -> Dom Type   -- ^ @a1@  The smaller domain.+  -> Dom Type   -- ^ @a2@  The other domain.+  -> Abs b      -- ^ @b1@  The smaller codomain.+  -> Abs c      -- ^ @b2@  The bigger codomain.+  -> m ()     -- ^ Continuation if mismatch in 'Hiding'.+  -> m ()     -- ^ Continuation if mismatch in 'Relevance'.+  -> m ()     -- ^ Continuation if mismatch in 'Quantity'.+  -> m ()     -- ^ Continuation if mismatch in 'Cohesion'.+  -> m ()     -- ^ Continuation if mismatch in 'Polarity'.+  -> m ()     -- ^ Continuation if mismatch in 'annFinite'.+  -> m ()     -- ^ Continuation if comparison is successful.+  -> m ()+compareDom cmp0+  dom1@(Dom{domInfo = i1, unDom = a1})+  dom2@(Dom{domInfo = i2, unDom = a2})+  b1 b2 errH errR errQ errC errP errF cont = do+  if | not $ sameHiding dom1 dom2 -> errH+     | not $ (==)         (getRelevance dom1) (getRelevance dom2) -> errR+     | not $ sameQuantity (getQuantity  dom1) (getQuantity  dom2) -> errQ+     | not $ sameCohesion (getCohesion  dom1) (getCohesion  dom2) -> errC+     | not $ samePolarity (getModalPolarity dom1) (getModalPolarity dom2) -> errP+     | not $ domIsFinite dom1 == domIsFinite dom2 -> errF+     | otherwise -> do+      let r = max (getRelevance dom1) (getRelevance dom2)+              -- take "most irrelevant"+          dependent = not (isIrrelevant r) && isBinderUsed b2+      pid <- newProblem_ $ compareType cmp0 a1 a2+      dom <- if dependent+             then (\ a -> dom1 {unDom = a}) <$> blockTypeOnProblem a1 pid+             else return dom1+        -- We only need to require a1 == a2 if b2 is dependent+        -- If it's non-dependent it doesn't matter what we add to the context.+      let name = suggests [ Suggestion b1 , Suggestion b2 ]+      addContext (name, dom) $ cont+      stealConstraints pid+        -- Andreas, 2013-05-15 Now, comparison of codomains is not+        -- blocked any more by getting stuck on domains.+        -- Only the domain type in context will be blocked.+        -- But see issue #1258.++-- | When comparing argument spines (in compareElims) where the first arguments+--   don't match, we keep going, substituting the anti-unification of the two+--   terms in the telescope. More precisely:+--+--  @@+--    (u = v : A)[pid]   w = antiUnify pid A u v   us = vs : Δ[w/x]+--    -------------------------------------------------------------+--                    u us = v vs : (x : A) Δ+--  @@+--+--   The simplest case of anti-unification is to return a fresh metavariable+--   (created by blockTermOnProblem), but if there's shared structure between+--   the two terms we can expose that.+--+--   This is really a crutch that lets us get away with things that otherwise+--   would require heterogenous conversion checking. See for instance issue+--   #2384.+antiUnify :: MonadConversion m => ProblemId -> Type -> Term -> Term -> m Term+antiUnify pid a u v = do+  SynEq.checkSyntacticEquality u v (\u _ -> return u) $ \u v -> do+  (u, v) <- reduce (u, v)+  reportSDoc "tc.conv.antiUnify" 30 $ vcat+    [ "antiUnify"+    , "a =" <+> prettyTCM a+    , "u =" <+> prettyTCM u+    , "v =" <+> prettyTCM v+    ]+  case (u, v) of+    (Pi ua ub, Pi va vb) -> do+      wa0 <- antiUnifyType pid (unDom ua) (unDom va)+      let wa = wa0 <$ ua+      wb <- addContext wa $ antiUnifyType pid (absBody ub) (absBody vb)+      return $ Pi wa (mkAbs (absName ub) wb)+    (Lam i u, Lam _ v) ->+      reduce (unEl a) >>= \case+        Pi a b -> Lam i . (mkAbs (absName u)) <$> addContext a (antiUnify pid (absBody b) (absBody u) (absBody v))+        _      -> fallback+    (Var i us, Var j vs) | i == j -> maybeGiveUp $ do+      a <- typeOfBV i+      antiUnifyElims pid a (var i) us vs+    -- Andreas, 2017-07-27:+    -- It seems that nothing guarantees here that the constructors are fully+    -- applied!?  Thus, @a@ could be a function type and we need the robust+    -- @getConType@ here.+    -- (Note that @patternViolation@ swallows exceptions coming from @getConType@+    -- thus, we would not see clearly if we used @getFullyAppliedConType@ instead.)+    (Con x ci us, Con y _ vs) | x == y -> maybeGiveUp $ do+      a <- maybe abort (return . snd) =<< getConType x a+      antiUnifyElims pid a (Con x ci []) us vs+    (Def f [], Def g []) | f == g -> return (Def f [])+    (Def f us, Def g vs) | f == g, length us == length vs -> maybeGiveUp $ do+      a <- computeElimHeadType f us vs+      antiUnifyElims pid a (Def f []) us vs+    _ -> fallback+  where+    maybeGiveUp = catchPatternErr $ \ _ -> fallback+    abort = patternViolation neverUnblock -- caught by maybeGiveUp+    fallback = blockTermOnProblem a u pid++antiUnifyArgs :: MonadConversion m => ProblemId -> Dom Type -> Arg Term -> Arg Term -> m (Arg Term)+antiUnifyArgs pid dom u v+  | not (sameModality (getModality u) (getModality v))+              = patternViolation neverUnblock+  | otherwise = applyModalityToContext u $+    ifM (isIrrelevantOrPropM dom)+    {-then-} (return u)+    {-else-} ((<$ u) <$> antiUnify pid (unDom dom) (unArg u) (unArg v))++antiUnifyType :: MonadConversion m => ProblemId -> Type -> Type -> m Type+antiUnifyType pid (El s a) (El _ b) = workOnTypes $ El s <$> antiUnify pid (sort s) a b++antiUnifyElims :: MonadConversion m => ProblemId -> Type -> Term -> Elims -> Elims -> m Term+antiUnifyElims pid a self [] [] = return self+antiUnifyElims pid a self (Proj o f : es1) (Proj _ g : es2) | f == g = do+  res <- projectTyped self a o f+  case res of+    Just (_, self, a) -> antiUnifyElims pid a self es1 es2+    Nothing -> patternViolation neverUnblock -- can fail for projection like+antiUnifyElims pid a self (Apply u : es1) (Apply v : es2) = do+  reduce (unEl a) >>= \case+    Pi a b -> do+      w <- antiUnifyArgs pid a u v+      antiUnifyElims pid (b `lazyAbsApp` unArg w) (apply self [w]) es1 es2+    _ -> patternViolation neverUnblock+antiUnifyElims _ _ _ _ _ = patternViolation neverUnblock -- trigger maybeGiveUp in antiUnify++-- | @compareElims pols a v els1 els2@ performs type-directed equality on eliminator spines.+--   @t@ is the type of the head @v@.+compareElims :: forall m. MonadConversion m => [Polarity] -> [IsForced] -> Type -> Term -> [Elim] -> [Elim] -> m ()+compareElims pols0 fors0 a v els01 els02 =+  verboseBracket "tc.conv.elim" 20 "compareElims" $+  (catchConstraint (ElimCmp pols0 fors0 a v els01 els02) :: m () -> m ()) $ do+  let v1 = applyE v els01+      v2 = applyE v els02+      failure = typeError $ UnequalTerms CmpEq v1 v2 (AsTermsOf a)+        -- Andreas, 2013-03-15 since one of the spines is empty, @a@+        -- is the correct type here.+  unless (null els01) $ do+    reportSDoc "tc.conv.elim" 25 $ "compareElims" $$ do+     nest 2 $ vcat+      [ "a     =" <+> prettyTCM a+      , "pols0 (truncated to 10) =" <+> hsep (map prettyTCM $ take 10 pols0)+      , "fors0 (truncated to 10) =" <+> hsep (map prettyTCM $ take 10 fors0)+      , "v     =" <+> prettyTCM v+      , "els01 =" <+> prettyTCM els01+      , "els02 =" <+> prettyTCM els02+      ]+  case (els01, els02) of+    ([]         , []         ) -> return ()+    ([]         , Proj{}:_   ) -> failure -- not impossible, see issue 821+    (Proj{}  : _, []         ) -> failure -- could be x.p =?= x for projection p+    ([]         , Apply{} : _) -> failure -- not impossible, see issue 878+    (Apply{} : _, []         ) -> failure+    ([]         , IApply{} : _) -> failure+    (IApply{} : _, []         ) -> failure+    (Apply{} : _, Proj{}  : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True -- NB: popped up in issue 889+    (Proj{}  : _, Apply{} : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True -- but should be impossible (but again in issue 1467)+    (IApply{} : _, Proj{}  : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True+    (Proj{}  : _, IApply{} : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True+    (IApply{} : _, Apply{}  : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True+    (Apply{}  : _, IApply{} : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True+    (e@(IApply x1 y1 r1) : els1, IApply x2 y2 r2 : els2) -> do+      reportSDoc "tc.conv.elim" 25 $ "compareElims IApply"+       -- Andrea: copying stuff from the Apply case..+      let (pol, pols) = nextPolarity pols0+      a  <- abortIfBlocked a+      va <- pathView a+      reportSDoc "tc.conv.elim.iapply" 60 $ "compareElims IApply" $$ do+        nest 2 $ "va =" <+> text (show (isPathType va))+      case va of+        PathType s path l bA x y -> do+          b <- primIntervalType+          compareWithPol pol (flip compareTerm b)+                              r1 r2+          -- TODO: compare (x1,x2) and (y1,y2) ?+          let r = r1 -- TODO Andrea:  do blocking+          codom <- el' (pure . unArg $ l) ((pure . unArg $ bA) <@> pure r)+          compareElims pols [] codom -- Path non-dependent (codom `lazyAbsApp` unArg arg)+                            (applyE v [e]) els1 els2+        -- We allow for functions (i : I) -> ... to also be heads of a IApply,+        -- because @etaContract@ can produce such terms+        OType t@(El _ Pi{}) -> compareElims pols0 fors0 t v (Apply (defaultArg r1) : els1) (Apply (defaultArg r2) : els2)++        OType t -> patternViolation (unblockOnAnyMetaIn t) -- Can we get here? We know a is not blocked.++    (Apply arg1 : els1, Apply arg2 : els2) ->+      (verboseBracket "tc.conv.elim" 20 "compare Apply" :: m () -> m ()) $ do+      reportSDoc "tc.conv.elim" 10 $ nest 2 $ vcat+        [ "a    =" <+> prettyTCM a+        , "v    =" <+> prettyTCM v+        , "arg1 =" <+> prettyTCM arg1+        , "arg2 =" <+> prettyTCM arg2+        ]+      reportSDoc "tc.conv.elim" 50 $ nest 2 $ vcat+        [ "raw:"+        , "a    =" <+> pretty a+        , "v    =" <+> pretty v+        , "arg1 =" <+> pretty arg1+        , "arg2 =" <+> pretty arg2+        ]+      let (pol, pols) = nextPolarity pols0+          (for, fors) = nextIsForced fors0+      a <- abortIfBlocked a+      reportSLn "tc.conv.elim" 40 $ "type is not blocked"+      case unEl a of+        (Pi (Dom{domInfo = info, unDom = b}) codom) -> do+          reportSLn "tc.conv.elim" 40 $ "type is a function type"+          mlvl <- tryMaybe primLevel+          let freeInCoDom (Abs _ c) = 0 `freeInIgnoringSorts` c+              freeInCoDom _         = False+              dependent = (Just (unEl b) /= mlvl) && freeInCoDom codom+                -- Level-polymorphism (x : Level) -> ... does not count as dependency here+                   -- NB: we could drop the free variable test and still be sound.+                   -- It is a trade-off between the administrative effort of+                   -- creating a blocking and traversing a term for free variables.+                   -- Apparently, it is believed that checking free vars is cheaper.+                   -- Andreas, 2013-05-15++-- NEW, Andreas, 2013-05-15++          -- compare arg1 and arg2+          pid <- newProblem_ $ applyModalityToContext info $+              if isForced for then+                reportSLn "tc.conv.elim" 40 $ "argument is forced"+              else if isIrrelevant info then do+                reportSLn "tc.conv.elim" 40 $ "argument is irrelevant"+                compareIrrelevant b (unArg arg1) (unArg arg2)+              else do+                reportSLn "tc.conv.elim" 40 $ "argument has polarity " ++ show pol+                compareWithPol pol (flip compareTerm b)+                  (unArg arg1) (unArg arg2)+          -- if comparison got stuck and function type is dependent, block arg+          solved <- isProblemSolved pid+          reportSLn "tc.conv.elim" 40 $ "solved = " ++ show solved+          arg <- if dependent && not solved+                 then applyModalityToContext info $ do+                  reportSDoc "tc.conv.elims" 50 $ vcat $+                    [ "Trying antiUnify:"+                    , nest 2 $ "b    =" <+> prettyTCM b+                    , nest 2 $ "arg1 =" <+> prettyTCM arg1+                    , nest 2 $ "arg2 =" <+> prettyTCM arg2+                    ]+                  arg <- (arg1 $>) <$> antiUnify pid b (unArg arg1) (unArg arg2)+                  reportSDoc "tc.conv.elims" 50 $ hang "Anti-unification:" 2 (prettyTCM arg)+                  reportSDoc "tc.conv.elims" 70 $ nest 2 $ "raw:" <+> pretty arg+                  return arg+                 else return arg1+          -- continue, possibly with blocked instantiation+          compareElims pols fors (codom `lazyAbsApp` unArg arg) (apply v [arg]) els1 els2+          -- any left over constraints of arg are associated to the comparison+          reportSLn "tc.conv.elim" 40 $ "stealing constraints from problem " ++ show pid+          stealConstraints pid+          {- Stealing solves this issue:++             Does not create enough blocked tc-problems,+             see test/fail/DontPrune.+             (There are remaining problems which do not show up as yellow.)+             Need to find a way to associate pid also to result of compareElims.+          -}+        a -> do+          reportSDoc "impossible" 10 $+            "unexpected type when comparing apply eliminations " <+> prettyTCM a+          reportSDoc "impossible" 50 $ "raw type:" <+> pretty a+          patternViolation (unblockOnAnyMetaIn a)+          -- Andreas, 2013-10-22+          -- in case of disabled reductions (due to failing termination check)+          -- we might get stuck, so do not crash, but fail gently.+          -- __IMPOSSIBLE__++    -- case: f == f' are projections+    (Proj o f : els1, Proj _ f' : els2)+      | f /= f'   -> typeError $ MismatchedProjectionsError f f'+      | otherwise -> do+        a   <- abortIfBlocked a+        res <- projectTyped v a o f -- fails only if f is proj.like but parameters cannot be retrieved+        case res of+          Just (_, u, t) -> do+            -- Andreas, 2015-07-01:+            -- The arguments following the principal argument of a projection+            -- are invariant.  (At least as long as we have no explicit polarity+            -- annotations.)+            compareElims [] [] t u els1 els2+          Nothing -> do+            reportSDoc "tc.conv.elims" 30 $ sep+              [ text $ "projection " ++ prettyShow f+              , text   "applied to value " <+> prettyTCM v+              , text   "of unexpected type " <+> prettyTCM a+              ]+            patternViolation (unblockOnAnyMetaIn a)+++-- | "Compare" two terms in irrelevant position.  This always succeeds.+--   However, we can dig for solutions of irrelevant metas in the+--   terms we compare.+--   (Certainly not the systematic solution, that'd be proof search...)+compareIrrelevant :: MonadConversion m => Type -> Term -> Term -> m ()+{- 2012-04-02 DontCare no longer present+compareIrrelevant t (DontCare v) w = compareIrrelevant t v w+compareIrrelevant t v (DontCare w) = compareIrrelevant t v w+-}+compareIrrelevant t v0 w0 = do+  let v = stripDontCare v0+      w = stripDontCare w0+  reportSDoc "tc.conv.irr" 20 $ vcat+    [ "compareIrrelevant"+    , nest 2 $ "v =" <+> prettyTCM v+    , nest 2 $ "w =" <+> prettyTCM w+    ]+  reportSDoc "tc.conv.irr" 50 $ vcat+    [ nest 2 $ "v =" <+> pretty v+    , nest 2 $ "w =" <+> pretty w+    ]+  whenProfile Profile.Conversion $ tick "compare irrelevant"+  try v w $ try w v $ return ()+  where+    try (MetaV x es) w fallback = do+      mi <- lookupMetaInstantiation x+      mm <- lookupMetaModality x+      let rel  = getRelevance mm+          inst = case mi of+                   InstV{} -> True+                   _       -> False+      reportSDoc "tc.conv.irr" 20 $ vcat+        [ nest 2 $ text $ "rel  = " ++ show rel+        , nest 2 $ "inst =" <+> pretty inst+        ]+      if not (isIrrelevant rel) || inst+        then fallback+        -- Andreas, 2016-08-08, issue #2131:+        -- Mining for solutions for irrelevant metas is not definite.+        -- Thus, in case of error, leave meta unsolved.+        else assignE DirEq x es w (AsTermsOf t) (compareIrrelevant t) `catchError` \ _ -> fallback+        -- the value of irrelevant or unused meta does not matter+    try v w fallback = fallback++compareWithPol :: MonadConversion m => Polarity -> (Comparison -> a -> a -> m ()) -> a -> a -> m ()+compareWithPol Invariant     cmp x y = cmp CmpEq x y+compareWithPol Covariant     cmp x y = cmp CmpLeq x y+compareWithPol Contravariant cmp x y = cmp CmpLeq y x+compareWithPol Nonvariant    cmp x y = return ()++polFromCmp :: Comparison -> Polarity+polFromCmp CmpLeq = Covariant+polFromCmp CmpEq  = Invariant++-- | Type-directed equality on argument lists+--+compareArgs :: MonadConversion m => [Polarity] -> [IsForced] -> Type -> Term -> Args -> Args -> m ()+compareArgs pol for a v args1 args2 =+  compareElims pol for a v (map Apply args1) (map Apply args2)++---------------------------------------------------------------------------+-- * Types+---------------------------------------------------------------------------++{-# SPECIALIZE compareType :: Comparison -> Type -> Type -> TCM () #-}+-- | Equality on Types+compareType :: MonadConversion m => Comparison -> Type -> Type -> m ()+compareType cmp ty1@(El s1 a1) ty2@(El s2 a2) =+    workOnTypes $+    verboseBracket "tc.conv.type" 20 "compareType" $ do+        reportSDoc "tc.conv.type" 50 $ vcat+          [ "compareType" <+> sep [ prettyTCM ty1 <+> prettyTCM cmp+                                       , prettyTCM ty2 ]+          , hsep [ "   sorts:", prettyTCM s1, " and ", prettyTCM s2 ]+          ]+        compareAs cmp AsTypes a1 a2++leqType :: MonadConversion m => Type -> Type -> m ()+leqType = compareType CmpLeq++{-# SPECIALIZE coerce :: Comparison -> Term -> Type -> Type -> TCM Term #-}+-- | @coerce v a b@ coerces @v : a@ to type @b@, returning a @v' : b@+--   with maybe extra hidden applications or hidden abstractions.+--+--   In principle, this function can host coercive subtyping, but+--   currently it only tries to fix problems with hidden function types.+--+coerce :: (MonadConversion m, MonadTCM m) => Comparison -> Term -> Type -> Type -> m Term+coerce cmp v t1 t2 = blockTerm t2 $ do+  verboseS "tc.conv.coerce" 10 $ do+    (a1,a2) <- reify (t1,t2)+    let dbglvl = 30+    reportSDoc "tc.conv.coerce" dbglvl $+      "coerce" <+> vcat+        [ "term      v  =" <+> prettyTCM v+        , "from type t1 =" <+> prettyTCM a1+        , "to type   t2 =" <+> prettyTCM a2+        , "comparison   =" <+> prettyTCM cmp+        ]+    reportSDoc "tc.conv.coerce" 70 $+      "coerce" <+> vcat+        [ "term      v  =" <+> pretty v+        , "from type t1 =" <+> pretty t1+        , "to type   t2 =" <+> pretty t2+        , "comparison   =" <+> pretty cmp+        ]+  -- v <$ do workOnTypes $ leqType t1 t2+  -- take off hidden/instance domains from t1 and t2+  TelV tel1 b1 <- telViewUpTo' (-1) notVisible t1+  TelV tel2 b2 <- telViewUpTo' (-1) notVisible t2+  let n = size tel1 - size tel2+  -- the crude solution would be+  --   v' = λ {tel2} → v {tel1}+  -- however, that may introduce unneccessary many function types+  -- If n  > 0 and b2 is not blocked, it is safe to+  -- insert n many hidden args+  if n <= 0 then fallback else do+    ifBlocked b2 (\ _ _ -> fallback) $ \ _ _ -> do+      (args, t1') <- implicitArgs n notVisible t1+      let v' = v `apply` args+      v' <$ coerceSize (compareType cmp) v' t1' t2+  where+    fallback = v <$ coerceSize (compareType cmp) v t1 t2++{-# SPECIALIZE coerceSize :: (Type -> Type -> TCM ()) -> Term -> Type -> Type -> TCM () #-}+-- | Account for situations like @k : (Size< j) <= (Size< k + 1)@+--+--   Actually, the semantics is+--   @(Size<= k) ∩ (Size< j) ⊆ rhs@+--   which gives a disjunctive constraint.  Mmmh, looks like stuff+--   TODO.+--+--   For now, we do a cheap heuristics.+--+coerceSize :: MonadConversion m => (Type -> Type -> m ()) -> Term -> Type -> Type -> m ()+coerceSize leqType v t1 t2 = verboseBracket "tc.conv.size.coerce" 45 "coerceSize" $+  workOnTypes $ do+    reportSDoc "tc.conv.size.coerce" 70 $+      "coerceSize" <+> vcat+        [ "term      v  =" <+> pretty v+        , "from type t1 =" <+> pretty t1+        , "to type   t2 =" <+> pretty t2+        ]+    let fallback = leqType t1 t2+        done = caseMaybeM (isSizeType =<< reduce t1) fallback $ \ _ -> return ()+    -- Andreas, 2015-07-22, Issue 1615:+    -- If t1 is a meta and t2 a type like Size< v2, we need to make sure we do not miss+    -- the constraint v < v2!+    caseMaybeM (isSizeType =<< reduce t2) fallback $ \ b2 -> do+      -- Andreas, 2017-01-20, issue #2329:+      -- If v is not a size suitable for the solver, like a neutral term,+      -- we can only rely on the type.+      mv <- sizeMaxView v+      if any (\case{ DOtherSize{} -> True; _ -> False }) mv then fallback else do+      -- Andreas, 2015-02-11 do not instantiate metas here (triggers issue 1203).+      unlessM (tryConversion $ dontAssignMetas $ leqType t1 t2) $ do+        -- A (most probably weaker) alternative is to just check syn.eq.+        -- ifM (snd <$> checkSyntacticEquality t1 t2) (return v) $ {- else -} do+        reportSDoc "tc.conv.size.coerce" 20 $ "coercing to a size type"+        case b2 of+          -- @t2 = Size@.  We are done!+          BoundedNo -> done+          -- @t2 = Size< v2@+          BoundedLt v2 -> do+            sv2 <- sizeView v2+            case sv2 of+              SizeInf     -> done+              OtherSize{} -> do+                -- Andreas, 2014-06-16:+                -- Issue 1203: For now, just treat v < v2 as suc v <= v2+                -- TODO: Need proper < comparison+                vinc <- sizeSuc 1 v+                compareSizes CmpLeq vinc v2+                done+              -- @v2 = a2 + 1@: In this case, we can try @v <= a2@+              SizeSuc a2 -> do+                compareSizes CmpLeq v a2+                done  -- to pass Issue 1136++---------------------------------------------------------------------------+-- * Sorts and levels+---------------------------------------------------------------------------++compareLevel :: MonadConversion m => Comparison -> Level -> Level -> m ()+compareLevel CmpLeq u v = leqLevel u v+compareLevel CmpEq  u v = equalLevel u v++compareSort :: MonadConversion m => Comparison -> Sort -> Sort -> m ()+compareSort CmpEq  = equalSort+compareSort CmpLeq = leqSort++-- | Check that the first sort is less or equal to the second.+--+--   We can put @SizeUniv@ below @Inf@, but otherwise, it is+--   unrelated to the other universes.+--+leqSort :: forall m. MonadConversion m => Sort -> Sort -> m ()+leqSort s1 s2 = do+  reportSDoc "tc.conv.sort" 30 $+    sep [ "leqSort"+        , nest 2 $ fsep [ prettyTCM s1 <+> "=<"+                        , prettyTCM s2 ]+        ]+  reportSDoc "tc.conv.sort" 60 $+    sep [ "leqSort"+        , nest 2 $ fsep [ pretty s1 <+> "=<"+                        , pretty s2 ]+        ]+  whenProfile Profile.Conversion $ tick "compare sorts"++  SynEq.checkSyntacticEquality s1 s2 (\_ _ -> return ()) $ \s1 s2 -> do++    s1b <- reduceB s1+    s2b <- reduceB s2++    let (s1,s2) = (ignoreBlocking s1b , ignoreBlocking s2b)+        blocker = unblockOnEither (getBlocker s1b) (getBlocker s2b)+        postpone = patternViolation blocker++    let postponeIfBlocked = catchPatternErr $ \blocker -> do+          if | blocker == neverUnblock -> typeError $ NotLeqSort s1 s2+             | otherwise -> do+                 reportSDoc "tc.conv.sort" 30 $ vcat+                   [ "Postponing constraint"+                   , nest 2 $ fsep [ prettyTCM s1 <+> "=<"+                                   , prettyTCM s2 ]+                   ]+                 reportSDoc "tc.conv.sort" 60 $ vcat+                   [ "Postponing constraint"+                   , nest 2 $ fsep [ pretty s1 <+> "=<"+                                   , pretty s2 ]+                   ]+                 blocker <- updateBlocker blocker+                 addConstraint blocker $ SortCmp CmpLeq s1 s2++    propEnabled <- isPropEnabled+    typeInTypeEnabled <- typeInType+    omegaInOmegaEnabled <- optOmegaInOmega <$> pragmaOptions+    let infInInf = typeInTypeEnabled || omegaInOmegaEnabled++    let fvsRHS = (`IntSet.member` allFreeVars s2)+    badRigid <- s1 `rigidVarsNotContainedIn` fvsRHS++    postponeIfBlocked $ case (s1, s2) of+      -- Andreas, 2018-09-03: crash on dummy sort+      (DummyS s, _) -> impossibleSort s+      (_, DummyS s) -> impossibleSort s++      -- The most basic rule: @Set l =< Set l'@ iff @l =< l'@+      -- Likewise for @Prop@+      -- Likewise for @SSet@+      -- @Prop l@ is below @Set l@+      -- @Set l@ is below @SSet l@+      -- @Prop l@ is below @SSet l@+      (Univ u a, Univ u' b) -> if u <= u' then leqLevel a b else no++      -- @Setωᵢ@ is above all small sorts+      (Inf u m , Inf u' n) -> answer $ u <= u' && (m <= n || infInInf)+      (Univ u _, Inf u' _) -> answer $ u <= u'+      (Inf u _, Univ u' _) -> answer $ u == u' && typeInTypeEnabled++      -- @LockUniv@, @LevelUniv@, @IntervalUniv@, @SizeUniv@, and @Prop0@ are bottom sorts.+      -- So is @Set0@ if @Prop@ is not enabled.+      (_       , LockUniv) -> equalSort s1 s2+      (_       , LevelUniv) -> equalSort s1 s2+      (_       , IntervalUniv) -> equalSort s1 s2+      (_       , SizeUniv) -> equalSort s1 s2+      (_       , Prop (ClosedLevel 0)) -> equalSort s1 s2+      (_       , Type (ClosedLevel 0))+        | not propEnabled  -> equalSort s1 s2++      -- @SizeUniv@, @LockUniv@ and @LevelUniv@ are unrelated to any @Set l@ or @Prop l@+      (SizeUniv, Univ{}  ) -> no+      (SizeUniv , Inf{}  ) -> no+      (LockUniv, Univ{}  ) -> no+      (LockUniv , Inf{}  ) -> no+      (LevelUniv, Univ{}  ) -> no+      (LevelUniv , Inf{}  ) -> no++      -- @IntervalUniv@ is below @SSet l@, but not @Set l@ or @Prop l@+      (IntervalUniv, Type{}) -> no+      (IntervalUniv, Prop{}) -> no+      (IntervalUniv , Inf u _) -> answer $ univFibrancy u == IsStrict+      (IntervalUniv , SSet b) -> leqLevel (ClosedLevel 0) b++      -- If the first sort is a small sort that rigidly depends on a+      -- variable and the second sort does not mention this variable,+      -- the second sort must be at least @Setω@.+      (_       , _       ) | Right (SmallSort f) <- sizeOfSort s1 , badRigid -> leqSort (Inf f 0) s2++      -- PiSort, FunSort, UnivSort and MetaS might reduce once we instantiate+      -- more metas, so we postpone.+      (PiSort{}, _       ) -> postpone+      (_       , PiSort{}) -> postpone+      (FunSort{}, _      ) -> postpone+      (_      , FunSort{}) -> postpone+      (UnivSort{}, _     ) -> postpone+      (_     , UnivSort{}) -> postpone+      (MetaS{} , _       ) -> postpone+      (_       , MetaS{} ) -> postpone++      -- DefS are postulated sorts, so they do not reduce.+      (DefS{} , _     ) -> no+      (_      , DefS{}) -> no++  where+  no  = patternViolation neverUnblock+  yes = return ()+  answer = \case+    True -> yes+    False -> no+  impossibleSort s = do+    reportS "impossible" 10+      [ "leqSort: found dummy sort with description:"+      , s+      ]+    __IMPOSSIBLE__++leqLevel :: MonadConversion m => Level -> Level -> m ()+leqLevel a b = catchConstraint (LevelCmp CmpLeq a b) $ do+      reportSDoc "tc.conv.level" 30 $+        "compareLevel" <+>+          sep [ prettyTCM a <+> "=<"+              , prettyTCM b ]+      whenProfile Profile.Conversion $ tick "compare levels"++      (a, b) <- normalise (a, b)+      SynEq.checkSyntacticEquality' a b+        (\_ _ ->+          reportSDoc "tc.conv.level" 60+            "checkSyntacticEquality returns True") $ \a b -> do+      reportSDoc "tc.conv.level" 60+        "checkSyntacticEquality returns False"++      let notok    = unlessM typeInType $ typeError $ NotLeqSort (Type a) (Type b)+          postpone = patternViolation (unblockOnAnyMetaIn (a, b))++          wrap m = m `catchError` \case+            TypeError{} -> notok+            err         -> throwError err++      cumulativity <- optCumulativity <$> pragmaOptions+      areWeComputingOverlap <- viewTC eConflComputingOverlap+      reportSDoc "tc.conv.level" 40 $+        "compareLevelView" <+>+          sep [ prettyList_ $ fmap (pretty . unSingleLevel) $ levelMaxView a+              , "=<"+              , prettyList_ $ fmap (pretty . unSingleLevel) $ levelMaxView b+              ]++      -- Extra reduce on level atoms, but should be cheap since they are already reduced.+      aB <- mapM reduceB a+      bB <- mapM reduceB b++      wrap $ case (levelMaxView aB, levelMaxView bB) of++        -- 0 ≤ any+        (SingleClosed 0 :| [] , _) -> return ()++        -- any ≤ 0+        (as , SingleClosed 0 :| []) ->+          forM_ as $ \ a' -> equalLevel (unSingleLevel $ fmap ignoreBlocking a') (ClosedLevel 0)++        -- closed ≤ closed+        (SingleClosed m :| [], SingleClosed n :| []) -> unless (m <= n) notok++        -- closed ≤ b+        (SingleClosed m :| [] , _)+          | m <= levelLowerBound b -> return ()++        -- as ≤ neutral/closed+        (as, bs)+          | all neutralOrClosed bs , levelLowerBound a > levelLowerBound b -> notok++        -- ⊔ as ≤ single+        (as@(_ :| _ : _), b :| []) ->+          forM_ as $ \ a' -> leqLevel (unSingleLevel $ ignoreBlocking <$> a')+                                      (unSingleLevel $ ignoreBlocking <$> b)++        -- reduce constants+        (as, bs)+          | let minN = min (fst $ levelPlusView a) (fst $ levelPlusView b)+                a'   = fromMaybe __IMPOSSIBLE__ $ subLevel minN a+                b'   = fromMaybe __IMPOSSIBLE__ $ subLevel minN b+          , minN > 0 -> leqLevel a' b'++        -- remove subsumed+        -- Andreas, 2014-04-07: This is ok if we do not go back to equalLevel+        (as, bs)+          | (subsumed@(_:_) , as') <- List1.partition (isSubsumed . fmap ignoreBlocking) as+          -> leqLevel (unSingleLevels $ (fmap . fmap) ignoreBlocking as') b+          where+            isSubsumed a = any (`subsumes` a) $ (fmap . fmap) ignoreBlocking bs++            subsumes :: SingleLevel -> SingleLevel -> Bool+            subsumes (SingleClosed m)        (SingleClosed n)        = m >= n+            subsumes (SinglePlus (Plus m _)) (SingleClosed n)        = m >= n+            subsumes (SinglePlus (Plus m a)) (SinglePlus (Plus n b)) = a == b && m >= n+            subsumes _ _ = False++        -- as ≤ _l x₁ .. xₙ ⊔ bs+        -- We can solve _l := λ x₁ .. xₙ -> as ⊔ (_l' x₁ .. xₙ)+        -- (where _l' is a new metavariable)+        (as , bs)+          | cumulativity+          , not areWeComputingOverlap+          , Just (mb@(MetaV x es) , bs') <- singleMetaView $ (map . fmap) ignoreBlocking (List1.toList bs)+          , null bs' || noMetas (Level a , unSingleLevels bs') -> do+            mv <- lookupLocalMeta x+            -- Jesper, 2019-10-13: abort if this is an interaction+            -- meta or a generalizable meta+            abort <- (isJust <$> isInteractionMeta x) `or2M`+                     ((== YesGeneralizeVar) <$> isGeneralizableMeta x)+            if | abort -> postpone+               | otherwise -> do+                  x' <- case mvJudgement mv of+                    IsSort{} -> __IMPOSSIBLE__+                    HasType _ cmp t -> do+                      TelV tel t' <- telView t+                      newMeta Instantiable (mvInfo mv) normalMetaPriority (idP $ size tel) $ HasType () cmp t+                  reportSDoc "tc.conv.level" 20 $ fsep+                    [ "attempting to solve" , prettyTCM (MetaV x es) , "to the maximum of"+                    , prettyTCM (Level a) , "and the fresh meta" , prettyTCM (MetaV x' es)+                    ]+                  equalLevel (atomicLevel mb) $ levelLub a (atomicLevel $ MetaV x' es)+++        -- Andreas, 2016-09-28: This simplification loses the solution lzero.+        -- Thus, it is invalid.+        -- See test/Succeed/LevelMetaLeqNeutralLevel.agda.+        -- -- [a] ≤ [neutral]+        -- ([a@(Plus n _)], [b@(Plus m NeutralLevel{})])+        --   | m == n -> equalLevel' (Max [a]) (Max [b])+        --   -- Andreas, 2014-04-07: This call to equalLevel is ok even if we removed+        --   -- subsumed terms from the lhs.++        -- anything else+        _ | noMetas (a, b) -> notok+          | otherwise      -> postpone+      where+        neutralOrClosed (SingleClosed _)                   = True+        neutralOrClosed (SinglePlus (Plus _ NotBlocked{})) = True+        neutralOrClosed _                                  = False++        -- Is there exactly one @MetaV@ in the list of single levels?+        singleMetaView :: [SingleLevel] -> Maybe (Term, [SingleLevel])+        singleMetaView (SinglePlus (Plus 0 l@(MetaV m es)) : ls)+          | all (not . isMetaLevel) ls = Just (l,ls)+        singleMetaView (l : ls)+          | not $ isMetaLevel l = second (l:) <$> singleMetaView ls+        singleMetaView _ = Nothing++        isMetaLevel :: SingleLevel -> Bool+        isMetaLevel (SinglePlus (Plus _ MetaV{})) = True+        isMetaLevel _                             = False++{-# SPECIALIZE equalLevel :: Level -> Level -> TCM () #-}+equalLevel :: forall m. MonadConversion m => Level -> Level -> m ()+equalLevel a b = do+  reportSDoc "tc.conv.level" 50 $ sep [ "equalLevel", nest 2 $ parens $ pretty a, nest 2 $ parens $ pretty b ]+  whenProfile Profile.Conversion $ tick "compare levels"+  -- Andreas, 2013-10-31 remove common terms (that don't contain metas!)+  -- THAT's actually UNSOUND when metas are instantiated, because+  --     max a b == max a c  does not imply  b == c+  -- as <- return $ Set.fromList $ closed0 as+  -- bs <- return $ Set.fromList $ closed0 bs+  -- let cs = Set.filter (not . hasMeta) $ Set.intersection as bs+  -- as <- return $ Set.toList $ as Set.\\ cs+  -- bs <- return $ Set.toList $ bs Set.\\ cs++  reportSDoc "tc.conv.level" 40 $+    sep [ "equalLevel"+        , vcat [ nest 2 $ sep [ prettyTCM a <+> "=="+                              , prettyTCM b+                              ]+               ]+        ]+  reportSDoc "tc.conv.level" 80 $ sep [ "equalLevel", nest 2 $ parens $ pretty a, nest 2 $ parens $ pretty b ]++  (a, b) <- normalise (a, b)++  -- Jesper, 2014-02-02 remove terms that certainly do not contribute+  -- to the maximum+  let (a', b') = removeSubsumed a b++  SynEq.checkSyntacticEquality' a' b'+    (\_ _ ->+      reportSDoc "tc.conv.level" 60+        "checkSyntacticEquality returns True") $ \a b -> do++  reportSDoc "tc.conv.level" 60 "checkSyntacticEquality returns False"++  let notok    = unlessM typeInType notOk+      notOk    = typeError $ UnequalLevel CmpEq a' b'+      postpone = do+        reportSDoc "tc.conv.level" 30 $ hang "postponing:" 2 $ hang (pretty a' <+> "==") 0 (pretty b')+        blocker <- unblockOnAnyMetaIn <$> instantiateFull (a', b')+        patternViolation blocker++  reportSDoc "tc.conv.level" 50 $+    sep [ "equalLevel (w/o subsumed)"+        , vcat [ nest 2 $ sep [ prettyTCM a' <+> "=="+                              , prettyTCM b'+                              ]+               ]+        ]++  let as  = levelMaxView a'+      bs  = levelMaxView b'+  reportSDoc "tc.conv.level" 50 $+    sep [ text "equalLevel"+        , vcat [ nest 2 $ sep [ prettyList_ $ fmap (prettyTCM . unSingleLevel) as+                              , "=="+                              , prettyList_ $ fmap (prettyTCM . unSingleLevel) bs+                              ]+               ]+        ]++  reportSDoc "tc.conv.level" 80 $+    sep [ text "equalLevel"+        , vcat [ nest 2 $ sep [ prettyList_ $ fmap (pretty . unSingleLevel) as+                              , "=="+                              , prettyList_ $ fmap (pretty . unSingleLevel) bs+                              ]+               ]+        ]++  -- Extra reduce on level atoms, but should be cheap since they are already reduced.+  as <- (mapM . mapM) reduceB as+  bs <- (mapM . mapM) reduceB bs++  catchConstraint (LevelCmp CmpEq a b) $ case (as, bs) of++        -- closed == closed+        (SingleClosed m :| [], SingleClosed n :| [])+          | m == n    -> return ()+          | otherwise -> notok++        -- closed == neutral+        (SingleClosed m :| [] , bs) | any isNeutral bs -> notok+        (as , SingleClosed n :| []) | any isNeutral as -> notok++        -- closed == b+        (SingleClosed m :| [] , _) | m < levelLowerBound b -> notok+        (_ , SingleClosed n :| []) | n < levelLowerBound a -> notok++        -- 0 == a ⊔ b+        (SingleClosed 0 :| [] , bs@(_ :| _ : _)) ->+          forM_ bs $ \ b' ->  equalLevel (ClosedLevel 0) (unSingleLevel $ ignoreBlocking <$> b')+        (as@(_ :| _ : _) , SingleClosed 0 :| []) ->+          forM_ as $ \ a' -> equalLevel (unSingleLevel $ ignoreBlocking <$> a') (ClosedLevel 0)++        -- meta == any+        (SinglePlus (Plus k a) :| [] , SinglePlus (Plus l b) :| [])+          -- there is only a potential choice when k == l+          | MetaV x as' <- ignoreBlocking a+          , MetaV y bs' <- ignoreBlocking b+          , k == l -> do+              lvl <- levelType'+              compareMetas CmpEq (AsTermsOf lvl) x as' y bs'+        (SinglePlus (Plus k a) :| [] , _)+          | MetaV x as' <- ignoreBlocking a+          , Just b' <- subLevel k b -> meta x as' b'+        (_ , SinglePlus (Plus l b) :| [])+          | MetaV y bs' <- ignoreBlocking b+          , Just a' <- subLevel l a -> meta y bs' a'++        -- a' ⊔ b == b+        _ | Just a' <- levelMaxDiff a b+          , b /= ClosedLevel 0 -> leqLevel a' b++        -- a == b' ⊔ a+        _ | Just b' <- levelMaxDiff b a+          , a /= ClosedLevel 0 -> leqLevel b' a++        -- neutral/closed == neutral/closed+        (as , bs)+          | all isNeutralOrClosed (as <> bs)+          -- Andreas, 2013-10-31: There could be metas in neutral levels (see Issue 930).+          -- Should not we postpone there as well?  Yes!+          , not (any hasMeta (as <> bs))+          , length as == length bs -> do+              reportSLn "tc.conv.level" 60 $ "equalLevel: all are neutral or closed"+              List1.zipWithM_ ((===) `on` levelTm . unSingleLevel . fmap ignoreBlocking) as bs++        -- more cases?+        _ | noMetas (a , b) -> notok+          | otherwise       -> postpone++      where+        a === b = unlessM typeInType $ do+          lvl <- levelType'+          equalAtom (AsTermsOf lvl) a b++        -- perform assignment (MetaV x as) := b+        meta x as b = do+          reportSLn "tc.meta.level" 30 $ "Assigning meta level"+          reportSDoc "tc.meta.level" 50 $ "meta" <+> sep [prettyList $ map pretty as, pretty b]+          lvl <- levelType'+          assignE DirEq x as (levelTm b) (AsTermsOf lvl) (===) -- fallback: check equality as atoms++        isNeutral (SinglePlus (Plus _ NotBlocked{})) = True+        isNeutral _                                  = False++        isNeutralOrClosed (SingleClosed _)                   = True+        isNeutralOrClosed (SinglePlus (Plus _ NotBlocked{})) = True+        isNeutralOrClosed _                                  = False++        hasMeta (SinglePlus (Plus _ Blocked{})) = True+        hasMeta (SinglePlus (Plus _ a))         = isJust $ firstMeta $ ignoreBlocking a+        hasMeta (SingleClosed _)                = False++        removeSubsumed a b =+          let as = List1.toList $ levelMaxView a+              bs = List1.toList $ levelMaxView b+              a' = unSingleLevels $ filter (not . (`isStrictlySubsumedBy` bs)) as+              b' = unSingleLevels $ filter (not . (`isStrictlySubsumedBy` as)) bs+          in (a',b')++        x `isStrictlySubsumedBy` ys = any (`strictlySubsumes` x) ys++        SingleClosed m        `strictlySubsumes` SingleClosed n        = m > n+        SinglePlus (Plus m a) `strictlySubsumes` SingleClosed n        = m > n+        SinglePlus (Plus m a) `strictlySubsumes` SinglePlus (Plus n b) = a == b && m > n+        _                     `strictlySubsumes` _                     = False+++{-# SPECIALIZE equalSort :: Sort -> Sort -> TCM () #-}+-- | Check that the first sort equal to the second.+equalSort :: forall m. MonadConversion m => Sort -> Sort -> m ()+equalSort s1 s2 = do+  reportSDoc "tc.conv.sort" 30 $ sep+    [ "equalSort"+    , vcat [ nest 2 $ fsep [ prettyTCM s1 <+> "=="+                           , prettyTCM s2 ]+           ]+    ]+  reportSDoc "tc.conv.sort" 60 $ sep+    [ "equalSort"+    , vcat [ nest 2 $ fsep [ pretty s1 <+> "=="+                           , pretty s2 ]+           ]+    ]+  whenProfile Profile.Conversion $ tick "compare sorts"++  guardPointerEquality s1 s2 "pointer equality: sorts" $+    SynEq.checkSyntacticEquality s1 s2 (\_ _ -> return ()) $ \s1 s2 -> do++    s1b <- reduceB s1+    s2b <- reduceB s2++    let (s1,s2) = (ignoreBlocking s1b, ignoreBlocking s2b)+        blocker = unblockOnEither (getBlocker s1b) (getBlocker s2b)++    let postponeIfBlocked = catchPatternErr $ \blocker -> do+          if | blocker == neverUnblock -> typeError $ UnequalSorts s1 s2+             | otherwise -> do+                 reportSDoc "tc.conv.sort" 30 $ vcat+                   [ "Postponing constraint"+                   , nest 2 $ fsep [ prettyTCM s1 <+> "=="+                                   , prettyTCM s2 ]+                   ]+                 -- Andreas, 2023-12-21, recomputing the blocker fixes issue #7034.+                 blocker <- updateBlocker blocker+                 addConstraint blocker $ SortCmp CmpEq s1 s2++    propEnabled <- isPropEnabled+    typeInTypeEnabled <- typeInType+    omegaInOmegaEnabled <- optOmegaInOmega <$> pragmaOptions+    let infInInf = typeInTypeEnabled || omegaInOmegaEnabled++    postponeIfBlocked $ case (s1, s2) of++            -- Andreas, 2018-09-03: crash on dummy sort+            (DummyS s, _) -> impossibleSort s+            (_, DummyS s) -> impossibleSort s++            -- one side is a meta sort: try to instantiate+            -- In case both sides are meta sorts, instantiate the+            -- bigger (i.e. more recent) one.+            (MetaS x es , MetaS y es') -> compareMetas CmpEq AsTypes x es y es'+            (MetaS x es , _          ) -> meta x es s2+            (_          , MetaS x es ) -> meta x es s1++            -- diagonal cases for rigid sorts+            (Univ u a   , Univ u' b  ) | u == u' -> equalLevel a b `catchInequalLevel` no+            (SizeUniv   , SizeUniv   ) -> yes+            (LockUniv   , LockUniv   ) -> yes+            (LevelUniv  , LevelUniv  ) -> yes+            (IntervalUniv , IntervalUniv) -> yes+            (Inf u m    , Inf u' n   ) ->+              if u == u' && (m == n || infInInf) then yes else no++            -- if --type-in-type is enabled, Setωᵢ is equal to any Set ℓ (see #3439)+            (Univ u _   , Inf  u' _  ) -> answer $ u == u' && typeInTypeEnabled+            (Inf  u _   , Univ u' _  ) -> answer $ u == u' && typeInTypeEnabled++            -- equating @PiSort a b@ to another sort+            (s1 , PiSort a b c) -> piSortEquals propEnabled s1 a b c blocker+            (PiSort a b c , s2) -> piSortEquals propEnabled s2 a b c blocker++            -- equating @FunSort a b@ to another sort+            (s1 , FunSort a b) -> funSortEquals propEnabled s1 a b blocker+            (FunSort a b , s2) -> funSortEquals propEnabled s2 a b blocker++            -- equating @UnivSort s@ to another sort+            (s1          , UnivSort s2) -> univSortEquals propEnabled infInInf s1 s2 blocker+            (UnivSort s1 , s2         ) -> univSortEquals propEnabled infInInf s2 s1 blocker++            -- postulated sorts can only be equal if they have the same head+            (DefS d es  , DefS d' es')+              | d == d'                -> do+                  pol <- getPolarity' CmpEq d+                  a <- computeElimHeadType d es es'+                  compareElims pol [] a (Def d []) es es'+              | otherwise              -> no++            -- any other combinations of sorts are not equal+            (_          , _          ) -> no++    where+      yes = return ()+      no  = patternViolation neverUnblock+      answer = \case+        True -> yes+        False -> no++      -- perform assignment (MetaS x es) := s+      meta :: MetaId -> [Elim' Term] -> Sort -> m ()+      meta x es s = do+        reportSLn "tc.meta.sort" 30 $ "Assigning meta sort"+        reportSDoc "tc.meta.sort" 50 $ "meta" <+> sep [pretty x, prettyList $ map pretty es, pretty s]+        assignE DirEq x es (Sort s) AsTypes __IMPOSSIBLE__++       -- Sorts that contain exactly one other kind of sorts.+      invertibleSort :: Bool -> Univ -> Bool+      invertibleSort propEnabled = \case+        -- @SSetω(n+1)@ is the successor sort of exactly @SSetω(n)@.+        USSet -> True+        -- @Setω(n+1)@ is the successor sort of exactly @Setω(n)@ if we do not have @Prop@.+        UType -> not propEnabled+        -- @Prop@ sorts are not successor sorts.+        UProp -> False++      -- Equate a sort @s1@ to @univSort s2@+      -- Precondition: @s1@ and @univSort s2@ are already reduced.+      univSortEquals :: Bool -> Bool -> Sort -> Sort -> Blocker -> m ()+      univSortEquals propEnabled infInInf s1 s2 blocker = do+        reportSDoc "tc.conv.sort" 35 $ vcat+          [ "univSortEquals"+          , "  s1 =" <+> prettyTCM s1+          , "  s2 =" <+> prettyTCM s2+          ]+        let postpone = patternViolation blocker+        case s1 of+          -- @Prop l@, @SizeUniv@ and @LevelUniv@ are not successor sorts.+          Prop{}      -> no+          Inf UProp _ -> no+          SizeUniv{}  -> no+          LevelUniv{} -> no+          -- Neither are @LockUniv@ or @IntervalUniv@.+          LockUniv{}     -> no+          IntervalUniv{} -> no++          -- @Set l1@ is the successor sort of either @Set l2@ or+          -- @Prop l2@ where @l1 == lsuc l2@.+          Type l1 -> do+            levelUnivEnabled <- optLevelUniverse <$> pragmaOptions+            guardedEnabled   <- optGuarded       <$> pragmaOptions+               -- @s2@ is definitely not @Inf n@ or @SizeUniv@+            if | Inf _ _n <- s2 -> __IMPOSSIBLE__+               | SizeUniv <- s2 -> __IMPOSSIBLE__+               -- The predecessor @s2@ is can also not be @SSet _@ or @IntervalUniv@+               | Univ USSet _ <- s2 -> __IMPOSSIBLE__+               | IntervalUniv <- s2 -> __IMPOSSIBLE__+               -- If @Prop@ is not used, then @s2@ must be of the form @Set l2@,+               -- except when l1 == 1, then it could also be @LockUniv@ or @LevelUniv@.+               | not (propEnabled || guardedEnabled || levelUnivEnabled) -> do+                   l2 <- case subLevel 1 l1 of+                     Just l2 -> return l2+                     Nothing -> do+                       l2 <- newLevelMeta+                       equalLevel l1 (levelSuc l2)+                       return l2+                   equalSort (Type l2) s2+               -- Otherwise we postpone+               | otherwise -> postpone+          -- @SSetω(n+1)@ is the successor sort of exactly @SSetω(n)@.+          -- @SSetω@ is the successor sort of exactly @SSetω@ if+          -- --type-in-type or --omega-in-omega is enabled.+          -- The same is only true for @Setω(n+1)@ if @Propω...@ are disabled.+          -- @Setω@ is the successor sort of @Setω@ (type:type) or @SizeUniv@ (--sized-types).+          Inf u 0 -> do+              -- Compute the predecessor(s) of (S)Setω and return it if it is unique.+              sizedTypesEnabled <- sizedTypesOption+              -- guardedEnabled <- optGuarded <$> pragmaOptions+              case concat+                [ [ s1       | u /= UProp, infInInf ]+                , [ dummy    | u == UType, infInInf, propEnabled, let dummy = Inf UProp 0 ]+                    -- We enter a dummy into the solution set if --prop makes predecessor ambiguous.+                , [ SizeUniv | u == UType, sizedTypesEnabled ]+                -- , [ LockUniv | guardedEnabled ]  -- LockUniv is actually in Set₁, not Setω+                ]+                of+                [ s ] -> equalSort s s2+                []    -> no+                _     -> postpone+          Inf u n | n > 0, invertibleSort propEnabled u ->+            equalSort (Inf u $ n - 1) s2++          -- Anything else: postpone+          _ -> postpone+++      -- Equate a sort @s@ to @piSort a s1 s2@+      -- Precondition: @s@ and @piSort a s1 s2@ are already reduced.+      piSortEquals :: Bool -> Sort -> Dom Term -> Sort -> Abs Sort -> Blocker -> m ()+      piSortEquals propEnabled s a s1 NoAbs{} blocker = __IMPOSSIBLE__+      piSortEquals propEnabled s a s1 s2Abs@(Abs x s2) blocker = do+        let adom = El s1 <$> a+        reportSDoc "tc.conv.sort" 35 $ vcat+          [ "piSortEquals"+          , "  s  =" <+> prettyTCM s+          , "  a  =" <+> prettyTCM adom+          , "  s1 =" <+> prettyTCM s1+          , "  s2 =" <+> addContext (x,adom) (prettyTCM s2)+          ]+        let postpone = patternViolation blocker+           -- If @s2@ is dependent, then @piSort a s1 s2@ computes to+           -- @Setωi@. Hence, if @s@ is small, then @s2@+           -- cannot be dependent.+        if | isSmallSort s -> do+               -- We force @s2@ to be non-dependent by unifying it with+               -- a fresh meta that does not depend on @x : a@+               s2' <- newSortMeta+               addContext (x , adom) $ equalSort s2 (raise 1 s2')+               funSortEquals propEnabled s s1 s2' blocker+           -- Otherwise: postpone+           | otherwise -> postpone++      -- Equate a sort @s@ to @funSort s1 s2@+      -- Precondition: @s@ and @funSort s1 s2@ are already reduced+      funSortEquals :: Bool -> Sort -> Sort -> Sort -> Blocker -> m ()+      funSortEquals propEnabled s0 s1 s2 blocker = do+        reportSDoc "tc.conv.sort" 35 $ vcat+          [ "funSortEquals"+          , "  s0 =" <+> prettyTCM s0+          , "  s1 =" <+> prettyTCM s1+          , "  s2 =" <+> prettyTCM s2+          ]+        sizedTypesEnabled <- sizedTypesOption+        cubicalEnabled <- isJust <$> cubicalOption+        levelUnivEnabled <- optLevelUniverse <$> pragmaOptions+        let postpone = patternViolation blocker+            err :: m ()+            err = typeError $ UnequalSorts s0 (FunSort s1 s2)+        case s0 of+          -- If @Setωᵢ == funSort s1 s2@, then either @s1@ or @s2@ must+          -- be @Setωᵢ@.++          Inf u n ->+            case (sizeOfSort s1, sizeOfSort s2) of++              -- Both sorts have to be <= n in size, and their fibrancy <= u+              (Right (SizeOfSort u' n'), _)+                | n' > n                           -> err+                | univFibrancy u' > univFibrancy u -> err+              (_, Right (SizeOfSort u' n'))+                | n' > n                           -> err+                | univFibrancy u' > univFibrancy u -> err+              -- Unless SSet, the kind of the funSort is the kind of the codomain+                | u /= USSet, u /= u'              -> err++              -- One sort has to be at least the same size as n+              (Right (SizeOfSort u1 n1), Right (SizeOfSort u2 n2))+                | n1 < n, n2 < n                   -> err+                | u /= funUniv u1 u2               -> err++              -- If have the domain sort only+              (Right (SizeOfSort u' n'), _)+                | u' /= USSet, n' < n              -> equalSort s0 s2+                | otherwise                        -> postpone++              -- If we just have the codomain sort+              (_, Right (SizeOfSort USSet n'))     -> postpone+              (_, Right (SizeOfSort _     n'))+                | n' < n, u == USSet               -> equalSort s1 s2+                | n' < n, not propEnabled,+                  -- issue #6648: with --level-universe we have PTS rule (LevelUniv,Set,Setω)+                  not levelUnivEnabled || n > 0    -> equalSort (Inf UType n) s1+                | otherwise                        -> postpone++              _ -> postpone++          -- If @Set l == funSort s1 s2@, then @s2@ must be of the+          -- form @Set l2@. @s1@ can be one of @Set l1@, @Prop l1@,+          -- @SizeUniv@, or @IUniv@.+          Type l -> do+            l2 <- forceUniv UType s2+            -- We must have @l2 =< l@, this might help us to solve+            -- more constraints (in particular when @l == 0@).+            leqLevel l2 l+            -- Jesper, 2022-10-22, #6211: the operations `forceUniv`+            -- and `leqLevel` above might have instantiated some+            -- metas, so we need to reduce s1 again to get an+            -- up-to-date Blocker.+            s1b <- reduceB s1+            let s1 = ignoreBlocking s1b+                blocker = getBlocker s1b+            -- Jesper, 2019-12-27: SizeUniv is disabled at the moment.+            if | {- sizedTypesEnabled || -} propEnabled || cubicalEnabled ->+                case funSort' s1 (Type l2) of+                   -- If the work we did makes the @funSort@ compute,+                   -- continue working.+                   Right s -> equalSort (Type l) s+                   -- Otherwise: postpone+                   Left{}  -> patternViolation blocker+               -- If both Prop and sized types are disabled, only the+               -- case @s1 == Set l1@ remains.+               | otherwise -> do+                   l1 <- forceUniv UType s1+                   equalLevel l (levelLub l1 l2)++          -- If @Prop l == funSort s1 s2@, then @s2@ must be of the+          -- form @Prop l2@, and @s1@ can be one of @Set l1@, Prop+          -- l1@, or @SizeUniv@.+          Prop l -> do+            l2 <- forceUniv UProp s2+            leqLevel l2 l+            s1b <- reduceB s1+            let s1 = ignoreBlocking s1b+                blocker = getBlocker s1b+            case funSort' s1 (Prop l2) of+                   -- If the work we did makes the @funSort@ compute,+                   -- continue working.+                   Right s -> equalSort (Prop l) s+                   -- Otherwise: postpone+                   Left _  -> patternViolation blocker++          -- TODO: SSet l++          -- We have @SizeUniv == funSort s1 s2@ iff @s2 == SizeUniv@+          SizeUniv -> equalSort SizeUniv s2+          LevelUniv -> equalSort LevelUniv s2+          -- Anything else: postpone+          _        -> postpone++      forceUniv :: Univ -> Sort -> m Level+      forceUniv u = \case+        Univ u' l | u == u' -> return l+        s -> do+          l <- newLevelMeta+          equalSort s (Univ u l)+          return l++      impossibleSort s = do+        reportS "impossible" 10+          [ "equalSort: found dummy sort with description:"+          , s+          ]+        __IMPOSSIBLE__++      catchInequalLevel m fail = m `catchError` \case+        TypeError{} -> fail+        err         -> throwError err+++forallFaceMaps+  :: MonadConversion m+  => Term+  -> (IntMap Bool -> Blocker -> Term -> m a)+  -> (IntMap Bool -> Substitution -> m a)+  -> m [a]+forallFaceMaps t kb k = do+  reportSDoc "conv.forall" 20 $+      fsep ["forallFaceMaps"+           , prettyTCM t+           ]+  as <- decomposeInterval t+  boolToI <- do+    io <- primIOne+    iz <- primIZero+    return (\b -> if b then io else iz)+  forM as $ \ (ms,ts) -> do+   ifBlockeds ts (kb ms) $ \ _ _ -> do+    let xs = map (second boolToI) $ IntMap.toAscList ms+    cxt <- getContext+    reportSDoc "conv.forall" 20 $+      fsep ["substContextN"+           , prettyTCM cxt+           , prettyTCM xs+           ]+    (cxt',sigma) <- substContextN cxt xs+    resolved <- forM xs (\ (i,t) -> (,) <$> lookupBV i <*> return (applySubst sigma t))+    updateContext sigma (const cxt') $+      addBindings resolved $ do+        cl <- buildClosure ()+        tel <- getContextTelescope+        m <- currentModule+        sub <- getModuleParameterSub m+        reportSDoc "conv.forall" 30 $ vcat+          [ text (replicate 10 '-')+          , prettyTCM (envCurrentModule $ clEnv cl)+          -- , prettyTCM (envLetBindings $ clEnv cl)+          , prettyTCM tel -- (toTelescope $ envContext $ clEnv cl)+          , prettyTCM sigma+          , prettyTCM m+          , prettyTCM sub+          ]+        k ms sigma+  where+    -- TODO Andrea: inefficient because we try to reduce the ts which we know are in whnf+    ifBlockeds ts blocked unblocked = do+      and <- getPrimitiveTerm PrimIMin+      io  <- primIOne+      let t = foldr (\ x r -> and `apply` [argN x,argN r]) io ts+      ifBlocked t blocked unblocked+    addBindings [] m = m+    addBindings ((CtxVar nm Dom{domInfo = info,unDom = ty},t):bs) m = addLetBinding info Inserted nm t ty (addBindings bs m)++    substContextN :: MonadConversion m => Context -> [(Int,Term)] -> m (Context , Substitution)+    substContextN c [] = return (c, idS)+    substContextN c ((i,t):xs) = do+      (c', sigma) <- substContext i t c+      (c'', sigma')  <- substContextN c' (map (subtract 1 -*- applySubst sigma) xs)+      return (c'', applySubst sigma' sigma)+++    -- assumes the term can be typed in the shorter telescope+    -- the terms we get from toFaceMaps are closed.+    substContext :: MonadConversion m => Int -> Term -> Context -> m (Context , Substitution)+    substContext i t [] = __IMPOSSIBLE__+    substContext i t (x:xs) | i == 0 = return $ (xs , singletonS 0 t)+    substContext i t (x:xs) | i > 0 = do+                                  reportSDoc "conv.forall" 20 $+                                    fsep ["substContext"+                                        , text (show (i-1))+                                        , prettyTCM t+                                        , prettyTCM xs+                                        ]+                                  (c,sigma) <- substContext (i-1) t xs+                                  let e = applySubst sigma x+                                  return (e:c, liftS 1 sigma)+    substContext i t (x:xs) = __IMPOSSIBLE__++compareInterval :: MonadConversion m => Comparison -> Type -> Term -> Term -> m ()+compareInterval cmp i t u = do+  reportSDoc "tc.conv.interval" 15 $+    sep [ "{ compareInterval" <+> prettyTCM t <+> "=" <+> prettyTCM u ]+  whenProfile Profile.Conversion $ tick "compare at interval type"+  tb <- reduceB t+  ub <- reduceB u+  let t = ignoreBlocking tb+      u = ignoreBlocking ub+  it <- decomposeInterval' t+  iu <- decomposeInterval' u+  case () of+    _ | isBlocked tb || isBlocked ub -> do+      -- in case of metas we wouldn't be able to make progress by how we deal with de morgan laws.+      -- (because the constraints generated by decomposition are sufficient but not necessary).+      -- but we could still prune/solve some metas by comparing the terms as atoms.+      -- also if blocked we won't find the terms conclusively unequal(?) so compareAtom+      -- won't report type errors when we should accept.+      interval <- primIntervalType+      compareAtom CmpEq (AsTermsOf interval) t u+    _ | otherwise -> do+      x <- leqInterval it iu+      y <- leqInterval iu it+      let final = isCanonical it && isCanonical iu+      if x && y then reportSDoc "tc.conv.interval" 15 $ "Ok! }" else+        if final then typeError $ UnequalTerms cmp t u (AsTermsOf i)+                 else do+                   reportSDoc "tc.conv.interval" 15 $ "Giving up! }"+                   patternViolation (unblockOnAnyMetaIn (t, u))+ where+   isBlocked Blocked{}    = True+   isBlocked NotBlocked{} = False+++type Conj = (IntMap BoolSet, [Term])++isCanonical :: [Conj] -> Bool+isCanonical = all (null . snd)++-- | leqInterval r q = r ≤ q in the I lattice.+-- (∨ r_i) ≤ (∨ q_j)  iff  ∀ i. ∃ j. r_i ≤ q_j+leqInterval :: MonadConversion m => [Conj] -> [Conj] -> m Bool+leqInterval r q =+  and <$> forM r (\ r_i ->+   or <$> forM q (\ q_j -> leqConj r_i q_j))  -- TODO shortcut++-- | leqConj r q = r ≤ q in the I lattice, when r and q are conjuctions.+-- ' (∧ r_i)   ≤ (∧ q_j)               iff+-- ' (∧ r_i)   ∧ (∧ q_j)   = (∧ r_i)   iff+-- ' {r_i | i} ∪ {q_j | j} = {r_i | i} iff+-- ' {q_j | j} ⊆ {r_i | i}+leqConj :: MonadConversion m => Conj -> Conj -> m Bool+leqConj (rs, rst) (qs, qst) = do+  if IntMap.isSubmapOfBy BoolSet.isSubsetOf qs rs+    then do+      interval <-+        El IntervalUniv . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinInterval+      -- we don't want to generate new constraints here because+      -- 1. in some situations the same constraint would get generated twice.+      -- 2. unless things are completely accepted we are going to+      --    throw patternViolation in compareInterval.+      let eqT t u = tryConversion (compareAtom CmpEq (AsTermsOf interval) t u)+      let listSubset ts us =+            and <$> forM ts (\t -> or <$> forM us (\u -> eqT t u)) -- TODO shortcut+      listSubset qst rst+    else+      return False++-- | equalTermOnFace φ A u v = _ , φ ⊢ u = v : A+equalTermOnFace :: MonadConversion m => Term -> Type -> Term -> Term -> m ()+equalTermOnFace = compareTermOnFace CmpEq++compareTermOnFace :: MonadConversion m => Comparison -> Term -> Type -> Term -> Term -> m ()+compareTermOnFace = compareTermOnFace' (const compareTerm)++compareTermOnFace'+  :: MonadConversion m+  => (Substitution -> Comparison -> Type -> Term -> Term -> m ())+  -> Comparison -> Term -> Type -> Term -> Term -> m ()+compareTermOnFace' k cmp phi ty u v = do+  reportSDoc "tc.conv.face" 40 $+    text "compareTermOnFace:" <+> pretty phi <+> "|-" <+> pretty u <+> "==" <+> pretty v <+> ":" <+> pretty ty+  whenProfile Profile.Conversion $ tick "compare at face type"++  phi <- reduce phi+  _ <- forallFaceMaps phi postponed $ \ faces alpha ->+      k alpha cmp (applySubst alpha ty) (applySubst alpha u) (applySubst alpha v)+  return ()+ where+  postponed ms blocker psi = do+    phi <- runNamesT [] $ do+             imin <- cl $ getPrimitiveTerm PrimIMin+             ineg <- cl $ getPrimitiveTerm PrimINeg+             psi <- open psi+             let phi = foldr (\ (i,b) r -> do i <- open (var i); pure imin <@> (if b then i else pure ineg <@> i) <@> r)+                          psi (IntMap.toList ms) -- TODO Andrea: make a view?              phi     addConstraint blocker (ValueCmpOnFace cmp phi ty u v)
src/full/Agda/TypeChecking/Conversion.hs-boot view
@@ -1,8 +1,8 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Conversion where  import Control.Monad.Except ( MonadError )-import qualified Control.Monad.Fail as Fail  import Agda.Syntax.Internal import Agda.TypeChecking.Monad@@ -17,7 +17,6 @@   , MonadStatistics m   , MonadFresh ProblemId m   , MonadFresh Int m-  , Fail.MonadFail m   )  compareTerm  :: MonadConversion m => Comparison -> Type -> Term -> Term -> m ()
src/full/Agda/TypeChecking/Conversion/Pure.hs view
@@ -1,9 +1,6 @@  module Agda.TypeChecking.Conversion.Pure where --- Control.Monad.Fail import is redundant since GHC 8.8.1-import Control.Monad.Fail (MonadFail)- import Control.Monad.Except import Control.Monad.State @@ -11,7 +8,6 @@  import Agda.Syntax.Common import Agda.Syntax.Internal-import Agda.Syntax.Internal.MetaVars (unblockOnAnyMetaIn)  import {-# SOURCE #-} Agda.TypeChecking.Conversion import Agda.TypeChecking.Monad@@ -19,7 +15,6 @@ import Agda.TypeChecking.Reduce (isBlocked) import Agda.TypeChecking.Warnings -import Agda.Utils.Either import Agda.Utils.Maybe import Agda.Utils.Null @@ -35,42 +30,73 @@   { unPureConversionT :: ExceptT TCErr (StateT FreshThings m) a }   deriving (Functor, Applicative, Monad, MonadError TCErr, MonadState FreshThings, PureTCM) +{-# SPECIALIZE pureEqualTerm :: Type -> Term -> Term -> TCM Bool #-} pureEqualTerm   :: (PureTCM m, MonadBlock m)   => Type -> Term -> Term -> m Bool pureEqualTerm a u v =   isJust <$> runPureConversion (equalTerm a u v) +{-# SPECIALIZE pureEqualTermB :: Type -> Term -> Term -> TCM (Either Blocker Bool) #-}+-- | Return the blocker instead of throwing a `patternViolation`.+pureEqualTermB :: PureTCM m => Type -> Term -> Term -> m (Either Blocker Bool)+pureEqualTermB a u v =+  fmap isJust <$> runPureConversionB (equalTerm a u v)++{-# SPECIALIZE pureEqualType :: Type -> Type -> TCM Bool #-} pureEqualType   :: (PureTCM m, MonadBlock m)   => Type -> Type -> m Bool pureEqualType a b =   isJust <$> runPureConversion (equalType a b) +{-# SPECIALIZE pureEqualType :: Type -> Type -> TCM Bool #-}+-- | Return the blocker instead of throwing a `patternViolation`.+pureEqualTypeB :: PureTCM m => Type -> Type -> m (Either Blocker Bool)+pureEqualTypeB a b =+  fmap isJust <$> runPureConversionB (equalType a b)++{-# SPECIALIZE pureCompareAs :: Comparison -> CompareAs -> Term -> Term -> TCM Bool #-} pureCompareAs   :: (PureTCM m, MonadBlock m)   => Comparison -> CompareAs -> Term -> Term -> m Bool pureCompareAs cmp a u v =   isJust <$> runPureConversion (compareAs cmp a u v) +{-# SPECIALIZE runPureConversion :: PureConversionT TCM a -> TCM (Maybe a) #-} runPureConversion-  :: (MonadBlock m, PureTCM m, Show a)+  :: (MonadBlock m, PureTCM m)   => PureConversionT m a -> m (Maybe a)-runPureConversion (PureConversionT m) = locallyTC eCompareBlocked (const True) $ do+runPureConversion m = either patternViolation pure =<< runPureConversionB m++{-# SPECIALIZE runPureConversionB :: PureConversionT TCM a -> TCM (Either Blocker (Maybe a)) #-}+runPureConversionB :: PureTCM m => PureConversionT m a -> m (Either Blocker (Maybe a))+runPureConversionB (PureConversionT m) = locallyTC eCompareBlocked (const True) $+  verboseBracket "tc.conv.pure" 40 "runPureConversion" $ do   i <- useR stFreshInt   pid <- useR stFreshProblemId   nid <- useR stFreshNameId   let frsh = FreshThings i pid nid   result <- fst <$> runStateT (runExceptT m) frsh-  reportSLn "tc.conv.pure" 40 $ "runPureConversion result: " ++ show result   case result of     Left (PatternErr block)-     | block == neverUnblock -> return Nothing-     | otherwise             -> patternViolation block-    Left TypeError{}   -> return Nothing-    Left Exception{}   -> __IMPOSSIBLE__-    Left IOException{} -> __IMPOSSIBLE__-    Right x            -> return $ Just x+     | block == neverUnblock -> do+         debugResult "stuck"+         return $ Right Nothing+     | otherwise             -> do+         debugResult $ "blocked on" <+> prettyTCM block+         return $ Left block+    Left TypeError{}         -> do+      debugResult "type error"+      return $ Right Nothing+    Left GenericException{}  -> __IMPOSSIBLE__+    Left IOException{}       -> __IMPOSSIBLE__+    Left ParserError{}       -> __IMPOSSIBLE__+    Right x                  -> do+      debugResult "success"+      return $ Right $ Just x+  where+    debugResult msg = reportSDoc "tc.conv.pure" 40 $ "runPureConversion result: " <+> msg  instance MonadTrans PureConversionT where   lift = PureConversionT . lift . lift@@ -102,7 +128,7 @@     err          -> throwError err  -instance (PureTCM m, MonadBlock m) => MonadConstraint (PureConversionT m) where+instance PureTCM m => MonadConstraint (PureConversionT m) where   addConstraint u _ = patternViolation u   addAwakeConstraint u _ = patternViolation u   solveConstraint c = patternViolation alwaysUnblock  -- TODO: does this happen?@@ -112,7 +138,7 @@   modifyAwakeConstraints _ = patternViolation alwaysUnblock  -- TODO: does this happen?   modifySleepingConstraints _ = patternViolation alwaysUnblock  -- TODO: does this happen? -instance (PureTCM m, MonadBlock m) => MonadMetaSolver (PureConversionT m) where+instance PureTCM m => MonadMetaSolver (PureConversionT m) where   newMeta' _ _ _ _ _ _ = patternViolation alwaysUnblock  -- TODO: does this happen?   assignV _ m _ v _ = do     bv <- isBlocked v@@ -128,7 +154,7 @@     KeepMetas     -> return ()     RollBackMetas -> fallback -instance (PureTCM m, MonadBlock m) => MonadInteractionPoints (PureConversionT m) where+instance PureTCM m => MonadInteractionPoints (PureConversionT m) where   freshInteractionId = patternViolation alwaysUnblock  -- TODO: does this happen?   modifyInteractionPoints _ = patternViolation alwaysUnblock  -- TODO: does this happen? @@ -139,8 +165,8 @@     concNames <- useR stConcreteNames     fst <$> runStateT m concNames -instance (PureTCM m, MonadBlock m) => MonadWarning (PureConversionT m) where-  addWarning w = case classifyWarning (tcWarning w) of+instance PureTCM m => MonadWarning (PureConversionT m) where+  addWarning _enabled w = case classifyWarning (tcWarning w) of     ErrorWarnings -> patternViolation neverUnblock     AllWarnings   -> return ()
src/full/Agda/TypeChecking/Coverage.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TypeApplications #-}  {-| Coverage checking, case splitting, and splitting for refine tactics. @@ -17,35 +18,42 @@  import Prelude hiding (null, (!!))  -- do not use partial functions like !! -import Control.Monad-import Control.Monad.Except-import Control.Monad.Trans ( lift )+import Control.Monad.Except ( MonadError(..), ExceptT(..), runExceptT )+import Control.Monad.State  ( State, evalState, state ) +import Data.Either (partitionEithers) import Data.Foldable (for_)+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as Set-import Data.IntSet (IntSet)-import qualified Data.IntSet as IntSet +import qualified Agda.Benchmarking as Bench+ import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Syntax.Position-import Agda.Syntax.Internal hiding (DataOrRecord(..))+import Agda.Syntax.Internal hiding (DataOrRecord) import Agda.Syntax.Internal.Pattern import Agda.Syntax.Translation.InternalToAbstract (NamedClause(..)) -import Agda.TypeChecking.Names import Agda.TypeChecking.Primitive hiding (Nat) import Agda.TypeChecking.Monad+import qualified Agda.TypeChecking.Monad.Benchmark as Bench -import Agda.TypeChecking.Rules.LHS (DataOrRecord(..), checkSortOfSplitVar)+import Agda.TypeChecking.Rules.LHS (DataOrRecord, checkSortOfSplitVar) import Agda.TypeChecking.Rules.LHS.Problem (allFlexVars) import Agda.TypeChecking.Rules.LHS.Unify import Agda.TypeChecking.Rules.Term (unquoteTactic)  import Agda.TypeChecking.Coverage.Match import Agda.TypeChecking.Coverage.SplitTree+import Agda.TypeChecking.Coverage.SplitClause+import Agda.TypeChecking.Coverage.Cubical  import Agda.TypeChecking.Conversion (tryConversion, equalType) import Agda.TypeChecking.Datatypes (getConForm)@@ -55,77 +63,29 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Reduce import Agda.TypeChecking.Records+import Agda.TypeChecking.Sort import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Telescope.Path import Agda.TypeChecking.MetaVars import Agda.TypeChecking.Warnings  import Agda.Interaction.Options  import Agda.Utils.Either+import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.List+import Agda.Utils.Lens+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Permutation-import Agda.Utils.Pretty (prettyShow) import Agda.Utils.Singleton import Agda.Utils.Size-import Agda.Utils.WithDefault+import Agda.Utils.Tuple  import Agda.Utils.Impossible -data SplitClause = SClause-  { scTel    :: Telescope-    -- ^ Type of variables in @scPats@.-  , scPats   :: [NamedArg SplitPattern]-    -- ^ The patterns leading to the currently considered branch of-    --   the split tree.-  , scSubst  :: Substitution' SplitPattern-    -- ^ Substitution from 'scTel' to old context.-    --   Only needed directly after split on variable:-    --   * To update 'scTarget'-    --   * To rename other split variables when splitting on-    --     multiple variables.-    --   @scSubst@ is not ``transitive'', i.e., does not record-    --   the substitution from the original context to 'scTel'-    --   over a series of splits.  It is freshly computed-    --   after each split by 'computeNeighborhood'; also-    --   'splitResult', which does not split on a variable,-    --   should reset it to the identity 'idS', lest it be-    --   applied to 'scTarget' again, leading to Issue 1294.-  , scCheckpoints :: Map CheckpointId Substitution-    -- ^ We need to keep track of the module parameter checkpoints for the-    -- clause for the purpose of inferring missing instance clauses.-  , scTarget :: Maybe (Dom Type)-    -- ^ The type of the rhs, living in context 'scTel'.-    --   'fixTargetType' computes the new 'scTarget' by applying-    --   substitution 'scSubst'.-  }---- | A @Covering@ is the result of splitting a 'SplitClause'.-data Covering = Covering-  { covSplitArg     :: Arg Nat-     -- ^ De Bruijn level (counting dot patterns) of argument we split on.-  , covSplitClauses :: [(SplitTag, SplitClause)]-      -- ^ Covering clauses, indexed by constructor/literal these clauses share.-  }---- | Project the split clauses out of a covering.-splitClauses :: Covering -> [SplitClause]-splitClauses (Covering _ qcs) = map snd qcs---- | Create a split clause from a clause in internal syntax. Used by make-case.-clauseToSplitClause :: Clause -> SplitClause-clauseToSplitClause cl = SClause-  { scTel    = clauseTel cl-  , scPats   = toSplitPatterns $ namedClausePats cl-  , scSubst  = idS  -- Andreas, 2014-07-15  TODO: Is this ok?-  , scCheckpoints = Map.empty -- #2996: not __IMPOSSIBLE__ for debug printing-  , scTarget = domFromArg <$> clauseType cl-  }- type CoverM = ExceptT SplitError TCM  -- | Top-level function for checking pattern coverage.@@ -183,12 +143,12 @@   -- some indices in @used@ and @noex@ point outside of @cs@,   -- since missing hcomp clauses have been added during the course of @cover@.   -- We simply delete theses indices from @noex@.-  noex <- return $ List.filter (< length cs) $ IntSet.toList noex+  noex <- return $ IntSet.filter (< length cs) noex    reportSDoc "tc.cover.top" 10 $ vcat     [ "cover computed!"     , text $ "used clauses: " ++ show used-    , text $ "non-exact clauses: " ++ show noex+    , text $ "non-exact clauses: " ++ show (IntSet.toList noex)     ]   reportSDoc "tc.cover.splittree" 10 $ vcat     [ "generated split tree for" <+> prettyTCM f@@ -202,12 +162,15 @@   -- Storing the covering clauses so that checkIApplyConfluence_ can   -- find them later.   -- Andreas, 2019-03-27, only needed when --cubical-  whenM (isJust . optCubical <$> pragmaOptions) $ do+  -- Jesper, 2022-10-18, also needed for some backends, so keep when flag says so+  opts <- pragmaOptions+  when (isJust (optCubical opts) || optKeepCoveringClauses opts) $     modifySignature $ updateDefinition f $ updateTheDef $ updateCovering $ const qss     -- filter out the missing clauses that are absurd.-  pss <- flip filterM pss $ \(tel,ps) ->+  pss <- ifNotM (optInferAbsurdClauses <$> pragmaOptions) (pure pss) {-else-} $+   flip filterM pss $ \(tel,ps) ->     -- Andreas, 2019-04-13, issue #3692: when adding missing absurd     -- clauses, also put the absurd pattern in.     caseEitherM (checkEmptyTel noRange tel) (\ _ -> return True) $ \ l -> do@@ -219,17 +182,17 @@         -- ifNotM (isEmptyTel tel) (return True) $ do       -- Jesper, 2018-11-28, Issue #3407: if the clause is absurd,       -- add the appropriate absurd clause to the definition.-      let cl = Clause { clauseLHSRange    = noRange-                      , clauseFullRange   = noRange-                      , clauseTel         = tel-                      , namedClausePats   = applySubst sub ps-                      , clauseBody        = Nothing-                      , clauseType        = Nothing-                      , clauseCatchall    = True       -- absurd clauses are safe as catch-all-                      , clauseExact       = Just False+      let cl = Clause { clauseLHSRange  = noRange+                      , clauseFullRange = noRange+                      , clauseTel       = tel+                      , namedClausePats = applySubst sub ps+                      , clauseBody      = Nothing+                      , clauseType      = Nothing+                      , clauseCatchall    = YesCatchall empty       -- absurd clauses are safe as catch-all                       , clauseRecursive   = Just False                       , clauseUnreachable = Just False                       , clauseEllipsis    = NoEllipsis+                      , clauseWhereModule = Nothing                       }       reportSDoc "tc.cover.missing" 20 $ inTopContext $ do         sep [ "adding missing absurd clause"@@ -244,44 +207,45 @@       return False    -- report a warning if there are uncovered cases,-  unless (null pss) $ do+  List1.unlessNull pss \ pss -> do     stLocalPartialDefs `modifyTCLens` Set.insert f     whenM ((YesCoverageCheck ==) <$> viewTC eCoverageCheck) $       setCurrentRange cs $ warning $ CoverageIssue f pss    -- Andreas, 2017-08-28, issue #2723:   -- Mark clauses as reachable or unreachable in the signature.-  -- Andreas, 2020-11-19, issue #5065-  -- Remember whether clauses are exact or not.-  let (is0, cs1) = unzip $ for (zip [0..] cs) $ \ (i, cl) -> let-          unreachable = i `IntSet.notMember` used-          exact       = i `IntSet.notMember` (IntSet.fromList noex)-        in (boolToMaybe unreachable i, cl-             { clauseUnreachable = Just unreachable-             , clauseExact       = Just exact-             })-  -- is = indices of unreachable clauses-  let is = catMaybes is0-  reportSDoc "tc.cover.top" 10 $ vcat-    [ text $ "unreachable clauses: " ++ if null is then "(none)" else show is-    ]+  let cs1 = zip [0..] cs <&> \ (i, cl) -> cl+             { clauseUnreachable = Just $ i `IntSet.notMember` used+             }+   -- Replace the first clauses by @cs1@.  There might be more   -- added by @inferMissingClause@.   modifyFunClauses f $ \ cs0 -> cs1 ++ drop (length cs1) cs0    -- Warn if there are unreachable clauses and mark them as unreachable.-  unless (null is) $ do+  List1.unlessNull (filter ((Just True ==) . clauseUnreachable) cs1) \ unreached -> do     -- Warn about unreachable clauses.-    let unreached = filter ((Just True ==) . clauseUnreachable) cs1-    let ranges    = map clauseFullRange unreached+    let ranges = fmap clauseFullRange unreached     setCurrentRange ranges $ warning $ UnreachableClauses f ranges -  -- report a warning if there are clauses that are not preserved as+  -- Partition clauses into exact and non-exact ones.+  let (noexclauses, exclauses) = partitionEithers $+        zipWith (\ i c  -> if i `IntSet.member` noex then Left c else Right c) [0..] cs1++  -- Report a warning if there are clauses that are not preserved as   -- definitional equalities and --exact-split is enabled-  unless (null noex) $ do-      let noexclauses = map (indexWithDefault __IMPOSSIBLE__ cs1) noex-      setCurrentRange (map clauseLHSRange noexclauses) $-        warning $ CoverageNoExactSplit f $ noexclauses+  -- and they are not labelled as CATCHALL.+  List1.unlessNull (filter (null . clauseCatchall) noexclauses) \ noexclauses -> do+      setCurrentRange (fmap clauseLHSRange noexclauses) $+        warning $ CoverageNoExactSplit f noexclauses++  -- Warn about unused CATCHALL pragmas.+  forM_ exclauses \ c ->+    case clauseCatchall c of+      YesCatchall r | not (null r)+        -> setCurrentRange r $ warning $ UselessPragma r $ "Superfluous CATCHALL pragma"+      _ -> pure ()+   return splitTree  -- | Top-level function for eliminating redundant clauses in the interactive@@ -305,18 +269,10 @@  -- to the user.  Rather, assume the clause is not already covered.  `catchError` \ _ -> return False -data CoverResult = CoverResult-  { coverSplitTree       :: SplitTree-  , coverUsedClauses     :: IntSet -- Set Nat-  , coverMissingClauses  :: [(Telescope, [NamedArg DeBruijnPattern])]-  , coverPatterns        :: [Clause]-  -- ^ The set of patterns used as cover.-  , coverNoExactClauses  :: IntSet -- Set Nat-  }---- | @cover f cs (SClause _ _ ps _) = return (splitTree, used, pss)@.+-- | @cover f cs (SClause _ _ ps _) = return (CoverResult splitTree used missing covering noex)@. --   checks that the list of clauses @cs@ covers the given split clause.---   Returns the @splitTree@, the @used@ clauses, and missing cases @pss@.+--   Returns the @splitTree@, the @used@ clauses, @missing@ cases, the @covering@ clauses,+--   and the non-exact clauses @noex@. -- --   Effect: adds missing instance clauses for @f@ to signature. --@@ -329,19 +285,34 @@     , nest 2 $ "target sort =" <+> do addContext tel $ maybe (text "<none>") (prettyTCM . getSort . unDom) target     ]   reportSLn "tc.cover.cover" 80 $ "raw target =\n" ++ show target+  verboseS  "tc.cover.matching" 20 $ do+    reportSLn "tc.cover.matching" 20 $ "clauses when matching:"+    forM_ cs $ \ c -> do+      let gamma = clauseTel c+          ps = namedClausePats c+      reportSDoc "tc.cover.matching" 20 $ addContext gamma $+          "ps   :" <+> prettyTCM (fmap namedArg ps)+   match cs ps >>= \case     Yes (i,mps) -> do       reportSLn "tc.cover.cover" 10 $ "pattern covered by clause " ++ show i       reportSDoc "tc.cover.cover" 20 $ text "with mps = " <+> do addContext tel $ pretty mps-      exact <- allM mps $ isTrivialPattern . snd       let cl0 = indexWithDefault __IMPOSSIBLE__ cs i+      -- Szumi, 2024-09-15, issue #7495: If the split clause has more+      -- patterns than the function clause, then the extra patterns need to+      -- be trivial for the clause to be exact+      let extra = drop (length $ namedClausePats cl0) ps+      exact <-+        and2M+          (forallM mps $ isTrivialPattern . snd)+          (forallM extra $ isTrivialPattern . namedArg)       cl <- applyCl sc cl0 mps       return $ CoverResult         { coverSplitTree      = SplittingDone (size tel)         , coverUsedClauses    = singleton i         , coverMissingClauses = []         , coverPatterns       = [cl]-        , coverNoExactClauses = IntSet.fromList [ i | not $ exact || clauseCatchall cl0 ]+        , coverNoExactClauses = if exact then empty else singleton i         }      No        ->  do@@ -397,11 +368,68 @@           Block{} -> Just c           No{}    -> Nothing +    -- Rename the variables in a telescope in accordance with their+    -- first appearance in the given NAPs. This is done to preserve+    -- variable names in IApplyConfluence error messages. Specifically,+    -- consider e.g.+    --+    --  data T : Set where+    --    x : T+    --    p : Path (Path T x x) refl refl+    --  f (p i j) = ...+    --+    -- When generating the covering clause corresponding to f's clause,+    -- the names we have in scope are i and i₁, since those are the+    -- names of both PathP binder arguments. (recall Path A x y = PathP (λ i → A) x y)+    -- So if we tried to print (Var 0 []) in the context of+    -- IApplyConfluence for that clause, what we see isn't j, it's i₁.+    --+    -- This function takes "name suggestions" from both variable+    -- patterns and IApply co/patterns, and replaces any existing names+    -- in the telescope by the name in that pattern.+    renTeleFromNap :: SplitClause -> Clause -> Telescope+    renTeleFromNap SClause{scTel = tel, scPats = sps} clause =+      telFromList $ evalState (traverse upd (telToList tel)) (size - offset)+      where+        ps = namedClausePats clause+        offset = 1 + length (fromSplitPatterns sps) - length ps+        -- Fold a single pattern into a map of name suggestions:+        -- In the running example above, we have+        --    f (p i@1 j@0)+        -- so the map that nameSuggest (p ...) returns is {0 → j, 1 → j}+        nameSuggest :: DeBruijnPattern -> IntMap ArgName+        nameSuggest ps = flip foldPattern ps $ \case+          VarP _ i | dbPatVarName i /= "_" ->+            IntMap.singleton (dbPatVarIndex i) (dbPatVarName i)+          IApplyP _ _ _ i | dbPatVarName i /= "_" ->+            IntMap.singleton (dbPatVarIndex i) (dbPatVarName i)+          _ -> mempty++        -- Suggestions from all patterns..+        suggestions = foldMap (nameSuggest . namedThing . unArg) ps++        -- The state will start counting from (length Γ - 1), which is+        -- the *highest* variable index, i.e. the index of the variable+        -- with level 0. Instead of doing a lot of de Bruijn arithmetic+        -- + recursion, traverse handles iteration and the State handles+        -- counting down.+        size = length (telToList tel)++        upd :: Dom (ArgName , Type) -> State Int (Dom (ArgName , Type))+        upd dom = state $ \s -> do+          case IntMap.lookup s suggestions of+            Just nm' -> ( dom{ domName = Just (WithOrigin CaseSplit (unranged nm'))+                             , unDom = (nm' , snd (unDom dom))+                             } , s - 1)+            Nothing -> (dom , s - 1)+     applyCl :: SplitClause -> Clause -> [(Nat, SplitPattern)] -> TCM Clause-    applyCl SClause{scTel = tel, scPats = sps} cl mps = addContext tel $ do+    applyCl sc@SClause{scTel = pretel, scPats = sps} cl mps+        | tel <- renTeleFromNap sc cl = addContext tel $ do         let ps = namedClausePats cl         reportSDoc "tc.cover.applyCl" 40 $ "applyCl"-        reportSDoc "tc.cover.applyCl" 40 $ "tel    =" <+> prettyTCM tel+        reportSDoc "tc.cover.applyCl" 40 $ "pretel =" <+> pretty pretel+        reportSDoc "tc.cover.applyCl" 40 $ "tel    =" <+> pretty tel         reportSDoc "tc.cover.applyCl" 40 $ "ps     =" <+> pretty ps         reportSDoc "tc.cover.applyCl" 40 $ "mps    =" <+> pretty mps         reportSDoc "tc.cover.applyCl" 40 $ "s      =" <+> pretty s@@ -437,16 +465,20 @@                     , namedClausePats = (s `applySubst` ps) ++ extra                     , clauseBody      = (`applyE` patternsToElims extra) . (s `applyPatSubst`) <$> clauseBody cl                     , clauseType      = ty-                    , clauseCatchall  = clauseCatchall cl-                    , clauseExact     = clauseExact cl-                    , clauseRecursive = clauseRecursive cl+                    , clauseCatchall    = clauseCatchall cl+                    , clauseRecursive   = clauseRecursive cl                     , clauseUnreachable = clauseUnreachable cl-                    , clauseEllipsis  = clauseEllipsis cl+                    , clauseEllipsis    = clauseEllipsis cl+                    , clauseWhereModule = clauseWhereModule cl                     }       where-        (vs,qs) = unzip mps-        mps' = zip vs $ map namedArg $ fromSplitPatterns $ map defaultNamedArg qs-        s = parallelS (for [0..maximum (-1:vs)] $ (\ i -> fromMaybe (deBruijnVar i) (List.lookup i mps')))+      mps' =+        Map.fromList $+        map (mapSnd (namedArg . fromSplitPattern . defaultNamedArg)) mps+      s = parallelS (for (case Map.lookupMax mps' of+                            Nothing     -> []+                            Just (i, _) -> [0..i]) $ \ i ->+                     fromMaybe (deBruijnVar i) (Map.lookup i mps'))      updateRelevance :: TCM a -> TCM a     updateRelevance cont =@@ -472,16 +504,24 @@           -- TODO Andrea: I guess an empty pattern is not part of the cover?           let qs = []           return $ CoverResult (SplittingDone (size tel)) empty [] qs empty-        Right (Covering n scs, x) -> do-          cs <- do-            let fallback = return cs+        Right (Covering n scs', x) -> do+          let scs = map (\(t,(sc,i)) -> (t,sc)) scs'++          (results_trX, cs) <- createMissingIndexedClauses f n x sc scs' cs+          (scs, cs, results_hc) <- do+            let fallback = return (scs, cs, [])             caseMaybeM (getPrimitiveName' builtinHComp) fallback $ \ comp -> do             let isComp = \case                   SplitCon c -> comp == c                   _ -> False-            caseMaybe (List.find (isComp . fst) scs) fallback $ \ (_, newSc) -> do-            snoc cs <$> createMissingHCompClause f n x sc newSc-          results <- mapM ((cover f cs) . snd) scs+            caseMaybe (List.find (isComp . fst) scs) fallback $ \ (sp, newSc) -> do+            (res,cs') <- createMissingHCompClause f n x sc newSc cs+            let scs2 = filter (not . isComp . fst) scs+            return (scs2,cs',res)+          let results_extra = results_hc ++ results_trX+              trees_extra = map (\(sp,cr) -> (sp, coverSplitTree cr)) results_extra++          results <- (++ map snd (results_extra)) <$> mapM ((cover f cs) . snd) scs           let trees = map coverSplitTree      results               useds = map coverUsedClauses    results               psss  = map coverMissingClauses results@@ -498,9 +538,8 @@               , "ps  = " <+> prettyTCMPatternList (fromSplitPatterns ps)               ]             ]-          -- TODO Andrea: do something with etaRecordSplits and qsss?           let trees' = zipWith (etaRecordSplits (unArg n) ps) scs trees-              tree   = SplitAt n StrictSplit trees'   -- TODO: Lazy?+              tree   = SplitAt n StrictSplit (trees' ++ trees_extra) -- TODO: Lazy?           return $ CoverResult tree (IntSet.unions useds) (concat psss) (concat qsss) (IntSet.unions noex)      -- Try to split result@@ -554,7 +593,7 @@         Right (Covering n scs) -> do           -- If result splitting was successful, continue coverage checking.           (projs, results) <- unzip <$> do-            mapM (traverseF $ cover f cs <=< (snd <.> insertTrailingArgs False)) scs+            mapM (traverseF $ cover f cs <=< (snd <.> insertTrailingArgs False)) (map (\(t,(sc,i)) -> (t,sc)) scs)             -- OR:             -- forM scs $ \ (proj, sc') -> (proj,) <$> do             --   cover f cs =<< do@@ -597,13 +636,13 @@     addEtaSplits :: Int -> [NamedArg SplitPattern] -> SplitTree -> SplitTree     addEtaSplits k []     t = t     addEtaSplits k (p:ps) t = case namedArg p of-      VarP  _ _     -> addEtaSplits (k+1) ps t-      DotP  _ _     -> addEtaSplits (k+1) ps t+      VarP  _ _     -> addEtaSplits (k + 1) ps t+      DotP  _ _     -> addEtaSplits (k + 1) ps t       ConP c cpi qs -> SplitAt (p $> k) LazySplit [(SplitCon (conName c) , addEtaSplits k (qs ++ ps) t)]       LitP{}        -> __IMPOSSIBLE__       ProjP{}       -> __IMPOSSIBLE__       DefP{}        -> __IMPOSSIBLE__ -- Andrea: maybe?-      IApplyP{}     -> addEtaSplits (k+1) ps t+      IApplyP{}     -> addEtaSplits (k + 1) ps t      etaRecordSplits :: Int -> [NamedArg SplitPattern] -> (SplitTag,SplitClause)                     -> SplitTree -> (SplitTag,SplitTree)@@ -611,241 +650,6 @@       (q , addEtaSplits 0 (gatherEtaSplits n sc ps) t)  ----- | Append an hcomp clause to the clauses of a function.-createMissingHCompClause-  :: QName-       -- ^ Function name.-  -> Arg Nat -- ^ index of hcomp pattern-  -> BlockingVar -- ^ Blocking var that lead to hcomp split.-  -> SplitClause -- ^ Clause before the hcomp split-  -> SplitClause-       -- ^ Clause to add.-   -> TCM Clause-createMissingHCompClause f n x old_sc (SClause tel ps _sigma' cps (Just t)) = setCurrentRange f $ do-  reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "Trying to create right-hand side of type" <+> prettyTCM t-  reportSDoc "tc.cover.hcomp" 30 $ addContext tel $ text "ps = " <+> prettyTCMPatternList (fromSplitPatterns ps)-  reportSDoc "tc.cover.hcomp" 30 $ text "tel = " <+> prettyTCM tel--  io      <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIOne-  iz      <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIZero-  let-    cannotCreate :: forall m a. (MonadTCEnv m, ReadTCState m, MonadError TCErr m) => Doc -> Closure (Abs Type) -> m a-    cannotCreate doc t = do-      typeError . SplitError $ CannotCreateMissingClause f (tel,fromSplitPatterns ps) doc t-  let old_ps = patternsToElims $ fromSplitPatterns $ scPats old_sc-      old_t  = fromJust $ scTarget old_sc-      old_tel = scTel old_sc-      -- old_tel = Γ(x:H)Δ-      -- Γ(x:H)Δ ⊢ old_t-      -- vs = iApplyVars old_ps-      -- [ α ⇒ b ] = [(i,f old_ps (i=0),f old_ps (i=1)) | i <- vs]--      -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ]-      -- Γ(x:H)Δ ⊢ f old_ps : old_t [ α ⇒ b ]-      -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ rhs_we_define : (old_t[ α ⇒ b ])(x = hcomp φ u u0)--      -- Extra assumption:-      -- tel = Γ,φ,u,u0,Δ(x = hcomp φ u u0),Δ'-      -- ps = old_ps[x = hcomp φ u u0],ps'-      -- with Δ' and ps' introduced by fixTarget.-      -- So final clause will be:-      -- tel ⊢ ps ↦ rhs_we_define{wkS ..} ps'-      getLevel t = do-        s <- reduce $ getSort t-        case s of-          Type l -> pure (Level l)-          s      -> do-            reportSDoc "tc.cover.hcomp" 20 $ text "getLevel, s = " <+> prettyTCM s-            typeError . GenericDocError =<<-                    (text "The sort of" <+> prettyTCM t <+> text "should be of the form \"Set l\"")--      -- Γ ⊢ hdelta = (x : H)(δ : Δ)-      (gamma,hdelta@(ExtendTel hdom delta)) = splitTelescopeAt (size old_tel - (blockingVarNo x + 1)) old_tel--      -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢-      (working_tel,_deltaEx) = splitTelescopeAt (size gamma + 3 + size delta) tel--      -- Γ,φ,u,u0,(x:H)(δ : Δ) ⊢ rhoS : Γ(x:H)(δ : Δ)-      {- rhoS = liftS (size hdelta) $ raiseS 3 -}-      vs = iApplyVars (scPats old_sc)--  -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ] = [(i,f old_ps (i=0),f old_ps (i=1)) | i <- vs]-  alphab <- forM vs $ \ i -> do-               let-                 -- Γ(x:H)(δ : Δ) ⊢-                 tm = Def f old_ps-               -- TODO only reduce IApply _ _ (0/1), as to avoid termination problems-               (l,r) <- reduce (inplaceS i iz `applySubst` tm, inplaceS i io `applySubst` tm)-               return $ (var i, (l, r))----  cl <- do-    (ty,rhs) <- addContext working_tel $ do-      -- Γ(x:H)Δ ⊢ g = f old_ps : old_t [ α ⇒ b ]-      -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ]-      -- Γ,φ,u,u0 ⊢ Δf = i.Δ[x = hfill φ u u0 i]-      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ δ_fill     = i.tFillTel (i. Δf[~i]) δ (~ i) : i.Δf[i]-      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ old_t_fill = i.old_t[x = hfill φ u u0 i, δ_fill[i]]-      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ comp (\ i. old_t_fill[i])-      --                 (\ i. [ φ ↦ g[x = hfill φ u u0 i,δ_fill[i]] = g[u i,δ_fill[i]]-      --                         α ↦ b[x = hfill φ u u0 i,δ_fill[i]]-      --                        ])-      --                 (g[x = u0,δ_fill[0]]) : old_t[x = hcomp φ u u0,δ]--      runNamesT [] $ do-          tPOr <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPOr-          tIMax <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIMax-          tIMin <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIMin-          tINeg <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinINeg-          tHComp <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinHComp-          tTrans <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinTrans-          extra_ps <- open $ patternsToElims $ fromSplitPatterns $ drop (length old_ps) ps-          let-            ineg j = pure tINeg <@> j-            imax i j = pure tIMax <@> i <@> j-            trFillTel' a b c d = do-              m <- trFillTel <$> a <*> b <*> c <*> d-              x <- lift $ runExceptT m-              case x of-                Left bad_t -> cannotCreate "Cannot transport with type family:" bad_t-                Right args -> return args-          comp <- do-            let forward la bA r u = pure tTrans <#> lam "i" (\ i -> la <@> (i `imax` r))-                                              <@> lam "i" (\ i -> bA <@> (i `imax` r))-                                              <@> r-                                              <@> u-            return $ \ la bA phi u u0 ->-              pure tHComp <#> (la <@> pure io) <#> (bA <@> pure io) <#> phi-                        <@> lam "i" (\ i -> ilam "o" $ \ o ->-                                forward la bA i (u <@> i <..> o))-                        <@> forward la bA (pure iz) u0-          let-            hcomp la bA phi u u0 = pure tHComp <#> la <#> bA-                                               <#> phi-                                               <@> u-                                               <@> u0--            hfill la bA phi u u0 i = hcomp la bA-                                               (pure tIMax <@> phi <@> (pure tINeg <@> i))-                                               (lam "j" $ \ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <#> ilam "o" (\ _ -> bA)-                                                     <@> ilam "o" (\ o -> u <@> (pure tIMin <@> i <@> j) <..> o)-                                                     <@> ilam "o" (\ _ -> u0)-                                                   )-                                               u0-          -- Γ,φ,u,u0,(δ : Δ(x = hcomp φ u u0)) ⊢ hcompS : Γ(x:H)(δ : Δ)-          hcompS <- lift $ do-            hdom <- pure $ raise 3 hdom-            let-              [phi,u,u0] = map (pure . var) [2,1,0]-              htype = pure $ unEl . unDom $ hdom-              lvl = getLevel $ unDom hdom-            hc <- pure tHComp <#> lvl <#> htype-                                      <#> phi-                                      <@> u-                                      <@> u0-            return $ liftS (size delta) $ hc `consS` raiseS 3-          -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ raise 3+|Δ| hdom-          hdom <- pure $ raise (3+size delta) hdom-          htype <- open $ unEl . unDom $ hdom-          lvl <- open =<< (lift . getLevel $ unDom hdom)--          -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢-          [phi,u,u0] <- mapM (open . raise (size delta) . var) [2,1,0]-          -- Γ,x,Δ ⊢ f old_ps-          -- Γ ⊢ abstract hdelta (f old_ps)-          g <- open $ raise (3+size delta) $ abstract hdelta (Def f old_ps)-          old_t <- open $ raise (3+size delta) $ abstract hdelta (unDom old_t)-          let bapp a x = lazyAbsApp <$> a <*> x-          (delta_fill :: NamesT TCM (Abs Args)) <- (open =<<) $ do-            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ x.Δ-            delta <- open $ raise (3+size delta) delta-            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ i.Δ(x = hfill phi u u0 (~ i))-            deltaf <- open =<< bind "i" (\ i ->-                           (delta `bapp` hfill lvl htype phi u u0 (ineg i)))-            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ Δ(x = hcomp phi u u0) = Δf[0]-            args <- (open =<<) $ teleArgs <$> (lazyAbsApp <$> deltaf <*> pure iz)-            bind "i" $ \ i -> addContext ("i" :: String) $ do -- for error messages.-              -- Γ,φ,u,u0,Δ(x = hcomp phi u u0),(i:I) ⊢ ... : Δ(x = hfill phi u u0 i)-              trFillTel' deltaf (pure iz) args (ineg i)-          let-            apply_delta_fill i f = apply <$> f <*> (delta_fill `bapp` i)-            call v i = apply_delta_fill i $ g <@> v-          ty <- do-                return $ \ i -> do-                    v <- hfill lvl htype phi u u0 i-                    hd <- old_t-                    args <- delta_fill `bapp` i-                    lift $ piApplyM hd $ Arg (domInfo hdom) v : args-          ty_level <- do-            t <- bind "i" ty-            s <- reduce $ getSort (absBody t)-            reportSDoc "tc.cover.hcomp" 20 $ text "ty_level, s = " <+> prettyTCM s-            case s of-              Type l -> open =<< lam "i" (\ _ -> pure $ Level l)-              _      -> cannotCreate "Cannot compose with type family:" =<< liftTCM (buildClosure t)--          let-            pOr_ty i phi psi u0 u1 = pure tPOr <#> (ty_level <@> i)-                                               <@> phi <@> psi-                                               <#> ilam "o" (\ _ -> unEl <$> ty i) <@> u0 <@> u1-          alpha <- do-            vars <- mapM (open . applySubst hcompS . fst) alphab-            return $ foldr (imax . (\ v -> v `imax` ineg v)) (pure iz) vars--          -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ b : (i : I) → [α] -> old_t[x = hfill φ u u0 i,δ_fill[i]]-          b <- do-             sides <- forM alphab $ \ (psi,(side0,side1)) -> do-                psi <- open $ hcompS `applySubst` psi--                [side0,side1] <- mapM (open . raise (3+size delta) . abstract hdelta) [side0,side1]-                return $ (ineg psi `imax` psi, \ i -> pOr_ty i (ineg psi) psi (ilam "o" $ \ _ -> apply_delta_fill i $ side0 <@> hfill lvl htype phi u u0 i)-                                                            (ilam "o" $ \ _ -> apply_delta_fill i $ side1 <@> hfill lvl htype phi u u0 i))-             let recurse []           i = __IMPOSSIBLE__-                 recurse [(psi,u)]    i = u i-                 recurse ((psi,u):xs) i = pOr_ty i psi (foldr (imax . fst) (pure iz) xs) (u i) (recurse xs i)-             return $ recurse sides--          ((,) <$> ty (pure io) <*>) $ do-            comp ty_level-               (lam "i" $ fmap unEl . ty)-                           (phi `imax` alpha)-                           (lam "i" $ \ i ->-                               let rhs = (ilam "o" $ \ o -> call (u <@> i <..> o) i)-                               in if null alphab then rhs else-                                   pOr_ty i phi alpha rhs (b i)-                           )-                           (call u0 (pure iz))-    reportSDoc "tc.cover.hcomp" 20 $ text "old_tel =" <+> prettyTCM tel-    let n = size tel - (size gamma + 3 + size delta)-    reportSDoc "tc.cover.hcomp" 20 $ text "n =" <+> text (show n)-    (TelV deltaEx t,bs) <- telViewUpToPathBoundary' n ty-    rhs <- pure $ raise n rhs `applyE` teleElims deltaEx bs--    cxt <- getContextTelescope-    reportSDoc "tc.cover.hcomp" 30 $ text "cxt = " <+> prettyTCM cxt-    reportSDoc "tc.cover.hcomp" 30 $ text "tel = " <+> prettyTCM tel-    reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "t = " <+> prettyTCM t-    reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "rhs = " <+> prettyTCM rhs--    return $ Clause { clauseLHSRange  = noRange-                    , clauseFullRange = noRange-                    , clauseTel       = tel-                    , namedClausePats = fromSplitPatterns ps-                    , clauseBody      = Just $ rhs-                    , clauseType      = Just $ defaultArg t-                    , clauseCatchall  = False-                    , clauseExact       = Just True-                    , clauseRecursive   = Nothing     -- TODO: can it be recursive?-                    , clauseUnreachable = Just False  -- missing, thus, not unreachable-                    , clauseEllipsis  = NoEllipsis-                    }-  addClauses f [cl]  -- Important: add at the end.-  return cl-createMissingHCompClause _ _ _ _ (SClause _ _ _ _ Nothing) = __IMPOSSIBLE__- -- | Append a instance clause to the clauses of a function. inferMissingClause   :: QName@@ -875,11 +679,11 @@                   , namedClausePats = fromSplitPatterns ps                   , clauseBody      = Just rhs                   , clauseType      = Just (argFromDom t)-                  , clauseCatchall  = False-                  , clauseExact       = Just True+                  , clauseCatchall    = empty                   , clauseRecursive   = Nothing     -- could be recursive                   , clauseUnreachable = Just False  -- missing, thus, not unreachable-                  , clauseEllipsis  = NoEllipsis+                  , clauseEllipsis    = NoEllipsis+                  , clauseWhereModule = Nothing                   }   addClauses f [cl]  -- Important: add at the end.   return cl@@ -909,7 +713,7 @@ -- the data type must be inductive. isDatatype :: (MonadTCM tcm, MonadError SplitError tcm) =>               Induction -> Dom Type ->-              tcm (DataOrRecord, QName, [Arg Term], [Arg Term], [QName], Bool)+              tcm (DataOrRecord, QName, Sort, Args, Args, [QName], Bool) isDatatype ind at = do   let t       = unDom at       throw f = throwError . f =<< do liftTCM $ buildClosure t@@ -921,21 +725,22 @@     Def d [Apply phi] | Just d == mIsOne -> do                 xs <- liftTCM $ decomposeInterval =<< reduce (unArg phi)                 if null xs-                   then return $ (IsData, d, [phi], [], [], False)+                   then return $ (IsData, d, mkSSet 0, [phi], [], [], False)                    else throw NotADatatype     Def d es -> do       let ~(Just args) = allApplyElims es-      def <- liftTCM $ theDef <$> getConstInfo d-      case def of-        Datatype{dataPars = np, dataCons = cs}+      def <- liftTCM $ getConstInfo d+      case theDef def of+        Datatype{dataSort = s, dataPars = np, dataCons = cs}           | otherwise -> do               let (ps, is) = splitAt np args-              return (IsData, d, ps, is, cs, not $ null (dataPathCons def))+              return (IsData, d, s, ps, is, cs, not $ null (dataPathCons $ theDef def))         Record{recPars = np, recConHead = con, recInduction = i, recEtaEquality'}           | i == Just CoInductive && ind /= CoInductive ->               throw CoinductiveDatatype-          | otherwise ->-              return (IsRecord i recEtaEquality', d, args, [], [conName con], False)+          | otherwise -> do+              s <- liftTCM $ shouldBeSort =<< defType def `piApplyM` args+              return (IsRecord InductionAndEta { recordInduction=i, recordEtaEquality=recEtaEquality' }, d, s, args, [], [conName con], False)         _ -> throw NotADatatype     _ -> throw NotADatatype @@ -986,7 +791,7 @@   let fallback = return (empty, sc)   caseMaybe target fallback $ \ a -> do     if isJust (domTactic a) && not force then fallback else do-    (TelV tel b) <- telViewUpTo (-1) $ unDom a+    (TelV tel b) <- addContext sctel $ telViewUpTo (-1) $ unDom a     reportSDoc "tc.cover.target" 15 $ sep       [ "target type telescope: " <+> do           addContext sctel $ prettyTCM tel@@ -1038,6 +843,15 @@   | visible ai = setOrigin UserWritten ai   | otherwise  = setOrigin Inserted ai ++-- | Checks if a type in this sort supports hcomp.+--   currently all such types will have a Level.+--   precondition: Sort in whnf and not blocked.+hasHComp :: Sort -> Maybe Level+hasHComp (Type l) = Just l+hasHComp _        = Nothing++ computeHCompSplit  :: Telescope   -- ^ Telescope before split point.   -> PatVarName                   -- ^ Name of pattern variable at split point.   -> Telescope                    -- ^ Telescope after split point.@@ -1051,13 +865,18 @@   -- -> QName                        -- ^ Constructor to fit into hole.   -> CoverM (Maybe (SplitTag,SplitClause))   -- ^ New split clause if successful. computeHCompSplit delta1 n delta2 d pars ixs hix tel ps cps = do+  withK   <- not <$> cubicalCompatibleOption+  if withK then return Nothing else do     -- Get the type of the datatype   -- Δ1 ⊢ dtype   dsort <- liftTCM $ (parallelS (reverse $ map unArg pars) `applySubst`) . dataSort . theDef <$> getConstInfo d   hCompName <- fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' builtinHComp   theHCompT <- defType <$> getConstInfo hCompName++  -- TODO can dsort be blocked or not in whnf?+  caseMaybe (hasHComp dsort) (return Nothing) $ \ dlvl' -> do   let-    dlvl = Level . (\ (Type s) -> s) $ dsort+    dlvl = Level dlvl'     dterm = Def d [] `apply` (pars ++ ixs)   -- Δ1 ⊢ gamma   TelV gamma _ <- lift $ telView (theHCompT `piApply` [setHiding Hidden $ defaultArg $ dlvl , defaultArg $ dterm])@@ -1068,7 +887,7 @@       -- We have Δ₁' ⊢ ρ₀ : Δ₁Γ, so split it into the part for Δ₁ and the part for Γ       let (rho1,rho2) = splitS (size gamma) $ toSplitPSubst rho0 -      let defp = DefP defaultPatternInfo hCompName . map (setOrigin Inserted) $+      let defp = DefP defaultPatternInfo hCompName . map (setOrigin Inserted) $ -- should there be a different Origin here?                    map (fmap unnamed) [setHiding Hidden $ defaultArg $ applySubst rho1 $ DotP defaultPatternInfo $ dlvl                                       ,setHiding Hidden $ defaultArg $ applySubst rho1 $ DotP defaultPatternInfo $ dterm]                    ++ applySubst rho2 (teleNamedArgs gamma) -- rho0?@@ -1091,7 +910,6 @@       return $ Just . (SplitCon hCompName,) $ SClause delta' ps' rho cps' Nothing -- target fixed later  - -- | @computeNeighbourhood delta1 delta2 d pars ixs hix tel ps con@ -- --   @@@ -1120,7 +938,7 @@   -> [NamedArg SplitPattern]      -- ^ Patterns before doing the split.   -> Map CheckpointId Substitution -- ^ Current checkpoints   -> QName                        -- ^ Constructor to fit into hole.-  -> CoverM (Maybe SplitClause)   -- ^ New split clause if successful.+  -> CoverM (Maybe (SplitClause, IInfo))   -- ^ New split clause if successful. computeNeighbourhood delta1 n delta2 d pars ixs hix tel ps cps c = do    -- Get the type of the datatype@@ -1136,7 +954,8 @@    -- Lookup the type of the constructor at the given parameters   (gamma0, cixs, boundary) <- do-    (TelV gamma0 (El _ d), boundary) <- liftTCM $ telViewPathBoundaryP (ctype `piApply` pars)+    (TelV gamma0 (El _ d), boundary) <- liftTCM $ addContext delta1 $+      telViewPathBoundary (ctype `piApply` pars)     let Def _ es = d         Just cixs = allApplyElims es     return (gamma0, cixs, boundary)@@ -1166,22 +985,34 @@   -- Andrea 2019-07-17 propagate the Cohesion to the equation telescope   -- TODO: should we propagate the modality in general?   -- See also LHS checking.-  dtype <- do+  dtype <- addContext delta1 $ do          let updCoh = composeCohesion (getCohesion info)          TelV dtel dt <- telView dtype          return $ abstract (mapCohesion updCoh <$> dtel) dt+  dsort <- addContext delta1 $ reduce (getSort dtype) -  withKIfStrict <- addContext delta1 $ reduce (getSort dtype) >>= \case-    SSet{} -> return $ locallyTC eSplitOnStrict $ const True-    _      -> return id+  let withKIfStrict = applyWhen (isStrictDataSort dsort) $ locallyTC eSplitOnStrict $ const True -  r <- withKIfStrict $ unifyIndices-         delta1Gamma-         flex-         (raise (size gamma) dtype)-         conIxs-         givenIxs+  -- Should we attempt to compute a left inverse for this clause? When+  -- --cubical-compatible --flat-split is given, we don't generate a+  -- left inverse (at all). This means that, when the coverage checker+  -- gets to the clause this was in, it won't generate a (malformed!)+  -- transpX clause for @♭ matching.+  -- TODO(Amy): properly support transpX when @♭ stuff is in the+  -- context.+  let flatSplit = boolToMaybe (getCohesion info == Flat) SplitOnFlat +  r <- withKIfStrict $ lift $+         Bench.billTo [Bench.Coverage, Bench.UnifyIndices] $+           unifyIndices' flatSplit+             delta1Gamma+             flex+             (raise (size gamma) dtype)+             conIxs+             givenIxs++  TelV eqTel _ <- telView $ (raise (size gamma) dtype)+   let stuck b errs = do         debugCantSplit         throwError $ UnificationStuck b (conName con) (delta1 `abstract` gamma) conIxs givenIxs errs@@ -1194,7 +1025,24 @@      UnifyStuck errs -> stuck Nothing errs -    Unifies (delta1',rho0,_) -> do+    Unifies (delta1',rho0,eqs,tauInv) -> do++      let unifyInfo | Type _ <- dsort     -- only types of sort Type l have trX constructors:+                                          -- re #3733: update if we add transp for other sorts.+                    , not $ null $ conIxs -- no point propagating this info if trivial?+                    , Right (tau,leftInv) <- tauInv+            = TheInfo $ UE delta1Gamma delta1' eqTel (map unArg conIxs) (map unArg givenIxs) rho0 tau leftInv+                    | otherwise+            = NoInfo++      case tauInv of+        Right{} -> return ()+        Left SplitOnStrict -> return ()+        Left x -> do+          whenM cubicalCompatibleOption $ do+            -- re #3733: TODO better error msg.+            lift $ warning . UnsupportedIndexedMatch =<< prettyTCM x+       debugSubst "rho0" rho0        let rho0' = toSplitPSubst rho0@@ -1208,7 +1056,8 @@       -- Andreas, 2017-09-03, issue #2729: remember that pattern was generated by case split.       let cpi  = noConPatternInfo{ conPInfo = PatternInfo PatOSplit [] , conPRecord = True }           conp = ConP con cpi $ applySubst rho0' $-                   map (mapArgInfo hiddenInserted) $ telePatterns' (tele2NamedArgs gamma0) gamma boundary+                   map (mapArgInfo hiddenInserted . fmap (fmap setSplitArgOrigin)) $+                   telePatterns' (tele2NamedArgs gamma0) gamma boundary           -- Andreas, 2016-09-08, issue #2166: use gamma0 for correct argument names        -- Compute final context and substitution@@ -1227,9 +1076,14 @@        let cps'  = applySplitPSubst rho cps -      return $ Just $ SClause delta' ps' rho cps' Nothing -- target fixed later+      return $ Just . (,unifyInfo) $ SClause delta' ps' rho cps' Nothing -- target fixed later    where+    setSplitArgOrigin :: SplitPattern -> SplitPattern+    setSplitArgOrigin (VarP i x) = VarP (i { patOrigin = PatOSplitArg (splitPatVarName x) }) x+    setSplitArgOrigin (IApplyP i u v x) = IApplyP (i { patOrigin = PatOSplitArg (splitPatVarName x)}) u v x+    setSplitArgOrigin p = p+     debugInit con ctype d pars ixs cixs delta1 delta2 gamma tel ps hix = liftTCM $ do       reportSDoc "tc.cover.split.con" 20 $ vcat         [ "computeNeighbourhood"@@ -1243,7 +1097,7 @@           , "ixs    =" <+> do addContext delta1 $ prettyList $ map prettyTCM ixs           , "cixs   =" <+> do addContext gamma  $ prettyList $ map prettyTCM cixs           , "delta1 =" <+> do inTopContext $ prettyTCM delta1-          , "delta2 =" <+> do inTopContext $ addContext delta1 $ addContext gamma $ prettyTCM delta2+          , "delta2 =" <+> do inTopContext $ addContext delta1 $ addContext n $ prettyTCM delta2           , "gamma  =" <+> do inTopContext $ addContext delta1 $ prettyTCM gamma           , "tel  =" <+> do inTopContext $ prettyTCM tel           , "hix    =" <+> text (show hix)@@ -1322,7 +1176,7 @@ splitLast ind tel ps = split ind NoAllowPartialCover sc (BlockingVar 0 [] [] True False)   where sc = SClause tel (toSplitPatterns ps) empty empty target         -- TODO 2ltt: allows (Empty_fib -> Empty_strict) which is not conservative-        target = (Just $ defaultDom $ El (Prop (Max 0 [])) $ Dummy "splitLastTarget" [])+        target = (Just $ defaultDom $ El (mkProp 0) $ __DUMMY_TERM_WITH__ "splitLastTarget")  -- | @split ind splitClause x = return res@ --   splits @splitClause@ at pattern var @x@ (de Bruijn index).@@ -1411,18 +1265,22 @@         -- Check that t is a datatype or a record         -- Andreas, 2010-09-21, isDatatype now directly throws an exception if it fails         -- cons = constructors of this datatype-        (dr, d, pars, ixs, cons', isHIT) <- inContextOfT $ isDatatype ind t+        (dr, d, s, pars, ixs, cons', isHIT) <- inContextOfT $ isDatatype ind t+        isFib <- fromRight (const False) <$> lift (isFibrant' t)         cons <- case checkEmpty of           CheckEmpty   -> ifM (liftTCM $ inContextOfT $ isEmptyType $ unDom t) (pure []) (pure cons')           NoCheckEmpty -> pure cons'         mns  <- forM cons $ \ con -> fmap (SplitCon con,) <$>           computeNeighbourhood delta1 n delta2 d pars ixs x tel ps cps con-        hcompsc <- if isHIT && inserttrailing == DoInsertTrailing+        hcompsc <- if isFib && (isHIT || not (null ixs)) && not (null mns) && inserttrailing == DoInsertTrailing                    then computeHCompSplit delta1 n delta2 d pars ixs x tel ps cps                    else return Nothing+        let ns = catMaybes mns         return ( dr+               , s                , not (null ixs) -- Is "d" indexed?-               , catMaybes (mns ++ [hcompsc])+               , length $ ns+               , ns ++ catMaybes ([fmap (fmap (,NoInfo)) hcompsc | not $ null $ ns])                )        computeLitNeighborhoods = do@@ -1452,33 +1310,44 @@         -- to an inductive family (with at least one index), then the         -- following code should be changed (the constructor False         -- stands for "not indexed").-        return (IsData, False, ns ++ [ ca ])+        let ns' = map ((fmap (,NoInfo))) $ ns ++ [ ca ]+        return (IsData, mkType 0, False, length ns', ns') -  (dr, isIndexed, ns) <- if null pcons' && not (null plits)+  -- numMatching is the number of proper constructors matching, excluding hcomp.+  -- for literals this considers the catchall clause as 1 extra constructor.+  (dr, s, isIndexed, numMatching, ns) <- if null pcons' && not (null plits)         then computeLitNeighborhoods         else computeNeighborhoods    ns <- case target of-    Just a  -> forM ns $ \ (con, sc) -> lift $ (con,) <$>+    Just a  -> forM ns $ \ (con,(sc,info)) -> lift $ (con,) . (,info) <$>                  fixTargetType (getQuantity t) con sc a     Nothing -> return ns    ns <- case inserttrailing of     DontInsertTrailing -> return ns-    DoInsertTrailing   -> lift $ forM ns $ \(con,sc) ->-      (con,) . snd <$> insertTrailingArgs False sc+    DoInsertTrailing   -> lift $ forM ns $ \(con,(sc,info)) ->+      (con,) . (,info) . snd <$> insertTrailingArgs False sc    mHCompName <- getPrimitiveName' builtinHComp-  withoutK   <- collapseDefault . optWithoutK <$> pragmaOptions+  opts       <- pragmaOptions+  let withoutK        = optWithoutK opts+      erasedMatches   = optErasedMatches opts+      isRecordWithEta = case dr of+        IsData       -> False+        IsRecord r ->+          case theEtaEquality (recordEtaEquality r) of+            YesEta{} -> True+            NoEta{}  -> False -  erased <- asksTC hasQuantity0+  erased <- hasQuantity0 <$> viewTC eQuantity   reportSLn "tc.cover.split" 60 $ "We are in erased context = " ++ show erased-  let erasedError causedByWithoutK =-        throwError . ErasedDatatype causedByWithoutK =<<+  let erasedError reason =+        throwError . ErasedDatatype reason =<<           do liftTCM $ inContextOfT $ buildClosure (unDom t) -  case ns of-    []  -> do+  case numMatching of+    0  -> do       let absurdp = VarP (PatternInfo PatOAbsurd []) $ SplitPatVar underscore 0 []           rho = liftS x $ consS absurdp $ raiseS 1           ps' = applySubst rho ps@@ -1491,15 +1360,16 @@                }      -- Andreas, 2018-10-17: If more than one constructor matches, we cannot erase.-    _ : _ : _ | not erased && not (usableQuantity t) ->-      erasedError False+    n | n > 1 && not erased && not (usableQuantity t) ->+      erasedError SeveralConstructors      -- If exactly one constructor matches and the K rule is turned-    -- off, then we only allow erasure for non-indexed data types-    -- (#4172).-    [_] | not erased && not (usableQuantity t) &&-          withoutK && isIndexed ->-      erasedError True+    -- off, then we only allow erasure for non-indexed data/record+    -- types (#4172). If the type is not a record type with+    -- η-equality, then the flag --erased-matches must be active.+    1 | not erased && not (usableQuantity t) && withoutK &&+        (isIndexed || not isRecordWithEta && not erasedMatches) ->+      erasedError (if isIndexed then NoK else NoErasedMatches)      _ -> do @@ -1512,9 +1382,9 @@       let all_tags = Set.fromList ptags `Set.union` inferred_tags        when (allowPartialCover == NoAllowPartialCover && not overlap) $-        for_ ns $ \(tag, sc) -> do+        for_ ns $ \(tag, (sc, _)) -> do           unless (tag `Set.member` all_tags) $ do-            isImpossibleClause <- liftTCM $ isEmptyTel $ scTel sc+            isImpossibleClause <- isEmptyTel $ scTel sc             unless isImpossibleClause $ do               liftTCM $ reportSDoc "tc.cover" 10 $ vcat                 [ text "Missing case for" <+> prettyTCM tag@@ -1522,7 +1392,8 @@                 ]               throwError (GenericSplitError "precomputed set of constructors does not cover all cases") -      liftTCM $ checkSortOfSplitVar dr (unDom t) delta2 target+      let t' = set lensSort s $ unDom t+      liftTCM $ inContextOfT $ checkSortOfSplitVar dr t' delta2 target       return $ Right $ Covering (lookupPatternVar sc x) ns    where@@ -1598,9 +1469,10 @@   -- if we want to split projections, but have no target type, we give up   let failure = return . Left   caseMaybe target (failure CosplitNoTarget) $ \ t -> do-    isR <- addContext tel $ isRecordType $ unDom t-    case isR of-      Just (_r, vs, Record{ recFields = fs }) -> do+    (addContext tel $ isRecordType $ unDom t) >>= \case+      Nothing -> addContext tel $ do+        failure . CosplitNoRecordType =<< buildClosure (unDom t)+      Just (_r, vs, RecordData{ _recFields = fs }) -> do         reportSDoc "tc.cover" 20 $ sep           [ text $ "we are of record type _r = " ++ prettyShow _r           , text   "applied to parameters vs =" <+> addContext tel (prettyTCM vs)@@ -1645,9 +1517,7 @@             reportSDoc "tc.cover.copattern" 40 $ vcat               [ "fieldSub for" <+> prettyTCM (unDom proj)               , nest 2 $ pretty fieldSub ]-            return (SplitCon (unDom proj), sc')-      _ -> addContext tel $ do-        buildClosure (unDom t) >>= failure . CosplitNoRecordType+            return (SplitCon (unDom proj), (sc', NoInfo))   -- Andreas, 2018-06-09, issue #2170: splitting with irrelevant fields is always fine!   -- where   -- -- A record type is strong if it has all the projections.
+ src/full/Agda/TypeChecking/Coverage/Cubical.hs view
@@ -0,0 +1,1141 @@+{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.Coverage.Cubical where++import Prelude hiding (null, (!!))  -- do not use partial functions like !!++import Control.Monad.Except ( runExceptT )++import qualified Data.Set as Set+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++import Agda.Syntax.Common+import Agda.Syntax.Position+import Agda.Syntax.Internal hiding (DataOrRecord)+import Agda.Syntax.Internal.Pattern+import Agda.Syntax.Common.Pretty (prettyShow)++import Agda.TypeChecking.Constraints () -- instance MonadConstraint TCM+import Agda.TypeChecking.Coverage.Match+import Agda.TypeChecking.Coverage.SplitClause+import Agda.TypeChecking.Coverage.SplitTree+import Agda.TypeChecking.Datatypes (getDatatypeArgs)+import Agda.TypeChecking.Irrelevance+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Names+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Primitive hiding (Nat)+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Telescope.Path++import Agda.Utils.Either ( fromRight )+import Agda.Utils.Functor+import Agda.Utils.List+import Agda.Utils.List1 ( pattern (:|) )+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Permutation+import Agda.Utils.Singleton+import Agda.Utils.Size++import Agda.Utils.Impossible+++createMissingIndexedClauses :: QName+                            -> Arg Nat+                            -> BlockingVar+                            -> SplitClause+                            -> [(SplitTag,(SplitClause,IInfo))]+                            -> [Clause]+                            -> TCM ([(SplitTag,CoverResult)],[Clause])+createMissingIndexedClauses f n x old_sc scs cs = do+  let infos = [(c,i) | (SplitCon c, (_,TheInfo i)) <- scs ]+  case scs of+    xs | info:_ <- infos -> do+         reportSDoc "tc.cover.indexed" 20 $ text "size (xs,infos):" <+> pretty (size xs,size infos)+         reportSDoc "tc.cover.indexed" 20 $ text "xs :" <+> pretty (map fst xs)++         unless (size xs == 1 + size infos) $+            reportSDoc "tc.cover.indexed" 20 $ text "missing some infos"+            -- Andrea: what to do when we only managed to build a unification proof for some of the constructors?+         Constructor{conData} <- theDef <$> getConstInfo (fst info)+         Datatype{dataPars = pars, dataIxs = nixs, dataTranspIx} <- theDef <$> getConstInfo conData+         hcomp <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinHComp+         trX <- fromMaybe __IMPOSSIBLE__ <$> pure dataTranspIx+         trX_cl <- createMissingTrXTrXClause trX f n x old_sc+         hcomp_cl <- createMissingTrXHCompClause trX f n x old_sc+         (trees,cls) <- fmap unzip . forM infos $ \ (c,i) -> do+           cl <- createMissingTrXConClause trX f n x old_sc c i+           return $ ((SplitCon c , SplittingDone (size $ clauseTel cl)) , cl)+         let extra = [ (SplitCon trX, SplittingDone $ size $ clauseTel trX_cl)+                                           , (SplitCon hcomp, SplittingDone $ size $ clauseTel hcomp_cl)+                                           ]+                 --  = [ (SplitCon trX, SplittingDone $ size $ clauseTel trX_cl) ]+             extraCl = [trX_cl, hcomp_cl]+                 --  = [trX_cl]+         let clauses = cls ++ extraCl+         let tree = SplitAt (n <&> (+ (pars + nixs + 1))) StrictSplit $+                                           trees+                                        ++ extra+             res = CoverResult+               { coverSplitTree      = tree+               , coverUsedClauses    = let l = length cs in IntSet.fromAscList [l .. l + length clauses - 1]+               , coverMissingClauses = []+               , coverPatterns       = clauses+               , coverNoExactClauses = IntSet.empty+               }+         reportSDoc "tc.cover.indexed" 20 $+           "tree:" <+> pretty tree+         addClauses f clauses+         return ([(SplitCon trX, res)], cs ++ clauses)+    xs | otherwise -> return ([], cs)++covFillTele :: QName -> Abs Telescope -> Term -> Args -> Term -> TCM [Term]+covFillTele func tel face d j = do+  ed_f <- liftTCM $ runExceptT $ trFillTel tel face d j+  case ed_f of+    Right d_f -> pure $ map unArg d_f+    Left failed_t -> typeError $ CannotGenerateTransportClause func failed_t++createMissingTrXTrXClause :: QName -- ^ trX+                            -> QName -- ^ f defined+                            -> Arg Nat+                            -> BlockingVar+                            -> SplitClause+                            -> TCM Clause+createMissingTrXTrXClause q_trX f n x old_sc = do+  let+   old_tel = scTel old_sc+   old_ps = fromSplitPatterns $ scPats old_sc+   old_t = fromMaybe __IMPOSSIBLE__ $ scTarget old_sc++  reportSDoc "tc.cover.trx.trx" 20 $ "trX-trX clause for" <+> prettyTCM f+  reportSDoc "tc.cover.trx.trx" 20 $ nest 2 $ vcat $+    [ "old_tel:" <+> prettyTCM old_tel+    , "old_ps :" <+> addContext old_tel (prettyTCM $ patternsToElims old_ps)+    , "old_t  :" <+> addContext old_tel (prettyTCM old_t)+    ]++  -- TODO: redo comments, the strategy changed.+  -- old_tel = Γ1, (x : D η v), Δ+  -- α = boundary(old_ps)+  -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [ α ↦ (f old_ps)[α] ]++  -- α' = boundary(old_ps[x = pat])+  -- Γ1, φ : I, p : Path X(η) _ v, ψ : I, q : Path X(η) _ (p i0), x0 : D η (q i0) ⊢ pat := trX p φ (trX q ψ x0) : D η v++  -- Ξ = Γ1, φ : I, p : Path X(η) _ v, ψ : I, q : Path X(η) _ (p i0), x0 : D η (q i0), Δ[x = pat]++  -- Ξ ⊢ w1 := f old_ps[γ1,x = pat,δ] : old_t[γ1,x = pat,δ] -- the case we are defining. can only be used if specialized.++  -- Ξ ⊢ rhs : old_t[γ1,x = pat,δ] [ α' ↦ w1[α']+                                -- , φ  ↦ w1[φ = i1, p = refl]+                                -- , ψ  ↦ w1[ψ = i1, q = refl]+                                -- ]+  -- Ξ ⊢ q2 := tr (i. Path X(η) (q i0) (p i)) φ q : Path X(η) (q i0) (p i1)+  -- Ξ ⊢ pat_rec[0] = pat : D η v+  -- Ξ ⊢ pat_rec[1] = trX q2 (φ ∧ ψ) x0 : D η v+  -- Ξ ⊢ pat-rec[i] := trX (\ j → p (i ∨ j)) (i ∨ φ) (trX (q2_f i) (ψ ∧ (φ ∨ ~ i)) t)++  -- Ξ ⊢ δ_f[1] = tr (i. Δ[γ1,x = pat_rec[i]]) (φ ∧ ψ) δ+  -- Ξ ⊢ w0 := f old_ps[γ1,x = pat_rec[1] ,δ_f[1]] : old_t[γ1,x = pat_rec[1],δ_f[1]]+  -- Ξ ⊢ rhs := tr (i. old_t[γ1,x = pat_rec[~i], δ_f[~i]]) (φ ∧ ψ) w0 -- TODO plus sides.++  interval <- elInf primInterval+  iz <- primIZero+  io <- primIOne+  tHComp <- primHComp+  tNeg <- primINeg+  let neg i = pure tNeg <@> i+  let min i j = cl primIMin <@> i <@> j+  let max i j = cl primIMax <@> i <@> j+  let+    old_tel = scTel old_sc+    old_ps' = AbsN (teleNames old_tel) $ fromSplitPatterns $ scPats old_sc+    old_ps = pure $ old_ps'+    old_ty = pure $ AbsN (teleNames old_tel) $ fromMaybe __IMPOSSIBLE__ $ scTarget old_sc+  -- old_tel = Γ(x: D η v)Δ+  -- Γ1, (x : D η v)  ⊢ delta = (δ : Δ)+    (gamma1x,delta') = splitTelescopeAt (size old_tel - blockingVarNo x) old_tel+    delta = pure $ AbsN (teleNames gamma1x) $ delta'+    gamma1_size = (size gamma1x - 1)+    (gamma1,ExtendTel dType' _) = splitTelescopeAt gamma1_size gamma1x++  old_sides <- forM old_ps' $ \ ps -> do+    let vs = iApplyVars ps+    let tm = Def f $ patternsToElims ps+    xs <- forM vs $ \ v ->+        -- have to reduce these under the appropriate substitutions, otherwise non-normalizing(?)+          fmap (var v,) . reduce $ (inplaceS v iz `applySubst` tm, inplaceS v io `applySubst` tm)+    return $ concatMap (\(v,(l,r)) -> [(tNeg `apply` [argN v],l),(v,r)]) xs+  let+    gamma1ArgNames = teleArgNames gamma1+    deltaArgNames = teleArgNames delta'+  (params,xTel,dT) <- addContext gamma1 $ do+    Just (d, ps, _is) <- getDatatypeArgs . unDom =<< reduce dType'+    def <- getConstInfo d+    let dTy = defType def+    let Datatype{dataSort = s} = theDef def+    TelV tel _ <- telView dTy+    let params = AbsN (teleNames gamma1) ps+        xTel = AbsN (teleNames gamma1) (tel `apply` ps)++    dT <- runNamesT [] $ do+          s <- open $ AbsN (teleNames tel) s+          bindNArg (teleArgNames gamma1) $ \ g1 -> do+          bindNArg (teleArgNames $ unAbsN xTel) $ \ x -> do+          params <- pure params `applyN` (fmap unArg <$> g1)+          x      <- sequence x+          s <- s `applyN` map (pure . unArg) (params ++ x)+          pure $ El s $ Def d [] `apply` (params ++ x)+    return $ (params, xTel,dT)++  let+    xTelI = pure $ expTelescope interval <$> xTel+    xTelIArgNames = teleArgNames (unAbsN xTel) -- same names++  -- Γ1, φ, p, ψ, q, x0 ⊢ pat := trX p φ (trX q ψ x0)+  let trX' = bindNArg gamma1ArgNames $ \ g1 -> do+             bindNArg ([defaultArg "phi"] ++ xTelIArgNames) $ \ phi_p -> do+             bindNArg [defaultArg "x0"] $ \ x0 -> do+             param_args <- fmap (map (setHiding Hidden . fmap (unnamed . dotP))) $+               pure params `applyN` (fmap unArg <$> g1)+             (phi, p) <- fromMaybe __IMPOSSIBLE__ . uncons <$> sequence phi_p+             x0 <- sequence x0+             pure $ DefP defaultPatternInfo q_trX $ param_args ++ p ++ [phi] ++ x0+      trX = (fmap . fmap . fmap) patternToTerm <$> trX'+  let pat' =+            bindN (map unArg gamma1ArgNames) $ \ g1 -> do+            bindN (map unArg $ ([defaultArg "phi"] ++ xTelIArgNames)) $ \ phi_p -> do+            bindN (map unArg $ ([defaultArg "psi"] ++ xTelIArgNames)) $ \ psi_q -> do+            bindN (map unArg $ [defaultArg "x0"]) $ \ x0 -> do+            -- (phi:p) <- sequence phi_p+            -- (psi:q) <- sequence psi_q+            -- x0 <- sequence x0+            let trX = trX' `applyN` g1+            trX `applyN` phi_p `applyN` [trX `applyN` psi_q `applyN` x0]+          --  pure $ trX $ p ++ [phi, defaultArg $ unnamed $ trX $ q ++ [psi] ++ x0]+      pat = (fmap . fmap . fmap . fmap) patternToTerm <$> pat'+  let deltaPat g1 phi p psi q x0 =+        delta `applyN` (g1 ++ [pat `applyN` g1 `applyN` (phi:p) `applyN` (psi:q) `applyN` [x0]])+  -- Ξ+  cTel <- runNamesT [] $+    abstractN (pure gamma1) $ \ g1 -> do+    abstractT "φ" (pure interval) $ \ phi -> do+    abstractN (xTelI `applyN` g1) $ \ p -> do+    abstractT "ψ" (pure interval) $ \ psi -> do+    abstractN (xTelI `applyN` g1) $ \ q -> do+    abstractT "x0" (pure dT `applyN` g1 `applyN` for q (\ f -> f <@> pure iz)) $ \ x0 -> do+    deltaPat g1 phi p psi q x0++  ps_ty_rhs <- runNamesT [] $ do+    bindN (map unArg gamma1ArgNames) $ \ g1 -> do+    bind "φ" $ \ phi -> do+    bindN (map unArg xTelIArgNames) $ \ p -> do+    bind "ψ" $ \ psi -> do+    bindN (map unArg xTelIArgNames) $ \ q -> do+    bind "x0" $ \ x0 -> do+    bindN (map unArg deltaArgNames) $ \ d -> do+    let+      ps :: NamesT TCM NAPs+      ps = old_ps `applyN` (g1+                          ++ [pat' `applyN` g1 `applyN` (phi:p) `applyN` (psi:q) `applyN` [x0]]+                          ++ d)++      rhsTy = old_ty `applyN` (g1+                          ++ [pat `applyN` g1 `applyN` (phi:p) `applyN` (psi:q) `applyN` [x0]]+                          ++ d)++    xTel <- (open =<<) $ pure xTel `applyN` g1+    q4_f <- (open =<<) $ bind "i" $ \ i -> lamTel $ bind "j" $ \ j -> do+      ty <- bind "i" $ \ _ -> xTel+      face <- max phi $ max (neg j) (neg i)+      base <- map defaultArg <$> appTel (sequence q) j+      u  <- liftM2 (,) (max j psi) $ bind "h" $ \ h -> do+              appTel (sequence p) (min j (min h i))+      xs <- fromRight __IMPOSSIBLE__ <$> do lift $ runExceptT $ transpSysTel' False ty [u] face base+      pure $ map unArg xs+    -- Ξ ⊢ pat_rec[0] = pat : D η v+    -- Ξ ⊢ pat_rec[1] = trX q4 (φ ∧ ψ) x0 : D η v+    -- Ξ ⊢ pat-rec[i] := trX (\ j → p (i ∨ j)) (i ∨ φ) (trX (q4_f i) (ψ ∧ (φ ∨ ~ i)) t)+    pat_rec <- (open =<<) $ bind "i" $ \ i -> do+          p_conn <- (mapM open =<<) $ lamTel $ bind "i" $ \ j -> sequence p `appTel` max i j+          q4_f' <- (mapM open =<<) $ absApp <$> q4_f <*> i+          trX `applyN` g1 `applyN` (max i phi:p_conn)+              `applyN` [trX `applyN` g1 `applyN` (min psi (max phi (neg i)):q4_f') `applyN` [x0]]++    let mkBndry args = do+            args1 <- (mapM open =<<) $ (absApp <$> args <*> pure io)+            -- faces ought to be constant on "j"+            faces <- pure (fmap (map fst) old_sides) `applyN` args1+            us <- forM (mapM (map snd) old_sides) $ \ u -> do+                  lam "j" $ \ j -> ilam "o" $ \ _ -> do+                    args <- (mapM open =<<) $ (absApp <$> args <*> j)+                    pure u `applyN` args+            forM (zip faces us) $ \ (phi,u) -> liftM2 (,) (open phi) (open u)+    let mkComp pr = bind "i" $ \ i -> do+          d_f <- (open =<<) $ bind "j" $ \ j -> do+            tel <- bind "j" $ \ j -> delta `applyN` (g1 ++ [pr `applyN` [i,j]])+            face <- min phi psi `max` (min i (max phi psi))+            j <- j+            d <- map defaultArg <$> sequence d+            lift $ covFillTele f tel face d j+          let args = bind "j" $ \ j -> do+                g1 <- sequence g1+                x <- pr `applyN` [i,neg j]+                ys <- absApp <$> d_f <*> neg j+                pure $ g1 ++ x:ys+          ty <- (open =<<) $ bind "j" $ \ j -> do+               args <- (mapM open =<<) $ absApp <$> args <*> j+               fmap unDom $ old_ty `applyN` args+          let face = max i (min phi psi)+          base <- (open =<<) $ do+            args' <- (mapM open =<<) $ absApp <$> args <*> pure iz+            fmap (Def f) $ (fmap patternsToElims <$> old_ps) `applyN` args'+          sys <- mkBndry args+          transpSys ty sys face base++    -- Ξ ⊢ δ_f[1] = tr (i. Δ[γ1,x = pat_rec[i]]) (φ ∧ ψ) δ+    -- Ξ ⊢ w0 := f old_ps[γ1,x = pat_rec[1] ,δ_f[1]] : old_t[γ1,x = pat_rec[1],δ_f[1]]+    -- Ξ ⊢ rhs := tr (i. old_t[γ1,x = pat_rec[~i], δ_f[~i]]) (φ ∧ ψ) w0 -- TODO plus sides.+    syspsi <- (open =<<) $ lam "i" $ \ i -> ilam "o" $ \ _ -> do+      c <- mkComp $ bindN ["i","j"] $ \ [i,j] -> do+        res <- bind "k" $ \ k -> do+          let phi_k = max phi (neg k)+          let p_k = for p $ \ p -> lam "h" $ \ h -> p <@> (min k h)+          data_ty <- pure dT `applyN` g1 `applyN` for p (\ p -> p <@> k)+          line1 <- trX `applyN` g1 `applyN` (phi_k:p_k) `applyN` [x0]++          line2 <- trX `applyN` g1+                       `applyN` (max phi_k j      : for p_k (\ p -> lam "h" $ \ h -> p <@> (max h j)))+                       `applyN`+                  [trX `applyN` g1+                       `applyN` (max phi_k (neg j): for p_k (\ p -> lam "h" $ \ h -> p <@> (min h j)))+                       `applyN` [x0]]+          pure (data_ty, [line1, line2])+        case res of+          Abs n (data_ty, [line1, line2]) -> do+            data_ty <- open $ Abs n data_ty+            line1   <- open $ Abs n line1+            line2   <- open $ Abs n line2+            let sys = [(neg i, lam "k" $ \ k -> ilam "o" $ \ _ -> absApp <$> line2 <*> k)+                      ,(neg j `max` j `max` i `max` phi, lam "k" $ \ k -> ilam "o" $ \ _ -> absApp <$> line1 <*> k)+                      ]+            transpSys data_ty sys (pure iz) x0+          _ -> __IMPOSSIBLE__+      absApp <$> pure c <*> i+    sysphi <- (open =<<) $ lam "i" $ \ i -> ilam "o" $ \ o -> do+      c <- mkComp $ bindN ["i","j"] $ \ _ij -> do+        trX `applyN` g1 `applyN` (psi:q) `applyN` [x0]+      absApp <$> pure c <*> i+    syse <- mkBndry $ bind "j" $ \ _ -> sequence $ g1 ++ [absApp <$> pat_rec <*> pure iz] ++ d+    let sys = syse ++ [(phi,sysphi)] ++ [(psi,syspsi)]+    w0 <- (open =<<) $ do+      let w = mkComp (bindN ["i","j"] $ \ [_i, j] -> absApp <$> pat_rec <*> j)+      absApp <$> w <*> pure iz+    let rhs = hcomp (unDom <$> rhsTy) sys w0+    (,,) <$> ps <*> rhsTy <*> rhs+  let (ps,ty,rhs) = unAbsN $ unAbs $ unAbsN $ unAbs $ unAbsN $ unAbs $ unAbsN $ ps_ty_rhs+  reportSDoc "tc.cover.trx.trx" 20 $ "trX-trX clause for" <+> prettyTCM f+  let c = Clause { clauseLHSRange  = noRange+                 , clauseFullRange = noRange+                 , clauseTel       = cTel+                 , namedClausePats = ps+                 , clauseBody      = Just rhs+                 , clauseType      = Just $ Arg (getArgInfo ty) (unDom ty)+                 , clauseCatchall    = empty+                 , clauseRecursive   = Just True+                 , clauseUnreachable = Just False+                 , clauseEllipsis    = NoEllipsis+                 , clauseWhereModule = Nothing+                 }+  debugClause "tc.cover.trx.trx" c+  return $ c+createMissingTrXHCompClause :: QName+                            -> QName+                            -> Arg Nat+                            -> BlockingVar+                            -> SplitClause+                            -> TCM Clause+createMissingTrXHCompClause q_trX f n x old_sc = do+  let+   old_tel = scTel old_sc+   old_ps = fromSplitPatterns $ scPats old_sc+   old_t = fromMaybe __IMPOSSIBLE__ $ scTarget old_sc++  reportSDoc "tc.cover.trx.hcomp" 20 $ "trX-hcomp clause for" <+> prettyTCM f+  reportSDoc "tc.cover.trx.hcomp" 20 $ nest 2 $ vcat $+    [ "old_tel:" <+> prettyTCM old_tel+    , "old_ps :" <+> addContext old_tel (prettyTCM $ patternsToElims old_ps)+    , "old_t  :" <+> addContext old_tel (prettyTCM old_t)+    ]++  -- old_tel = Γ1, (x : D η v), Δ+  -- α = boundary(old_ps)+  -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [ α ↦ (f old_ps)[α] ]++  -- α' = boundary(old_ps[x = pat])+  -- Γ1, φ : I, p : Path X(η) _ v, ψ : I, u : I -> [ψ] → D η (p i0), u0 : D η (p i0) ⊢ pat := trX p φ (hcomp ψ u u0) : D η v++  -- Ξ = Γ1, φ : I, p : Path X(η) _ v, ψ : I, u : ..., u0 : D η (p i0), Δ[x = pat]++  -- Ξ ⊢ w1 := f old_ps[γ1,x = pat,δ] : old_t[γ1,x = pat,δ] -- the case we are defining. can only be used if specialized.++  -- Ξ ⊢ rhs : old_t[γ1,x = pat,δ] [ α' ↦ w1[α']+                                -- , φ  ↦ w1[φ = i1, p = refl]   = f old_ps[γ1,x = hcomp ψ u u0    ,δ]+                                -- , ψ  ↦ w1[ψ = i1]             = f old_ps[γ1,x = trX p φ (u i1 _),δ]+                                -- ]++  -- Ξ ⊢ q2 := tr (i. Path X(η) (q i0) (p i)) φ q : Path X(η) (q i0) (p i1)+  -- Ξ ⊢ pat_rec[0] = pat : D η v+  -- Ξ ⊢ pat_rec[1] = trX q2 (φ ∧ ψ) x0 : D η v+  -- Ξ ⊢ pat-rec[i] := trX (\ j → q (i ∨ j)) (i ∨ φ) (trX (q2_f i) (ψ ∧ (φ ∨ ~ i)) t)++  -- Ξ ⊢ δ_f[1] = tr (i. Δ[γ1,x = pat_rec[i]]) (φ ∧ ψ) δ : Δ[γ1,x = pat_rec[1]]+  -- Ξ ⊢ w0 := f old_ps[γ1,x = pat_rec[1] ,δ_f[1]] : old_t[γ1,x = pat_rec[1],δ_f[1]]+  -- Ξ ⊢ rhs := tr (i. old_t[γ1,x = pat_rec[~i], δ_f[~i]]) (φ ∧ ψ) w0 -- TODO plus sides.++  q_hcomp <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinHComp+  let+   old_tel = scTel old_sc+   old_ps = fromSplitPatterns $ scPats old_sc+   old_t = fromMaybe __IMPOSSIBLE__ $ scTarget old_sc++  reportSDoc "tc.cover.trx.trx" 20 $ "trX-trX clause for" <+> prettyTCM f+  reportSDoc "tc.cover.trx.trx" 20 $ nest 2 $ vcat $+    [ "old_tel:" <+> prettyTCM old_tel+    , "old_ps :" <+> addContext old_tel (prettyTCM $ patternsToElims old_ps)+    , "old_t  :" <+> addContext old_tel (prettyTCM old_t)+    ]++  -- TODO: redo comments, the strategy changed.+  -- old_tel = Γ1, (x : D η v), Δ+  -- α = boundary(old_ps)+  -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [ α ↦ (f old_ps)[α] ]++  -- α' = boundary(old_ps[x = pat])+  -- Γ1, φ : I, p : Path X(η) _ v, ψ : I, q : Path X(η) _ (p i0), x0 : D η (q i0) ⊢ pat := trX p φ (trX q ψ x0) : D η v++  -- Ξ = Γ1, φ : I, p : Path X(η) _ v, ψ : I, q : Path X(η) _ (p i0), x0 : D η (q i0), Δ[x = pat]++  -- Ξ ⊢ w1 := f old_ps[γ1,x = pat,δ] : old_t[γ1,x = pat,δ] -- the case we are defining. can only be used if specialized.++  -- Ξ ⊢ rhs : old_t[γ1,x = pat,δ] [ α' ↦ w1[α']+                                -- , φ  ↦ w1[φ = i1, p = refl]+                                -- , ψ  ↦ w1[ψ = i1, q = refl]+                                -- ]+  -- Ξ ⊢ q2 := tr (i. Path X(η) (q i0) (p i)) φ q : Path X(η) (q i0) (p i1)+  -- Ξ ⊢ pat_rec[0] = pat : D η v+  -- Ξ ⊢ pat_rec[1] = trX q2 (φ ∧ ψ) x0 : D η v+  -- Ξ ⊢ pat-rec[i] := trX (\ j → p (i ∨ j)) (i ∨ φ) (trX (q2_f i) (ψ ∧ (φ ∨ ~ i)) t)++  -- Ξ ⊢ δ_f[1] = tr (i. Δ[γ1,x = pat_rec[i]]) (φ ∧ ψ) δ+  -- Ξ ⊢ w0 := f old_ps[γ1,x = pat_rec[1] ,δ_f[1]] : old_t[γ1,x = pat_rec[1],δ_f[1]]+  -- Ξ ⊢ rhs := tr (i. old_t[γ1,x = pat_rec[~i], δ_f[~i]]) (φ ∧ ψ) w0 -- TODO plus sides.++  interval <- elInf primInterval+  iz <- primIZero+  io <- primIOne+  tHComp <- primHComp+  tNeg <- primINeg+  let neg i = pure tNeg <@> i+  let min i j = cl primIMin <@> i <@> j+  let max i j = cl primIMax <@> i <@> j+  let+    old_tel = scTel old_sc+    old_ps' = AbsN (teleNames old_tel) $ fromSplitPatterns $ scPats old_sc+    old_ps = pure $ old_ps'+    old_ty = pure $ AbsN (teleNames old_tel) $ fromMaybe __IMPOSSIBLE__ $ scTarget old_sc+  -- old_tel = Γ(x: D η v)Δ+  -- Γ1, (x : D η v)  ⊢ delta = (δ : Δ)+    (gamma1x,delta') = splitTelescopeAt (size old_tel - blockingVarNo x) old_tel+    delta = pure $ AbsN (teleNames gamma1x) $ delta'+    gamma1_size = (size gamma1x - 1)+    (gamma1,ExtendTel dType' _) = splitTelescopeAt gamma1_size gamma1x++  old_sides <- forM old_ps' $ \ ps -> do+    let vs = iApplyVars ps+    let tm = Def f $ patternsToElims ps+    xs <- forM vs $ \ v ->+        -- have to reduce these under the appropriate substitutions, otherwise non-normalizing(?)+          fmap (var v,) . reduce $ (inplaceS v iz `applySubst` tm, inplaceS v io `applySubst` tm)+    return $ concatMap (\(v,(l,r)) -> [(tNeg `apply` [argN v],l),(v,r)]) xs+  let+    gamma1ArgNames = teleArgNames gamma1+    deltaArgNames = teleArgNames delta'+  (params,xTel,dT) <- addContext gamma1 $ do+    Just (d, ps, _is) <- getDatatypeArgs . unDom =<< reduce dType'+    def <- getConstInfo d+    let dTy = defType def+    let Datatype{dataSort = s} = theDef def+    TelV tel _ <- telView dTy+    let params = AbsN (teleNames gamma1) ps+        xTel = AbsN (teleNames gamma1) (tel `apply` ps)++    dT <- runNamesT [] $ do+          s <- open $ AbsN (teleNames tel) s+          bindNArg (teleArgNames gamma1) $ \ g1 -> do+          bindNArg (teleArgNames $ unAbsN xTel) $ \ x -> do+          params <- pure params `applyN` (fmap unArg <$> g1)+          x      <- sequence x+          s <- s `applyN` map (pure . unArg) (params ++ x)+          pure $ El s $ Def d [] `apply` (params ++ x)+    return $ (params, xTel,dT)++  let+    xTelI = pure $ expTelescope interval <$> xTel+    xTelIArgNames = teleArgNames (unAbsN xTel) -- same names++  -- Γ1, φ, p, ψ, q, x0 ⊢ pat := trX p φ (trX q ψ x0)+  let trX' = bindNArg gamma1ArgNames $ \ g1 -> do+             bindNArg ([defaultArg "phi"] ++ xTelIArgNames) $ \ phi_p -> do+             bindNArg [defaultArg "x0"] $ \ x0 -> do+             param_args <- fmap (map (setHiding Hidden . fmap (unnamed . dotP))) $+               pure params `applyN` (fmap unArg <$> g1)+             (phi, p) <- fromMaybe __IMPOSSIBLE__ . uncons <$> sequence phi_p+             x0 <- sequence x0+             pure $ DefP defaultPatternInfo q_trX $ param_args ++ p ++ [phi] ++ x0+      trX = (fmap . fmap . fmap) patternToTerm <$> trX'+  let+    hcompD' g1 v =+        bindNArg [argH "psi",argN "u", argN "u0"] $ \ x0 -> do+        x0 <- sequence x0+        LEl l t <- fromMaybe __IMPOSSIBLE__ <.> toLType =<< do pure dT `applyN` g1 `applyN` v+        let ty = map (fmap (unnamed . dotP) . argH) [Level l,t]+        pure $ DefP defaultPatternInfo q_hcomp $ ty ++ x0+  hcompD <- runNamesT [] $+            bindN (map unArg $ gamma1ArgNames) $ \ g1 -> do+            bindN (teleNames $ unAbsN $ xTel) $ \ v -> do+            fmap patternToTerm <$> hcompD' g1 v+  let pat' =+            bindN (map unArg gamma1ArgNames) $ \ g1 -> do+            bindN1 (fmap unArg (defaultArg "phi" :| xTelIArgNames)) $ \ phi_p -> do+            bindN ["psi","u","u0"] $ \ x0 -> do+            let trX = trX' `applyN` g1+            let p0 = for (List1.tail phi_p) $ \ p -> p <@> pure iz+            trX `applyN` (List1.toList phi_p) `applyN` [hcompD' g1 p0 `applyN` x0]+      pat = (fmap . fmap . fmap) patternToTerm <$> pat'+  let deltaPat g1 phi p x0 =+        delta `applyN` (g1 ++ [pat `applyN` g1 `applyN` (phi:p) `applyN` x0])+  -- Ξ+  cTel <- runNamesT [] $+    abstractN (pure gamma1) $ \ g1 -> do+    abstractT "φ" (pure interval) $ \ phi -> do+    abstractN (xTelI `applyN` g1) $ \ p -> do+    let p0 = for p $ \ p -> p <@> pure iz+    let ty = pure dT `applyN` g1 `applyN` p0+    abstractT "ψ" (pure interval) $ \ psi -> do+    abstractT "u" (pure interval --> pPi' "o" psi (\ _ -> ty)) $ \ u -> do+    abstractT "u0" ty $ \ u0 -> do+    deltaPat g1 phi p [psi,u,u0]++  ps_ty_rhs <- runNamesT [] $ do+    bindN (map unArg gamma1ArgNames) $ \ g1 -> do+    bind "φ" $ \ phi -> do+    bindN (map unArg xTelIArgNames) $ \ p -> do+    bind "ψ" $ \ psi -> do+    bind "u" $ \ u -> do+    bind "u0" $ \ u0 -> do+    bindN (map unArg deltaArgNames) $ \ d -> do+    let+      x0 :: Vars TCM+      x0 = [psi,u,u0]+      ps :: NamesT TCM NAPs+      ps = old_ps `applyN` (g1+                          ++ [pat' `applyN` g1 `applyN` (phi:p) `applyN` x0]+                          ++ d)++      rhsTy = old_ty `applyN` (g1+                          ++ [pat `applyN` g1 `applyN` (phi:p) `applyN` x0]+                          ++ d)++    xTel <- (open =<<) $ pure xTel `applyN` g1+    -- Ξ ⊢ pat-rec[i] := trX .. (hfill ... (~ i))+    pat_rec <- (open =<<) $ bind "i" $ \ i -> do+          let tr x = trX `applyN` g1 `applyN` (phi:p) `applyN` [x]+          let p0 = for p $ \ p -> p <@> pure iz+          tr (hcomp (pure dT `applyN` g1 `applyN` p0)+                    [(psi,lam "j" $ \ j -> u <@> (min j (neg i)))+                    ,(i  ,lam "j" $ \ _ -> ilam "o" $ \ _ -> u0)]+                    u0)+    --   args : (i.old_tel)  -> ...+    let mkBndry args = do+            args1 <- (mapM open =<<) $ (absApp <$> args <*> pure io)+            -- faces ought to be constant on "j"+            faces <- pure (fmap (map fst) old_sides) `applyN` args1+            us <- forM (mapM (map snd) old_sides) $ \ u -> do+                  lam "j" $ \ j -> ilam "o" $ \ _ -> do+                    args <- (mapM open =<<) $ (absApp <$> args <*> j)+                    pure u `applyN` args+            forM (zip faces us) $ \ (phi,u) -> liftM2 (,) (open phi) (open u)+    rhs <- do+      d_f <- (open =<<) $ bind "j" $ \ j -> do+        tel <- bind "j" $ \ j -> delta `applyN` (g1 ++ [absApp <$> pat_rec <*> j])+        let face = iz+        j <- j+        d <- map defaultArg <$> sequence d+        lift $ covFillTele f tel face d j+      let args = bind "j" $ \ j -> do+            g1 <- sequence g1+            x <- absApp <$> pat_rec <*> neg j+            ys <- absApp <$> d_f <*> neg j+            pure $ g1 ++ x:ys+      ty <- (open =<<) $ bind "j" $ \ j -> do+           args <- (mapM open =<<) $ absApp <$> args <*> j+           fmap unDom $ old_ty `applyN` args+      let face = pure iz+      othersys <- (open =<<) $ lam "j" $ \ j -> ilam "o" $ \ _ -> do+        args' <- (mapM open =<<) $ absApp <$> args <*> j+        fmap (Def f) $ (fmap patternsToElims <$> old_ps) `applyN` args'+      sys <- mkBndry args+      let+        -- we could specialize all of sysphi/syspsi/base to compute+        -- away trX or the hcomp respectively, should lead to+        -- smaller/more efficient terms.+        --+        -- we could also ditch sysphi completely,+        -- as the computation rule for hcomp would achieve the same.+        sysphi = othersys+        syspsi = othersys+      base <- (open =<<) $ do+        args' <- (mapM open =<<) $ absApp <$> args <*> pure iz+        fmap (Def f) $ (fmap patternsToElims <$> old_ps) `applyN` args'+      transpSys ty ((phi,sysphi):(psi,syspsi):sys) face base+    (,,) <$> ps <*> rhsTy <*> pure rhs+  let (ps,ty,rhs) = unAbsN $ unAbs $ unAbs $ unAbs $ unAbsN $ unAbs $ unAbsN $ ps_ty_rhs+  reportSDoc "tc.cover.trx.hcomp" 20 $ "trX-hcomp clause for" <+> prettyTCM f+  let c = Clause { clauseLHSRange  = noRange+                 , clauseFullRange = noRange+                 , clauseTel       = cTel+                 , namedClausePats = ps+                 , clauseBody      = Just rhs+                 , clauseType      = Just $ Arg (getArgInfo ty) (unDom ty)+                 , clauseCatchall    = empty+                 , clauseRecursive   = Just True+                 , clauseUnreachable = Just False+                 , clauseEllipsis    = NoEllipsis+                 , clauseWhereModule = Nothing+                 }+  debugClause "tc.cover.trx.hcomp" c+  return c+createMissingTrXConClause :: QName -- trX+                            -> QName -- f defined+                            -> Arg Nat+                            -> BlockingVar+                            -> SplitClause+                            -> QName -- constructor name+                            -> UnifyEquiv+                            -> TCM Clause+createMissingTrXConClause q_trX f n x old_sc c (UE gamma gamma' xTel u v rho tau leftInv) = do+  reportSDoc "tc.cover.trxcon" 20 $ "trX-con clause for" <+> prettyTCM f <+> "with con" <+> prettyTCM c+  reportSDoc "tc.cover.trxcon" 20 $ nest 2 $ vcat $+    [ "gamma" <+> prettyTCM gamma+    , "gamma'" <+> prettyTCM gamma'+    , "xTel" <+> addContext gamma (prettyTCM xTel)+    , "u"  <+> addContext gamma (prettyTCM u)+    , "v"  <+> addContext gamma (prettyTCM v)+    , "rho" <+> addContext gamma' (prettyTCM rho)+    ]++  Constructor{conSrcCon = chead} <- theDef <$> getConstInfo c++  -- = TheInfo $ UE delta1' eqTel (map unArg conIxs) (map unArg givenIxs) rho0 tau leftInv++  -- η : Params_D ⊢ c : (a : Args(η)) → D η (ξ(η,a))++  -- scTel old_sc = Γ1, (x : D η v), Δ+  -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [α(γ1,x,δ) ↦ e(γ1,x,δ)]++  -- Γ = Γ1, a : Args(η)+  -- Γ ⊢ u = ξ(η,a)+  -- Γ ⊢ c a : D η u++  -- Γ' ⊢ ρ : Γ++  -- Γ' ⊢ u[ρ] = v[ρ] : X(η)[ρ]++  -- Γ' ⊢ c a[ρ] : (D η v)[ρ]++  -- Γ' ⊢ ρx := ρ,x = c a[ρ] : Γ,(x : D η v)++  -- Γ',Δ[ρx] ⊢ old_t[ρx]+  -- Γ',Δ[ρx] ⊢ f old_ps[ρx] : old_t[ρx] [α[ρx] ↦ e[γ1,x,δ][ρx]]++  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ τ : Γ'++  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ [ρx][τ] = [ρ[τ], x = c a[ρ[τ]]] : Γ,(x : D η v)++  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ leftInv : ρ[τ],i1,refl ≡ idS : Γ,(φ : I),(p : Path X(η) u v)++  -- Γ,(φ : I),(p : Path X(η) u v)| (i : I) ⊢ leftInv i : Γ,(φ : I),(p : Path X(η) u v)++  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ leftInv i0 = ρ[τ],i1,refl : Γ,(φ : I),(p : Path X(η) u v)+  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ leftInv i1 = γ   ,φ ,p    : Γ,(φ : I),(p : Path X(η) u v)+  --                                 leftInv[φ = i1][i] = idS++  -- Γ,(φ : I),(p : Path X(η) u v),Δ[ρx][τ] ⊢ τ' = liftS |Δ[ρx]| τ : Γ',Δ[ρx]++  -- Γ,(φ : I),(p : Path X(η) u v),Δ[ρx][τ] ⊢+  --            w := f old_ps[γ1[ρ[τ]],x = c a[ρ[τ]],δ] : old_t[ρx][τ'] = old_t[γ1[ρ[τ]],x = c a[ρ[τ]],δ]++  -- Γ,(φ : I),(p : Path X(η) u v),Δ[ρx][τ], α(γ1,x,δ)[ρx][τ'] ⊢ w = e(γ1,x,δ)[ρx][τ']++  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ pat := trX p φ (c a) : D η v+++  -- Ξ := Γ,(φ : I),(p : Path X(η) u v),(δ : Δ[x = pat])++  -- Ξ ⊢ δ_f[1] = trTel (i. Δ[γ1[leftInv (~ i)], pat[leftInv (~i)]]) φ δ : Δ[ρ[τ], x = c a[ρ[τ]]]++  -- Ξ ⊢ w[δ_f[1]] : old_t[γ1[ρ[τ]],x = c a[ρ[τ]],δ_f[1]]+  -- Ξ, α(γ1,x,δ)[ρx][τ'][δ = δ_f[1]] ⊢ w[δ_f[1]] = e(γ1,x,δ)[ρx][τ'][δ_f[1]]++  -- Ξ, α(γ1[ρ[τ]],c a[ρ[τ]],δ_f[1]) ⊢ w[δ_f[1]] = e(γ1[ρ[τ]],c a[ρ[τ]],δ_f[1])++  -- Recap:+  -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [α(γ1,x,δ) ↦ e(γ1,x,δ)]+  -- Ξ := Γ,(φ : I),(p : Path X(η) u v),(δ : Δ[x = pat])+  -- Ξ ⊢ δ_f[1] := trTel (i. Δ[γ1[leftInv (~ i)], pat[leftInv (~i)]]) φ δ : Δ[ρ[τ], x = c a[ρ[τ]]]+  -- Γ,(φ : I),(p : Path X(η) u v),Δ[ρx][τ] ⊢+  --            w := f old_ps[γ1[ρ[τ]],x = c a[ρ[τ]],δ] : old_t[ρx][τ'] = old_t[γ1[ρ[τ]],x = c a[ρ[τ]],δ]+  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ pat := trX p φ (c a) : D η v+++  -- Ξ ⊢ ?rhs : old_t[γ1,x = pat,δ] [α(γ1,pat,δ) ↦ e(γ1,pat,δ)+  --                               ,φ           ↦ w+  --                               ]++  -- ?rhs := transp (i. old_t[γ1[leftInv i],x = pat[leftInv i], δ_f[~i]]) φ (w[δ_f[1]])++  -- we shall consider α(γ1,pat,δ) = α(γ1[ρ[τ]],c a[ρ[τ]],δ_f[1])+  -- also rather than (p : Path X(η) u v) we'll have (p : I -> X(η)), same as the type of trX.++  iz <- primIZero+  interval <- elInf primInterval+  let+      old_tel = scTel old_sc+      old_ps = pure $ AbsN (teleNames old_tel) $ fromSplitPatterns $ scPats old_sc+      old_ty = pure $ AbsN (teleNames old_tel) $ fromMaybe __IMPOSSIBLE__ $ scTarget old_sc+  -- old_tel = Γ(x: D η v)Δ+  -- Γ1, (x : D η v)  ⊢ delta = (δ : Δ)+      (gamma1x,delta') = splitTelescopeAt (size old_tel - blockingVarNo x) old_tel+  let+    gammaArgNames = teleArgNames gamma+    deltaArgNames = teleArgNames delta'+  let+    xTelI = pure $ AbsN (teleNames gamma) $ expTelescope interval xTel+    delta = pure $ AbsN (teleNames gamma1x) $ delta'+    gamma1_size = (size gamma1x - 1)+    (gamma1,ExtendTel dType' _) = splitTelescopeAt gamma1_size gamma1x+  params <- addContext gamma1 $ do+    Just (_d, ps, _is) <- getDatatypeArgs . unDom =<< reduce dType'+    return $ AbsN (teleNames gamma1) ps+  -- Γ, φ , p ⊢ pat := trX p φ (c a)+  let pat' =+            bindNArg gammaArgNames $ \ g1_args -> do+            bindNArg ([defaultArg "phi"] ++ teleArgNames xTel) $ \ phi_p -> do+            let (g1,args) = splitAt gamma1_size g1_args+            (phi, p) <- fromMaybe __IMPOSSIBLE__ . uncons <$> sequence phi_p+            args <- sequence args+            let cargs = defaultArg $ unnamed $ ConP chead noConPatternInfo args+            -- Amy (2022-11-06): Set the parameters to quantity-0.+            param_args <- fmap (map (setQuantity (Quantity0 Q0Inferred) . setHiding Hidden . fmap (unnamed . dotP))) $+              pure params `applyN` take gamma1_size (fmap unArg <$> g1_args)+            pure $ DefP defaultPatternInfo q_trX $ param_args ++ p ++ [phi,cargs]+      pat = (fmap . fmap) patternToTerm <$> pat'+      pat_left' = (fmap . fmap) (Abs "i" . (applySubst leftInv)) <$> pat+      g1_left' = bindN (map unArg gammaArgNames) $ \ g1_args -> do+                bindN (map unArg $ [defaultArg "phi"] ++ teleArgNames xTel) $ \ phi_p -> do+                g1 <- sequence $ take gamma1_size g1_args :: NamesT TCM [Term]+                pure $ Abs "i" (applySubst leftInv g1)++  gamma <- return $ pure gamma+  let deltaPat g1_args phi p =+        delta `applyN` (take gamma1_size g1_args ++ [pat `applyN` g1_args `applyN` (phi:p)])+  let neg i = cl primINeg <@> i+  -- Ξ+  cTel <- runNamesT [] $+    abstractN gamma $ \ g1_args -> do+    abstractT "φ" (pure interval) $ \ phi -> do+    abstractN (xTelI `applyN` g1_args) $ \ p -> do+    deltaPat g1_args phi p+  ps_ty_rhs <- runNamesT [] $ do+    bindN (map unArg gammaArgNames) $ \ g1_args -> do+    bind "phi" $ \ phi -> do+    bindN (teleNames xTel) $ \ p -> do+    bindN (map unArg $ deltaArgNames) $ \ d -> do+    let+      g1_left = g1_left' `applyN` g1_args `applyN` (phi:p)+      pat_left = pat_left' `applyN` g1_args `applyN` (phi:p)+      g1 :: Vars TCM+      g1 = take gamma1_size g1_args++      args :: Vars TCM+      args = drop gamma1_size g1_args++      ps :: NamesT TCM NAPs+      ps = old_ps `applyN` (g1 ++ [pat' `applyN` g1_args `applyN` (phi:p)] ++ d)++      rhsTy = old_ty `applyN` (g1 ++ [pat `applyN` g1_args `applyN` (phi:p)] ++ d)++    -- (i. Δ[γ1[leftInv (~ i)], pat[leftInv (~i)]])+    delta_f <- (open =<<) $ bind "i" $ \ i -> do+      let ni = neg i+      dargs <- (mapM open =<<) $ do+        xs <- absApp <$> g1_left <*> ni+        y <- absApp <$> pat_left <*> ni+        return $ xs ++ [y]+      delta `applyN` dargs++    --  trFillTel (i. Δ[γ1[leftInv (~ i)], pat[leftInv (~i)]]) φ δ+    d_f <- (open =<<) $ bind "i" $ \ i -> do+      delta_f <- delta_f+      phi <- phi+      d <- map defaultArg <$> sequence d+      i <- i+      lift $ covFillTele f delta_f phi d i++    -- w = Def f (old_ps[g1_left[i],pat_left[i],d_f[~ i]])+    w <- (open =<<) $ bind "i" $ \ i -> do+      psargs <- (mapM open =<<) $ do+        xs <- absApp <$> g1_left <*> i+        y <- absApp <$> pat_left <*> i+        zs <- absApp <$> d_f <*> neg i+        return $ xs ++ [y] ++ zs+      ps <- (fmap patternsToElims <$> old_ps) `applyN` psargs+      pure $ Def f ps+++    -- (i. old_t[γ1[leftInv i],x = pat[leftInv i], δ_f[~i]])+    ty <- (open =<<) $ bind "i" $ \ i -> do+      tyargs <- (mapM open =<<) $ do+        xs <- absApp <$> g1_left <*> i+        y <- absApp <$> pat_left <*> i+        zs <- absApp <$> d_f <*> neg i+        return $ xs ++ [y] ++ zs+      fmap unDom $ old_ty `applyN` tyargs++    sys <- do+      sides <- do+        neg <- primINeg+        io <- primIOne+        vs <- iApplyVars <$> ps+        tm <- w+        xs <- forM vs $ \ v ->+            -- have to reduce these under the appropriate substitutions, otherwise non-normalizing(?)+              fmap (var v,) . reduce $ (inplaceS v iz `applySubst` tm, inplaceS v io `applySubst` tm)+        return $ concatMap (\(v,(l,r)) -> [(neg `apply` [argN v],l),(v,r)]) xs+      forM sides $ \ (psi,u') -> do+        u' <- open u'+        u <- lam "i" $ \ i -> ilam "o" $ \ o -> absApp <$> u' <*> i+        (,) <$> open psi <*> open u++    let rhs = transpSys ty sys phi (absApp <$> w <*> pure iz)++    (,,) <$> ps <*> rhsTy <*> rhs++  let (ps,ty,rhs) = unAbsN $ unAbsN $ unAbs $ unAbsN $ ps_ty_rhs+  qs <- mapM (fmap (fromMaybe __IMPOSSIBLE__) . getName') [builtinINeg, builtinIMax, builtinIMin]+  rhs <- addContext cTel $+           locallyReduceDefs (OnlyReduceDefs (Set.fromList $ q_trX : qs)) $ normalise rhs+  let cl = Clause { clauseLHSRange  = noRange+                  , clauseFullRange = noRange+                  , clauseTel       = cTel+                  , namedClausePats = ps+                  , clauseBody      = Just rhs+                  , clauseType      = Just $ Arg (getArgInfo ty) (unDom ty)+                  , clauseCatchall    = empty+                  , clauseRecursive   = Just True+                  , clauseUnreachable = Just False+                  , clauseEllipsis    = NoEllipsis+                  , clauseWhereModule = Nothing+                  }+++  debugClause "tc.cover.trxcon" cl++  reportSDoc "tc.cover.trxcon" 20 $ vcat $+    [ "clause:"+    ,  nest 2 $ prettyTCM . QNamed f $ cl+    ]++  let mod =+        setRelevance irrelevant $  -- See #5611.+        getModality $ fromMaybe __IMPOSSIBLE__ $ scTarget old_sc+  -- we follow what `cover` does when updating the modality from the target.+  applyModalityToContext mod $ do+    unlessM (hasQuantity0 <$> viewTC eQuantity) $ do+    reportSDoc "tc.cover.trxcon" 20 $ text "testing usable at mod: " <+> pretty mod+    addContext cTel $ usableAtModality IndexedClause mod rhs++  return cl++{-+  OLD leftInv case+  -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv : ρ[τ] ≡ wkS 2 : Γ+  -- Γ,(φ : I),(p : Path A u v)(i : I) ⊢ leftInv i : Γ+  -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv i0 = ρ[τ] : Γ+  -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv i1 = wkS 2 : Γ+  -- leftInv[φ = i1][i] = wkS 2++  -- Γ,(φ : I),(p : Path A u v),Δ[ρ,x = refl][τ] ⊢ τ' = liftS |Δ[ρ,x = refl]| τ : Γ',Δ[ρ,x = refl]++  -- Γ,(φ : I),(p : Path A u v),Δ[ρ,x = refl][τ] ⊢ w = f old_ps[ρ,x = refl][τ'] : old_t[ρ,x = refl][τ']++  -- Γ,(φ : I),(p : Path A u v) | (i : I) ⊢ μ = ⟨ (φ ∨ ~ i) , (\ j → p (i ∧ j)) ⟩ : Id A u (p i) =?= (Id A u v)[leftInv (~ i)]+                                  μ[0] = ⟨ 1 , (\ _ → u[ρ[τ]]) ⟩+                                  μ[1] = ⟨ φ , p               ⟩+  -- Γ,(φ : I),(p : Path A u v),(δ : Δ[x = ⟨ φ , p ⟩]) ⊢ vecTransp (i. Δ[leftInv (~ i),μ[i]]) φ δ : Δ[ρ[τ], x = refl u[ρ[τ]]]+-}++-- | Append an hcomp clause to the clauses of a function.+createMissingHCompClause+  :: QName+       -- ^ Function name.+  -> Arg Nat -- ^ index of hcomp pattern+  -> BlockingVar -- ^ Blocking var that lead to hcomp split.+  -> SplitClause -- ^ Clause before the hcomp split+  -> SplitClause+       -- ^ Clause to add.+  -> [Clause]+   -> TCM ([(SplitTag,CoverResult)], [Clause])+createMissingHCompClause f n x old_sc (SClause tel ps _sigma' _cps (Just t)) cs = setCurrentRange f $ do+  reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "Trying to create right-hand side of type" <+> prettyTCM t+  reportSDoc "tc.cover.hcomp" 30 $ addContext tel $ text "ps = " <+> prettyTCMPatternList (fromSplitPatterns ps)+  reportSDoc "tc.cover.hcomp" 30 $ text "tel = " <+> prettyTCM tel++  io      <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIOne+  iz      <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIZero+  let+    cannotCreate :: MonadTCError m => Doc -> Closure (Abs Type) -> m a+    cannotCreate doc t = do+      typeError . SplitError $ CannotCreateMissingClause f (tel,fromSplitPatterns ps) doc t+  let old_ps = patternsToElims $ fromSplitPatterns $ scPats old_sc+      old_t  = fromJust $ scTarget old_sc+      old_tel = scTel old_sc+      -- old_tel = Γ(x:H)Δ+      -- Γ(x:H)Δ ⊢ old_t+      -- vs = iApplyVars old_ps+      -- [ α ⇒ b ] = [(i,f old_ps (i=0),f old_ps (i=1)) | i <- vs]++      -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ]+      -- Γ(x:H)Δ ⊢ f old_ps : old_t [ α ⇒ b ]+      -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ rhs_we_define : (old_t[ α ⇒ b ])(x = hcomp φ u u0)++      -- Extra assumption:+      -- tel = Γ,φ,u,u0,Δ(x = hcomp φ u u0),Δ'+      -- ps = old_ps[x = hcomp φ u u0],ps'+      -- with Δ' and ps' introduced by fixTarget.+      -- So final clause will be:+      -- tel ⊢ ps ↦ rhs_we_define{wkS ..} ps'++      getLevel t = do+        s <- reduce $ getSort t+        case s of+          Type l -> pure (Level l)++          -- Impossible since we only have HITs in Type:+          s -> do+            reportSDoc "tc.cover.hcomp" 20 $ vcat+              [ "sort of blocking variable when creating hcomp clause is not Type"+              , nest 2 ("t =" <+> prettyTCM t)+              , nest 2 ("s =" <+> prettyTCM s)+              , ""+              , "clause:"+              , nest 2 $ prettyTCM (QNamed f empty{ clauseTel = tel, namedClausePats = fromSplitPatterns ps })+              ]+            __IMPOSSIBLE__++      -- Γ ⊢ hdelta = (x : H)(δ : Δ)+      (gamma,hdelta@(ExtendTel hdom delta)) = splitTelescopeAt (size old_tel - (blockingVarNo x + 1)) old_tel++      -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢+      (working_tel,_deltaEx) = splitTelescopeAt (size gamma + 3 + size delta) tel++      -- Γ,φ,u,u0,(x:H)(δ : Δ) ⊢ rhoS : Γ(x:H)(δ : Δ)+      {- rhoS = liftS (size hdelta) $ raiseS 3 -}+      vs = iApplyVars (scPats old_sc)++  -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ] = [(i,f old_ps (i=0),f old_ps (i=1)) | i <- vs]+  alphab <- forM vs $ \ i -> do+               let+                 -- Γ(x:H)(δ : Δ) ⊢+                 tm = Def f old_ps+               -- TODO only reduce IApply _ _ (0/1), as to avoid termination problems+               (l,r) <- reduce (inplaceS i iz `applySubst` tm, inplaceS i io `applySubst` tm)+               return $ (var i, (l, r))++++  cl <- do+    (ty,rhs) <- addContext working_tel $ do+      -- Γ(x:H)Δ ⊢ g = f old_ps : old_t [ α ⇒ b ]+      -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ]+      -- Γ,φ,u,u0 ⊢ Δf = i.Δ[x = hfill φ u u0 i]+      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ δ_fill     = i.tFillTel (i. Δf[~i]) δ (~ i) : i.Δf[i]+      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ old_t_fill = i.old_t[x = hfill φ u u0 i, δ_fill[i]]+      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ comp (\ i. old_t_fill[i])+      --                 (\ i. [ φ ↦ g[x = hfill φ u u0 i,δ_fill[i]] = g[u i,δ_fill[i]]+      --                         α ↦ b[x = hfill φ u u0 i,δ_fill[i]]+      --                        ])+      --                 (g[x = u0,δ_fill[0]]) : old_t[x = hcomp φ u u0,δ]++      runNamesT [] $ do+          tPOr <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPOr+          tIMax <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIMax+          tIMin <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIMin+          tINeg <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinINeg+          tHComp <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinHComp+          tTrans <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinTrans+          extra_ps <- open $ patternsToElims $ fromSplitPatterns $ drop (length old_ps) ps+          let+            ineg j = pure tINeg <@> j+            imax i j = pure tIMax <@> i <@> j+            trFillTel' a b c d = do+              m <- trFillTel <$> a <*> b <*> c <*> d+              x <- lift $ runExceptT m+              case x of+                Left bad_t -> cannotCreate "Cannot transport with type family:" bad_t+                Right args -> return args+          comp <- mkCompLazy "hcompClause"+          let+            hcomp la bA phi u u0 = pure tHComp <#> la <#> bA+                                               <#> phi+                                               <@> u+                                               <@> u0++            hfill la bA phi u u0 i = hcomp la bA+                                               (pure tIMax <@> phi <@> (pure tINeg <@> i))+                                               (lam "j" $ \ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <#> ilam "o" (\ _ -> bA)+                                                     <@> ilam "o" (\ o -> u <@> (pure tIMin <@> i <@> j) <..> o)+                                                     <@> ilam "o" (\ _ -> u0)+                                                   )+                                               u0+          -- Γ,φ,u,u0,(δ : Δ(x = hcomp φ u u0)) ⊢ hcompS : Γ(x:H)(δ : Δ)+          hcompS <- lift $ do+            hdom <- pure $ raise 3 hdom+            let+              [phi,u,u0] = map (pure . var) [2,1,0]+              htype = pure $ unEl . unDom $ hdom+              lvl = getLevel $ unDom hdom+            hc <- pure tHComp <#> lvl <#> htype+                                      <#> phi+                                      <@> u+                                      <@> u0+            return $ liftS (size delta) $ hc `consS` raiseS 3+          -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ raise 3+|Δ| hdom+          hdom <- pure $ raise (3 + size delta) hdom+          htype <- open $ unEl . unDom $ hdom+          lvl <- open =<< (lift . getLevel $ unDom hdom)++          -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢+          let vr = open . raise (size delta) . var+          phi <- vr 2+          u   <- vr 1+          u0  <- vr 0+          -- Γ,x,Δ ⊢ f old_ps+          -- Γ ⊢ abstract hdelta (f old_ps)+          g <- open $ raise (3 + size delta) $ abstract hdelta (Def f old_ps)+          old_t <- open $ raise (3 + size delta) $ abstract hdelta (unDom old_t)+          let bapp a x = lazyAbsApp <$> a <*> x+          (delta_fill :: NamesT TCM (Abs Args)) <- (open =<<) $ do+            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ x.Δ+            delta <- open $ raise (3 + size delta) delta+            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ i.Δ(x = hfill phi u u0 (~ i))+            deltaf <- open =<< bind "i" (\ i ->+                           (delta `bapp` hfill lvl htype phi u u0 (ineg i)))+            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ Δ(x = hcomp phi u u0) = Δf[0]+            args <- (open =<<) $ teleArgs <$> (lazyAbsApp <$> deltaf <*> pure iz)+            bind "i" $ \ i -> addContext ("i" :: String) $ do -- for error messages.+              -- Γ,φ,u,u0,Δ(x = hcomp phi u u0),(i:I) ⊢ ... : Δ(x = hfill phi u u0 i)+              trFillTel' deltaf (pure iz) args (ineg i)+          let+            apply_delta_fill i f = apply <$> f <*> (delta_fill `bapp` i)+            call v i = apply_delta_fill i $ g <@> v+          ty <- do+                return $ \ i -> do+                    v <- hfill lvl htype phi u u0 i+                    hd <- old_t+                    args <- delta_fill `bapp` i+                    lift $ piApplyM hd $ Arg (domInfo hdom) v : args+          ty_level <- do+            t <- bind "i" $ \ x -> ty x+            s <- reduce $ getSort (absBody t)+            reportSDoc "tc.cover.hcomp" 20 $ text "ty_level, s = " <+> prettyTCM s+            case s of+              Type l -> open =<< lam "i" (\ _ -> pure $ Level l)+              _      -> do cl <- liftTCM (buildClosure t)+                           liftTCM (cannotCreate "Cannot compose with type family:" cl)++          let+            pOr_ty i phi psi u0 u1 = pure tPOr <#> (ty_level <@> i)+                                               <@> phi <@> psi+                                               <#> ilam "o" (\ _ -> unEl <$> ty i) <@> u0 <@> u1+          alpha <- do+            vars <- mapM (open . applySubst hcompS . fst) alphab+            return $ foldr (imax . (\ v -> v `imax` ineg v)) (pure iz) vars++          -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ b : (i : I) → [α] -> old_t[x = hfill φ u u0 i,δ_fill[i]]+          b <- do+             sides <- forM alphab $ \ (psi,(side0,side1)) -> do+                psi <- open $ hcompS `applySubst` psi+                let f = open . raise (3 + size delta) . abstract hdelta+                side0 <- f side0+                side1 <- f side1+                return $ (ineg psi `imax` psi, \ i -> pOr_ty i (ineg psi) psi (ilam "o" $ \ _ -> apply_delta_fill i $ side0 <@> hfill lvl htype phi u u0 i)+                                                            (ilam "o" $ \ _ -> apply_delta_fill i $ side1 <@> hfill lvl htype phi u u0 i))+             let recurse []           i = __IMPOSSIBLE__+                 recurse [(psi,u)]    i = u i+                 recurse ((psi,u):xs) i = pOr_ty i psi (foldr (imax . fst) (pure iz) xs) (u i) (recurse xs i)+             return $ recurse sides++          ((,) <$> ty (pure io) <*>) $ do+            comp ty_level+               (lam "i" $ fmap unEl . ty)+                           (phi `imax` alpha)+                           (lam "i" $ \ i ->+                               let rhs = (ilam "o" $ \ o -> call (u <@> i <..> o) i)+                               in if null alphab then rhs else+                                   pOr_ty i phi alpha rhs (b i)+                           )+                           (call u0 (pure iz))+    reportSDoc "tc.cover.hcomp" 20 $ text "old_tel =" <+> prettyTCM tel+    let n = size tel - (size gamma + 3 + size delta)+    reportSDoc "tc.cover.hcomp" 20 $ text "n =" <+> text (show n)+    (TelV deltaEx t,bs) <- telViewUpToPathBoundary' n ty+    rhs <- pure $ raise n rhs `applyE` teleElims deltaEx bs++    cxt <- getContextTelescope+    reportSDoc "tc.cover.hcomp" 30 $ text "cxt = " <+> prettyTCM cxt+    reportSDoc "tc.cover.hcomp" 30 $ text "tel = " <+> prettyTCM tel+    reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "t = " <+> prettyTCM t+    reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "rhs = " <+> prettyTCM rhs++    return $ Clause { clauseLHSRange  = noRange+                    , clauseFullRange = noRange+                    , clauseTel       = tel+                    , namedClausePats = fromSplitPatterns ps+                    , clauseBody      = Just $ rhs+                    , clauseType      = Just $ defaultArg t+                    , clauseCatchall    = empty+                    , clauseRecursive   = Nothing     -- TODO: can it be recursive?+                    , clauseUnreachable = Just False  -- missing, thus, not unreachable+                    , clauseEllipsis    = NoEllipsis+                    , clauseWhereModule = Nothing+                    }+  addClauses f [cl]  -- Important: add at the end.+  let result = CoverResult+          { coverSplitTree      = SplittingDone (size (clauseTel cl))+          , coverUsedClauses    = IntSet.singleton (length cs)+          , coverMissingClauses = []+          , coverPatterns       = [cl]+          , coverNoExactClauses = IntSet.empty+          }+  hcompName <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinHComp+  return ([(SplitCon hcompName, result)], cs ++ [cl])+createMissingHCompClause _ _ _ _ (SClause _ _ _ _ Nothing) _ = __IMPOSSIBLE__
src/full/Agda/TypeChecking/Coverage/Match.hs view
@@ -13,7 +13,8 @@  module Agda.TypeChecking.Coverage.Match   ( Match(..), match, matchClause-  , SplitPattern, SplitPatVar(..), fromSplitPatterns, toSplitPatterns+  , SplitPattern, SplitPatVar(..)+  , fromSplitPattern, fromSplitPatterns, toSplitPatterns   , toSplitPSubst, applySplitPSubst   , isTrivialPattern   , BlockingVar(..), BlockingVars, BlockedOnResult(..)@@ -21,10 +22,10 @@   , ApplyOrIApply(..)   ) where -import Control.Monad.State- import Prelude hiding ( null ) +import Data.DList (DList)+import Data.Foldable (toList) import qualified Data.List as List import Data.Maybe (mapMaybe, fromMaybe) import Data.Semigroup ( Semigroup, (<>))@@ -32,7 +33,6 @@ import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Literal-import Agda.Syntax.Position  import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty ( PrettyTCM(..) )@@ -41,8 +41,9 @@ import Agda.TypeChecking.Substitute  import Agda.Utils.Null-import Agda.Utils.Pretty ( Pretty(..), text, (<+>), cat , prettyList_ )+import Agda.Syntax.Common.Pretty ( Pretty(..), text, (<+>), cat , prettyList_ ) import Agda.Utils.Monad+import Agda.Utils.Singleton  import Agda.Utils.Impossible @@ -96,6 +97,7 @@ --   clause to match 'SplitClause'. type SplitInstantiation = [(Nat,SplitPattern)] +{-# SPECIALIZE match :: [Clause] -> [NamedArg SplitPattern] -> TCM (Match (Nat, SplitInstantiation)) #-} -- | Match the given patterns against a list of clauses. -- -- If successful, return the index of the covering clause.@@ -110,7 +112,7 @@             => Nat  -- Clause number.             -> Clause             -> m (Match (Nat, SplitInstantiation))-    matchIt i c = fmap (i,) <$> matchClause ps c+    matchIt i c = fmap (\s -> (i, toList s)) <$> matchClause ps c  -- | For each variable in the patterns of a split clause, we remember the --   de Bruijn-index and the literals excluded by previous matches.@@ -142,13 +144,16 @@  instance DeBruijn SplitPatVar where   deBruijnView x = deBruijnView (fromSplitVar x)-  debruijnNamedVar n i = toSplitVar (debruijnNamedVar n i)+  deBruijnNamedVar n i = toSplitVar (deBruijnNamedVar n i)  toSplitPatterns :: [NamedArg DeBruijnPattern] -> [NamedArg SplitPattern] toSplitPatterns = (fmap . fmap . fmap . fmap) toSplitVar +fromSplitPattern :: NamedArg SplitPattern -> NamedArg DeBruijnPattern+fromSplitPattern = (fmap . fmap . fmap) fromSplitVar+ fromSplitPatterns :: [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]-fromSplitPatterns = (fmap . fmap . fmap . fmap) fromSplitVar+fromSplitPatterns = fmap fromSplitPattern  type SplitPSubstitution = Substitution' SplitPattern @@ -205,6 +210,7 @@         p -> p  +{-# SPECIALIZE isTrivialPattern :: Pattern' a -> TCM Bool #-} -- | A pattern that matches anything (modulo eta). isTrivialPattern :: (HasConstInfo m) => Pattern' a -> m Bool isTrivialPattern = \case@@ -219,7 +225,7 @@  -- | If matching succeeds, we return the instantiation of the clause pattern vector --   to obtain the split clause pattern vector.-type MatchResult = Match SplitInstantiation+type MatchResult = Match (DList (Nat, SplitPattern))  instance Pretty BlockingVar where   pretty (BlockingVar i cs ls o l) = cat@@ -304,8 +310,7 @@     No         -> return $ Block r xs   No    -> m' --- | @matchClause qs i c@ checks whether clause @c@---   covers a split clause with patterns @qs@.+{-# SPECIALIZE matchClause :: [NamedArg SplitPattern] -> Clause -> TCM MatchResult #-} matchClause   :: PureTCM m   => [NamedArg SplitPattern]@@ -317,7 +322,7 @@      --   If 'Yes' the instantiation @rs@ such that @(namedClausePats c)[rs] == qs@. matchClause qs c = matchPats (namedClausePats c) qs -+{-# SPECIALIZE matchPats :: DeBruijn a => [NamedArg (Pattern' a)] -> [NamedArg SplitPattern] -> TCM MatchResult #-} -- | @matchPats ps qs@ checks whether a function clause with patterns --   @ps@ covers a split clause with patterns @qs@. --@@ -342,7 +347,7 @@   -> m MatchResult      -- ^ Result.      --   If 'Yes' the instantiation @rs@ such that @ps[rs] == qs@.-matchPats [] [] = yes []+matchPats [] [] = yes mempty matchPats (p:ps) (q:qs) =   matchPat (namedArg p) (namedArg q) `combine` matchPats ps qs @@ -352,8 +357,8 @@ -- Thus, if the split clause has copatterns left, -- the current (shorter) clause is not considered covering. matchPats [] qs@(_:_) = case mapMaybe isProjP qs of-  [] -> yes [] -- no proj. patterns left-  _  -> no     -- proj. patterns left+  [] -> yes mempty -- no proj. patterns left+  _  -> no         -- proj. patterns left  -- Patterns left in candidate clause: -- If the current clause has additional copatterns in@@ -385,6 +390,7 @@       Block s ys -> return $ Block (anyBlockedOnResult r s) (xs ++ ys)       Yes{} -> return x +{-# SPECIALIZE matchPat :: DeBruijn a => Pattern' a -> SplitPattern -> TCM MatchResult #-} -- | @matchPat p q@ checks whether a function clause pattern @p@ --   covers a split clause pattern @q@.  There are three results: --@@ -408,9 +414,10 @@      --   to produce the split clause pattern, @p[rs] = q@. matchPat p q = case p of -  VarP _ x   -> yes [(fromMaybe __IMPOSSIBLE__ (deBruijnView x),q)]+  VarP _ x ->+    yes $ singleton (fromMaybe __IMPOSSIBLE__ (deBruijnView x), q) -  DotP{}   -> yes []+  DotP{} -> yes mempty   -- Jesper, 2014-11-04: putting 'Yes [q]' here triggers issue 1333.   -- Not checking for trivial patterns should be safe here, as dot patterns are   -- guaranteed to match if the rest of the pattern does, so some extra splitting@@ -421,16 +428,22 @@                 then no                 else blockedOnLiteral (splitPatVarIndex x) l     _ -> isLitP q >>= \case-      Just l' -> if l == l' then yes [] else no+      Just l' -> if l == l' then yes mempty else no       Nothing -> no    ProjP _ d -> case q of     ProjP _ d' -> do       d <- getOriginalProjection d-      if d == d' then yes [] else no-    _          -> __IMPOSSIBLE__+      if d == d' then yes mempty else no+    VarP{}     -> no  -- not impossible, see issue #7753+    DotP{}     -> __IMPOSSIBLE__+    ConP{}     -> __IMPOSSIBLE__+    DefP{}     -> __IMPOSSIBLE__+    LitP{}     -> __IMPOSSIBLE__+    IApplyP{}  -> __IMPOSSIBLE__ -  IApplyP _ _ _ x -> yes [(fromMaybe __IMPOSSIBLE__ (deBruijnView x),q)]+  IApplyP _ _ _ x ->+    yes $ singleton (fromMaybe __IMPOSSIBLE__ (deBruijnView x), q)                             --    Issue #4179: If the inferred pattern is a literal                            -- v  we need to turn it into a constructor pattern.@@ -446,7 +459,7 @@     IApplyP _ _ _ x -> blockedOnConstructor (splitPatVarIndex x) c ci    DefP o c ps -> unDotP q >>= \case-    VarP _ x -> __IMPOSSIBLE__ -- blockedOnConstructor (splitPatVarIndex x) c+    VarP _ x -> no     ConP c' i qs -> no     DotP o t  -> no     LitP{}    -> no@@ -456,6 +469,7 @@     ProjP{}   -> __IMPOSSIBLE__  -- excluded by typing     IApplyP _ _ _ x -> __IMPOSSIBLE__ -- blockedOnConstructor (splitPatVarIndex x) c +{-# SPECIALIZE unDotP :: DeBruijn a => Pattern' a -> TCM (Pattern' a) #-} -- | Unfold one level of a dot pattern to a proper pattern if possible. unDotP :: (MonadReduce m, DeBruijn a) => Pattern' a -> m (Pattern' a) unDotP (DotP o v) = reduce v >>= \case@@ -467,19 +481,20 @@   v     -> return $ dotP v unDotP p = return p +{-# SPECIALIZE isLitP :: Pattern' a -> TCM (Maybe Literal) #-} isLitP :: PureTCM m => Pattern' a -> m (Maybe Literal) isLitP (LitP _ l) = return $ Just l isLitP (DotP _ u) = reduce u >>= \case   Lit l -> return $ Just l   _ -> return $ Nothing isLitP (ConP c ci []) = do-  Con zero _ [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinZero-  if c == zero+  zero <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinZero+  if conName c == zero     then return $ Just $ LitNat 0     else return Nothing isLitP (ConP c ci [a]) | visible a && isRelevant a = do-  Con suc _ [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSuc-  if c == suc+  suc <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSuc+  if conName c == suc     then fmap inc <$> isLitP (namedArg a)     else return Nothing   where@@ -488,13 +503,17 @@     inc _ = __IMPOSSIBLE__ isLitP _ = return Nothing +{-# SPECIALIZE unLitP :: Pattern' a -> TCM (Pattern' a) #-} unLitP :: HasBuiltins m => Pattern' a -> m (Pattern' a) unLitP (LitP info l@(LitNat n)) | n >= 0 = do-  Con c ci es <- constructorForm' (fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinZero)-                                  (fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSuc)-                                  (Lit l)-  let toP (Apply (Arg i (Lit l))) = Arg i (LitP info l)-      toP _ = __IMPOSSIBLE__-      cpi   = noConPatternInfo { conPInfo = info }-  return $ ConP c cpi $ map (fmap unnamed . toP) es+ constructorForm'+   (fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinZero)+   (fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSuc)+   (Lit l) >>= \case+  Con c ci es -> do+    let toP (Apply (Arg i (Lit l))) = Arg i (LitP info l)+        toP _ = __IMPOSSIBLE__+        cpi   = noConPatternInfo { conPInfo = info }+    return $ ConP c cpi $ map (fmap unnamed . toP) es+  _ -> __IMPOSSIBLE__ unLitP p = return p
+ src/full/Agda/TypeChecking/Coverage/SplitClause.hs view
@@ -0,0 +1,124 @@+{-| SplitClause and CoverResult types.+ -}++module Agda.TypeChecking.Coverage.SplitClause where++import Prelude hiding (null, (!!))  -- do not use partial functions like !!++import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty (prettyShow)+import Agda.Syntax.Internal hiding (DataOrRecord)++import Agda.TypeChecking.Coverage.Match+import Agda.TypeChecking.Coverage.SplitTree+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Records+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Telescope.Path+import Agda.TypeChecking.MetaVars+import Agda.TypeChecking.Warnings++import Agda.Interaction.Options++import Agda.Utils.Either+import Agda.Utils.Functor+import Agda.Utils.List+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Permutation+import Agda.Utils.Singleton+import Agda.Utils.Size+import Agda.Utils.WithDefault++import Agda.Utils.Impossible+++data SplitClause = SClause+  { scTel    :: Telescope+    -- ^ Type of variables in @scPats@.+  , scPats   :: [NamedArg SplitPattern]+    -- ^ The patterns leading to the currently considered branch of+    --   the split tree.+  , scSubst  :: Substitution' SplitPattern+    -- ^ Substitution from 'scTel' to old context.+    --   Only needed directly after split on variable:+    --   * To update 'scTarget'+    --   * To rename other split variables when splitting on+    --     multiple variables.+    --   @scSubst@ is not ``transitive'', i.e., does not record+    --   the substitution from the original context to 'scTel'+    --   over a series of splits.  It is freshly computed+    --   after each split by 'computeNeighborhood'; also+    --   'splitResult', which does not split on a variable,+    --   should reset it to the identity 'idS', lest it be+    --   applied to 'scTarget' again, leading to Issue 1294.+  , scCheckpoints :: Map CheckpointId Substitution+    -- ^ We need to keep track of the module parameter checkpoints for the+    -- clause for the purpose of inferring missing instance clauses.+  , scTarget :: Maybe (Dom Type)+    -- ^ The type of the rhs, living in context 'scTel'.+    --   'fixTargetType' computes the new 'scTarget' by applying+    --   substitution 'scSubst'.+  }++data UnifyEquiv = UE { infoTel0 :: Telescope          -- Γ0+                     , infoTel :: Telescope           -- Γ'+                     , infoEqTel :: Telescope         -- Γ0 ⊢ Δ+                     , infoEqLHS :: [Term]            -- Γ0 ⊢ us : Δ+                     , infoEqRHS :: [Term]            -- Γ0 ⊢ vs : Δ+                     , infoRho :: PatternSubstitution -- Γ' ⊢ ρ : Γ0+                                                      -- Γ = Γ0,(φ : I),(eqs : Paths Δ us vs)+                                                      -- Γ' ⊢ ρ,i1,refls : Γ+                     , infoTau :: Substitution        -- Γ  ⊢ τ           : Γ'+                     , infoLeftInv :: Substitution    -- Γ | (i : I) ⊢ leftInv : Γ+                     -- leftInv[i=0] = ρ[τ],i1s,refls+                     -- leftInv[i=1] = idS+                     }+                  deriving Show++data IInfo = TheInfo UnifyEquiv | NoInfo deriving Show++-- | A @Covering@ is the result of splitting a 'SplitClause'.+data Covering = Covering+  { covSplitArg     :: Arg Nat+     -- ^ De Bruijn level (counting dot patterns) of argument we split on.+  , covSplitClauses :: [(SplitTag, (SplitClause, IInfo))]+      -- ^ Covering clauses, indexed by constructor/literal these clauses share.+  }++-- | Project the split clauses out of a covering.+splitClauses :: Covering -> [SplitClause]+splitClauses (Covering _ qcs) = map (fst . snd) qcs++-- | Create a split clause from a clause in internal syntax. Used by make-case.+clauseToSplitClause :: Clause -> SplitClause+clauseToSplitClause cl = SClause+  { scTel    = clauseTel cl+  , scPats   = toSplitPatterns $ namedClausePats cl+  , scSubst  = idS  -- Andreas, 2014-07-15  TODO: Is this ok?+  , scCheckpoints = Map.empty -- #2996: not __IMPOSSIBLE__ for debug printing+  , scTarget = domFromArg <$> clauseType cl+  }+++---------------------------------------------+-- Record type for the results of @cover@+---------------------------------------------++data CoverResult = CoverResult+  { coverSplitTree       :: SplitTree+  , coverUsedClauses     :: IntSet -- Set Nat+  , coverMissingClauses  :: [(Telescope, [NamedArg DeBruijnPattern])]+  , coverPatterns        :: [Clause]+  -- ^ The set of patterns used as cover.+  , coverNoExactClauses  :: IntSet -- Set Nat+  }
src/full/Agda/TypeChecking/Coverage/SplitTree.hs view
@@ -1,4 +1,6 @@ +{-# OPTIONS_GHC -Wall #-}+ {-| Split tree for transforming pattern clauses into case trees.  The coverage checker generates a split tree from the clauses.@@ -15,7 +17,6 @@ import Control.DeepSeq  import Data.Tree-import Data.Data (Data)  import GHC.Generics (Generic) @@ -25,7 +26,7 @@ import Agda.Syntax.Literal import Agda.Syntax.Position -import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.Null  import Agda.Utils.Impossible@@ -46,10 +47,10 @@     , splitLazy  :: LazySplit     , splitTrees :: SplitTrees' a -- ^ Sub split trees.     }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  data LazySplit = LazySplit | StrictSplit-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  -- | Split tree branching.  A finite map from constructor names to splittrees --   A list representation seems appropriate, since we are expecting not@@ -64,7 +65,7 @@   = SplitCon QName   | SplitLit Literal   | SplitCatchall-  deriving (Show, Eq, Ord, Data, Generic)+  deriving (Show, Eq, Ord, Generic)  instance Pretty SplitTag where   pretty (SplitCon c) = pretty c@@ -106,14 +107,14 @@  instance KillRange SplitTag where   killRange = \case-    SplitCon c -> killRange1 SplitCon c-    SplitLit l -> killRange1 SplitLit l+    SplitCon c -> killRangeN SplitCon c+    SplitLit l -> killRangeN SplitLit l     SplitCatchall -> SplitCatchall  instance KillRange a => KillRange (SplitTree' a) where   killRange = \case     SplittingDone n -> SplittingDone n-    SplitAt i lz ts -> killRange1 (SplitAt i lz) ts+    SplitAt i lz ts -> killRangeN (SplitAt i lz) ts  instance NFData a => NFData (SplitTree' a) instance NFData LazySplit
src/full/Agda/TypeChecking/Datatypes.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Datatypes where @@ -11,11 +12,13 @@  import Agda.TypeChecking.Monad import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Pretty  import Agda.Utils.Either-import Agda.Utils.Pretty ( prettyShow )+import Agda.Utils.Functor+import Agda.Syntax.Common.Pretty ( prettyShow ) import Agda.Utils.Size  import Agda.Utils.Impossible@@ -33,6 +36,9 @@     Record     { recConHead = c' } -> return c'     _ -> throwError $ SigUnknown $ prettyShow c ++ " is not a constructor" +isConstructor :: (HasConstInfo m) => QName -> m Bool+isConstructor q = isRight <$> getConHead q+ -- | Get true constructor with fields, expanding literals to constructors --   if possible. getConForm :: QName -> TCM (Either SigError ConHead)@@ -66,49 +72,14 @@     Record{} -> return False     _  -> __IMPOSSIBLE__ --- | @getConType c t@ computes the constructor parameters from type @t@---   and returns them plus the instantiated type of constructor @c@.---   This works also if @t@ is a function type ending in a data/record type;---   the term from which @c@ comes need not be fully applied------   @Nothing@ if @t@ is not a data/record type or does not have---   a constructor @c@.-getConType-  :: PureTCM m-  => ConHead  -- ^ Constructor.-  -> Type     -- ^ Ending in data/record type.-  -> m (Maybe ((QName, Type, Args), Type))-       -- ^ @Nothing@ if not ends in data or record type.-       ---       --   @Just ((d, dt, pars), ct)@ otherwise, where-       --     @d@    is the data or record type name,-       --     @dt@   is the type of the data or record name,-       --     @pars@ are the reconstructed parameters,-       --     @ct@   is the type of the constructor instantiated to the parameters.-getConType c t = do-  reportSDoc "tc.getConType" 30 $ sep $-    [ "getConType: constructor "-    , prettyTCM c-    , " at type "-    , prettyTCM t-    ]-  TelV tel t <- telView t-  -- Now @t@ lives under @tel@, we need to remove the dependency on @tel@.-  -- This will succeed if @t@ is indeed a data/record type that is the-  -- type of a constructor coming from a term-  -- (applied to at least the parameters).-  -- Note: @t@ will have some unbound deBruijn indices if view outside of @tel@.-  reportSLn "tc.getConType" 35 $ "  target type: " ++ prettyShow t-  applySubst (strengthenS impossible (size tel)) <$> do-    addContext tel $ getFullyAppliedConType c t-  -- Andreas, 2017-08-18, issue #2703:-  -- The original code-  --    getFullyAppliedConType c $ applySubst (strengthenS impossible (size tel)) t-  -- crashes because substitution into @Def@s is slightly too strict-  -- (see @defApp@ and @canProject@).-  -- Strengthening the parameters after the call to @getFullyAppliedConType@-  -- does not produce intermediate terms with __IMPOSSIBLE__s and this thus-  -- robust wrt. strictness/laziness of substitution.+isPathCons :: HasConstInfo m => QName -> m Bool+isPathCons c = do+  d <- getConstructorData c+  def <- theDef <$> getConstInfo d+  case def of+    Datatype {dataPathCons = xs} -> return $ c `elem` xs+    Record{} -> return False+    _  -> __IMPOSSIBLE__  -- | @getFullyAppliedConType c t@ computes the constructor parameters --   from data type @t@ and returns them@@ -133,48 +104,134 @@ getFullyAppliedConType c t = do   reportSLn "tc.getConType" 35 $ unwords $     [ "getFullyAppliedConType", prettyShow c, prettyShow t ]-  c <- fromRight __IMPOSSIBLE__ <$> do getConHead $ conName c+  c <- fromRight __IMPOSSIBLE__ <$> getConHead (conName c)+  cdef <- getConstInfo $ conName c+  let ctype = defType cdef+      cdata = conData $ theDef cdef+      npars = conPars $ theDef cdef   case unEl t of-    -- Note that if we come e.g. from getConType,-    -- then the non-parameter arguments of @es@ might contain __IMPOSSIBLE__-    -- coming from strengthening.  (Thus, printing them is not safe.)-    Def d es -> do+    Def d es | d == cdata -> do       reportSLn "tc.getConType" 35 $ unwords $         [ "getFullyAppliedConType: case Def", prettyShow d, prettyShow es ]-      def <- getConstInfo d-      let cont n = do-            -- At this point we can be sure that the parameters are well-scoped.-            let pars = fromMaybe __IMPOSSIBLE__ $ allApplyElims $ take n es-            Just . ((d, defType def, pars),) <$> do-              (`piApplyM` pars) . defType =<< getConInfo c-      case theDef def of-        Datatype { dataPars = n, dataCons   = cs  } | conName c `elem` cs -> cont n-        Record   { recPars  = n, recConHead = con } | c == con            -> cont n-        _ ->  return Nothing+      dt <- defType <$> getConstInfo d+      let pars = fromMaybe __IMPOSSIBLE__ $ allApplyElims $ take npars es+      ctPars <- ctype `piApplyM` pars+      return $ Just ((d, dt, pars), ctPars)     _ -> return Nothing +-- | Make sure a constructor is fully applied and infer the type of the constructor.+--   Raises a type error if the constructor does not belong to the given type.+fullyApplyCon+  :: (PureTCM m, MonadBlock m, MonadTCError m)+  => ConHead -- ^ Constructor.+  -> Elims    -- ^ Constructor arguments.+  -> Type    -- ^ Type of the constructor application.+  -> (QName -> Type -> Args -> Type -> Elims -> Telescope -> Type -> m a)+       -- ^ Name of the data/record type,+       --   type of the data/record type,+       --   reconstructed parameters,+       --   type of the constructor (applied to parameters),+       --   full application arguments,+       --   types of missing arguments (already added to context),+       --   type of the full application.+  -> m a+fullyApplyCon c vs t ret = fullyApplyCon' c vs t ret $+  typeError . ConstructorDoesNotTargetGivenType (conName c)++-- | Like @fullyApplyCon@, but calls the given fallback function if+--   it encounters something other than a datatype.+fullyApplyCon'+  :: (PureTCM m, MonadBlock m)+  => ConHead -- ^ Constructor.+  -> Elims    -- ^ Constructor arguments.+  -> Type    -- ^ Type of the constructor application.+  -> (QName -> Type -> Args -> Type -> Elims -> Telescope -> Type -> m a) -- ^ See @fullyApplyCon@+  -> (Type -> m a) -- ^ Fallback function+  -> m a+fullyApplyCon' c vs t0 ret err = do+  reportSDoc "tc.getConType" 30 $ sep $+    [ "fullyApplyCon': constructor "+    , prettyTCM c+    , " with arguments"+    , prettyTCM vs+    , " at type "+    , prettyTCM t0+    ]+  (TelV tel t, boundary) <- telViewPathBoundary t0+  -- The type of the constructor application may still be a function+  -- type.  In this case, we introduce the domains @tel@ into the context+  -- and apply the constructor to these fresh variables.+  addContext tel $ do+    reportSLn "tc.getConType" 35 $ "  target type: " ++ prettyShow t+    t <- abortIfBlocked t+    getFullyAppliedConType c t >>= \case+      Nothing -> err t+      Just ((d, dt, pars), a) ->+        ret d dt pars a (raise (size tel) vs ++ teleElims tel boundary) tel t++-- | @getConType c t@ computes the constructor parameters from type @t@+--   and returns them plus the instantiated type of constructor @c@.+--   This works also if @t@ is a function type ending in a data/record type;+--   the term from which @c@ comes need not be fully applied+--+--   @Nothing@ if @t@ is not a data/record type or does not have+--   a constructor @c@.+getConType+  :: (PureTCM m, MonadBlock m)+  => ConHead  -- ^ Constructor.+  -> Type     -- ^ Ending in data/record type.+  -> m (Maybe ((QName, Type, Args), Type))+       -- ^ @Nothing@ if not ends in data or record type.+       --+       --   @Just ((d, dt, pars), ct)@ otherwise, where+       --     @d@    is the data or record type name,+       --     @dt@   is the type of the data or record name,+       --     @pars@ are the reconstructed parameters,+       --     @ct@   is the type of the constructor instantiated to the parameters.+getConType ch t = do+  let c = conName ch+  -- Optimization: if the constructor has no parameters, there+  -- is no need to reduce the type.+  npars <- getNumberOfParameters c+  if | npars == Just 0 -> do+      ctype <- defType <$> getConstInfo c+      d  <- getConstructorData c+      dtype <- defType <$> getConstInfo d+      return $ Just ((d,dtype,[]),ctype)+     | otherwise -> fullyApplyCon' ch [] t+      (\d dt pars ct es tel a -> return $+        -- Now @dt@, @pars@, and @ct@ live under @tel@,+        -- so we need to remove the dependency on @tel@.+        let escape = applySubst (strengthenS impossible (size tel)) in+        Just $ escape ((d, dt, pars), ct))+      (\_ -> return Nothing)+ data ConstructorInfo-  = DataCon Nat-      -- ^ Arity.-  | RecordCon PatternOrCopattern HasEta [Dom QName]-      -- ^ List of field names.+  = DataCon Arity+      -- ^ Arity of the data constructor.+  | RecordCon PatternOrCopattern HasEta+      Arity+      -- ^ Arity of the record constructor.+      [Dom QName]+      -- ^ List of field names. Has length 'Arity'. --- | Return the number of non-parameter arguments to a data constructor,---   or the field names of a record constructor.+-- | Return the number of non-parameter arguments to a constructor (arity).+--   In case of record constructors, also return the field names (plus other info). -----   For getting just the arity of constructor @c@,---   use @either id size <$> getConstructorArity c@. getConstructorInfo :: HasConstInfo m => QName -> m ConstructorInfo-getConstructorInfo c = do-  (theDef <$> getConstInfo c) >>= \case-    Constructor{ conData = d, conArity = n } -> do-      (theDef <$> getConstInfo d) >>= \case-        r@Record{ recFields = fs } ->-           return $ RecordCon (recPatternMatching r) (recEtaEquality r) fs-        Datatype{} ->-           return $ DataCon n+getConstructorInfo c = fromMaybe __IMPOSSIBLE__ <$> getConstructorInfo' c++getConstructorInfo' :: HasConstInfo m => QName -> m (Maybe ConstructorInfo)+getConstructorInfo' c = do+  getConstInfo c <&> theDef >>= \case+    Constructor{ conData = d, conArity = n } -> Just <$> do+      getConstInfo d <&> theDef <&> \case+        RecordDefn (r@RecordData{ _recFields = fs, _recPatternMatching = pat }) ->+          RecordCon pat (_recEtaEquality r) n fs+        DatatypeDefn _ ->+          DataCon n         _ -> __IMPOSSIBLE__-    _ -> __IMPOSSIBLE__+    _ -> return Nothing  --------------------------------------------------------------------------- -- * Data types@@ -193,14 +250,20 @@ isDataOrRecordType :: QName -> TCM (Maybe DataOrRecord) isDataOrRecordType d = do   (theDef <$> getConstInfo d) >>= \case-    Record{ recPatternMatching } -> return $ Just $ IsRecord recPatternMatching+    Record{ recEtaEquality', recPatternMatching } -> return $ Just $ IsRecord $+      case recPatternMatching of+        -- If the user explicitly asked for @pattern@, pattern matching is allowed.+        p@PatternMatching -> p+        -- Otherwise, 'recEtaEquality' might allow pattern matching.+        CopatternMatching ->+          if patternMatchingAllowed recEtaEquality' then PatternMatching else CopatternMatching     Datatype{} -> return $ Just IsData     _          -> return $ Nothing  -- | Precodition: 'Term' is 'reduce'd.-isDataOrRecord :: Term -> TCM (Maybe QName)+isDataOrRecord :: Term -> TCM (Maybe (QName, DataOrRecord)) isDataOrRecord = \case-    Def d _ -> fmap (const d) <$> isDataOrRecordType d+    Def d _ -> fmap (d,) <$> isDataOrRecordType d     _       -> return Nothing  getNumberOfParameters :: HasConstInfo m => QName -> m (Maybe Nat)@@ -212,11 +275,26 @@     Constructor{ conPars = n } -> return $ Just n     _                          -> return Nothing +-- | This is a simplified version of @isDatatype@ from @Coverage@,+--   useful when we do not want to import the module.+getDatatypeArgs :: HasConstInfo m => Type -> m (Maybe (QName, Args, Args))+getDatatypeArgs t = do+  case unEl t of+    Def d es -> do+      let ~(Just args) = allApplyElims es+      def <- theDef <$> getConstInfo d+      case def of+        Datatype{dataPars = np} -> do+          let !(ps, is) = splitAt np args+          return $ Just (d,   ps, is)+        Record{} -> do+          return $ Just (d, args, [])+        _ -> return Nothing+    _ -> return Nothing+ getNotErasedConstructors :: QName -> TCM [QName] getNotErasedConstructors d = do-  cs <- getConstructors d-  flip filterM cs $ \ c -> do-    usableModality <$> getConstInfo c+  filterM (usableModality <.> getConstInfo) =<< getConstructors d  -- | Precondition: Name is a data or record type. getConstructors :: QName -> TCM [QName]
src/full/Agda/TypeChecking/Datatypes.hs-boot view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Datatypes where
src/full/Agda/TypeChecking/DeadCode.hs view
@@ -1,13 +1,15 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.DeadCode (eliminateDeadCode) where -import Data.Monoid (All(..))-import qualified Data.Map as Map-import Data.Set (Set)-import qualified Data.Set as Set-import qualified Data.HashMap.Strict as HMap+import Control.Monad (filterM)+import Control.Monad.Trans -import qualified Agda.Syntax.Abstract as A+import Data.Maybe+import qualified Data.Map.Strict as MapS+import qualified Data.HashMap.Strict as HMap +import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Names import Agda.Syntax.Scope.Base@@ -16,36 +18,129 @@ import qualified Agda.TypeChecking.Monad.Benchmark as Bench  import Agda.TypeChecking.Monad-import Agda.TypeChecking.Reduce +import Agda.Utils.Monad (mapMaybeM)+import Agda.Utils.Impossible import Agda.Utils.Lens --- | Run before serialisation to remove any definitions that are not reachable---   from the public interface to the module.-eliminateDeadCode :: DisplayForms -> Signature -> TCM (DisplayForms, Signature)-eliminateDeadCode disp sig = Bench.billTo [Bench.DeadCode] $ do-  patsyn <- getPatternSyns-  public <- Set.mapMonotonic anameName . publicNames <$> getScope-  defs <- traverse instantiateFull $ sig ^. sigDefinitions+import Agda.Utils.HashTable (HashTable)+import qualified Agda.Utils.HashTable as HT++-- | Run before serialisation to remove data that's not reachable from the+--   public interface. We do not compute reachable data precisely, because that+--   would be very expensive, mainly because of rewrite rules. The following+--   things are assumed to be "roots":+--     - public definitions+--     - definitions marked as primitive+--     - definitions with COMPILE pragma+--     - all pattern synonyms (because currently all of them go into interfaces)+--     - all parameter sections (because currently all of them go into interfaces)+--       (see also issues #6931 and #7382)+--     - local builtins+--     - all rewrite rules+--     - closed display forms+--   We only ever prune dead metavariables and definitions. We return the pruned metas,+--   pruned definitions and closed display forms.+eliminateDeadCode :: ScopeInfo -> TCM (RemoteMetaStore, Definitions, DisplayForms)+eliminateDeadCode !scope = Bench.billTo [Bench.DeadCode] $ do+  !sig <- getSignature+  let !defs = sig ^. sigDefinitions+  !metas <- useR stSolvedMetaStore+   -- #2921: Eliminating definitions with attached COMPILE pragmas results in   -- the pragmas not being checked. Simple solution: don't eliminate these.-  let hasCompilePragma = Set.fromList . HMap.keys . HMap.filter (not . Map.null . defCompiledRep) $ defs-  let r     = reachableFrom (Set.union public hasCompilePragma) patsyn defs-      dead  = Set.fromList (HMap.keys defs) `Set.difference` r-      valid = getAll . namesIn' (All . (`Set.notMember` dead))  -- no used name is dead-      defs' = HMap.map ( \ d -> d { defDisplay = filter valid (defDisplay d) } )-            $ HMap.filterWithKey (\ x _ -> Set.member x r) defs-      disp' = HMap.filter (not . null) $ HMap.map (filter valid) disp-  reportSLn "tc.dead" 10 $ "Removed " ++ show (HMap.size defs - HMap.size defs') ++ " unused definitions."-  return (disp', set sigDefinitions defs' sig)+  -- #6022 (Andreas, 2022-09-30): Eliminating cubical primitives can lead to crashes.+  -- Simple solution: retain all primitives (shouldn't be many).+  let hasCompilePragma = not . MapS.null . defCompiledRep -reachableFrom :: Set QName -> A.PatternSynDefns -> Definitions -> Set QName-reachableFrom names psyns defs = follow names (Set.toList names)-  where-    follow visited [] = visited-    follow visited (x : xs) = follow (Set.union visited new) (Set.toList new ++ xs)-      where-        new = names `Set.difference` visited-        names = case HMap.lookup x defs of-                  Nothing -> namesIn (PSyn <$> Map.lookup x psyns)-                  Just d  -> namesIn d+      isPrimitive = \case+        Primitive{}     -> True+        PrimitiveSort{} -> True+        _               -> False++      extraRootsFilter (name, def)+        | hasCompilePragma def || isPrimitive (theDef def) = Just name+        | otherwise = Nothing++  let !pubModules = publicModules scope++    -- Ulf, 2016-04-12:+    -- Non-closed display forms are not applicable outside the module anyway,+    -- and should be dead-code eliminated (#1928).+  !rootDisplayForms <-+      HMap.filter (not . null) . HMap.map (filter isClosed) <$> useTC stImportsDisplayForms++  let !rootPubNames  = map anameName $ publicNamesOfModules pubModules+  let !rootExtraDefs = mapMaybe extraRootsFilter $ HMap.toList defs+  let !rootRewrites  = sig ^. sigRewriteRules+  let !rootModSections = sig ^. sigSections+  !rootBuiltins <- useTC stLocalBuiltins+  !rootPatSyns  <- getPatternSyns++  !seenNames <- liftIO HT.empty :: TCM (HashTable QName ())+  !seenMetas <- liftIO HT.empty :: TCM (HashTable MetaId ())++  let goName :: QName -> IO ()+      goName !x = HT.lookup seenNames x >>= \case+        Just _ ->+          pure ()+        Nothing -> do+          HT.insert seenNames x ()+          go (HMap.lookup x defs)++      goMeta :: MetaId -> IO ()+      goMeta !m = HT.lookup seenMetas m >>= \case+        Just _ ->+          pure ()+        Nothing -> do+          HT.insert seenMetas m ()+          case MapS.lookup m metas of+            Nothing -> pure ()+            Just mv -> do+              go (instBody (theInstantiation mv))+              go (jMetaType (mvJudgement mv))++      go :: NamesIn a => a -> IO ()+      go !x = namesAndMetasIn' (either goName goMeta) x+      {-# INLINE go #-}++  Bench.billTo [Bench.DeadCode, Bench.DeadCodeReachable] $ liftIO $ do+    go rootDisplayForms+    foldMap goName rootPubNames+    foldMap goName rootExtraDefs+    go rootRewrites+    go rootModSections+    go rootBuiltins+    foldMap (go . PSyn) rootPatSyns++  let filterMeta :: (MetaId, MetaVariable) -> IO (Maybe (MetaId, RemoteMetaVariable))+      filterMeta (!i, !m) = HT.lookup seenMetas i >>= \case+        Nothing -> pure Nothing+        Just _  -> let !m' = remoteMetaVariable m in pure $ Just (i, m')++      filterDef :: (QName, Definition) -> IO Bool+      filterDef (!x, !d) = HT.lookup seenNames x >>= \case+        Nothing -> pure False+        Just _  -> pure True++  !metas <- liftIO $ HMap.fromList <$> mapMaybeM filterMeta (MapS.toList metas)+  !defs  <- liftIO $ HMap.fromList <$> filterM filterDef (HMap.toList defs)+  pure (metas, defs, rootDisplayForms)++-- | Returns the instantiation.+--   Precondition: The instantiation must be of the form @'InstV' inst@.+theInstantiation :: MetaVariable -> Instantiation+theInstantiation mv = case mvInstantiation mv of+  InstV inst                     -> inst+  OpenMeta{}                     -> __IMPOSSIBLE__+  BlockedConst{}                 -> __IMPOSSIBLE__+  PostponedTypeCheckingProblem{} -> __IMPOSSIBLE__++-- | Converts from 'MetaVariable' to 'RemoteMetaVariable'.+--   Precondition: The instantiation must be of the form @'InstV' inst@.+remoteMetaVariable :: MetaVariable -> RemoteMetaVariable+remoteMetaVariable !mv = RemoteMetaVariable+  { rmvInstantiation = theInstantiation mv+  , rmvModality      = getModality mv+  , rmvJudgement     = mvJudgement mv+  }
+ src/full/Agda/TypeChecking/DiscrimTree.hs view
@@ -0,0 +1,441 @@+-- | Imperfect discrimination trees for indexing data by internal+-- syntax.+module Agda.TypeChecking.DiscrimTree+  ( insertDT+  , lookupDT, lookupUnifyDT, QueryResult(..)+  , deleteFromDT+  )+  where++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Foldable+import Data.Maybe++import Control.Monad.Trans.Maybe+import Control.Monad.Trans+import Control.Monad++import Agda.Syntax.Internal+import Agda.Syntax.Common++import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Records+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Free++import Agda.TypeChecking.DiscrimTree.Types++import qualified Agda.Utils.ProfileOptions as Profile++import Agda.Utils.Impossible+import Agda.Utils.Trie (Trie(..))++-- | Dummy term to use as a stand-in for expanded eta-records while+-- building instance trees.+etaExpansionDummy :: Term+etaExpansionDummy = Dummy "eta-record argument in instance head" []++-- | Extract a list of arguments from the list of eliminations; If+-- called while *adding* an instance, additionally replace any arguments+-- that might belong to an eta-record by dummy terms.+termKeyElims+  :: Bool      -- ^ Are we adding or looking up an instance?+  -> TCM Type  -- ^ Continuation to compute the type of the arguments in the spine.+  -> [Arg Term] -- ^ The spine.+  -> TCM (Int, [Term])++-- Since the case tree was generated with wildcards everywhere an eta+-- record appeared, if we're *looking up* an instance, we don't have to+-- do the censorship again.+termKeyElims False _ es = pure (length es, map unArg es)++termKeyElims precise ty args = do+  let+    go ty (Arg _ a:as) = flip (ifPiTypeB ty) (patternViolation . getBlocker) \dom ty' -> do++      -- Is this argument an eta record type --- or a blocked value? In+      -- either case, we replace this position by a dummy, to make sure+      -- that eta-equality is respected.+      maybeEta <- ifBlocked (unDom dom) (\_ _ -> pure True) \_ tm ->+        isJust <$> isEtaRecordType tm++      let+        here+          | maybeEta  = etaExpansionDummy+          | otherwise = a++      (k, there) <- addContext dom (go (unAbs ty') as)+      pure (k + 1, here:there)++    go _ [] = pure (0, [])++  ty >>= flip go args++-- | Ticky profiling for the reason behind "inexactness" in instance+-- search. If at some point while narrowing the set of candidates we had+-- to go through all the possibilities, one of these counters is+-- incremented.+tickExplore :: Term -> TCM ()+tickExplore tm = whenProfile Profile.Instances do+  tick "flex term blocking instance"++  case tm of+    Def{}      -> tick "explore: Def"+    Var{}      -> tick "explore: Var"+    Lam _ v+      -- These two are a hunch: just like FunK, it might be worth+      -- optimising for the case where a lambda is constant (which is+      -- easy to handle, by just pretending the term is something else).+      -- These would come up in e.g. Dec (PathP (λ i → Nat) x y)+      | NoAbs{} <- v -> tick "explore: constant function"+      | Abs _ b <- v, not (0 `freeIn` b) -> tick "explore: constant function"++      | otherwise    -> tick "explore: Lam"+    Lit{}      -> tick "explore: Lit"+    Sort{}     -> tick "explore: Sort"+    Level{}    -> tick "explore: Level"+    MetaV{}    -> tick "explore: Meta"+    DontCare{} -> tick "explore: DontCare"+    _ -> pure ()++-- | Split a term into a 'Key' and some arguments. The 'Key' indicates+-- whether or not the 'Term' is in head-normal form, and provides a+-- quick way to match on the head.+--+-- The 'Int' argument indicates how free a variable must be to be+-- considered a 'LocalK'.+--+-- Presently, non-head-normal terms end up with an empty argument list.+splitTermKey :: Bool -> Int -> Term -> TCM (Key, [Term], Blocker)+splitTermKey precise local tm = catchPatternErr (\b -> pure (FlexK, [], b)) do+  (b, tm') <- ifBlocked tm (\b _ -> patternViolation b) (\b -> fmap (b,) . constructorForm)++  case tm' of+    -- Adding a 'Def' to the key poses a few problems when opacity (or+    -- abstractness) are involved (see issue #7304). Suppose we have an+    -- opaque binding `X = Y`, and an opaque instance `C X`. The problem+    -- is as follows:+    --+    --   if we unfold X → Y when adding the instance, then it will not+    --   get recorded as an instance for C X, only C Y; this is 7304b.+    --+    --   if we *don't* unfold X → Y, then it only gets added as an+    --   instance of C X; in opaque blocks where X is allowed to unfold,+    --   we *won't* find it, because we're looking for C Y.+    --+    -- The solution is to throw our hands up and say "not our problem".+    -- The discrimination tree is allowed to return more results than+    -- strictly necessary, after all, so the solution is to add an+    -- instance for *neither* of C X or C Y, but instead, to treat all+    -- 'Def's headed by 'AbstractDefn' as though they were flexible+    -- (think "as though they were metas").+    Def q as | ReallyNotBlocked <- b, (as, _) <- splitApplyElims as -> do+      info <- getConstInfo q+      case theDef info of+        AbstractDefn{} | precise -> pure (FlexK, [], neverUnblock)+        _ -> do+          (arity, as) <- termKeyElims precise (pure (defType info)) as+          pure (RigidK q arity, as, neverUnblock)++    -- When adding a quantified instance, we record how many 'Pi's we went+    -- under, and only variables beyond those are considered LocalK. The+    -- others are considered FlexK since they're "pattern variables" of+    -- the instance.+    Var i as | i >= local, Just as <- allApplyElims as -> do+      let ty = unDom <$> domOfBV i+      (arity, as) <- termKeyElims precise ty as+      pure (LocalK (i - local) arity, as, neverUnblock)++    -- When looking up an instance, it's better to treat variables and+    -- neutral definitions as rigid things regardless of their spines+    -- (especially if they have projections), than it is to try to+    -- represent them accurately.+    Def q as | not precise             -> pure (RigidK q 0, [], neverUnblock)+    Var i as | not precise, i >= local -> pure (LocalK (i - local) 0, [], neverUnblock)++    Con ch _ as | Just as <- allApplyElims as -> do+      let+        q  = conName ch+        ty = defType <$> getConstInfo q+      (arity, as) <- termKeyElims precise ty as+      pure (RigidK q arity, as, neverUnblock)++    Pi dom ret ->+      let+        -- If we're looking at a non-dependent function type, then we+        -- might as well represent the codomain accurately; Otherwise,+        -- turn the codomain into a wildcard.+        --+        -- The use of a dummy term *shouldn't* leak to the user, because+        -- when we call splitTermKey again, it'll be handled by the last+        -- case, and become a FlexK.+        ret' = case isNoAbs (unEl <$> ret) of+          Just b  -> b+          Nothing -> __DUMMY_TERM__+      in pure (PiK (getHiding dom), [unEl (unDom dom), ret'], neverUnblock)++    Lam _ body+      -- Constant lambdas come up quite a bit, particularly (in cubical+      -- mode) as the domain of a PathP. Having this trick improves the+      -- indexing of 'Dec' instances in the 1Lab significantly.+      | Just b <- isNoAbs body -> pure (ConstK, [b], neverUnblock)++    -- Probably not a good idea for accurate indexing if universes+    -- overlap literally everything else.+    Sort _ -> pure (SortK, [], neverUnblock)++    _ -> do+      reportSDoc "tc.instance.split" 30 $ pretty tm+      pure (FlexK, [], neverUnblock)++termPath :: Int -> Bool -> Int -> [Key] -> [Term] -> TCM [Key]+termPath 0 _ _ acc _                        = pure $! reverse acc+termPath limit toplevel local acc []        = pure $! reverse acc+termPath limit toplevel local acc (tm:todo) = do++  -- We still want to ignore abstractness at the very top-level of+  -- instance heads, for issue #6941, to ensure that each instance ends+  -- up in the right 'class'. See the comment in `splitTermKey` about+  -- abstract definitions.+  (k, as, blk) <-+    if toplevel+      then ignoreAbstractMode (splitTermKey True local tm)+      else splitTermKey True local tm++  reportSDoc "tc.instance.discrim.add" 666 $ vcat+    [ "k:  " <+> prettyTCM k+    , "as: " <+> prettyTCM as+    , "blk:" <+> prettyTCM blk+    , "lim:" <+> prettyTCM limit+    ]+  termPath (limit - 1) False local (k:acc) (as <> todo)++-- | Maximum length for the keys (thus, depth for the discrimination+-- tree) that should be used.+--+-- Adding an instance still causes reduction of everything 'rigid' in+-- the type of the instance (so if normalisation is slow, so will be+-- adding the instance) but this limit prevents us from building a+-- discrimination tree with 2^32 intermediate @case 0 of suc → ...@+-- nodes.+discrimTreeDepthLimit :: Int+discrimTreeDepthLimit = 16++-- | Insert a value into the discrimination tree, turning variables into+-- rigid locals or wildcards depending on the given scope.+insertDT+  :: (Ord a, PrettyTCM a)+  => Int   -- ^ Number of variables to consider wildcards, e.g. the number of leading invisible pis in an instance type.+  -> Term  -- ^ The term to use as a key+  -> a+  -> DiscrimTree a+  -> TCM (DiscrimTree a)+insertDT local key val tree = do+  path <- termPath discrimTreeDepthLimit True local [] [key]+  let it = singletonDT path val+  reportSDoc "tc.instance.discrim.add" 20 $ vcat+    [ "added value" <+> prettyTCM val <+> "to discrimination tree with case"+    , nest 2 (prettyTCM it)+    , "its type:"+    , nest 2 (prettyTCM key)+    , "its path:"+    , nest 2 (prettyTCM path)+    ]+  pure $ mergeDT it tree++-- | If a term matches this key, how many arguments does it place on the+-- spine?+keyArity :: Key -> Int+keyArity = \case+  RigidK _ a -> a+  LocalK _ a -> a+  PiK _      -> 2+  ConstK     -> 1+  SortK      -> 0+  FlexK      -> 0++data QueryResult a = QueryResult+  { resultValues  :: Set.Set a+  , resultBlocker :: Blocker+  }++instance Ord a => Semigroup (QueryResult a) where+  QueryResult s b <> QueryResult s' b' = QueryResult (s <> s') (b `unblockOnEither` b')++instance Ord a => Monoid (QueryResult a) where+  mempty = QueryResult mempty neverUnblock++setResult :: Set.Set a -> QueryResult a+setResult = flip QueryResult neverUnblock++blockerResult :: Blocker -> QueryResult a+blockerResult = QueryResult Set.empty++-- | Look up a 'Term' in the given discrimination tree, treating local+-- variables as rigid symbols. The returned set is guaranteed to contain+-- everything that could overlap the given key.+lookupDT :: forall a. (Ord a, PrettyTCM a) => Term -> DiscrimTree a -> TCM (QueryResult a)+lookupDT = lookupDT' True++-- | Look up a 'Term' in the given discrimination tree, treating local+-- variables as wildcards.+lookupUnifyDT :: forall a. (Ord a, PrettyTCM a) => Term -> DiscrimTree a -> TCM (QueryResult a)+lookupUnifyDT = lookupDT' False++lookupDT'+  :: forall a. (Ord a, PrettyTCM a)+  => Bool -- ^ Should local variables be treated as rigid?+  -> Term -- ^ The term to use as key+  -> DiscrimTree a+  -> TCM (QueryResult a)+lookupDT' localsRigid term tree = match True [term] tree where++  split :: Term -> TCM (Key, [Term], Blocker)+  split tm | localsRigid = splitTermKey False 0 tm+  split tm = do+    ctx <- getContextSize+    splitTermKey False ctx tm++  ignoreAbstractMaybe :: forall a. Bool -> TCM a -> TCM a+  ignoreAbstractMaybe True  = ignoreAbstractMode+  ignoreAbstractMaybe False = id++  -- Match a spine against *all* clauses.+  explore :: [Term] -> [Term] -> [Term] -> [(Key, DiscrimTree a)] -> TCM (QueryResult a)+  explore sp0 sp1 args bs = do+    let+      cont (key, trie) res = do+        -- At the moment, explore will always be called with empty args.+        -- But even if this restriction is lifted in the future, we have+        -- to be careful about exploring. Consider:+        --+        --   instance+        --     _ : Foo (con x)+        --+        --   ⊢ Foo ?0+        --+        -- Since ?0 might be applied to more or less arguments than the+        -- one argument that is expected to be between sp0 and sp1 after+        -- matching con, we need to make sure that the spine has the+        -- right number of arguments, otherwise the (sp0, t:sp1) pattern+        -- for a Case will fail.+        let+          dummy n = Dummy ("_pad" <> show n) []+          args' = take (keyArity key) (args ++ [ dummy n | n <- [0..] ])++        reportSDoc "tc.instance.discrim.lookup" 99 $ vcat+          [ "explore" <+> prettyTCM key <+> pretty (keyArity key) <+> pretty (length args)+          , nest 2 (prettyTCM trie)+          , "sp0:  " <+> prettyTCM sp0+          , "sp1:  " <+> prettyTCM sp1+          , "args: " <+> prettyTCM args+          , "args':" <+> prettyTCM args'+          ]+        (<> res) <$> match False (sp0 ++ args' ++ sp1) trie++    foldrM cont mempty bs++  match :: Bool -> [Term] -> DiscrimTree a -> TCM (QueryResult a)+  match toplevel ts EmptyDT    = pure mempty+  match toplevel ts (DoneDT t) = setResult t <$ do+    reportSDoc "tc.instance.discrim.lookup" 99 $ vcat+      [ "done" <+> prettyTCM ts+      , "  →" <+> prettyTCM t+      ]++  match toplevel ts tree@(CaseDT i branches rest) | (sp0, t:sp1) <- splitAt i ts = do+    let+      (sp0, t:sp1) = splitAt i ts+      visit k sp' = case Map.lookup k branches of+        Just m  -> match False sp' m+        Nothing -> pure mempty++    unless toplevel $ reportSDoc "tc.instance.discrim.lookup" 99 $ vcat+      [ "match" <+> prettyTCM sp0 <+> ("«" <> prettyTCM t <> "»") <+> prettyTCM sp1+      , prettyTCM tree+      ]++    -- TODO (Amy, 2024-02-12): Could use reduceB in splitTermKey, and+    -- the blocker here, to suspend instances more precisely when there+    -- is an ambiguity.+    ignoreAbstractMaybe toplevel (split t) >>= \case+      (FlexK, args, blocker) -> do++        reportSDoc "tc.instance.discrim.lookup" 99 $ vcat+          [ "flexible term was forced"+          , "t:" <+> (pretty =<< instantiate t)+          , "will explore" <+> pretty (length branches + 1) <+> "branches"+          ]+        tickExplore t++        -- If we have a "flexible head" at this position then instance+        -- search *at this point* degenerates to looking for all+        -- possible matches.+        --+        -- In any nested CaseDTs, however, it's possible for us to+        -- recover and go back to productively matching. Consider:+        --+        --    instance+        --      xa : X T1 A+        --      xb : X T2 B+        --+        --    ⊢ X ?0 A+        --+        -- Since ?0 is way too flabby to narrow which of T1 or T2 should+        -- be taken, we take both. But then we match A against A and B:+        -- this query will only return {xa}.++        branches <- explore sp0 sp1 args $ Map.toList branches+        rest <- match False ts rest++        pure $! rest <> branches <> blockerResult blocker++      (k, args, blocker) -> do+        let sp' = sp0 ++ args ++ sp1++        -- Actually take the branch corresponding to our rigid head.+        branch <- visit k sp'++        -- When exploring the rest of the tree, the value we cased on+        -- has to be put back in the tree. mergeDT does not perform+        -- commuting conversions to ensure that variables aren't+        -- repeatedly cased on.+        rest <- match False ts rest++        pure $! rest <> branch++  match _ ts tree@(CaseDT i _ rest) = do+    reportSDoc "tc.instance.discrim.lookup" 99 $ vcat+      [ "IMPOSSIBLE match" <+> prettyTCM ts+      , prettyTCM tree+      ]+    -- This really is impossible: since each branch is annotated with+    -- its arity, we only take branches corresponding to neutrals which+    -- exploded into enough arguments.+    __IMPOSSIBLE__++-- | Smart constructor for a leaf node.+doneDT :: Set.Set a -> DiscrimTree a+doneDT s | Set.null s = EmptyDT+doneDT s = DoneDT s++-- | Remove a set of values from the discrimination tree. The tree is+-- rebuilt so that cases with no leaves are removed.+deleteFromDT :: Ord a => Set.Set a -> DiscrimTree a -> DiscrimTree a+deleteFromDT gone = \case+  EmptyDT -> EmptyDT+  DoneDT s -> doneDT $! Set.difference s gone+  CaseDT i s k ->+    let+      del x = case deleteFromDT gone x of+        EmptyDT -> Nothing+        dt'     -> Just dt'++      s' = Map.mapMaybe del s+      k' = deleteFromDT gone k+    in if | Map.null s' -> k'+          | otherwise   -> CaseDT i s' k'
+ src/full/Agda/TypeChecking/DiscrimTree/Types.hs view
@@ -0,0 +1,140 @@+module Agda.TypeChecking.DiscrimTree.Types where++import Control.DeepSeq++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set++import Data.Map.Strict (Map)+import Data.Set (Set)++import GHC.Generics (Generic)++import Agda.Syntax.Internal+import Agda.Syntax.Position+import Agda.Syntax.Common++import Agda.Utils.Impossible+import Agda.Utils.Null++data Key+  = RigidK {-# UNPACK #-} !QName {-# UNPACK #-} !Int+    -- ^ Rigid symbols (constructors, data types, record types,+    -- postulates) identified by a QName.+  | LocalK {-# UNPACK #-} !Int {-# UNPACK #-} !Int+    -- ^ Local variables.++  | PiK Hiding+    -- ^ Dependent function types. The domain will be represented+    -- accurately, for the case of a genuine dependent function type,+    -- the codomain will be a dummy.++  | ConstK+    -- ^ Constant lambdas.++  | SortK+    -- ^ Universes.++  | FlexK+  -- ^ Anything else.+  deriving (Show, Eq, Ord, Generic)++instance NFData Key++-- | A 'Term'-indexed associative data structure supporting+-- /approximate/ (conservative) lookup. Rather than using a @Trie@ keyed+-- by 'Key' directly, a 'DiscrimTree' is instead represented more like a+-- /case/ tree.+--+-- This allows us to exploit the fact that instance selection often+-- focuses on a small part of the term: Only that critical chain is+-- represented in the tree. As an example, level parameters are unlikely+-- to contribute to narrowing a search problem, so it would be wasteful+-- to have an indirection in the tree for every 'FlexK' standing for a+-- level parameter.+data DiscrimTree a+  = EmptyDT+    -- ^ The empty discrimination tree.+  | DoneDT (Set a)+    -- ^ Succeed with a given set of values.+  | CaseDT+    -- ^ Do case analysis on a term. 'CaseDT' is scoped in the same way+    -- as fast case trees for the abstract machine: When matching+    -- actually succeeds, the variable that was matched gets replaced by+    -- its arguments directly in the context.+      {-# UNPACK #-} !Int       -- ^ The variable to case on.+      (Map Key (DiscrimTree a)) -- ^ The proper branches.+      (DiscrimTree a)           -- ^ A further tree, which should always be explored.+  deriving (Generic, Eq, Show)++{-+The extra continuation to CaseDT is used to represent instance tables+which have non-trivial overlap, e.g.++  instance+    a : Foo X ?+    b : Foo ? X++If we commited to the {a} branch of the discrimination tree, then we+would miss {b} entirely. Note that an "obvious" overlap like++  instance+    a : Bar X+    b : Bar X++would be represented as++  case 0 of+    Bar → case 0 of+      X → done {a, b}++and the extra continuation would be empty.+-}++instance NFData a => NFData (DiscrimTree a)++instance (KillRange a, Ord a) => KillRange (DiscrimTree a) where+  killRange = \case+    EmptyDT      -> EmptyDT+    DoneDT s     -> killRangeN DoneDT s+    CaseDT i k o -> killRangeN CaseDT i k o++instance Null (DiscrimTree a) where+  empty = EmptyDT+  null = \case+    EmptyDT -> True+    _       -> False++-- | Merge a pair of discrimination trees. This function tries to build+-- the minimal discrimination tree that yields the union of the inputs'+-- results, though it does so slightly naïvely, without considerable+-- optimisations (e.g. it does not turn single-alternative 'CaseDT's+-- into 'DoneDT's).+mergeDT :: Ord a => DiscrimTree a -> DiscrimTree a -> DiscrimTree a+mergeDT EmptyDT    x = x+mergeDT (DoneDT s) x = case x of+  EmptyDT       -> DoneDT s+  DoneDT s'     -> DoneDT (s <> s')+  CaseDT i bs x -> CaseDT i bs (mergeDT (DoneDT s) x)+mergeDT (CaseDT i bs els) x = case x of+  EmptyDT  -> CaseDT i bs els+  DoneDT s -> CaseDT i bs (mergeDT (DoneDT s) els)+  CaseDT j bs' els' -> case compare i j of+    EQ -> CaseDT j (Map.unionWith mergeDT bs bs') (mergeDT els els')+    LT -> CaseDT i bs (mergeDT els (CaseDT j bs' els'))+    GT -> CaseDT j bs' (mergeDT els' (CaseDT i bs els))++instance Ord a => Semigroup (DiscrimTree a) where+  (<>) = mergeDT++instance Ord a => Monoid (DiscrimTree a) where+  mempty = EmptyDT++-- | Construct the case tree corresponding to only performing proper+-- matches on the given key. In this context, a "proper match" is any+-- 'Key' that is not 'FlexK'.+singletonDT :: [Key] -> a -> DiscrimTree a+singletonDT key val = go 0 key where+  go focus []         = DoneDT $ Set.singleton val+  go focus (FlexK:ts) = go (focus + 1) ts+  go focus (t:ts)     = CaseDT focus (Map.singleton t (go focus ts)) EmptyDT
src/full/Agda/TypeChecking/DisplayForm.hs view
@@ -9,6 +9,8 @@ import Control.Monad.Trans.Maybe  import Data.Monoid (All(..))+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as Set@@ -25,21 +27,12 @@  import Agda.Utils.Functor import Agda.Utils.List+import Agda.Utils.List1 (List1) import Agda.Utils.Maybe-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty  import Agda.Utils.Impossible --- | Convert a 'DisplayTerm' into a 'Term'.-dtermToTerm :: DisplayTerm -> Term-dtermToTerm dt = case dt of-  DWithApp d ds es ->-    dtermToTerm d `apply` map (defaultArg . dtermToTerm) ds `applyE` es-  DCon c ci args   -> Con c ci $ map (Apply . fmap dtermToTerm) args-  DDef f es        -> Def f $ map (fmap dtermToTerm) es-  DDot v           -> v-  DTerm v          -> v- -- | Get the arities of all display forms for a name. displayFormArities :: (HasConstInfo m, ReadTCState m) => QName -> m [Int] displayFormArities q = map (length . dfPats . dget) <$> getDisplayForms q@@ -124,24 +117,39 @@   | length ps > length es = mzero   | otherwise             = do       let (es0, es1) = splitAt (length ps) es-      mm <- match (Window 0 n) ps es0++      -- The 'Display' constructor acts as though it binds the pattern+      -- pattern variables up to 'n', so a match like+      --+      --   Display 1 [@1 @0] x =? [@0 _]+      --+      -- should work (it didn't; see LiftDisplayIntermediate). In+      -- effect, this is because the LHS patterns are in some context+      -- "Γ . @0", but the RHS term is only in context Γ.+      --+      -- Therefore, we should raise the RHS term by the number of+      -- pattern variables, to bring it into the context of the+      -- patterns.++      mm <- match (Window 0 n) ps (raise n es0)       us <- forM [0 .. n - 1] $ \ i -> do-              -- #5294: Fail if we don't have bindings for all variables. This can-              --        happen outside parameterised modules when some of the parameters-              --        are not used in the lhs.-              Just u <- return $ Map.lookup i mm-              return u+        -- #5294: Fail if we don't have bindings for all variables. This can+        --        happen outside parameterised modules when some of the parameters+        --        are not used in the lhs.+        Just u <- return $ IntMap.lookup i mm+        -- Note that the RHS terms are independent of the pattern variables.+        return (applySubst (strengthenS __IMPOSSIBLE__ n) <$> u)       return (d, substWithOrigin (parallelS $ map woThing us) us v `applyE` es1) -type MatchResult = Map Int (WithOrigin Term)+type MatchResult = IntMap (WithOrigin Term)  unionMatch :: Monad m => MatchResult -> MatchResult -> MaybeT m MatchResult unionMatch m1 m2-  | Set.disjoint (Map.keysSet m1) (Map.keysSet m2) = return $ Map.union m1 m2+  | null (IntMap.intersection m1 m2) = return $ IntMap.union m1 m2   | otherwise = mzero  -- Non-linear pattern, fail for now.  unionsMatch :: Monad m => [MatchResult] -> MaybeT m MatchResult-unionsMatch = foldM unionMatch Map.empty+unionsMatch = foldM unionMatch mempty  data Window = Window {dbLo, dbHi :: Nat} @@ -162,15 +170,17 @@   match :: MonadDisplayForm m => Window -> a -> a -> MaybeT m MatchResult  instance Match a => Match [a] where-  match n xs ys = unionsMatch =<< zipWithM (match n) xs ys+  match n xs ys+    | length xs == length ys = unionsMatch =<< zipWithM (match n) xs ys+    | otherwise = mzero  instance Match a => Match (Arg a) where-  match n p v = Map.map (setOrigin (getOrigin v)) <$> match n (unArg p) (unArg v)+  match n p v = IntMap.map (setOrigin (getOrigin v)) <$> match n (unArg p) (unArg v)  instance Match a => Match (Elim' a) where   match n p v =     case (p, v) of-      (Proj _ f, Proj _ f') | f == f' -> return Map.empty+      (Proj _ f, Proj _ f') | f == f' -> return mempty       _ | Just a  <- isApplyElim p         , Just a' <- isApplyElim v    -> match n a a'       -- we do not care to differentiate between Apply and IApply for@@ -179,14 +189,14 @@  instance Match Term where   match w p v = lift (instantiate v) >>= \ v -> case (unSpine p, unSpine v) of-    (Var i [], v)    | Just j <- inWindow w i -> return $ Map.singleton j (WithOrigin Inserted v)+    (Var i [], v)    | Just j <- inWindow w i -> return $ IntMap.singleton j (WithOrigin Inserted v)     (Var i (_:_), v) | Just{} <- inWindow w i -> mzero  -- Higher-order pattern, fail for now.     (Var i ps, Var j vs) | i == j  -> match w ps vs     (Def c ps, Def d vs) | c == d  -> match w ps vs     (Con c _ ps, Con d _ vs) | c == d -> match w ps vs-    (Lit l, Lit l')      | l == l' -> return Map.empty+    (Lit l, Lit l')      | l == l' -> return mempty     (Lam h p, Lam h' v)  | h == h' -> match (shiftWindow w) (unAbs p) (unAbs v)-    (p, v)               | p == v  -> return Map.empty  -- TODO: this is wrong (this is why we lifted the rhs before)+    (p, v)               | p == v  -> return mempty  -- TODO: this is wrong (this is why we lifted the rhs before)     (p, Level l)                   -> match w p =<< reallyUnLevelView l     (Sort ps, Sort pv)             -> match w ps pv     (p, Sort (Type v))             -> match w p =<< reallyUnLevelView v@@ -195,7 +205,7 @@ instance Match Sort where   match w p v = case (p, v) of     (Type pl, Type vl) -> match w pl vl-    _ | p == v -> return Map.empty+    _ | p == v -> return mempty     _          -> mzero  instance Match Level where@@ -218,6 +228,9 @@ instance SubstWithOrigin a => SubstWithOrigin [a] where   substWithOrigin rho ots = map (substWithOrigin rho ots) +instance SubstWithOrigin a => SubstWithOrigin (List1 a) where+  substWithOrigin rho ots = fmap (substWithOrigin rho ots)+ instance (SubstWithOrigin a, SubstWithOrigin (Arg a)) => SubstWithOrigin (Elim' a) where   substWithOrigin rho ots (Apply arg) = Apply $ substWithOrigin rho ots arg   substWithOrigin rho ots e@Proj{}    = e@@ -257,10 +270,10 @@  -- Do not go into dot pattern, otherwise interaction test #231 fails instance SubstWithOrigin DisplayTerm where-  substWithOrigin rho ots dt =-    case dt of-      DTerm v        -> DTerm     $ substWithOrigin rho ots v-      DDot  v        -> DDot      $ applySubst rho v+  substWithOrigin rho ots =+    \case+      DTerm' v es    -> DTerm' (substWithOrigin rho ots v) $ substWithOrigin rho ots es+      DDot'  v es    -> DDot'  (substWithOrigin rho ots v) $ substWithOrigin rho ots es       DDef q es      -> DDef q    $ substWithOrigin rho ots es       DCon c ci args -> DCon c ci $ substWithOrigin rho ots args       DWithApp t ts es -> DWithApp@@ -272,8 +285,8 @@ instance SubstWithOrigin (Arg DisplayTerm) where   substWithOrigin rho ots (Arg ai dt) =     case dt of-      DTerm v        -> fmap DTerm $ substWithOrigin rho ots $ Arg ai v-      DDot  v        -> Arg ai $ DDot      $ applySubst rho v+      DTerm' v es    -> substWithOrigin rho ots (Arg ai v) <&> (`DTerm'` substWithOrigin rho ots es)+      DDot'  v es    -> Arg ai $ DDot' (applySubst rho v)  $ substWithOrigin rho ots es       DDef q es      -> Arg ai $ DDef q    $ substWithOrigin rho ots es       DCon c ci args -> Arg ai $ DCon c ci $ substWithOrigin rho ots args       DWithApp t ts es -> Arg ai $ DWithApp
src/full/Agda/TypeChecking/DropArgs.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.DropArgs where
src/full/Agda/TypeChecking/Empty.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Empty   ( isEmptyType@@ -6,11 +7,9 @@   , checkEmptyTel   ) where -import Control.Monad        ( void ) import Control.Monad.Except ( MonadError(..) )  import Data.Semigroup-import qualified Data.Set as Set  import Agda.Syntax.Common import Agda.Syntax.Internal@@ -21,6 +20,7 @@ import Agda.TypeChecking.Coverage import Agda.TypeChecking.Coverage.Match ( fromSplitPatterns ) import Agda.TypeChecking.Records+import Agda.TypeChecking.Reduce ( instantiateFull ) import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope @@ -36,7 +36,7 @@   | DontKnow Blocker   -- ^ Emptyness check blocked  instance Semigroup ErrorNonEmpty where-  DontKnow u1     <> DontKnow u2  = DontKnow $ u1 <> u2  -- Both must unblock for this to proceed+  DontKnow u1     <> DontKnow u2  = DontKnow $ unblockOnBoth u1 u2  -- Both must unblock for this to proceed   e@DontKnow{}    <> _            = e   _               <> e@DontKnow{} = e   FailBecause err <> _            = FailBecause err@@ -59,12 +59,12 @@   failure Fail              = typeError $ ShouldBeEmpty t []  -- | Check whether a type is empty.-isEmptyType :: Type -> TCM Bool-isEmptyType ty = isRight <$> checkEmptyType noRange ty+isEmptyType :: MonadTCM tcm => Type -> tcm Bool+isEmptyType ty = liftTCM $ isRight <$> checkEmptyType noRange ty  -- | Check whether some type in a telescope is empty.-isEmptyTel :: Telescope -> TCM Bool-isEmptyTel tel = isRight <$> checkEmptyTel noRange tel+isEmptyTel :: MonadTCM tcm => Telescope -> tcm Bool+isEmptyTel tel = liftTCM $ isRight <$> checkEmptyTel noRange tel  -- Either the type is possibly non-empty (Left err) or it is really empty -- (Right ()).@@ -88,7 +88,9 @@       dontAssignMetas $ do         r <- splitLast Inductive tel ps         case r of-          Left UnificationStuck{} -> return $ Left $ DontKnow $ unblockOnAnyMetaIn tel+          Left UnificationStuck{} -> do+            blocker <- unblockOnAnyMetaIn <$> instantiateFull tel -- TODO Jesper: get proper blocking information from unification+            return $ Left $ DontKnow blocker           Left _                  -> return $ Left Fail           Right cov -> do             let ps = map (namedArg . lastWithDefault __IMPOSSIBLE__ . fromSplitPatterns . scPats) $ splitClauses cov@@ -97,8 +99,8 @@      -- If t is a record type, see if any of the field types is empty     Right (r, pars, def) -> do-      if | NoEta{} <- recEtaEquality def -> return $ Left Fail-         | otherwise -> void <$> do checkEmptyTel range $ recTel def `apply` pars+      if not (isEtaRecordDef def) then return $ Left Fail else+         void <$> do checkEmptyTel range $ _recTel def `apply` pars  -- | Check whether one of the types in the given telescope is constructor-less --   and if yes, return its index in the telescope (0 = leftmost).
src/full/Agda/TypeChecking/Empty.hs-boot view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Empty   ( isEmptyType@@ -6,14 +7,14 @@   , checkEmptyTel   ) where -import Agda.TypeChecking.Monad (TCM)+import Agda.TypeChecking.Monad (TCM, MonadTCM) import Agda.Syntax.Internal (Type, Telescope) import Agda.Syntax.Position (Range)  data ErrorNonEmpty -isEmptyType :: Type      -> TCM Bool-isEmptyTel  :: Telescope -> TCM Bool+isEmptyType :: MonadTCM tcm => Type -> tcm Bool+isEmptyTel  :: MonadTCM tcm => Telescope -> tcm Bool  ensureEmptyType :: Range -> Type -> TCM () checkEmptyTel   :: Range -> Telescope -> TCM (Either ErrorNonEmpty Int)
src/full/Agda/TypeChecking/Errors.hs view
@@ -3,1415 +3,2198 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}  module Agda.TypeChecking.Errors-  ( prettyError-  , tcErrString-  , prettyTCWarnings'-  , prettyTCWarnings-  , tcWarningsToError-  , applyFlagsToTCWarningsPreserving-  , applyFlagsToTCWarnings-  , getAllUnsolvedWarnings-  , getAllWarningsPreserving-  , getAllWarnings-  , getAllWarningsOfTCErr-  , dropTopLevelModule-  , topLevelModuleDropper-  , stringTCErr-  ) where--import Prelude hiding ( null, foldl )--import Control.Monad.Except--import qualified Data.CaseInsensitive as CaseInsens-import Data.Foldable (foldl)-import Data.Function-import Data.List (sortBy, dropWhileEnd, intercalate)-import qualified Data.List.NonEmpty as NonEmpty-import Data.Maybe-import qualified Data.Set as Set-import qualified Text.PrettyPrint.Boxes as Boxes--import Agda.Syntax.Common-import Agda.Syntax.Concrete.Definitions (notSoNiceDeclarations)-import Agda.Syntax.Concrete.Pretty (prettyHiding, prettyRelevance)-import Agda.Syntax.Notation-import Agda.Syntax.Position-import qualified Agda.Syntax.Concrete as C-import Agda.Syntax.Abstract as A-import Agda.Syntax.Internal as I-import Agda.Syntax.Translation.InternalToAbstract-import Agda.Syntax.Scope.Monad (isDatatypeModule)-import Agda.Syntax.Scope.Base--import Agda.TypeChecking.Monad.Base-import Agda.TypeChecking.Monad.Closure-import Agda.TypeChecking.Monad.Context-import Agda.TypeChecking.Monad.Debug-import Agda.TypeChecking.Monad.Builtin-import Agda.TypeChecking.Monad.SizedTypes ( sizeType )-import Agda.TypeChecking.Monad.State-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Pretty.Call-import Agda.TypeChecking.Pretty.Warning-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope ( ifPiType )-import Agda.TypeChecking.Reduce (instantiate)--import Agda.Utils.FileName-import Agda.Utils.Float  ( toStringWithoutDotZero )-import Agda.Utils.Function-import Agda.Utils.List   ( initLast )-import Agda.Utils.List1 (List1, pattern (:|))-import qualified Agda.Utils.List1 as List1-import Agda.Utils.Maybe-import Agda.Utils.Null-import Agda.Utils.Pretty ( prettyShow, render )-import qualified Agda.Utils.Pretty as P-import Agda.Utils.Size--import Agda.Utils.Impossible-------------------------------------------------------------------------------- * Top level function------------------------------------------------------------------------------{-# SPECIALIZE prettyError :: TCErr -> TCM String #-}-prettyError :: MonadTCM tcm => TCErr -> tcm String-prettyError err = liftTCM $ show <$> prettyError' err []-  where-  prettyError' :: TCErr -> [TCErr] -> TCM Doc-  prettyError' err errs-    | length errs > 3 = fsep (-        pwords "total panic: error when printing error from printing error from printing error." ++-        pwords "I give up! Approximations of errors (original error last):" )-        $$ vcat (map (text . tcErrString) errs)-    | otherwise = applyUnless (null errs) ("panic: error when printing error!" $$) $ do-        (prettyTCM err $$ vcat (map (text . ("when printing error " ++) . tcErrString) errs))-        `catchError` \ err' -> prettyError' err' (err:errs)-------------------------------------------------------------------------------- * Helpers------------------------------------------------------------------------------panic :: Monad m => String -> m Doc-panic s = fwords $ "Panic: " ++ s--nameWithBinding :: MonadPretty m => QName -> m Doc-nameWithBinding q =-  (prettyTCM q <+> "bound at") <?> prettyTCM r-  where-    r = nameBindingSite $ qnameName q--tcErrString :: TCErr -> String-tcErrString err = prettyShow (getRange err) ++ " " ++ case err of-  TypeError _ _ cl  -> errorString $ clValue cl-  Exception r s     -> prettyShow r ++ " " ++ show s-  IOException _ r e -> prettyShow r ++ " " ++ show e-  PatternErr{}      -> "PatternErr"--stringTCErr :: String -> TCErr-stringTCErr = Exception noRange . P.text--errorString :: TypeError -> String-errorString err = case err of-  AmbiguousModule{}                        -> "AmbiguousModule"-  AmbiguousName{}                          -> "AmbiguousName"-  AmbiguousParseForApplication{}           -> "AmbiguousParseForApplication"-  AmbiguousParseForLHS{}                   -> "AmbiguousParseForLHS"---  AmbiguousParseForPatternSynonym{}        -> "AmbiguousParseForPatternSynonym"-  AmbiguousTopLevelModuleName {}           -> "AmbiguousTopLevelModuleName"-  BadArgumentsToPatternSynonym{}           -> "BadArgumentsToPatternSynonym"-  TooFewArgumentsToPatternSynonym{}        -> "TooFewArgumentsToPatternSynonym"-  CannotResolveAmbiguousPatternSynonym{}   -> "CannotResolveAmbiguousPatternSynonym"-  BothWithAndRHS                           -> "BothWithAndRHS"-  BuiltinInParameterisedModule{}           -> "BuiltinInParameterisedModule"-  BuiltinMustBeConstructor{}               -> "BuiltinMustBeConstructor"-  ClashingDefinition{}                     -> "ClashingDefinition"-  ClashingFileNamesFor{}                   -> "ClashingFileNamesFor"-  ClashingImport{}                         -> "ClashingImport"-  ClashingModule{}                         -> "ClashingModule"-  ClashingModuleImport{}                   -> "ClashingModuleImport"-  CompilationError{}                       -> "CompilationError"-  ConstructorPatternInWrongDatatype{}      -> "ConstructorPatternInWrongDatatype"-  CyclicModuleDependency{}                 -> "CyclicModuleDependency"-  DataMustEndInSort{}                      -> "DataMustEndInSort"--- UNUSED:    DataTooManyParameters{}                  -> "DataTooManyParameters"-  CantResolveOverloadedConstructorsTargetingSameDatatype{} -> "CantResolveOverloadedConstructorsTargetingSameDatatype"-  DoesNotConstructAnElementOf{}            -> "DoesNotConstructAnElementOf"-  DuplicateBuiltinBinding{}                -> "DuplicateBuiltinBinding"-  DuplicateConstructors{}                  -> "DuplicateConstructors"-  DuplicateFields{}                        -> "DuplicateFields"-  DuplicateImports{}                       -> "DuplicateImports"-  FieldOutsideRecord                       -> "FieldOutsideRecord"-  FileNotFound{}                           -> "FileNotFound"-  GenericError{}                           -> "GenericError"-  GenericDocError{}                        -> "GenericDocError"-  InstanceNoCandidate{}                    -> "InstanceNoCandidate"-  IllformedProjectionPattern{}             -> "IllformedProjectionPattern"-  CannotEliminateWithPattern{}             -> "CannotEliminateWithPattern"-  IllegalLetInTelescope{}                  -> "IllegalLetInTelescope"-  IllegalPatternInTelescope{}              -> "IllegalPatternInTelescope"--- UNUSED:  IncompletePatternMatching{}              -> "IncompletePatternMatching"-  InternalError{}                          -> "InternalError"-  InvalidPattern{}                         -> "InvalidPattern"-  LocalVsImportedModuleClash{}             -> "LocalVsImportedModuleClash"-  MetaCannotDependOn{}                     -> "MetaCannotDependOn"-  MetaOccursInItself{}                     -> "MetaOccursInItself"-  MetaIrrelevantSolution{}                 -> "MetaIrrelevantSolution"-  MetaErasedSolution{}                     -> "MetaErasedSolution"-  ModuleArityMismatch{}                    -> "ModuleArityMismatch"-  ModuleDefinedInOtherFile {}              -> "ModuleDefinedInOtherFile"-  ModuleNameUnexpected{}                   -> "ModuleNameUnexpected"-  ModuleNameDoesntMatchFileName {}         -> "ModuleNameDoesntMatchFileName"-  NeedOptionCopatterns{}                   -> "NeedOptionCopatterns"-  NeedOptionRewriting{}                    -> "NeedOptionRewriting"-  NeedOptionProp{}                         -> "NeedOptionProp"-  NeedOptionTwoLevel{}                     -> "NeedOptionTwoLevel"-  GeneralizeNotSupportedHere{}             -> "GeneralizeNotSupportedHere"-  GeneralizeCyclicDependency{}             -> "GeneralizeCyclicDependency"-  GeneralizeUnsolvedMeta{}                 -> "GeneralizeUnsolvedMeta"-  MultipleFixityDecls{}                    -> "MultipleFixityDecls"-  MultiplePolarityPragmas{}                -> "MultiplePolarityPragmas"-  NoBindingForBuiltin{}                    -> "NoBindingForBuiltin"-  NoParseForApplication{}                  -> "NoParseForApplication"-  NoParseForLHS{}                          -> "NoParseForLHS"---  NoParseForPatternSynonym{}               -> "NoParseForPatternSynonym"-  NoRHSRequiresAbsurdPattern{}             -> "NoRHSRequiresAbsurdPattern"-  NoSuchBuiltinName{}                      -> "NoSuchBuiltinName"-  NoSuchModule{}                           -> "NoSuchModule"-  DuplicatePrimitiveBinding{}              -> "DuplicatePrimitiveBinding"-  NoSuchPrimitiveFunction{}                -> "NoSuchPrimitiveFunction"-  WrongModalityForPrimitive{}              -> "WrongModalityForPrimitive"-  NotAModuleExpr{}                         -> "NotAModuleExpr"-  NotAProperTerm                           -> "NotAProperTerm"-  InvalidType{}                            -> "InvalidType"-  InvalidTypeSort{}                        -> "InvalidTypeSort"-  FunctionTypeInSizeUniv{}                 -> "FunctionTypeInSizeUniv"-  NotAValidLetBinding{}                    -> "NotAValidLetBinding"-  NotValidBeforeField{}                    -> "NotValidBeforeField"-  NotAnExpression{}                        -> "NotAnExpression"-  NotImplemented{}                         -> "NotImplemented"-  NotSupported{}                           -> "NotSupported"-  AbstractConstructorNotInScope{}          -> "AbstractConstructorNotInScope"-  NotInScope{}                             -> "NotInScope"-  NotLeqSort{}                             -> "NotLeqSort"-  NothingAppliedToHiddenArg{}              -> "NothingAppliedToHiddenArg"-  NothingAppliedToInstanceArg{}            -> "NothingAppliedToInstanceArg"-  OverlappingProjects {}                   -> "OverlappingProjects"-  OperatorInformation {}                   -> "OperatorInformation"-  PatternShadowsConstructor {}             -> "PatternShadowsConstructor"-  PropMustBeSingleton                      -> "PropMustBeSingleton"-  RepeatedVariablesInPattern{}             -> "RepeatedVariablesInPattern"-  ShadowedModule{}                         -> "ShadowedModule"-  ShouldBeASort{}                          -> "ShouldBeASort"-  ShouldBeApplicationOf{}                  -> "ShouldBeApplicationOf"-  ShouldBeAppliedToTheDatatypeParameters{} -> "ShouldBeAppliedToTheDatatypeParameters"-  ShouldBeEmpty{}                          -> "ShouldBeEmpty"-  ShouldBePi{}                             -> "ShouldBePi"-  ShouldBePath{}                           -> "ShouldBePath"-  ShouldBeRecordType{}                     -> "ShouldBeRecordType"-  ShouldBeRecordPattern{}                  -> "ShouldBeRecordPattern"-  NotAProjectionPattern{}                  -> "NotAProjectionPattern"-  ShouldEndInApplicationOfTheDatatype{}    -> "ShouldEndInApplicationOfTheDatatype"-  SplitError{}                             -> "SplitError"-  ImpossibleConstructor{}                  -> "ImpossibleConstructor"-  TooManyFields{}                          -> "TooManyFields"-  TooManyPolarities{}                      -> "TooManyPolarities"-  SplitOnIrrelevant{}                      -> "SplitOnIrrelevant"-  SplitOnUnusableCohesion{}                -> "SplitOnUnusableCohesion"-  -- UNUSED: -- SplitOnErased{}                          -> "SplitOnErased"-  SplitOnNonVariable{}                     -> "SplitOnNonVariable"-  SplitOnNonEtaRecord{}                    -> "SplitOnNonEtaRecord"-  DefinitionIsIrrelevant{}                 -> "DefinitionIsIrrelevant"-  DefinitionIsErased{}                     -> "DefinitionIsErased"-  VariableIsIrrelevant{}                   -> "VariableIsIrrelevant"-  VariableIsErased{}                       -> "VariableIsErased"-  VariableIsOfUnusableCohesion{}           -> "VariableIsOfUnusableCohesion"-  UnequalBecauseOfUniverseConflict{}       -> "UnequalBecauseOfUniverseConflict"-  UnequalRelevance{}                       -> "UnequalRelevance"-  UnequalQuantity{}                        -> "UnequalQuantity"-  UnequalCohesion{}                        -> "UnequalCohesion"-  UnequalHiding{}                          -> "UnequalHiding"-  UnequalLevel{}                           -> "UnequalLevel"-  UnequalSorts{}                           -> "UnequalSorts"-  UnequalTerms{}                           -> "UnequalTerms"-  UnequalTypes{}                           -> "UnequalTypes"---  UnequalTelescopes{}                      -> "UnequalTelescopes" -- UNUSED-  WithOnFreeVariable{}                     -> "WithOnFreeVariable"-  UnexpectedWithPatterns{}                 -> "UnexpectedWithPatterns"-  UninstantiatedDotPattern{}               -> "UninstantiatedDotPattern"-  ForcedConstructorNotInstantiated{}       -> "ForcedConstructorNotInstantiated"-  SolvedButOpenHoles{}                     -> "SolvedButOpenHoles"-  UnusedVariableInPatternSynonym           -> "UnusedVariableInPatternSynonym"-  UnquoteFailed{}                          -> "UnquoteFailed"-  DeBruijnIndexOutOfScope{}                -> "DeBruijnIndexOutOfScope"-  WithClausePatternMismatch{}              -> "WithClausePatternMismatch"-  WrongHidingInApplication{}               -> "WrongHidingInApplication"-  WrongHidingInLHS{}                       -> "WrongHidingInLHS"-  WrongHidingInLambda{}                    -> "WrongHidingInLambda"-  WrongIrrelevanceInLambda{}               -> "WrongIrrelevanceInLambda"-  WrongQuantityInLambda{}                  -> "WrongQuantityInLambda"-  WrongCohesionInLambda{}                  -> "WrongCohesionInLambda"-  WrongNamedArgument{}                     -> "WrongNamedArgument"-  WrongNumberOfConstructorArguments{}      -> "WrongNumberOfConstructorArguments"-  QuantityMismatch{}                       -> "QuantityMismatch"-  HidingMismatch{}                         -> "HidingMismatch"-  RelevanceMismatch{}                      -> "RelevanceMismatch"-  NonFatalErrors{}                         -> "NonFatalErrors"-  InstanceSearchDepthExhausted{}           -> "InstanceSearchDepthExhausted"-  TriedToCopyConstrainedPrim{}             -> "TriedToCopyConstrainedPrim"-  SortOfSplitVarError{}                    -> "SortOfSplitVarError"--instance PrettyTCM TCErr where-  prettyTCM err = case err of-    -- Gallais, 2016-05-14-    -- Given where `NonFatalErrors` are created, we know for a-    -- fact that ̀ws` is non-empty.-    TypeError loc _ Closure{ clValue = NonFatalErrors ws } -> do-      reportSLn "error" 2 $ "Error raised at " ++ prettyShow loc-      foldr1 ($$) $ fmap prettyTCM ws-    -- Andreas, 2014-03-23-    -- This use of withTCState seems ok since we do not collect-    -- Benchmark info during printing errors.-    TypeError loc s e -> withTCState (const s) $ do-      reportSLn "error" 2 $ "Error raised at " ++ prettyShow loc-      sayWhen (envRange $ clEnv e) (envCall $ clEnv e) $ prettyTCM e-    Exception r s     -> sayWhere r $ return s-    IOException _ r e -> sayWhere r $ fwords $ show e-    PatternErr{}      -> sayWhere err $ panic "uncaught pattern violation"---- | Drops given amount of leading components of the qualified name.-dropTopLevelModule' :: Int -> QName -> QName-dropTopLevelModule' k (QName (MName ns) n) = QName (MName (drop k ns)) n---- | Drops the filename component of the qualified name.-dropTopLevelModule :: QName -> TCM QName-dropTopLevelModule q = ($ q) <$> topLevelModuleDropper---- | Produces a function which drops the filename component of the qualified name.-topLevelModuleDropper :: (MonadDebug m, MonadTCEnv m, ReadTCState m) => m (QName -> QName)-topLevelModuleDropper = do-  caseMaybeM (asksTC envCurrentPath) (return id) $ \ f -> do-  reportSDoc "err.dropTopLevel" 60 $ vcat-    [ "current path =" <+> (text . filePath) f-    , "moduleToSource =" <+> do text . show =<< useR stModuleToSource-    ]-  m <- fromMaybe __IMPOSSIBLE__ <$> lookupModuleFromSource f-  return $ dropTopLevelModule' $ size m--instance PrettyTCM TypeError where-  prettyTCM err = case err of-    InternalError s -> panic s--    NotImplemented s -> fwords $ "Not implemented: " ++ s--    NotSupported s -> fwords $ "Not supported: " ++ s--    CompilationError s -> sep [fwords "Compilation error:", text s]--    GenericError s -> fwords s--    GenericDocError d -> return d--    PropMustBeSingleton -> fwords-      "Datatypes in Prop must have at most one constructor when proof irrelevance is enabled"--    DataMustEndInSort t -> fsep $-      pwords "The type of a datatype must end in a sort."-      ++ [prettyTCM t] ++ pwords "isn't a sort."--{- UNUSED:-    DataTooManyParameters -> fsep $ pwords "Too many parameters given to data type."--}--    ShouldEndInApplicationOfTheDatatype t -> fsep $-      pwords "The target of a constructor must be the datatype applied to its parameters,"-      ++ [prettyTCM t] ++ pwords "isn't"--    ShouldBeAppliedToTheDatatypeParameters s t -> fsep $-      pwords "The target of the constructor should be" ++ [prettyTCM s] ++-      pwords "instead of" ++ [prettyTCM t]--    ShouldBeApplicationOf t q -> fsep $-      pwords "The pattern constructs an element of" ++ [prettyTCM q] ++-      pwords "which is not the right datatype"--    ShouldBeRecordType t -> fsep $-      pwords "Expected non-abstract record type, found " ++ [prettyTCM t]--    ShouldBeRecordPattern p -> fsep $-      pwords "Expected record pattern" -- ", found " ++ [prettyTCM p]--    NotAProjectionPattern p -> fsep $-      pwords "Not a valid projection for a copattern: " ++ [ prettyA p ]--    WrongHidingInLHS -> fwords "Unexpected implicit argument"--    WrongHidingInLambda t ->-      fwords "Found an implicit lambda where an explicit lambda was expected"--    WrongIrrelevanceInLambda ->-      fwords "Found a non-strict lambda where a irrelevant lambda was expected"--    WrongQuantityInLambda ->-      fwords "Incorrect quantity annotation in lambda"--    WrongCohesionInLambda ->-      fwords "Incorrect cohesion annotation in lambda"--    WrongNamedArgument a xs0 -> fsep $-      pwords "Function does not accept argument "-      ++ [prettyTCM a] -- ++ pwords " (wrong argument name)"-      ++ [parens $ fsep $ text "possible arguments:" : map pretty xs | not (null xs)]-      where-      xs = filter (not . isNoName) xs0--    WrongHidingInApplication t ->-      fwords "Found an implicit application where an explicit application was expected"--    HidingMismatch h h' -> fwords $-      "Expected " ++ verbalize (Indefinite h') ++ " argument, but found " ++-      verbalize (Indefinite h) ++ " argument"--    RelevanceMismatch r r' -> fwords $-      "Expected " ++ verbalize (Indefinite r') ++ " argument, but found " ++-      verbalize (Indefinite r) ++ " argument"--    QuantityMismatch q q' -> fwords $-      "Expected " ++ verbalize (Indefinite q') ++ " argument, but found " ++-      verbalize (Indefinite q) ++ " argument"--    UninstantiatedDotPattern e -> fsep $-      pwords "Failed to infer the value of dotted pattern"--    ForcedConstructorNotInstantiated p -> fsep $-      pwords "Failed to infer that constructor pattern "-      ++ [prettyA p] ++ pwords " is forced"--    IllformedProjectionPattern p -> fsep $-      pwords "Ill-formed projection pattern " ++ [prettyA p]--    CannotEliminateWithPattern b p a -> do-      let isProj = isJust (isProjP p)-      fsep $-        pwords "Cannot eliminate type" ++ prettyTCM a : if-         | isProj -> pwords "with projection pattern" ++ [prettyA p]-         | A.ProjP _ _ f <- namedArg p -> pwords "with pattern" ++ [prettyA p] ++-             pwords "(suggestion: write" ++ [".(" <> prettyA (A.Proj ProjPrefix f) <> ")"] ++ pwords "for a dot pattern," ++-             pwords "or remove the braces for a postfix projection)"-         | otherwise ->-             "with" : text (kindOfPattern (namedArg p)) : "pattern" : prettyA p :-             pwords "(did you supply too many arguments?)"-      where-      kindOfPattern = \case-        A.VarP{}    -> "variable"-        A.ConP{}    -> "constructor"-        A.ProjP{}   -> __IMPOSSIBLE__-        A.DefP{}    -> __IMPOSSIBLE__-        A.WildP{}   -> "wildcard"-        A.DotP{}    -> "dot"-        A.AbsurdP{} -> "absurd"-        A.LitP{}    -> "literal"-        A.RecP{}    -> "record"-        A.WithP{}   -> "with"-        A.EqualP{}  -> "equality"-        A.AsP _ _ p -> kindOfPattern p-        A.PatternSynP{} -> __IMPOSSIBLE__-        A.AnnP _ _ p -> kindOfPattern p--    WrongNumberOfConstructorArguments c expect given -> fsep $-      pwords "The constructor" ++ [prettyTCM c] ++-      pwords "expects" ++ [prettyTCM expect] ++-      pwords "arguments (including hidden ones), but has been given"-      ++ [prettyTCM given] ++ pwords "(including hidden ones)"--    CantResolveOverloadedConstructorsTargetingSameDatatype d cs -> fsep $-      pwords "Can't resolve overloaded constructors targeting the same datatype"-      ++ [parens (prettyTCM (qnameToConcrete d)) <> colon]-      ++ map pretty (List1.toList cs)--    DoesNotConstructAnElementOf c t -> fsep $-      pwords "The constructor" ++ [prettyTCM c] ++-      pwords "does not construct an element of" ++ [prettyTCM t]--    ConstructorPatternInWrongDatatype c d -> fsep $-      [prettyTCM c] ++ pwords "is not a constructor of the datatype"-      ++ [prettyTCM d]--    ShadowedModule x [] -> __IMPOSSIBLE__--    ShadowedModule x ms@(m0 : _) -> do-      -- Clash! Concrete module name x already points to the abstract names ms.-      (r, m) <- do-        -- Andreas, 2017-07-28, issue #719.-        -- First, we try to find whether one of the abstract names @ms@ points back to @x@-        scope <- getScope-        -- Get all pairs (y,m) such that y points to some m ∈ ms.-        let xms0 = ms >>= \ m -> map (,m) $ inverseScopeLookupModule m scope-        reportSLn "scope.clash.error" 30 $ "candidates = " ++ prettyShow xms0--        -- Try to find x (which will have a different Range, if it has one (#2649)).-        let xms = filter ((\ y -> not (null $ getRange y) && y == C.QName x) . fst) xms0-        reportSLn "scope.class.error" 30 $ "filtered candidates = " ++ prettyShow xms--        -- If we found a copy of x with non-empty range, great!-        ifJust (listToMaybe xms) (\ (x', m) -> return (getRange x', m)) $ {-else-} do--        -- If that failed, we pick the first m from ms which has a nameBindingSite.-        let rms = ms >>= \ m -> map (,m) $-              filter (noRange /=) $ map nameBindingSite $ reverse $ mnameToList m-              -- Andreas, 2017-07-25, issue #2649-              -- Take the first nameBindingSite we can get hold of.-        reportSLn "scope.class.error" 30 $ "rangeful clashing modules = " ++ prettyShow rms--        -- If even this fails, we pick the first m and give no range.-        return $ fromMaybe (noRange, m0) $ listToMaybe rms--      fsep $-        pwords "Duplicate definition of module" ++ [prettyTCM x <> "."] ++-        pwords "Previous definition of" ++ [help m] ++ pwords "module" ++ [prettyTCM x] ++-        pwords "at" ++ [prettyTCM r]-      where-        help :: MonadPretty m => ModuleName -> m Doc-        help m = caseMaybeM (isDatatypeModule m) empty $ \case-          IsDataModule   -> "(datatype)"-          IsRecordModule -> "(record)"--    ModuleArityMismatch m EmptyTel args -> fsep $-      pwords "The module" ++ [prettyTCM m] ++-      pwords "is not parameterized, but is being applied to arguments"--    ModuleArityMismatch m tel@(ExtendTel _ _) args -> fsep $-      pwords "The arguments to " ++ [prettyTCM m] ++ pwords "do not fit the telescope" ++-      [prettyTCM tel]--    ShouldBeEmpty t [] -> fsep $-       prettyTCM t : pwords "should be empty, but that's not obvious to me"--    ShouldBeEmpty t ps -> fsep (-      prettyTCM t :-      pwords "should be empty, but the following constructor patterns are valid:"-      ) $$ nest 2 (vcat $ map (prettyPat 0) ps)--    ShouldBeASort t -> fsep $-      prettyTCM t : pwords "should be a sort, but it isn't"--    ShouldBePi t -> fsep $-      prettyTCM t : pwords "should be a function type, but it isn't"--    ShouldBePath t -> fsep $-      prettyTCM t : pwords "should be a Path or PathP type, but it isn't"--    NotAProperTerm -> fwords "Found a malformed term"--    InvalidTypeSort s -> fsep $ prettyTCM s : pwords "is not a valid type"-    InvalidType v -> fsep $ prettyTCM v : pwords "is not a valid type"--    FunctionTypeInSizeUniv v -> fsep $-      pwords "Functions may not return sizes, thus, function type " ++-      [ prettyTCM v ] ++ pwords " is illegal"--    SplitOnIrrelevant t -> fsep $-      pwords "Cannot pattern match against" ++ [text $ verbalize $ getRelevance t] ++-      pwords "argument of type" ++ [prettyTCM $ unDom t]--    SplitOnUnusableCohesion t -> fsep $-      pwords "Cannot pattern match against" ++ [text $ verbalize $ getCohesion t] ++-      pwords "argument of type" ++ [prettyTCM $ unDom t]--    -- UNUSED:-    -- SplitOnErased t -> fsep $-    --   pwords "Cannot pattern match against" ++ [text $ verbalize $ getQuantity t] ++-    --   pwords "argument of type" ++ [prettyTCM $ unDom t]--    SplitOnNonVariable v t -> fsep $-      pwords "Cannot pattern match because the (refined) argument " ++-      [ prettyTCM v ] ++ pwords " is not a variable."--    SplitOnNonEtaRecord q -> fsep $ concat-      [ pwords "Pattern matching on no-eta record type"-      , [ prettyTCM q, parens ("defined at" <+> prettyTCM r) ]-      , pwords "is not allowed"-      , [ parens "to activate, add declaration `pattern` to record definition" ]-      ]-      where r = nameBindingSite $ qnameName q--    DefinitionIsIrrelevant x -> fsep $-      "Identifier" : prettyTCM x : pwords "is declared irrelevant, so it cannot be used here"--    DefinitionIsErased x -> fsep $-      "Identifier" : prettyTCM x : pwords "is declared erased, so it cannot be used here"--    VariableIsIrrelevant x -> fsep $-      "Variable" : prettyTCM (nameConcrete x) : pwords "is declared irrelevant, so it cannot be used here"--    VariableIsErased x -> fsep $-      "Variable" : prettyTCM (nameConcrete x) : pwords "is declared erased, so it cannot be used here"--    VariableIsOfUnusableCohesion x c -> fsep-      ["Variable", prettyTCM (nameConcrete x), "is declared", text (show c), "so it cannot be used here"]--    UnequalBecauseOfUniverseConflict cmp s t -> fsep $-      [prettyTCM s, notCmp cmp, prettyTCM t, "because this would result in an invalid use of Setω" ]--    UnequalTerms cmp s t a -> case (s,t) of-      (Sort s1      , Sort s2      )-        | CmpEq  <- cmp              -> prettyTCM $ UnequalSorts s1 s2-        | CmpLeq <- cmp              -> prettyTCM $ NotLeqSort s1 s2-      (Sort MetaS{} , t            ) -> prettyTCM $ ShouldBeASort $ El __IMPOSSIBLE__ t-      (s            , Sort MetaS{} ) -> prettyTCM $ ShouldBeASort $ El __IMPOSSIBLE__ s-      (Sort DefS{}  , t            ) -> prettyTCM $ ShouldBeASort $ El __IMPOSSIBLE__ t-      (s            , Sort DefS{}  ) -> prettyTCM $ ShouldBeASort $ El __IMPOSSIBLE__ s-      (_            , _            ) -> do-        (d1, d2, d) <- prettyInEqual s t-        fsep $ concat $-          [ [return d1, notCmp cmp, return d2]-          , case a of-                AsTermsOf t -> pwords "of type" ++ [prettyTCM t]-                AsSizes     -> pwords "of type" ++ [prettyTCM =<< sizeType]-                AsTypes     -> []-          , [return d]-          ]--    UnequalLevel cmp s t -> fsep $-      [prettyTCM s, notCmp cmp, prettyTCM t]---- UnequalTelescopes is UNUSED---   UnequalTelescopes cmp a b -> fsep $---     [prettyTCM a, notCmp cmp, prettyTCM b]--    UnequalTypes cmp a b -> prettyUnequal a (notCmp cmp) b---              fsep $ [prettyTCM a, notCmp cmp, prettyTCM b]--    UnequalRelevance cmp a b -> fsep $-      [prettyTCM a, notCmp cmp, prettyTCM b] ++-      pwords "because one is a relevant function type and the other is an irrelevant function type"--    UnequalQuantity cmp a b -> fsep $-      [prettyTCM a, notCmp cmp, prettyTCM b] ++-      pwords "because one is a non-erased function type and the other is an erased function type"--    UnequalCohesion cmp a b -> fsep $-      [prettyTCM a, notCmp cmp, prettyTCM b] ++-      pwords "because one is a non-flat function type and the other is a flat function type"-      -- FUTURE Cohesion: update message if/when introducing sharp.--    UnequalHiding a b -> fsep $-      [prettyTCM a, "!=", prettyTCM b] ++-      pwords "because one is an implicit function type and the other is an explicit function type"--    UnequalSorts s1 s2 -> fsep $-      [prettyTCM s1, "!=", prettyTCM s2]--    NotLeqSort s1 s2 -> fsep $-      [prettyTCM s1] ++ pwords "is not less or equal than" ++ [prettyTCM s2]--    TooManyFields r missing xs -> prettyTooManyFields r missing xs--    DuplicateConstructors xs -> fsep $-      pwords "Duplicate" ++ constructors xs ++ punctuate comma (map pretty xs) ++-      pwords "in datatype"-      where-      constructors ys = P.singPlural ys [text "constructor"] [text "constructors"]--    DuplicateFields xs -> prettyDuplicateFields xs--    WithOnFreeVariable e v -> do-      de <- prettyA e-      dv <- prettyTCM v-      if show de == show dv-        then fsep $-          pwords "Cannot `with` on variable" ++ [return dv] ++-          pwords " bound in a module telescope (or patterns of a parent clause)"-        else fsep $-          pwords "Cannot `with` on expression" ++ [return de] ++ pwords "which reduces to variable" ++ [return dv] ++-          pwords " bound in a module telescope (or patterns of a parent clause)"--    UnexpectedWithPatterns ps -> fsep $-      pwords "Unexpected with patterns" ++ punctuate " |" (map prettyA ps)--    WithClausePatternMismatch p q -> fsep $-      pwords "With clause pattern " ++ [prettyA p] ++-      pwords " is not an instance of its parent pattern " ++ [P.fsep <$> prettyTCMPatterns [q]]--    -- The following error is caught and reraised as GenericDocError in Occurs.hs-    MetaCannotDependOn m {- ps -} i -> fsep $-      pwords "The metavariable" ++ [prettyTCM $ MetaV m []] ++-      pwords "cannot depend on" ++ [pvar i] ++-      [] -- pwords "because it" ++ deps-        where-          pvar = prettyTCM . I.var-          -- deps = case map pvar ps of-          --   []  -> pwords "does not depend on any variables"-          --   [x] -> pwords "only depends on the variable" ++ [x]-          --   xs  -> pwords "only depends on the variables" ++ punctuate comma xs--    -- The following error is caught and reraised as GenericDocError in Occurs.hs-    MetaOccursInItself m -> fsep $-      pwords "Cannot construct infinite solution of metavariable" ++ [prettyTCM $ MetaV m []]--    -- The following error is caught and reraised as GenericDocError in Occurs.hs-    MetaIrrelevantSolution m _ -> fsep $-      pwords "Cannot instantiate the metavariable because (part of) the" ++-      pwords "solution was created in an irrelevant context."--    -- The following error is caught and reraised as GenericDocError in Occurs.hs-    MetaErasedSolution m _ -> fsep $-      pwords "Cannot instantiate the metavariable because (part of) the" ++-      pwords "solution was created in an erased context."--    BuiltinMustBeConstructor s e -> fsep $-      [prettyA e] ++ pwords "must be a constructor in the binding to builtin" ++ [text s]--    NoSuchBuiltinName s -> fsep $-      pwords "There is no built-in thing called" ++ [text s]--    DuplicateBuiltinBinding b x y -> fsep $-      pwords "Duplicate binding for built-in thing" ++ [text b <> comma] ++-      pwords "previous binding to" ++ [prettyTCM x]--    NoBindingForBuiltin x-      | x `elem` [builtinZero, builtinSuc] -> fsep $-        pwords "No binding for builtin " ++ [text x <> comma] ++-        pwords ("use {-# BUILTIN " ++ builtinNat ++ " name #-} to bind builtin natural " ++-                "numbers to the type 'name'")-      | otherwise -> fsep $-        pwords "No binding for builtin thing" ++ [text x <> comma] ++-        pwords ("use {-# BUILTIN " ++ x ++ " name #-} to bind it to 'name'")--    DuplicatePrimitiveBinding b x y -> fsep $-      pwords "Duplicate binding for primitive thing" ++ [text b <> comma] ++-      pwords "previous binding to" ++ [prettyTCM x]--    NoSuchPrimitiveFunction x -> fsep $-      pwords "There is no primitive function called" ++ [text x]--    WrongModalityForPrimitive x got expect ->-      vcat [ fsep $ pwords "Wrong modality for primitive" ++ [text x]-           , nest 2 $ text $ "Got:      " ++ intercalate ", " gs-           , nest 2 $ text $ "Expected: " ++ intercalate ", " es ]-      where-        (gs, es) = unzip [ p | p@(g, e) <- zip (things got) (things expect), g /= e ]-        things i = [verbalize $ getHiding i,-                    verbalize $ getRelevance i,-                    verbalize $ getQuantity i,-                    verbalize $ getCohesion i]--    BuiltinInParameterisedModule x -> fwords $-      "The BUILTIN pragma cannot appear inside a bound context " ++-      "(for instance, in a parameterised module or as a local declaration)"--    IllegalLetInTelescope tb -> fsep $-      -- pwords "The binding" ++-      pretty tb :-      pwords " is not allowed in a telescope here."--    IllegalPatternInTelescope bd -> fsep $-      pretty bd :-      pwords " is not allowed in a telescope here."--    NoRHSRequiresAbsurdPattern ps -> fwords $-      "The right-hand side can only be omitted if there " ++-      "is an absurd pattern, () or {}, in the left-hand side."--    LocalVsImportedModuleClash m -> fsep $-      pwords "The module" ++ [prettyTCM m] ++-      pwords "can refer to either a local module or an imported module"--    SolvedButOpenHoles -> fsep $-      pwords "Module cannot be imported since it has open interaction points" ++-      pwords "(consider adding {-# OPTIONS --allow-unsolved-metas #-} to this module)"--    CyclicModuleDependency ms ->-      fsep (pwords "cyclic module dependency:")-      $$ nest 2 (vcat $ map pretty ms)--    FileNotFound x files ->-      fsep ( pwords "Failed to find source of module" ++ [pretty x] ++-             pwords "in any of the following locations:"-           ) $$ nest 2 (vcat $ map (text . filePath) files)--    OverlappingProjects f m1 m2-      | canon d1 == canon d2 -> fsep $ concat-          [ pwords "Case mismatch when accessing file"-          , [ text $ filePath f ]-          , pwords "through module name"-          , [ pure d2 ]-          ]-      | otherwise -> fsep-           ( pwords "The file" ++ [text (filePath f)] ++-             pwords "can be accessed via several project roots. Both" ++-             [ pure d1 ] ++ pwords "and" ++ [ pure d2 ] ++-             pwords "point to this file."-           )-      where-      canon = CaseInsens.mk . P.render-      d1 = P.pretty m1-      d2 = P.pretty m2--    AmbiguousTopLevelModuleName x files ->-      fsep ( pwords "Ambiguous module name. The module name" ++-             [pretty x] ++-             pwords "could refer to any of the following files:"-           ) $$ nest 2 (vcat $ map (text . filePath) files)--    ClashingFileNamesFor x files ->-      fsep ( pwords "Multiple possible sources for module"-             ++ [prettyTCM x] ++ pwords "found:"-           ) $$ nest 2 (vcat $ map (text . filePath) files)--    ModuleDefinedInOtherFile mod file file' -> fsep $-      pwords "You tried to load" ++ [text (filePath file)] ++-      pwords "which defines the module" ++ [pretty mod <> "."] ++-      pwords "However, according to the include path this module should" ++-      pwords "be defined in" ++ [text (filePath file') <> "."]--    ModuleNameUnexpected given expected-      | canon dGiven == canon dExpected -> fsep $ concat-          [ pwords "Case mismatch between the actual module name"-          , [ pure dGiven ]-          , pwords "and the expected module name"-          , [ pure dExpected ]-          ]-      | otherwise -> fsep $ concat-          [ pwords "The name of the top level module does not match the file name. The module"-          , [ pure dGiven ]-          , pwords "should probably be named"-          , [ pure dExpected ]-          ]-      where-      canon = CaseInsens.mk . P.render-      dGiven    = P.pretty given-      dExpected = P.pretty expected---    ModuleNameDoesntMatchFileName given files ->-      fsep (pwords "The name of the top level module does not match the file name. The module" ++-           [ pretty given ] ++ pwords "should be defined in one of the following files:")-      $$ nest 2 (vcat $ map (text . filePath) files)--    BothWithAndRHS -> fsep $ pwords "Unexpected right hand side"--    AbstractConstructorNotInScope q -> fsep $-      [ "Constructor"-      , prettyTCM q-      ] ++ pwords "is abstract, thus, not in scope here"--    NotInScope xs ->-      -- using the warning version to avoid code duplication-      prettyWarning (NotInScopeW xs)--    NoSuchModule x -> fsep $ pwords "No module" ++ [pretty x] ++ pwords "in scope"--    AmbiguousName x ys -> vcat-      [ fsep $ pwords "Ambiguous name" ++ [pretty x <> "."] ++-               pwords "It could refer to any one of"-      , nest 2 $ vcat $ fmap nameWithBinding ys-      , fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)"-      ]--    AmbiguousModule x ys -> vcat-      [ fsep $ pwords "Ambiguous module name" ++ [pretty x <> "."] ++-               pwords "It could refer to any one of"-      , nest 2 $ vcat $ fmap help ys-      , fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)"-      ]-      where-        help :: MonadPretty m => ModuleName -> m Doc-        help m = do-          anno <- caseMaybeM (isDatatypeModule m) (return empty) $ \case-            IsDataModule   -> return $ "(datatype module)"-            IsRecordModule -> return $ "(record module)"-          sep [prettyTCM m, anno ]--    ClashingDefinition x y suggestion -> fsep $-      pwords "Multiple definitions of" ++ [pretty x <> "."] ++-      pwords "Previous definition at"-      ++ [prettyTCM $ nameBindingSite $ qnameName y] ++-      caseMaybe suggestion [] (\d ->-        [  "Perhaps you meant to write "-        $$ nest 2 ("'" <> pretty (notSoNiceDeclarations d) <> "'")-        $$ ("at" <+> (pretty . envRange =<< askTC)) <> "?"-        $$ "In data definitions separate from data declaration, the ':' and type must be omitted."-        ])--    ClashingModule m1 m2 -> fsep $-      pwords "The modules" ++ [prettyTCM m1, "and", prettyTCM m2]-      ++ pwords "clash."--    ClashingImport x y -> fsep $-      pwords "Import clash between" ++ [pretty x, "and", prettyTCM y]--    ClashingModuleImport x y -> fsep $-      pwords "Module import clash between" ++ [pretty x, "and", prettyTCM y]--    PatternShadowsConstructor x c -> fsep $-      pwords "The pattern variable" ++ [prettyTCM x] ++-      pwords "has the same name as the constructor" ++ [prettyTCM c]--    DuplicateImports m xs -> fsep $-      pwords "Ambiguous imports from module" ++ [pretty m] ++ pwords "for" ++-      punctuate comma (map pretty xs)--    NotAModuleExpr e -> fsep $-      pwords "The right-hand side of a module definition must have the form 'M e1 .. en'" ++-      pwords "where M is a module name. The expression"-      ++ [pretty e, "doesn't."]--    FieldOutsideRecord -> fsep $-      pwords "Field appearing outside record declaration."--    InvalidPattern p -> fsep $-      pretty p : pwords "is not a valid pattern"--    RepeatedVariablesInPattern xs -> fsep $-      pwords "Repeated variables in pattern:" ++ map pretty xs--    NotAnExpression e -> fsep $-      pretty e : pwords "is not a valid expression."--    NotAValidLetBinding nd -> fwords $-      "Not a valid let-declaration"--    NotValidBeforeField nd -> fwords $-      "This declaration is illegal in a record before the last field"--    NothingAppliedToHiddenArg e -> fsep $-      [pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" ++-      pwords "a function expecting an implicit argument."--    NothingAppliedToInstanceArg e -> fsep $-      [pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" ++-      pwords "a function expecting an instance argument."--    NoParseForApplication es -> fsep (-      pwords "Could not parse the application" ++ [pretty $ C.RawApp noRange es])--    AmbiguousParseForApplication es es' -> fsep (-      pwords "Don't know how to parse" ++ [pretty_es <> "."] ++-      pwords "Could mean any one of:"-      ) $$ nest 2 (vcat $ fmap pretty' es')-      where-        pretty_es :: MonadPretty m => m Doc-        pretty_es = pretty $ C.RawApp noRange es--        pretty' :: MonadPretty m => C.Expr -> m Doc-        pretty' e = do-          p1 <- pretty_es-          p2 <- pretty e-          if render p1 == render p2 then unambiguous e else return p2--        unambiguous :: MonadPretty m => C.Expr -> m Doc-        unambiguous e@(C.OpApp r op _ xs)-          | all (isOrdinary . namedArg) xs =-            pretty $-              foldl (C.App r) (C.Ident op) $-                (fmap . fmap . fmap) fromOrdinary xs-          | any (isPlaceholder . namedArg) xs =-              pretty e <+> "(section)"-        unambiguous e = pretty e--        isOrdinary :: MaybePlaceholder (C.OpApp e) -> Bool-        isOrdinary (NoPlaceholder _ (C.Ordinary _)) = True-        isOrdinary _                                = False--        fromOrdinary :: MaybePlaceholder (C.OpApp e) -> e-        fromOrdinary (NoPlaceholder _ (C.Ordinary e)) = e-        fromOrdinary _                                = __IMPOSSIBLE__--        isPlaceholder :: MaybePlaceholder a -> Bool-        isPlaceholder Placeholder{}   = True-        isPlaceholder NoPlaceholder{} = False--    BadArgumentsToPatternSynonym x -> fsep $-      pwords "Bad arguments to pattern synonym " ++ [prettyTCM $ headAmbQ x]--    TooFewArgumentsToPatternSynonym x -> fsep $-      pwords "Too few arguments to pattern synonym " ++ [prettyTCM $ headAmbQ x]--    CannotResolveAmbiguousPatternSynonym defs -> vcat-      [ fsep $ pwords "Cannot resolve overloaded pattern synonym" ++ [prettyTCM x <> comma] ++-               pwords "since candidates have different shapes:"-      , nest 2 $ vcat $ fmap prDef defs-      , fsep $ pwords "(hint: overloaded pattern synonyms must be equal up to variable and constructor names)"-      ]-      where-        (x, _) = NonEmpty.head defs-        prDef (x, (xs, p)) = prettyA (A.PatternSynDef x (map (fmap BindName) xs) p) <?> ("at" <+> pretty r)-          where r = nameBindingSite $ qnameName x--    UnusedVariableInPatternSynonym -> fsep $-      pwords "Unused variable in pattern synonym."--    NoParseForLHS lhsOrPatSyn errs p -> vcat-      [ fsep $ pwords "Could not parse the" ++ prettyLhsOrPatSyn ++ [pretty p]-      , prettyErrs-      ]-      where-      prettyLhsOrPatSyn = pwords $ case lhsOrPatSyn of-        IsLHS    -> "left-hand side"-        IsPatSyn -> "pattern synonym"-      prettyErrs = case errs of-        []     -> empty-        p0 : _ -> fsep $ pwords "Problematic expression:" ++ [pretty p0]--{- UNUSED-    NoParseForPatternSynonym p -> fsep $-      pwords "Could not parse the pattern synonym" ++ [pretty p]--}--    AmbiguousParseForLHS lhsOrPatSyn p ps -> do-      d <- pretty p-      vcat $-        [ fsep $-            pwords "Don't know how to parse" ++ [pure d <> "."] ++-            pwords "Could mean any one of:"-        ]-          ++-        map (nest 2 . pretty' d) ps-      where-        pretty' :: MonadPretty m => Doc -> C.Pattern -> m Doc-        pretty' d1 p' = do-          d2 <- pretty p'-          if render d1 == render d2 then pretty $ unambiguousP p' else return d2--        -- the entire pattern is shown, not just the ambiguous part,-        -- so we need to dig in order to find the OpAppP's.-        unambiguousP :: C.Pattern -> C.Pattern-        unambiguousP (C.AppP x y)         = C.AppP (unambiguousP x) $ (fmap.fmap) unambiguousP y-        unambiguousP (C.HiddenP r x)      = C.HiddenP r $ fmap unambiguousP x-        unambiguousP (C.InstanceP r x)    = C.InstanceP r $ fmap unambiguousP x-        unambiguousP (C.ParenP r x)       = C.ParenP r $ unambiguousP x-        unambiguousP (C.AsP r n x)        = C.AsP r n $ unambiguousP x-        unambiguousP (C.OpAppP r op _ xs) = foldl C.AppP (C.IdentP op) xs-        unambiguousP e                    = e--    OperatorInformation sects err ->-      prettyTCM err-        $+$-      fsep (pwords "Operators used in the grammar:")-        $$-      nest 2-        (if null sects then "None" else-         vcat (map text $-               lines $-               Boxes.render $-               (\(col1, col2, col3) ->-                   Boxes.hsep 1 Boxes.top $-                   map (Boxes.vcat Boxes.left) [col1, col2, col3]) $-               unzip3 $-               map prettySect $-               sortBy (compare `on` prettyShow . notaName . sectNotation) $-               filter (not . closedWithoutHoles) sects))-      where-      trimLeft  = dropWhile isNormalHole-      trimRight = dropWhileEnd isNormalHole--      closedWithoutHoles sect =-        sectKind sect == NonfixNotation-          &&-        null [ () | NormalHole {} <- trimLeft $ trimRight $-                                       notation (sectNotation sect) ]--      prettyName n = Boxes.text $-        P.render (P.pretty n) ++-        " (" ++ P.render (P.pretty (nameBindingSite n)) ++ ")"--      prettySect sect =-        ( Boxes.text (P.render (P.pretty section))-            Boxes.//-          strut-        , Boxes.text-            ("(" ++-             kind ++ " " ++-             (if notaIsOperator nota-              then "operator"-              else "notation") ++-             (if sectIsSection sect-              then " section"-              else "") ++-             (case sectLevel sect of-                Nothing          -> ""-                Just Unrelated   -> ", unrelated"-                Just (Related l) -> ", level " ++ toStringWithoutDotZero l) ++-             ")")-            Boxes.//-          strut-        , "["-            Boxes.<>-          Boxes.vcat Boxes.left-            (map (\n -> prettyName n Boxes.<> ",") names ++-             [prettyName name Boxes.<> "]"])-        )-        where-        nota    = sectNotation sect-        section = qualifyFirstIdPart-                    (foldr (\x s -> C.nameToRawName x ++ "." ++ s)-                           ""-                           (List1.init (C.qnameParts (notaName nota))))-                    (spacesBetweenAdjacentIds $-                     trim (notation nota))--        qualifyFirstIdPart _ []              = []-        qualifyFirstIdPart q (IdPart x : ps) = IdPart (fmap (q ++) x) : ps-        qualifyFirstIdPart q (p : ps)        = p : qualifyFirstIdPart q ps--        spacesBetweenAdjacentIds (IdPart x : ps@(IdPart _ : _)) =-          IdPart x : IdPart (unranged " ") : spacesBetweenAdjacentIds ps-        spacesBetweenAdjacentIds (p : ps) =-          p : spacesBetweenAdjacentIds ps-        spacesBetweenAdjacentIds [] = []--        trim = case sectKind sect of-          InfixNotation   -> trimLeft . trimRight-          PrefixNotation  -> trimRight-          PostfixNotation -> trimLeft-          NonfixNotation  -> id-          NoNotation      -> __IMPOSSIBLE__--        (names, name) = fromMaybe __IMPOSSIBLE__ $ initLast $ Set.toList $ notaNames nota--        strut = Boxes.emptyBox (length names) 0--        kind = case sectKind sect of-          PrefixNotation  -> "prefix"-          PostfixNotation -> "postfix"-          NonfixNotation  -> "closed"-          NoNotation      -> __IMPOSSIBLE__-          InfixNotation   ->-            case fixityAssoc $ notaFixity nota of-              NonAssoc   -> "infix"-              LeftAssoc  -> "infixl"-              RightAssoc -> "infixr"--{- UNUSED-    AmbiguousParseForPatternSynonym p ps -> fsep (-      pwords "Don't know how to parse" ++ [pretty p <> "."] ++-      pwords "Could mean any one of:"-      ) $$ nest 2 (vcat $ map pretty ps)--}--{- UNUSED-    IncompletePatternMatching v args -> fsep $-      pwords "Incomplete pattern matching for" ++ [prettyTCM v <> "."] ++-      pwords "No match for" ++ map prettyTCM args--}--    SplitError e -> prettyTCM e--    ImpossibleConstructor c neg -> fsep $-      pwords "The case for the constructor " ++ [prettyTCM c] ++-      pwords " is impossible" ++ [prettyTCM neg] ++-      pwords "Possible solution: remove the clause, or use an absurd pattern ()."--    TooManyPolarities x n -> fsep $-      pwords "Too many polarities given in the POLARITY pragma for" ++-      [prettyTCM x] ++-      pwords "(at most" ++ [text (show n)] ++ pwords "allowed)."--    InstanceNoCandidate t errs -> vcat $-      [ fsep $ pwords "No instance of type" ++ [prettyTCM t] ++ pwords "was found in scope."-      , vcat $ map prCand errs ]-      where-        prCand (term, err) =-          text "-" <+>-            vcat [ prettyTCM term <?> text "was ruled out because"-                 , prettyTCM err ]--    UnquoteFailed e -> case e of-      BadVisibility msg arg -> fsep $-        pwords $ "Unable to unquote the argument. It should be `" ++ msg ++ "'."--      ConInsteadOfDef x def con -> fsep $-        pwords ("Use " ++ con ++ " instead of " ++ def ++ " for constructor") ++-        [prettyTCM x]--      DefInsteadOfCon x def con -> fsep $-        pwords ("Use " ++ def ++ " instead of " ++ con ++ " for non-constructor")-        ++ [prettyTCM x]--      NonCanonical kind t ->-        fwords ("Cannot unquote non-canonical " ++ kind)-        $$ nest 2 (prettyTCM t)--      BlockedOnMeta _ m -> fsep $-        pwords $ "Unquote failed because of unsolved meta variables."--      UnquotePanic err -> __IMPOSSIBLE__--    DeBruijnIndexOutOfScope i EmptyTel [] -> fsep $-        pwords $ "de Bruijn index " ++ show i ++ " is not in scope in the empty context"-    DeBruijnIndexOutOfScope i cxt names ->-        sep [ text ("de Bruijn index " ++ show i ++ " is not in scope in the context")-            , inTopContext $ addContext ("_" :: String) $ prettyTCM cxt' ]-      where-        cxt' = cxt `abstract` raise (size cxt) (nameCxt names)-        nameCxt :: [Name] -> I.Telescope-        nameCxt [] = EmptyTel-        nameCxt (x : xs) = ExtendTel (defaultDom (El __DUMMY_SORT__ $ I.var 0)) $-          NoAbs (P.prettyShow x) $ nameCxt xs--    NeedOptionCopatterns -> fsep $-      pwords "Option --copatterns needed to enable destructor patterns"--    NeedOptionRewriting  -> fsep $-      pwords "Option --rewriting needed to add and use rewrite rules"--    NeedOptionProp       -> fsep $-      pwords "Universe Prop is disabled (use options --prop and --no-prop to enable/disable Prop)"--    NeedOptionTwoLevel   -> fsep $-      pwords "Universe SSet is disabled (use option --two-level to enable SSet)"--    GeneralizeNotSupportedHere x -> fsep $-      pwords $ "Generalizable variable " ++ prettyShow x ++ " is not supported here"--    GeneralizeCyclicDependency -> fsep $-      pwords "Cyclic dependency between generalized variables"--    GeneralizeUnsolvedMeta -> fsep $-      pwords "Unsolved meta not generalized"--    MultipleFixityDecls xs ->-      sep [ fsep $ pwords "Multiple fixity or syntax declarations for"-          , vcat $ map f xs-          ]-      where-        f (x, fs) = (pretty x <> ": ") <+> fsep (map pretty fs)--    MultiplePolarityPragmas xs -> fsep $-      pwords "Multiple polarity pragmas for" ++ map pretty xs--    NonFatalErrors ws -> foldr1 ($$) $ fmap prettyTCM ws--    InstanceSearchDepthExhausted c a d -> fsep $-      pwords ("Instance search depth exhausted (max depth: " ++ show d ++ ") for candidate") ++-      [hang (prettyTCM c <+> ":") 2 (prettyTCM a)]--    TriedToCopyConstrainedPrim q -> fsep $-      pwords "Cannot create a module containing a copy of" ++ [prettyTCM q]-    SortOfSplitVarError _ doc -> return doc--    where-    mpar n args-      | n > 0 && not (null args) = parens-      | otherwise                = id--    prettyArg :: MonadPretty m => Arg (I.Pattern' a) -> m Doc-    prettyArg (Arg info x) = case getHiding info of-      Hidden     -> braces $ prettyPat 0 x-      Instance{} -> dbraces $ prettyPat 0 x-      NotHidden  -> prettyPat 1 x--    prettyPat :: MonadPretty m => Integer -> (I.Pattern' a) -> m Doc-    prettyPat _ (I.VarP _ _) = "_"-    prettyPat _ (I.DotP _ _) = "._"-    prettyPat n (I.ConP c _ args) =-      mpar n args $-        prettyTCM c <+> fsep (map (prettyArg . fmap namedThing) args)-    prettyPat n (I.DefP o q args) =-      mpar n args $-        prettyTCM q <+> fsep (map (prettyArg . fmap namedThing) args)-    prettyPat _ (I.LitP _ l) = prettyTCM l-    prettyPat _ (I.ProjP _ p) = "." <> prettyTCM p-    prettyPat _ (I.IApplyP _ _ _ _) = "_"--notCmp :: MonadPretty m => Comparison -> m Doc-notCmp cmp = "!" <> prettyTCM cmp---- | Print two terms that are supposedly unequal.---   If they print to the same identifier, add some explanation---   why they are different nevertheless.-prettyInEqual :: MonadPretty m => Term -> Term -> m (Doc, Doc, Doc)-prettyInEqual t1 t2 = do-  d1 <- prettyTCM t1-  d2 <- prettyTCM t2-  (d1, d2,) <$> do-     -- if printed differently, no extra explanation needed-    if P.render d1 /= P.render d2 then empty else do-      (v1, v2) <- instantiate (t1, t2)-      case (v1, v2) of-        (I.Var i1 _, I.Var i2 _)-          | i1 == i2  -> generic -- possible, see issue 1826-          | otherwise -> varVar i1 i2-        (I.Def{}, I.Con{}) -> __IMPOSSIBLE__  -- ambiguous identifiers-        (I.Con{}, I.Def{}) -> __IMPOSSIBLE__-        (I.Var{}, I.Def{}) -> varDef-        (I.Def{}, I.Var{}) -> varDef-        (I.Var{}, I.Con{}) -> varCon-        (I.Con{}, I.Var{}) -> varCon-        _                  -> empty-  where-    varDef, varCon, generic :: MonadPretty m => m Doc-    varDef = parens $ fwords "because one is a variable and one a defined identifier"-    varCon = parens $ fwords "because one is a variable and one a constructor"-    generic = parens $ fwords $ "although these terms are looking the same, " ++-      "they contain different but identically rendered identifiers somewhere"-    varVar :: MonadPretty m => Int -> Int -> m Doc-    varVar i j = parens $ fwords $-                   "because one has de Bruijn index " ++ show i-                   ++ " and the other " ++ show j--class PrettyUnequal a where-  prettyUnequal :: MonadPretty m => a -> m Doc -> a -> m Doc--instance PrettyUnequal Term where-  prettyUnequal t1 ncmp t2 = do-    (d1, d2, d) <- prettyInEqual t1 t2-    fsep $ return d1 : ncmp : return d2 : return d : []--instance PrettyUnequal Type where-  prettyUnequal t1 ncmp t2 = prettyUnequal (unEl t1) ncmp (unEl t2)--instance PrettyTCM SplitError where-  prettyTCM :: forall m. MonadPretty m => SplitError -> m Doc-  prettyTCM err = case err of-    NotADatatype t -> enterClosure t $ \ t -> fsep $-      pwords "Cannot split on argument of non-datatype" ++ [prettyTCM t]--    BlockedType b t -> enterClosure t $ \ t -> fsep $-      pwords "Cannot split on argument of unresolved type" ++ [prettyTCM t]--    ErasedDatatype causedByWithoutK t -> enterClosure t $ \ t -> fsep $-      pwords "Cannot branch on erased argument of datatype" ++-      [prettyTCM t] ++-      if causedByWithoutK-      then pwords "because the K rule is turned off"-      else []--    CoinductiveDatatype t -> enterClosure t $ \ t -> fsep $-      pwords "Cannot pattern match on the coinductive type" ++ [prettyTCM t]--{- UNUSED-    NoRecordConstructor t -> fsep $-      pwords "Cannot pattern match on record" ++ [prettyTCM t] ++-      pwords "because it has no constructor"- -}--    UnificationStuck b c tel cIxs gIxs errs-      | length cIxs /= length gIxs -> __IMPOSSIBLE__-      | otherwise                  -> vcat . concat $-        [ [ fsep . concat $-            [ pwords "I'm not sure if there should be a case for the constructor"-            , [prettyTCM c <> ","]-            , pwords "because I get stuck when trying to solve the following"-            , pwords "unification problems (inferred index ≟ expected index):"-            ]-          ]-        , zipWith prEq cIxs gIxs-        , if null errs then [] else-            fsep ( pwords "Possible" ++ pwords (P.singPlural errs "reason" "reasons") ++-                     pwords "why unification failed:" ) :-            map (nest 2 . prettyTCM) errs-        ]-      where-        -- Andreas, 2019-08-08, issue #3943-        -- To not print hidden indices just as {_}, we strip the Arg and print-        -- the hiding information manually.-        prEq :: Arg Term -> Arg Term -> m Doc-        prEq cIx gIx = addContext tel $ nest 2 $ hsep [ pr cIx , "≟" , pr gIx ]-        pr arg = prettyRelevance arg . prettyHiding arg id <$> prettyTCM (unArg arg)--    CosplitCatchall -> fsep $-      pwords "Cannot split into projections because not all clauses have a projection copattern"--    CosplitNoTarget -> fsep $-      pwords "Cannot split into projections because target type is unknown"--    CosplitNoRecordType t -> enterClosure t $ \t -> fsep $-      pwords "Cannot split into projections because the target type "-      ++ [prettyTCM t] ++ pwords " is not a record type"--    CannotCreateMissingClause f cl msg t -> fsep (-      pwords "Cannot generate inferred clause for" ++ [prettyTCM f <> "."] ++-      pwords "Case to handle:") $$ nest 2 (vcat $ [display cl])-                                $$ ((pure msg <+> enterClosure t displayAbs) <> ".")-        where-        displayAbs :: Abs Type -> m Doc-        displayAbs (Abs x t) = addContext x $ prettyTCM t-        displayAbs (NoAbs x t) = prettyTCM t-        display (tel, ps) = prettyTCM $ NamedClause f True $-          empty { clauseTel = tel, namedClausePats = ps }---    GenericSplitError s -> fsep $ pwords "Split failed:" ++ pwords s--instance PrettyTCM NegativeUnification where-  prettyTCM err = case err of-    UnifyConflict tel u v -> addContext tel $ vcat $-      [ fsep $ pwords "because unification ended with a conflicting equation "-      , nest 2 $ prettyTCM u <+> "≟" <+> prettyTCM v-      ]--    UnifyCycle tel i u -> addContext tel $ vcat $-      [ fsep $ pwords "because unification ended with a cyclic equation "-      , nest 2 $ prettyTCM (var i) <+> "≟" <+> prettyTCM u-      ]--instance PrettyTCM UnificationFailure where-  prettyTCM err = case err of-    UnifyIndicesNotVars tel a u v ixs -> addContext tel $ fsep $-      pwords "Cannot apply injectivity to the equation" ++ [prettyTCM u] ++-      pwords "=" ++ [prettyTCM v] ++ pwords "of type" ++ [prettyTCM a] ++-      pwords "because I cannot generalize over the indices" ++-      [prettyList (map prettyTCM ixs) <> "."]--    UnifyRecursiveEq tel a i u -> addContext tel $ fsep $-      pwords "Cannot solve variable " ++ [prettyTCM (var i)] ++-      pwords " of type " ++ [prettyTCM a] ++-      pwords " with solution " ++ [prettyTCM u] ++-      pwords " because the variable occurs in the solution," ++-      pwords " or in the type of one of the variables in the solution."--    UnifyReflexiveEq tel a u -> addContext tel $ fsep $-      pwords "Cannot eliminate reflexive equation" ++ [prettyTCM u] ++-      pwords "=" ++ [prettyTCM u] ++ pwords "of type" ++ [prettyTCM a] ++-      pwords "because K has been disabled."--    UnifyUnusableModality tel a i u mod -> addContext tel $ fsep $-      pwords "Cannot solve variable " ++ [prettyTCM (var i)] ++-      pwords "of type " ++ [prettyTCM a] ++-      pwords "with solution " ++ [prettyTCM u] ++-      pwords "because the solution cannot be used at" ++-             [ text (verbalize $ getRelevance mod) <> ","-             , text $ verbalize $ getQuantity mod ] ++-      pwords "modality"--------------------------------------------------------------------------------- * Natural language------------------------------------------------------------------------------class Verbalize a where-  verbalize :: a -> String--instance Verbalize Hiding where-  verbalize h =-    case h of-      Hidden     -> "hidden"-      NotHidden  -> "visible"-      Instance{} -> "instance"--instance Verbalize Relevance where-  verbalize r =-    case r of-      Relevant   -> "relevant"-      Irrelevant -> "irrelevant"-      NonStrict  -> "shape-irrelevant"--instance Verbalize Quantity where-  verbalize = \case-    Quantity0{} -> "erased"-    Quantity1{} -> "linear"-    Quantityω{} -> "unrestricted"--instance Verbalize Cohesion where-  verbalize r =-    case r of-      Flat       -> "flat"-      Continuous -> "continuous"-      Squash     -> "squashed"+  ( renderError+  , prettyError+  , tcErrString+  , prettyTCWarnings'+  , prettyTCWarnings+  , tcWarningsToError+  , applyFlagsToTCWarningsPreserving+  , applyFlagsToTCWarnings+  , getAllUnsolvedWarnings+  , getAllWarningsPreserving+  , getAllWarnings+  , getAllWarningsOfTCErr+  , dropTopLevelModule+  , topLevelModuleDropper+  , explainWhyInScope+  , Verbalize(verbalize)+  ) where++import Prelude hiding ( null, foldl )++import qualified Control.Exception as E+import Control.Monad ((>=>), (<=<))+import Control.Monad.Except++import qualified Data.CaseInsensitive as CaseInsens+import Data.Foldable (foldl)+import Data.Function (on)+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import Data.List (sortBy, dropWhileEnd, intercalate)+import qualified Data.List as List+import Data.Maybe+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Text as Text+import System.FilePath+import qualified Text.PrettyPrint.Boxes as Boxes++import Agda.Interaction.Options+import Agda.Interaction.Options.Errors++import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty ( prettyShow, render )+import qualified Agda.Syntax.Common.Pretty as P+import Agda.Syntax.Concrete.Definitions (notSoNiceDeclarations)+import Agda.Syntax.Concrete.Definitions.Errors (declarationExceptionString)+import Agda.Syntax.Concrete.Pretty (attributesForModality)+import Agda.Syntax.Notation+import Agda.Syntax.Position+import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Abstract as A+import Agda.Syntax.Internal as I+import Agda.Syntax.Translation.InternalToAbstract+import Agda.Syntax.Scope.Monad (isDatatypeModule)+import Agda.Syntax.Scope.Base++import Agda.TypeChecking.Errors.Names (typeErrorString)+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Pretty.Call+import Agda.TypeChecking.Pretty.Warning+import Agda.TypeChecking.SizedTypes.Pretty ()+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Reduce (instantiate)++import Agda.Interaction.Library.Base (formatLibErrors, libFile)++import Agda.Utils.FileName+import Agda.Utils.Float  ( toStringWithoutDotZero )+import Agda.Utils.Function+import Agda.Utils.Functor( for )+import Agda.Utils.IO     ( showIOException )+import Agda.Utils.Lens+import Agda.Utils.List   ( initLast, lastMaybe )+import Agda.Utils.List1  ( List1, pattern (:|) )+import Agda.Utils.List2  ( pattern List2 )+import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.List2 as List2+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+import qualified Agda.Utils.Set1 as Set1+import Agda.Utils.Singleton+import Agda.Utils.Size++import Agda.Utils.Impossible++---------------------------------------------------------------------------+-- * Top level function+---------------------------------------------------------------------------++{-# SPECIALIZE renderError :: TCErr -> TCM String #-}+renderError :: MonadTCM tcm => TCErr -> tcm String+renderError = fmap show . prettyError++{-# SPECIALIZE prettyError :: TCErr -> TCM Doc #-}+prettyError :: MonadTCM tcm => TCErr -> tcm Doc+prettyError = liftTCM . flip renderError' [] where+  renderError' :: TCErr -> [TCErr] -> TCM Doc+  renderError' err errs+    | length errs > 3 = fsep (+        pwords "total panic: error when printing error from printing error from printing error." +++        pwords "I give up! Approximations of errors (original error last):" )+        $$ vcat (map (text . tcErrString) errs)+    | otherwise = applyUnless (null errs) ("panic: error when printing error!" $$) $ do+        (prettyTCM err $$ vcat (map (text . ("when printing error " ++) . tcErrString) errs))+        `catchError` \ err' -> renderError' err' (err:errs)++---------------------------------------------------------------------------+-- * Helpers+---------------------------------------------------------------------------++panic :: Monad m => String -> m Doc+panic s = fwords $ "Panic: " ++ s++nameWithBinding :: MonadPretty m => QName -> m Doc+nameWithBinding q =+  (prettyTCM q <+> "bound at") <?> prettyTCM r+  where+    r = nameBindingSite $ qnameName q++tcErrString :: TCErr -> String+tcErrString err =+  unwords . filter (not . null) . (prettyShow (getRange err) :) $+    case err of+      TypeError _ _ cl     -> [ typeErrorString $ clValue cl ]+      ParserError e        -> [ "ParserError" ]+      GenericException msg -> [ msg ]+      IOException _ r e    -> [ prettyShow r, showIOException e ]+      PatternErr{}         -> [ "PatternErr" ]++instance PrettyTCM TCErr where+  prettyTCM err = case err of+    -- Gallais, 2016-05-14+    -- Given where `NonFatalErrors` are created, we know for a+    -- fact that  ̀ws` is non-empty.+    TypeError loc _ Closure{ clValue = NonFatalErrors ws } -> do+      reportSLn "error" 2 $ "Error raised at " ++ prettyShow loc+      vsep $ fmap prettyTCM $ Set1.toAscList ws+    -- Andreas, 2014-03-23+    -- This use of withTCState seems ok since we do not collect+    -- Benchmark info during printing errors.+    TypeError loc s e -> withTCState (const s) $ do+      reportSLn "error" 2 $ "Error raised at " ++ prettyShow loc+      let r = envRange $ clEnv e+      vcat+        [ hsep+          [ if null r then empty else prettyTCM r <> ":"+          , "error:"+          , brackets (text $ typeErrorString $ clValue e)+          ]+        , prettyTCM e+        , prettyTCM (envCall $ clEnv e)+        ]+    ParserError err   -> pretty err+    GenericException msg -> fwords msg+    IOException _ r e -> sayWhere r $ fwords $ showIOException e+    PatternErr{}      -> sayWhere err $ panic "uncaught pattern violation"++-- | Drops given amount of leading components of the qualified name.+dropTopLevelModule' :: Int -> QName -> QName+dropTopLevelModule' k (QName (MName ns) n) = QName (MName (drop k ns)) n++-- | Drops the filename component of the qualified name.+dropTopLevelModule :: MonadPretty m => QName -> m QName+dropTopLevelModule q = ($ q) <$> topLevelModuleDropper++-- | Produces a function which drops the filename component of the qualified name.+topLevelModuleDropper :: (MonadDebug m, MonadTCEnv m, ReadTCState m) => m (QName -> QName)+topLevelModuleDropper =+  caseMaybeM currentTopLevelModule+    (return id)+    (return . dropTopLevelModule' . size)++prettyDisamb :: MonadPretty m => (QName -> Maybe (Range' SrcFile)) -> QName -> m Doc+prettyDisamb f x = do+  let d  = pretty =<< dropTopLevelModule x+  caseMaybe (f x) d $ \ r -> d <+> ("(introduced at " <> prettyTCM r <> ")")++-- | Print the last range in 'qnameModule'.+prettyDisambProj :: MonadPretty m => QName -> m Doc+prettyDisambProj = prettyDisamb $ lastMaybe . filter (noRange /=) . map nameBindingSite . mnameToList . qnameModule++--   Print the range in 'qnameName'. This fixes the bad error message in #4130.+prettyDisambCons :: MonadPretty m => QName -> m Doc+prettyDisambCons = prettyDisamb $ Just . nameBindingSite . qnameName++instance PrettyTCM TypeError where+  prettyTCM :: forall m. MonadPretty m => TypeError -> m Doc+  prettyTCM err = case err of+    InternalError s -> panic s++    NotImplemented s -> fwords $ "Not implemented: " ++ s++    NotSupported s -> fwords $ "Not supported: " ++ s++    CompilationError s -> sep [fwords "Compilation error:", text s]++    GenericError s -> fwords s++    GenericDocError d -> return d++    ExecError err -> prettyTCM err++    NicifierError err -> pretty err++    OptionError s -> fwords s++    SyntaxError s -> fwords $ "Syntax error: "  ++ s++    DoNotationError err -> fwords err++    IdiomBracketError err -> fwords err++    InvalidDottedExpression -> fwords "Invalid dotted expression"++    NoKnownRecordWithSuchFields fields -> fsep $+      case fields of+        []  -> pwords "There are no records in scope"+        [f] -> pwords "There is no known record with the field" ++ [ pretty f ]+        _   -> pwords "There is no known record with the fields" ++ map pretty fields++    ShouldEndInApplicationOfTheDatatype t -> fsep $+      pwords "The target of a constructor must be the datatype applied to its parameters,"+      ++ [prettyTCM t] ++ pwords "isn't"++    ShouldBeRecordType t -> fsep $+      pwords "Expected non-abstract record type, found " ++ [prettyTCM t]++    ShouldBeRecordPattern p -> fsep $+      pwords "Expected record pattern" -- ", found " ++ [prettyTCM p]++    WrongHidingInLHS -> fwords "Unexpected implicit argument"++    WrongHidingInLambda t ->+      fwords "Found an implicit lambda where an explicit lambda was expected"++    WrongHidingInProjection d ->+      sep [ "Wrong hiding used for projection " , prettyTCM d ]++    IllegalHidingInPostfixProjection arg -> fsep $+      pwords "Illegal hiding in postfix projection " +++      [pretty arg]++    WrongAnnotationInLambda ->+      fwords "Wrong annotation in lambda"++    WrongIrrelevanceInLambda ->+      fwords "Found a non-strict lambda where a irrelevant lambda was expected"++    WrongQuantityInLambda ->+      fwords "Incorrect quantity annotation in lambda"++    WrongCohesionInLambda ->+      fwords "Incorrect cohesion annotation in lambda"++    WrongPolarityInLambda ->+      fwords "Incorrect polarity annotation in lambda"++    WrongNamedArgument a xs0 -> fsep $+      pwords "Function does not accept argument "+      ++ [prettyTCM a] -- ++ pwords " (wrong argument name)"+      ++ [parens $ fsep $ text "possible arguments:" : map pretty xs | not (null xs)]+      where+      xs = List1.filter (not . isNoName) xs0++    WrongHidingInApplication t ->+      fwords "Found an implicit application where an explicit application was expected"++    HidingMismatch h h' -> fwords $+      "Expected " ++ verbalize (Indefinite h') ++ " argument, but found " +++      verbalize (Indefinite h) ++ " argument"++    RelevanceMismatch r r' -> fwords $+      "Expected " ++ verbalize (Indefinite r') ++ " argument, but found " +++      verbalize (Indefinite r) ++ " argument"++    QuantityMismatch q q' -> fwords $+      "Expected " ++ verbalize (Indefinite q') ++ " argument, but found " +++      verbalize (Indefinite q) ++ " argument"++    ForcedConstructorNotInstantiated p -> fsep $+      pwords "Failed to infer that constructor pattern "+      ++ [prettyA p] ++ pwords " is forced"++    IllformedProjectionPatternAbstract p -> fsep $+      pwords "Ill-formed projection pattern " ++ [prettyA p]++    IllformedProjectionPatternConcrete p -> fsep $+      pwords "Ill-formed projection pattern" ++ [pretty p]++    LiteralTooBig -> fsep $ concat+      [ pwords "Matching on natural number literals is done by expanding"+      , pwords "the literal to the corresponding constructor pattern,"+      , pwords "so you probably don't want to do it this way"+      ]++    NegativeLiteralInPattern -> fsep $+      pwords "Negative literals are not supported in patterns"++    CannotEliminateWithPattern b p a -> do+      let isProj = isJust (isProjP p)+      fsep $+        pwords "Cannot eliminate type" ++ prettyTCM a : if+         | isProj -> pwords "with projection pattern" ++ [prettyA p]+         | A.ProjP _ _ f <- namedArg p -> pwords "with pattern" ++ [prettyA p] +++             pwords "(suggestion: write" ++ [".(" <> prettyA (A.Proj ProjPrefix f) <> ")"] ++ pwords "for a dot pattern," +++             pwords "or remove the braces for a postfix projection)"+         | otherwise ->+             "with" : text (kindOfPattern (namedArg p)) : "pattern" : prettyA p :+             pwords "(did you supply too many arguments?)"+      where+      kindOfPattern = \case+        A.VarP{}    -> "variable"+        A.ConP{}    -> "constructor"+        A.ProjP{}   -> __IMPOSSIBLE__+        A.DefP{}    -> __IMPOSSIBLE__+        A.WildP{}   -> "wildcard"+        A.DotP{}    -> "dot"+        A.AbsurdP{} -> "absurd"+        A.LitP{}    -> "literal"+        A.RecP{}    -> "record"+        A.WithP{}   -> "with"+        A.EqualP{}  -> "equality"+        A.AsP _ _ p -> kindOfPattern p+        A.PatternSynP{} -> __IMPOSSIBLE__++    CannotEliminateWithProjection ty isAmbiguous projection -> sep+        [ "Cannot eliminate type "+        , prettyTCM (unArg ty)+        , " with projection "+        , if isAmbiguous then+            text $ prettyShow projection+          else+            prettyTCM projection+        ]++    WrongNumberOfConstructorArguments c expect given -> fsep $+      pwords "The constructor" ++ [prettyTCM c] +++      pwords "expects" ++ [prettyTCM expect] +++      pwords "arguments (including hidden ones), but has been given"+      ++ [prettyTCM given] ++ pwords "(including hidden ones)"++    CantResolveOverloadedConstructorsTargetingSameDatatype d cs -> fsep $+      pwords "Can't resolve overloaded constructors targeting the same datatype"+      ++ [parens (prettyTCM (qnameToConcrete d)) <> colon]+      ++ map pretty (List1.toList cs)++    ConstructorDoesNotTargetGivenType c t -> fsep $+      pwords "The constructor" ++ [prettyTCM c] +++      pwords "does not construct an element of" ++ [prettyTCM t]++    ConstructorPatternInWrongDatatype c d -> fsep $+      [prettyTCM c] ++ pwords "is not a constructor of the datatype"+      ++ [prettyTCM d]++    ShadowedModule x ms@(m0 :| _) -> do+      -- Clash! Concrete module name x already points to the abstract names ms.+      (r, m) <- do+        -- Andreas, 2017-07-28, issue #719.+        -- First, we try to find whether one of the abstract names @ms@ points back to @x@+        scope <- getScope+        -- Get all pairs (y,m) such that y points to some m ∈ ms.+        let xms0 = concat $ ms <&> \ m -> map (,m) $ inverseScopeLookupModule m scope+        reportSLn "scope.clash.error" 30 $ "candidates = " ++ prettyShow xms0++        -- Try to find x (which will have a different Range, if it has one (#2649)).+        let xms = filter ((\ y -> not (null $ getRange y) && y == C.QName x) . fst) xms0+        reportSLn "scope.class.error" 30 $ "filtered candidates = " ++ prettyShow xms++        -- If we found a copy of x with non-empty range, great!+        ifJust (listToMaybe xms) (\ (x', m) -> return (getRange x', m)) $ {-else-} do++        -- If that failed, we pick the first m from ms which has a nameBindingSite.+        let rms = concat $ ms <&> \ m -> map (,m) $+              filter (noRange /=) $ map nameBindingSite $ reverse $ mnameToList m+              -- Andreas, 2017-07-25, issue #2649+              -- Take the first nameBindingSite we can get hold of.+        reportSLn "scope.class.error" 30 $ "rangeful clashing modules = " ++ prettyShow rms++        -- If even this fails, we pick the first m and give no range.+        return $ fromMaybe (noRange, m0) $ listToMaybe rms++      fsep $+        pwords "Duplicate definition of module" ++ [prettyTCM x <> "."] +++        pwords "Previous definition of" ++ [help m] ++ pwords "module" ++ [prettyTCM x] +++        pwords "at" ++ [prettyTCM r]+      where+        help :: MonadPretty m => ModuleName -> m Doc+        help m = caseMaybeM (isDatatypeModule m) empty $ \case+          IsDataModule   -> "(datatype)"+          IsRecordModule -> "(record)"++    ModuleArityMismatch m EmptyTel args -> fsep $+      pwords "The module" ++ [prettyTCM m] +++      pwords "is not parameterized, but is being applied to arguments"++    ModuleArityMismatch m tel@(ExtendTel _ _) args -> fsep $+      pwords "The arguments to " ++ [prettyTCM m] ++ pwords "do not fit the telescope" +++      [prettyTCM tel]++    ShouldBeEmpty t [] -> fsep $+       prettyTCM t : pwords "should be empty, but that's not obvious to me"++    ShouldBeEmpty t ps -> fsep (+      prettyTCM t :+      pwords "should be empty, but the following constructor patterns are valid:"+      ) $$ nest 2 (vcat $ map (prettyPat 0) ps)++    ShouldBeASort t -> fsep $+      prettyTCM t : pwords "should be a sort, but it isn't"++    ShouldBePi t -> fsep $+      prettyTCM t : pwords "should be a function type, but it isn't"++    ShouldBePath t -> fsep $+      prettyTCM t : pwords "should be a Path or PathP type, but it isn't"++    CannotApply e t -> sep+      [ "Expression used as function but does not have function type:"+      , nest 2 $ "expr:" <+> prettyA e+      , nest 2 $ "type:" <+> prettyTCM t+      ]++    InvalidTypeSort s -> fsep $ prettyTCM s : pwords "is not a valid sort"++    CannotSolveSizeConstraints ccs reason -> do+      -- Print the HypSizeConstraints (snd)+      vcat $ concat+        [ [ text $ "Cannot solve size constraints" ]+        , List1.toList $ fmap (prettyTCM . snd) ccs+        , [ "Reason:" <+> pure reason | not (null reason) ]+        ]++    ContradictorySizeConstraint cc@(_,c0) -> fsep $+      pwords "Contradictory size constraint" ++ [prettyTCM c0]++    EmptyTypeOfSizes t -> fsep $ pwords "Possibly empty type of sizes:" ++ [prettyTCM t]++    FunctionTypeInSizeUniv v -> fsep $+      pwords "Functions may not return sizes, thus, function type " +++      [ prettyTCM v ] ++ pwords " is illegal"++    PostulatedSizeInModule -> fwords "We don't like postulated sizes in parametrized modules."++    SplitOnCoinductive -> fsep $ pwords "Pattern matching on coinductive types is not allowed"++    SplitOnIrrelevant t -> fsep $+      pwords "Cannot pattern match against" ++ [text $ verbalize $ getRelevance t] +++      pwords "argument of type" ++ [prettyTCM $ unDom t]++    SplitOnUnusableCohesion t -> fsep $+      pwords "Cannot pattern match against" ++ [text $ verbalize $ getCohesion t] +++      pwords "argument of type" ++ [prettyTCM $ unDom t]++    SplitOnUnusablePolarity t -> fsep $+      pwords "Cannot pattern match against" ++ [text $ verbalize $ getModalPolarity t] +++      pwords "argument of type" ++ [prettyTCM $ unDom t]++    -- UNUSED:+    -- SplitOnErased t -> fsep $+    --   pwords "Cannot pattern match against" ++ [text $ verbalize $ getQuantity t] +++    --   pwords "argument of type" ++ [prettyTCM $ unDom t]++    SplitOnNonVariable v t -> fsep $+      pwords "Cannot pattern match because the (refined) argument " +++      [ prettyTCM v ] ++ pwords " is not a variable."++    SplitOnNonEtaRecord q -> fsep $ concat+      [ pwords "Pattern matching on no-eta record type"+      , [ prettyTCM q, parens ("defined at" <+> prettyTCM r) ]+      , pwords "is not allowed"+      , [ parens "to activate, add declaration `pattern` to record definition" ]+      ]+      where r = nameBindingSite $ qnameName q++    SplitOnAbstract d ->+      "Cannot split on abstract data type" <+> prettyTCM d++    SplitOnUnchecked d ->+      "Cannot split on data type" <+> prettyTCM d <+> "whose definition has not yet been checked"++    SplitOnPartial dom -> vcat+      [ "Splitting on partial elements is only allowed at the type Partial, but the domain here is", nest 2 $ prettyTCM $ unDom dom ]++    SplitInProp dr -> fsep+      [ text "Cannot split on"+      , text $ kindOfData dr+      , text "in Prop unless target is in Prop"+      ]+      where+        kindOfData :: DataOrRecordE -> String+        kindOfData IsData                                                          = "datatype"+        kindOfData (IsRecord InductionAndEta {recordInduction=Nothing})            = "record type"+        kindOfData (IsRecord InductionAndEta {recordInduction=(Just Inductive)})   =  "inductive record type"+        kindOfData (IsRecord InductionAndEta {recordInduction=(Just CoInductive)}) = "coinductive record type"+++    DefinitionIsIrrelevant x -> fsep $+      "Identifier" : prettyTCM x : pwords "is declared irrelevant, so it cannot be used here"++    DefinitionIsErased x -> fsep $+      "Identifier" : prettyTCM x : pwords "is declared erased, so it cannot be used here"++    ProjectionIsIrrelevant x -> vcat+      [ fsep [ "Projection " , prettyTCM x, " is irrelevant." ]+      , "Turn on option --irrelevant-projections to use it (unsafe)"+      ]++    VariableIsIrrelevant x -> fsep $+      "Variable" : prettyTCM (nameConcrete x) : pwords "is declared irrelevant, so it cannot be used here"++    VariableIsErased x -> fsep $+      "Variable" : prettyTCM (nameConcrete x) : pwords "is declared erased, so it cannot be used here"++    VariableIsOfUnusableCohesion x c -> fsep+      ["Variable", prettyTCM (nameConcrete x), "is declared", text (show c), "so it cannot be used here"]++    LambdaIsErased -> fwords $ "Erased pattern-matching lambdas may only be used in erased contexts"++    RecordIsErased -> fwords $+      "A record expression corresponding to an erased record " +++      "constructor must only be used in erased settings"++    InvalidModalTelescopeUse t used avail def -> fsep+      [ "Telescope variable" <+> prettyTCM t+      , "is indirectly being used in the" <+> text (verbalize (getModality used)) <+> "modality"+      , "but only available in the" <+> text (verbalize (getModality avail)) <+> "modality"+      , "when inserting into the telescope of definition"+      , pretty (defName def) <+> ":" <+> prettyTCM (defType def)+      ]++    VariableIsOfUnusablePolarity x c -> fsep $+      ["Variable", prettyTCM (nameConcrete x), "is bound with", text (verbalize p)] ++  pwords "polarity, so it cannot be used here at" +++      [text (verbalize (Indefinite l)), "position"]+      where+        PolarityModality _ p l = c++    UnequalTerms cmp s t a -> case (s,t) of+      (Sort s1      , Sort s2      )+        | CmpEq  <- cmp              -> prettyTCM $ UnequalSorts s1 s2+        | CmpLeq <- cmp              -> prettyTCM $ NotLeqSort s1 s2+      (Sort MetaS{} , t            ) -> prettyTCM $ ShouldBeASort $ El __IMPOSSIBLE__ t+      (s            , Sort MetaS{} ) -> prettyTCM $ ShouldBeASort $ El __IMPOSSIBLE__ s+      (Sort DefS{}  , t            ) -> prettyTCM $ ShouldBeASort $ El __IMPOSSIBLE__ t+      (s            , Sort DefS{}  ) -> prettyTCM $ ShouldBeASort $ El __IMPOSSIBLE__ s+      (_            , _            ) -> do+        (d1, d2, d) <- prettyInEqual s t+        fsep $ concat $+          [ [return d1, notCmp cmp, return d2]+          , case a of+                AsTermsOf t -> pwords "of type" ++ [prettyTCM t]+                AsSizes     -> pwords "of type" ++ [prettyTCM =<< sizeType]+                AsTypes     -> []+          , [return d]+          ]++    UnequalLevel cmp s t -> fsep $+      [prettyTCM s, notCmp cmp, prettyTCM t]++    UnequalRelevance cmp a b -> fsep $+      [prettyTCM a, notCmp cmp, prettyTCM b] +++      pwords "because one is a relevant function type and the other is an irrelevant function type"++    UnequalQuantity cmp a b -> fsep $+      [prettyTCM a, notCmp cmp, prettyTCM b] +++      pwords "because one is a non-erased function type and the other is an erased function type"++    UnequalCohesion cmp a b -> fsep $+      [prettyTCM a, notCmp cmp, prettyTCM b] +++      pwords "because one is a non-flat function type and the other is a flat function type"+      -- FUTURE Cohesion: update message if/when introducing sharp.++    UnequalPolarity cmp a b -> fsep $+      [prettyTCM a, notCmp cmp, prettyTCM b] +++      pwords "because they do not have the same polarity annotations"++    UnequalFiniteness cmp a b -> fsep $+      [prettyTCM a, notCmp cmp, prettyTCM b] +++      pwords "because one is a type of partial elements and the other is a function type"+      -- FUTURE Cohesion: update message if/when introducing sharp.++    UnequalHiding a b -> fsep $+      [prettyTCM a, "!=", prettyTCM b] +++      pwords "because one is an implicit function type and the other is an explicit function type"++    UnequalSorts s1 s2 -> fsep $+      [prettyTCM s1, "!=", prettyTCM s2]++    NotLeqSort s1 s2 -> fsep $+      [prettyTCM s1] ++ pwords "is not less or equal than" ++ [prettyTCM s2]++    TooManyFields r missing xs -> prettyTooManyFields r missing xs++    DuplicateConstructors xs -> fsep $ concat+      [ [ "Duplicate" ]+      , [ pluralS xs "constructor" ]+      , punctuate comma $ fmap pretty xs+      , pwords "in datatype"+      ]++    DuplicateFields xs -> prettyDuplicateFields xs++    DuplicateOverlapPragma q old new -> fsep $+      pwords "The instance" ++ [prettyTCM q] +++      pwords "was already marked" ++ [pretty old <> "."] +++      pwords "This" ++ [pretty new] +++      pwords "pragma can not be applied to it."++    WithOnFreeVariable e v -> do+      de <- prettyA e+      dv <- prettyTCM v+      if show de == show dv+        then fsep $+          pwords "Cannot `with` on variable" ++ [return dv] +++          pwords " bound in a module telescope (or patterns of a parent clause)"+        else fsep $+          pwords "Cannot `with` on expression" ++ [return de] ++ pwords "which reduces to variable" ++ [return dv] +++          pwords " bound in a module telescope (or patterns of a parent clause)"++    UnexpectedWithPatterns ps -> fsep $+      pwords "Unexpected with patterns" ++ punctuate " |" (fmap prettyA ps)++    TooFewPatternsInWithClause -> fsep $ pwords "Too few arguments given in with-clause"+    TooManyPatternsInWithClause -> fsep $ pwords "Too many arguments given in with-clause"++    WithClausePatternMismatch p q -> fsep $+      pwords "With clause pattern " ++ [prettyA p] +++      pwords " is not an instance of its parent pattern " ++ [P.fsep <$> prettyTCMPatterns [q]]++    PathAbstractionFailed b -> vcat+      [ ("Path abstraction failed for type" <+> prettyTCM (unAbs b)) <> "."+      , "The type may be non-fibrant or its sort depends on an interval variable"+      ]++    MetaCannotDependOn m v i ->+      ifM (isSortMeta m `and2M` (not <$> hasUniversePolymorphism))+      ( {- then -}+        fsep [ text "Cannot instantiate the metavariable"+             , prettyTCM m+             , "to"+             , prettyTCM v+             , "since universe polymorphism is disabled"+             ]+      ) {- else -}+      ( fsep [ text "Cannot instantiate the metavariable"+             , prettyTCM m+             , "to solution"+             , prettyTCM v+             , "since it contains the variable"+             , prettyTCM (I.Var i [])+             , "which is not in scope of the metavariable"+             ]+        )+    MetaIrrelevantSolution m v ->+      fsep [ text "Cannot instantiate the metavariable"+           , prettyTCM m+           , "to solution"+           , prettyTCM v+           , "since (part of) the solution was created in an irrelevant context"+           ]++    MetaErasedSolution m v  ->+      fsep [ text "Cannot instantiate the metavariable"+           , prettyTCM m+           , "to solution"+           , prettyTCM v+           , "since (part of) the solution was created in an erased context"+           ]++    WrongSharpArity c -> fsep $+      [prettyA c] ++ pwords "must be applied to exactly one argument"++    BuiltinMustBeConstructor s e -> fsep $+      [prettyA e] ++ pwords "must be a constructor in the binding to builtin" ++ [pretty s]++    BuiltinMustBeData s n -> fsep $+      pwords "The builtin" ++ [pretty s] ++ pwords "must be a datatype with" +++      if n == 1 then pwords "a single constructor or an (inductive) record type"+      else [pretty n] ++ pwords "constructors"++    BuiltinMustBeDef s -> fsep $+      pwords "The argument to BUILTIN" ++ [pretty s] ++ pwords "must be a defined name"++    BuiltinMustBeFunction s -> fsep $+      pwords "Builtin" ++ [pretty s] ++ pwords "must be bound to a function"++    BuiltinMustBePostulate s -> fsep $+      pwords "The argument to BUILTIN" ++ [pretty s] ++ pwords "must be a postulated name"++    NoSuchBuiltinName s -> fsep $+      pwords "There is no built-in thing called" ++ [pretty s]++    InvalidBuiltin s -> fwords s++    DuplicateBuiltinBinding b x y -> fsep $+      pwords "Duplicate binding for built-in thing" ++ [pretty b <> comma] +++      pwords "previous binding to" ++ [prettyTCM x]++    NoBindingForBuiltin x+      | x `elem` [builtinZero, builtinSuc] -> fsep $+        pwords "No binding for builtin " ++ [pretty x <> comma] +++        pwords ("use {-# BUILTIN " ++ getBuiltinId builtinNat ++ " name #-} to bind builtin natural " +++                "numbers to the type 'name'")+      | otherwise -> fsep $+        pwords "No binding for builtin thing" ++ [pretty x <> comma] +++        pwords ("use {-# BUILTIN " ++ getBuiltinId x ++ " name #-} to bind it to 'name'")++    NoBindingForPrimitive x -> fsep $+      pwords "Missing binding for" +++      [pretty x] +++      pwords "primitive."++    DuplicatePrimitiveBinding b x y -> fsep $+      pwords "Duplicate binding for primitive thing" ++ [pretty b <> comma] +++      pwords "previous binding to" ++ [prettyTCM x]++    NoSuchPrimitiveFunction x -> fsep $+      pwords "There is no primitive function called" ++ [text x]++    WrongArgInfoForPrimitive x got expect ->+      vcat [ fsep $ pwords "Wrong definition properties for primitive" ++ [pretty x]+           , nest 2 $ text $ "Got:      " ++ intercalate ", " gs+           , nest 2 $ text $ "Expected: " ++ intercalate ", " es ]+      where+        (gs, es) = unzip [ p | p@(g, e) <- zip (things got) (things expect), g /= e ]+        things i = [verbalize $ getHiding i,+                    "at modality " ++ verbalize (getModality i)]++    BuiltinInParameterisedModule x -> fwords $+      "The BUILTIN pragma cannot appear inside a bound context " +++      "(for instance, in a parameterised module or as a local declaration)"++    IllegalDeclarationInDataDefinition ds -> vcat+      [ "Illegal declaration in data type definition"+      , nest 2 $ vcat $ fmap pretty ds+      ]++    IllegalLetInTelescope tb -> fsep $+      -- pwords "The binding" +++      pretty tb :+      pwords " is not allowed in a telescope here."++    IllegalPatternInTelescope bd -> fsep $+      pretty bd :+      pwords " is not allowed in a telescope here."++    AbsentRHSRequiresAbsurdPattern -> fwords $+      "The right-hand side can only be omitted if there " +++      "is an absurd pattern, () or {}, in the left-hand side."++    LibraryError err -> return $ formatLibErrors err++    LibTooFarDown m lib -> vcat+      [ text "An .agda-lib file for" <+> pretty m+      , text "must not be located in the directory" <+> text (takeDirectory (lib ^. libFile))+      ]++    SolvedButOpenHoles -> fsep $+      pwords "Module cannot be imported since it has open interaction points" +++      pwords "(consider adding {-# OPTIONS --allow-unsolved-metas #-} to this module)"++    CyclicModuleDependency (List2 m0 m1 ms) ->+      fsep (pwords "cyclic module dependency:")+      $$ nest 2 (vcat $ (pretty m0 :) $ map (("importing" <+>) . pretty) (m1 : ms))++    FileNotFound x files ->+      fsep ( pwords "Failed to find source of module" ++ [pretty x] +++             pwords "in any of the following locations:"+           ) $$ nest 2 (vcat $ map (text . filePath) files)++    OverlappingProjects f m1 m2+      | canon d1 == canon d2 -> fsep $ concat+          [ pwords "Case mismatch when accessing file"+          , [ text $ filePath f ]+          , pwords "through module name"+          , [ pure d2 ]+          ]+      | otherwise -> fsep+           ( pwords "The file" ++ [text (filePath f)] +++             pwords "can be accessed via several project roots. Both" +++             [ pure d1 ] ++ pwords "and" ++ [ pure d2 ] +++             pwords "point to this file."+           )+      where+      canon = CaseInsens.mk . P.render+      d1 = P.pretty m1+      d2 = P.pretty m2++    AmbiguousTopLevelModuleName x files ->+      fsep ( pwords "Ambiguous module name. The module name" +++             [pretty x] +++             pwords "could refer to any of the following files:"+           ) $$ nest 2 (vcat $ fmap (text . filePath) files)++    AmbiguousProjection d disambs -> vcat+      [ "Ambiguous projection " <> prettyTCM d <> "."+      , "It could refer to any of"+      , nest 2 $ vcat $ fmap prettyDisambProj $ List2.cons d disambs+      ]++    AmbiguousOverloadedProjection ds reason -> do+      let nameRaw = pretty $ A.nameConcrete $ A.qnameName $ List1.head ds+      vcat+        [ fsep+          [ text "Cannot resolve overloaded projection"+          , nameRaw+          , text "because"+          , pure reason+          ]+        , nest 2 $ text "candidates in scope:"+        , vcat $ for ds $ \ d -> do+            t <- typeOfConst d+            text "-" <+> nest 2 (nameRaw <+> text ":" <+> prettyTCM t)+        ]++    AmbiguousConstructor c disambs -> vcat+      [ "Ambiguous constructor " <> pretty (qnameName c) <> "."+      , "It could refer to any of"+      , nest 2 $ vcat $ fmap prettyDisambCons disambs+      ]++    InvalidFileName file reason -> fsep $+      pwords "The file name" ++ [pretty file] ++ pwords "is invalid because" +++      case reason of+        DoesNotCorrespondToValidModuleName ->+          pwords "it does not correspond to a valid module name."+        RootNameModuleNotAQualifiedModuleName defaultName ->+          pretty defaultName : pwords "is not an unqualified module name."++    ModuleDefinedInOtherFile mod file file' -> fsep $ concat+      [ pwords "You tried to load"+      , [ text (filePath file) ]+      , if moduleNameInferred mod+          then pwords "which seems to define the module"+          else pwords "which defines the module"+      , [ pretty mod <> "." ]+      , pwords "However, according to the include path this module should be defined in"+      , [ text (filePath file') ]+        -- Andreas, 2025-06-21, issue #7953:+        -- We have no test that triggers this hint, not sure it can be triggered at all.+      , if moduleNameInferred mod then pwords "(Hint: no module header was found in this file; adding one might fix this error.)"+        else empty+      ]++    ModuleNameUnexpected given expected+      | canon dGiven == canon dExpected -> fsep $ concat+          [ pwords "Case mismatch between the actual module name"+          , [ pure dGiven ]+          , pwords "and the expected module name"+          , [ pure dExpected ]+          ]+      | otherwise -> fsep $ concat+          [ pwords "The name of the top level module does not match the file name. The module"+          , [ pure dGiven ]+          , pwords "should probably be named"+          , [ pure dExpected ]+          ]+      where+      canon = CaseInsens.mk . P.render+      dGiven    = P.pretty given+      dExpected = P.pretty expected++    ModuleNameHashCollision raw raw' -> fwords $ case raw' of+      Nothing ->+        "The module name " ++ prettyShow raw ++ " has a reserved " +++        "hash (you may want to consider renaming the module with this name)"+      Just raw' ->+        "Module name hash collision for " ++ prettyShow raw +++        " and " ++ prettyShow raw' ++ " (you may want to consider " +++        "renaming one of these modules)"++    ModuleNameDoesntMatchFileName given files -> vcat+      [ fsep $ concat+        [ [ "The" ]+        , [ "inferred" | moduleNameInferred given ]+        , [ "name" ]+        , [ "`" <> pretty given <> "`"]+        , pwords "of the top level module"+        , pwords "does not match the file name."+        , pwords "A such named module should be defined in one of the following files:"+        ]+      , nest 2 (vcat $ map (text . filePath) files)+      , if moduleNameInferred given then fsep $+          pwords "(Hint: no module header was found in this file; adding one might fix this error.)"+        else empty+      ]++    AbstractConstructorNotInScope q -> fsep $+      [ "Constructor"+      , prettyTCM q+      ] ++ pwords "is abstract, thus, not in scope here"++    BothWithAndRHS -> fsep $ pwords "Unexpected right hand side"++    CopatternHeadNotProjection x -> fsep $ concat+      [ pwords "Head of copattern needs to be a projection, but"+      , [ prettyTCM x ]+      , pwords "isn't one"+      ]++    NotAllowedInDotPatterns what -> fsep $ verb what ++ pwords "are not allowed in dot patterns"+      where+      verb = \case+        LetExpressions -> pwords "Let expressions"+        PatternLambdas -> pwords "Pattern lambdas"++    NotInScope x ->+      -- using the warning version to avoid code duplication+      prettyWarning $ NotInScopeW x++    NoSuchModule x -> fsep $ pwords "No module" ++ [pretty x] ++ pwords "in scope"++    AmbiguousName x reason -> vcat+      [ fsep $ pwords "Ambiguous name" ++ [pretty x <> "."] +++               pwords "It could refer to any one of"+      , nest 2 $ vcat $ fmap nameWithBinding $ ambiguousNamesInReason reason+      , explainWhyInScope $ whyInScopeDataFromAmbiguousNameReason x reason+      ]++    AmbiguousModule x ys -> vcat+      [ fsep $ pwords "Ambiguous module name" ++ [pretty x <> "."] +++               pwords "It could refer to any one of"+      , nest 2 $ vcat $ fmap help ys+      , fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)"+      ]+      where+        help :: MonadPretty m => ModuleName -> m Doc+        help m = do+          anno <- caseMaybeM (isDatatypeModule m) (return empty) $ \case+            IsDataModule   -> return $ "(datatype module)"+            IsRecordModule -> return $ "(record module)"+          sep [prettyTCM m, anno ]++    AmbiguousField field modules -> vcat $+      hsep [ "Ambiguity: the field", prettyTCM field, "appears in the following modules:" ]+      : map prettyTCM (List2.toList modules)++    ClashingDefinition x y suggestion -> fsep $+      pwords "Multiple definitions of" ++ [pretty x <> "."] +++      pwords "Previous definition at"+      ++ [prettyTCM $ nameBindingSite $ qnameName y] +++      caseMaybe suggestion [] (\d ->+        [  "Perhaps you meant to write "+        $$ nest 2 ("'" <> pretty (notSoNiceDeclarations d) <> "'")+        $$ ("at" <+> (pretty . envRange =<< askTC)) <> "?"+        $$ "In data definitions separate from data declaration, the ':' and type must be omitted."+        ])++    ClashingModule m1 m2 -> fsep $+      pwords "The modules" ++ [prettyTCM m1, "and", prettyTCM m2]+      ++ pwords "clash."++    DuplicateImports m xs -> fsep $+      pwords "Ambiguous imports from module" ++ [pretty m] ++ pwords "for" +++      punctuate comma (fmap pretty xs)++    DefinitionInDifferentModule _x -> fsep $+      pwords "Definition in different module than its type signature"++    FieldOutsideRecord -> fsep $+      pwords "Field appearing outside record declaration."++    PrivateRecordField -> fwords "Record fields cannot be private"++    InvalidPattern p -> fsep $+      pretty p : pwords "is not a valid pattern"++    InvalidPun kind x -> fsep $ concat+      [ pwords "A pun must not use the"+      , [ pure $ P.pretty kind ]+      , [ prettyTCM x ]+      ]++    RepeatedVariablesInPattern xs -> fsep $+      pwords "Repeated variables in pattern:" ++ map pretty (List1.toList xs)++    RepeatedNamesInImportDirective yss -> fsep+      [ fsep $ concat+         [ [ "Repeated" , pluralS yss "name" ]+         , pwords "in import directive:"+         ]+      , fsep $ punctuate comma $ fmap (prettyTCM . List2.head) yss+      ]++    DeclarationsAfterTopLevelModule -> fwords $ "No declarations allowed after top-level module."++    IllegalDeclarationBeforeTopLevelModule -> fwords $ "Illegal declaration(s) before top-level module"++    MissingTypeSignature info -> fwords "Missing type signature for" <+> prettyTCM info++    NotAnExpression e -> fsep $+      pretty e : pwords "is not a valid expression."++    NotAValidLetBinding Nothing -> fwords $ "Not a valid let binding"+    NotAValidLetBinding (Just err) -> fwords $ verbalizeNotAValidLetBinding err++    NotAValidLetExpression err -> fwords $ verbalizeNotAValidLetExpression err++    NotValidBeforeField nd -> fwords $+      "This declaration is illegal in a record before the last field"++    NoParseForApplication es -> fsep (+      pwords "Could not parse the application" ++ [pretty $ C.RawApp noRange es])++    AmbiguousParseForApplication es es' -> fsep (+      pwords "Don't know how to parse" ++ [pretty_es <> "."] +++      pwords "Could mean any one of:"+      ) $$ nest 2 (vcat $ fmap pretty' es')+      where+        pretty_es :: MonadPretty m => m Doc+        pretty_es = pretty $ C.RawApp noRange es++        pretty' :: MonadPretty m => C.Expr -> m Doc+        pretty' e = do+          p1 <- pretty_es+          p2 <- pretty e+          if render p1 == render p2 then unambiguous e else return p2++        unambiguous :: MonadPretty m => C.Expr -> m Doc+        unambiguous e@(C.OpApp r op _ xs)+          | all (isOrdinary . namedArg) xs =+            pretty $+              foldl (C.App r) (C.Ident op) $+                (fmap . fmap . fmap) fromOrdinary xs+          | any (isPlaceholder . namedArg) xs =+              pretty e <+> "(section)"+        unambiguous e = pretty e++        isOrdinary :: MaybePlaceholder (C.OpApp e) -> Bool+        isOrdinary (NoPlaceholder _ (C.Ordinary _)) = True+        isOrdinary _                                = False++        fromOrdinary :: MaybePlaceholder (C.OpApp e) -> e+        fromOrdinary (NoPlaceholder _ (C.Ordinary e)) = e+        fromOrdinary _                                = __IMPOSSIBLE__++        isPlaceholder :: MaybePlaceholder a -> Bool+        isPlaceholder Placeholder{}   = True+        isPlaceholder NoPlaceholder{} = False++    AsPatternInPatternSynonym -> fsep $ pwords "@-patterns are not allowed in pattern synonyms"++    DotPatternInPatternSynonym -> fsep $ pwords+      "Dot or equality patterns are not allowed in pattern synonyms. Maybe use '_' instead."++    BadArgumentsToPatternSynonym x -> fsep $+      pwords "Bad arguments to pattern synonym " ++ [prettyTCM $ headAmbQ x]++    TooFewArgumentsToPatternSynonym x -> fsep $+      pwords "Too few arguments to pattern synonym " ++ [prettyTCM $ headAmbQ x]++    CannotResolveAmbiguousPatternSynonym defs -> vcat+      [ fsep $ pwords "Cannot resolve overloaded pattern synonym" ++ [prettyTCM x <> comma] +++               pwords "since candidates have different shapes:"+      , nest 2 $ vcat $ fmap prDef defs+      , fsep $ pwords "(hint: overloaded pattern synonyms must be equal up to variable and constructor names)"+      ]+      where+        (x, _) = List1.head defs+        prDef (x, (xs, p)) = prettyA (A.PatternSynDef x (map (fmap BindName) xs) p) <?> ("at" <+> pretty r)+          where r = nameBindingSite $ qnameName x++    IllegalInstanceVariableInPatternSynonym x -> fsep $ concat+      [ pwords "Variable is bound as instance in pattern synonym,"+      , pwords "but does not resolve as instance in pattern: "+      , [pretty x]+      ]++    PatternSynonymArgumentShadows kind x (y :| _ys) -> vcat+      [ fsep $ concat+        [ pwords "Pattern synonym variable"+        , [ pretty x ]+        , [ "shadows" ]+        , [ pretty kind ]+        , pwords "defined at:"+        ]+      , pretty $ nameBindingSite $ qnameName $ anameName y+      ]++    UnusedVariableInPatternSynonym x -> fsep $+      pwords "Unused variable in pattern synonym: " ++ [pretty x]++    UnboundVariablesInPatternSynonym xs -> fsep $+      pwords "Unbound variables in pattern synonym: " +++      [sep (fmap prettyA xs)]++    NoParseForLHS lhsOrPatSyn errs p -> vcat+      [ fsep $ pwords "Could not parse the" ++ prettyLhsOrPatSyn ++ [pretty p]+      , prettyErrs+      ]+      where+      prettyLhsOrPatSyn = pwords $ case lhsOrPatSyn of+        IsLHS    -> "left-hand side"+        IsPatSyn -> "pattern synonym right-hand side"+      prettyErrs = case errs of+        []     -> empty+        p0 : _ -> fsep $ pwords "Problematic expression:" ++ [pretty p0]++    AmbiguousParseForLHS lhsOrPatSyn p ps -> do+      d <- pretty p+      vcat $+        [ fsep $+            pwords "Don't know how to parse" ++ [pure d <> "."] +++            pwords "Could mean any one of:"+        ]+          +++        map (nest 2 . pretty' d) (List2.toList ps)+      where+        pretty' :: MonadPretty m => Doc -> C.Pattern -> m Doc+        pretty' d1 p' = do+          d2 <- pretty p'+          if render d1 == render d2 then pretty $ unambiguousP p' else return d2++        -- the entire pattern is shown, not just the ambiguous part,+        -- so we need to dig in order to find the OpAppP's.+        unambiguousP :: C.Pattern -> C.Pattern+        unambiguousP (C.AppP x y)         = C.AppP (unambiguousP x) $ (fmap.fmap) unambiguousP y+        unambiguousP (C.HiddenP r x)      = C.HiddenP r $ fmap unambiguousP x+        unambiguousP (C.InstanceP r x)    = C.InstanceP r $ fmap unambiguousP x+        unambiguousP (C.ParenP r x)       = C.ParenP r $ unambiguousP x+        unambiguousP (C.AsP r n x)        = C.AsP r n $ unambiguousP x+        unambiguousP (C.OpAppP r op _ xs) = foldl C.AppP (C.IdentP True op) xs+        unambiguousP e                    = e++    OperatorInformation sects err ->+      prettyTCM err+        $+$+      fsep (pwords "Operators used in the grammar:")+        $$+      nest 2+        (if null sects then "None" else+         vcat (map text $+               lines $+               Boxes.render $+               (\(col1, col2, col3) ->+                   Boxes.hsep 1 Boxes.top $+                   map (Boxes.vcat Boxes.left) [col1, col2, col3]) $+               unzip3 $+               map prettySect $+               sortBy (compare `on` prettyShow . notaName . sectNotation) $+               filter (not . closedWithoutHoles) sects))+      where+      trimLeft  = dropWhile isAHole+      trimRight = dropWhileEnd isAHole++      closedWithoutHoles sect =+        sectKind sect == NonfixNotation+          &&+        null [ () | HolePart{} <- trimLeft $ trimRight $+                                    notation (sectNotation sect) ]++      prettyName n = Boxes.text $+        P.render (P.pretty n) +++        " (" ++ P.render (P.pretty (nameBindingSite n)) ++ ")"++      prettySect sect =+        ( Boxes.text (P.render (P.pretty section))+            Boxes.//+          strut+        , Boxes.text+            ("(" +++             kind ++ " " +++             (if notaIsOperator nota+              then "operator"+              else "notation") +++             (if sectIsSection sect+              then " section"+              else "") +++             (case sectLevel sect of+                Nothing          -> ""+                Just Unrelated   -> ", unrelated"+                Just (Related l) -> ", level " ++ toStringWithoutDotZero l) +++             ")")+            Boxes.//+          strut+        , "["+            Boxes.<>+          Boxes.vcat Boxes.left+            (map (\n -> prettyName n Boxes.<> ",") names +++             [prettyName name Boxes.<> "]"])+        )+        where+        nota    = sectNotation sect+        section = qualifyFirstIdPart+                    (foldr (\x s -> C.nameToRawName x ++ "." ++ s)+                           ""+                           (List1.init (C.qnameParts (notaName nota))))+                    (spacesBetweenAdjacentIds $+                     trim (notation nota))++        qualifyFirstIdPart _ []              = []+        qualifyFirstIdPart q (IdPart x : ps) = IdPart (fmap (q ++) x) : ps+        qualifyFirstIdPart q (p : ps)        = p : qualifyFirstIdPart q ps++        spacesBetweenAdjacentIds (IdPart x : ps@(IdPart _ : _)) =+          IdPart x : IdPart (unranged " ") : spacesBetweenAdjacentIds ps+        spacesBetweenAdjacentIds (p : ps) =+          p : spacesBetweenAdjacentIds ps+        spacesBetweenAdjacentIds [] = []++        trim = case sectKind sect of+          InfixNotation   -> trimLeft . trimRight+          PrefixNotation  -> trimRight+          PostfixNotation -> trimLeft+          NonfixNotation  -> id+          NoNotation      -> __IMPOSSIBLE__++        (names, name) = List1.initLast $ Set1.toList $ notaNames nota++        strut = Boxes.emptyBox (length names) 0++        kind = case sectKind sect of+          PrefixNotation  -> "prefix"+          PostfixNotation -> "postfix"+          NonfixNotation  -> "closed"+          NoNotation      -> __IMPOSSIBLE__+          InfixNotation   ->+            case fixityAssoc $ notaFixity nota of+              NonAssoc   -> "infix"+              LeftAssoc  -> "infixl"+              RightAssoc -> "infixr"++{- UNUSED+    AmbiguousParseForPatternSynonym p ps -> fsep (+      pwords "Don't know how to parse" ++ [pretty p <> "."] +++      pwords "Could mean any one of:"+      ) $$ nest 2 (vcat $ map pretty ps)+-}++{- UNUSED+    IncompletePatternMatching v args -> fsep $+      pwords "Incomplete pattern matching for" ++ [prettyTCM v <> "."] +++      pwords "No match for" ++ map prettyTCM args+-}++    SplitError e -> prettyTCM e++    ImpossibleConstructor c neg -> fsep $+      pwords "The case for the constructor " ++ [prettyTCM c] +++      pwords " is impossible" ++ [prettyTCM neg] +++      pwords "Possible solution: remove the clause, or use an absurd pattern ()."++    DatatypeIndexPolarity -> fsep $+      pwords "Cannot annotate datatype indices with polarity other than @mixed"++    RecursiveRecordNeedsInductivity q -> fsep $ concat+      [ pwords "Recursive record"+      , [ prettyTCM q ]+      , pwords "needs to be declared as either inductive or coinductive"+      ]++    InstanceNoCandidate t errs -> vcat $+      [ fsep $ pwords "No instance of type" ++ [prettyTCM t] ++ pwords "was found in scope."+      , vcat $ map prCand errs ]+      where+        prCand (term, err) =+          text "-" <+>+            vcat [ prettyTCM term <?> text "was ruled out because"+                 , prettyTCM err ]++    UnquoteFailed e -> prettyTCM e++    DeBruijnIndexOutOfScope i EmptyTel [] -> fsep $+        pwords $ "de Bruijn index " ++ show i ++ " is not in scope in the empty context"+    DeBruijnIndexOutOfScope i cxt names ->+        sep [ text ("de Bruijn index " ++ show i ++ " is not in scope in the context")+            , inTopContext $ addContext ("_" :: String) $ prettyTCM cxt' ]+      where+        cxt' = cxt `abstract` raise (size cxt) (nameCxt names)+        nameCxt :: [Name] -> I.Telescope+        nameCxt [] = EmptyTel+        nameCxt (x : xs) = ExtendTel (defaultDom (El __DUMMY_SORT__ $ I.var 0)) $+          NoAbs (P.prettyShow x) $ nameCxt xs++    NeedOptionAllowExec -> fsep $+      pwords "Option --allow-exec needed to call external commands from macros"++    NeedOptionCopatterns -> fsep $+      pwords "Option --copatterns needed to enable destructor patterns"++    NeedOptionCubical cubical reason -> fsep $ concat+        [ [ "Option" ], opt, [ "required" ]+        , pwords reason+        ]+      where+      opt = case cubical of+        CFull   -> [ "--cubical" ]+        CErased -> pwords $ "--cubical or --erased-cubical"++    NeedOptionPatternMatching -> fsep $+      pwords "Pattern matching is disabled (use option --pattern-matching to enable it)"++    NeedOptionProp       -> fsep $+      pwords "Universe Prop is disabled (use options --prop and --no-prop to enable/disable Prop)"++    NeedOptionRewriting  -> fsep $+      pwords "Option --rewriting needed to add and use rewrite rules"++    NeedOptionSizedTypes reason -> fsep $+      pwords "Option --sized-types needed" ++ pwords reason++    NeedOptionTwoLevel   -> fsep $+      pwords "Universe SSet is disabled (use option --two-level to enable SSet)"++    NeedOptionUniversePolymorphism -> fsep $+      pwords "Universe polymorphism is disabled (use option --universe-polymorphism to allow level arguments to sorts)"++    GeneralizeNotSupportedHere x -> fsep $+      pwords $ "Generalizable variable " ++ prettyShow x ++ " is not supported here"++    GeneralizeCyclicDependency -> fsep $+      pwords "Cyclic dependency between generalized variables"++    GeneralizedVarInLetOpenedModule x -> fsep $+      pwords "Cannot use generalized variable from let-opened module: " +++      [prettyTCM x]++    MultipleFixityDecls xs ->+      sep [ fsep $ pwords "Multiple fixity or syntax declarations for"+          , vcat $ fmap f xs+          ]+      where+        f (x, fs) = (pretty x <> ": ") <+> fsep (fmap pretty fs)++    MultiplePolarityPragmas xs -> fsep $+      pwords "Multiple polarity pragmas for" ++ map pretty (List1.toList xs)++    CannotQuote what -> do+      fwords "`quote' expects an unambiguous defined name," $$ do+      fsep $ pwords "but here the argument is" +++        case what of+          CannotQuoteNothing ->+            pwords "missing"+          CannotQuoteHidden ->+            pwords "implicit"+          CannotQuoteAmbiguous (List2 x y zs) ->+            pwords "ambiguous:" ++ [ pretty $ AmbQ $ x :| y : zs ]+          CannotQuoteExpression e -> case e of+            -- These expression can be quoted:+            A.Def' _ NoSuffix -> __IMPOSSIBLE__+              -- Andreas, 2024-09-27, issue #7514:+              -- Why only quote suffix-free universes?+            A.Macro        {} -> __IMPOSSIBLE__+            A.Proj         {} -> __IMPOSSIBLE__+            A.Con          {} -> __IMPOSSIBLE__+            A.DontCare     {} -> __IMPOSSIBLE__+            A.ScopedExpr   {} -> __IMPOSSIBLE__+            -- These cannot:+            A.PatternSyn   {} -> other "a pattern synonym:"+            A.Var          {} -> other "a variable:"+            A.Lit          {} -> other "a literal:"+            A.QuestionMark {} -> pwords "a metavariable"+            A.Underscore   {} -> pwords "a metavariable"+            _ ->+              pwords "a compound expression"+            where+              other s = pwords s ++ [ prettyTCM e]+          CannotQuotePattern p -> case namedArg p of+            C.IdentP    {} -> __IMPOSSIBLE__+            C.HiddenP   {} -> __IMPOSSIBLE__+            C.InstanceP {} -> __IMPOSSIBLE__+            C.RawAppP   {} -> __IMPOSSIBLE__+            C.AbsurdP   {} -> pwords "an absurd pattern"+            C.LitP      {} -> pwords "a literal pattern"+            C.WildP     {} -> pwords "a wildcard pattern"+            _ ->+              pwords "a compound pattern"++    CannotQuoteTerm what -> do+      fwords "`quoteTerm' expects a single visible argument," $$ do+      fsep $ pwords "but has been given" +++        case what of+          CannotQuoteTermNothing ->+            pwords "none"+          CannotQuoteTermHidden ->+            pwords "an implicit one"+++    ConstructorNameOfNonRecord res -> case res of+      UnknownName -> __IMPOSSIBLE__ -- Turned into NotInScope when the name is resolved+      name ->+        let+          qn :: m Doc+          (qn, whatis) = case name of+            DefinedName _ nm _ -> (prettyTCM nm,) case anameKind nm of+              RecName                  -> __IMPOSSIBLE__+              ConName                  -> __IMPOSSIBLE__+              CoConName                -> __IMPOSSIBLE__+              FldName                  -> __IMPOSSIBLE__+              PatternSynName           -> __IMPOSSIBLE__++              GeneralizeName           -> "a generalized variable"+              DisallowedGeneralizeName -> "a generalized variable"+              MacroName                -> "a macro"+              QuotableName             -> "a quotable name"++              DataName                 -> "a data type"+              FunName                  -> "a function"+              AxiomName                -> "a postulate"+              PrimName                 -> "a primitive"+              OtherDefName             -> "a defined symbol"+            VarName a _ -> (prettyTCM a, "a local variable")+            FieldName (a :| _) -> (prettyTCM a, "a projection")+            ConstructorName _ (a :| _) -> (prettyTCM a, "a constructor")+            PatternSynResName (a :| _) -> (prettyTCM a, "a pattern synonym")+        in fsep $ pwords "Only record types have constructor names, but" ++ [qn, "is"] ++ pwords (whatis <> ".")++    NonFatalErrors ws -> vsep $ fmap prettyTCM $ Set1.toAscList ws++    ExplicitPolarityVsPragma p -> fsep $+      pwords "Polarity pragma used for " ++ [ prettyTCM p ] ++ pwords " but its type is already annotated with polarities."++    InstanceSearchDepthExhausted c a d -> fsep $+      pwords ("Instance search depth exhausted (max depth: " ++ show d ++ ") for candidate") +++      [hang (prettyTCM c <+> ":") 2 (prettyTCM a)]++    TriedToCopyConstrainedPrim q -> fsep $+      pwords "Cannot create a module containing a copy of" ++ [prettyTCM q]++    InvalidInstanceHeadType _ why -> fsep $ case why of+      ImproperInstHead -> pwords "Instance search can only be used to find elements in a named type"+      ImproperInstTele -> pwords "Instance search cannot be used to find elements in an explicit function type"++    SortOfSplitVarError _ doc -> return doc++    ReferencesFutureVariables term (disallowed :| _) lock leftmost+      | disallowed == leftmost+      -> fsep $ pwords "The lock variable"+             ++ pure (prettyTCM =<< nameOfBV disallowed)+             ++ pwords "can not appear simultaneously in the \"later\" term"+             ++ pure (prettyTCM term)+             ++ pwords "and in the lock term"+             ++ pure (prettyTCM lock <> ".")++    ReferencesFutureVariables term (disallowed :| rest) lock leftmost -> do+      explain <- (/=) <$> prettyTCM lock <*> (prettyTCM =<< nameOfBV leftmost)+      let+        name = prettyTCM =<< nameOfBV leftmost+        mod = case getLock lock of+          IsLock LockOLock -> "@lock"+          IsLock LockOTick -> "@tick"+          _ -> __IMPOSSIBLE__+      vcat $ concat+        [ pure . fsep $ concat+          [ pwords "The variable", pure (prettyTCM =<< nameOfBV disallowed), pwords "can not be mentioned here,"+          , pwords "since it was not introduced before the variable", pure (name <> ".")+          ]+        , [ fsep ( pwords "Variables introduced after"+                ++ pure name+                ++ pwords "can not be used, since that is the leftmost" ++ pure mod ++ pwords "variable in the locking term"+                ++ pure (prettyTCM lock <> "."))+          | explain+          ]+        , [ fsep ( pwords "The following"+                  ++ P.singPlural rest (pwords "variable is") (pwords "variables are")+                  ++ pwords "not allowed here, either:"+                  ++ punctuate comma (map (prettyTCM <=< nameOfBV) rest))+          | not (null rest)+          ]+        ]++    DoesNotMentionTicks term ty lock ->+      let+        mod = case getLock lock of+          IsLock LockOLock -> "@lock"+          IsLock LockOTick -> "@tick"+          _ -> __IMPOSSIBLE__+      in+        vcat+        [ fsep $+            pwords "The term"+            ++ [prettyTCM lock <> ","]+            ++ pwords "given as an argument to the guarded value"+        , nest 2 (prettyTCM term <+> ":" <+> prettyTCM ty)+        , fsep (pwords ("can not be used as a " ++ mod ++ " argument, since it does not mention any " ++ mod ++ " variables."))+        ]++    MismatchedProjectionsError left right -> fsep $+      pwords "The projections" ++ [prettyTCM left] +++      pwords "and" ++ [prettyTCM right] +++      pwords "do not match"++    AttributeKindNotEnabled kind opt s -> fsep $+      [text kind] +++      pwords "attributes have not been enabled (use" +++      [text opt] +++      pwords "to enable them):" +++      [text s]++    InvalidProjectionParameter arg -> fsep $+      pwords "Invalid projection parameter " +++      [prettyA arg]++    TacticAttributeNotAllowed -> fsep $+      pwords "The @tactic attribute is not allowed here"++    CannotRewriteByNonEquation t ->+      "Cannot rewrite by equation of type" <+> prettyTCM t++    MacroResultTypeMismatch expectedType ->+      sep [ "Result type of a macro must be", nest 2 $ prettyTCM expectedType ]++    NamedWhereModuleInRefinedContext args names -> do+      let pr x v = text (x ++ " =") <+> prettyTCM v+      vcat+        [ fsep (pwords $ "Named where-modules are not allowed when module parameters have been refined by pattern matching. " +++                          "See https://github.com/agda/agda/issues/2897.")+        , text $ "In this case the module parameter" +++                  (if not (null args) then "s have" else " has") +++                  " been refined to"+        , nest 2 $ vcat (zipWith pr names args) ]++    CannotGenerateHCompClause ty -> fsep $ concat+        [ pwords "Cannot generate hcomp clause at type"+        , [ prettyTCM ty ]+        ]++    CannotGenerateTransportClause f clos ->+      enterClosure clos \ failed_t -> addContext ("i" :: String, __DUMMY_DOM__) $ vcat+        [ "Could not generate a transport clause for" <+> prettyTCM f+        , "because a term of type" <+> prettyTCM (unAbs failed_t)+        , "lives in the sort" <+> prettyTCM (getSort (unAbs failed_t))+        , "and thus can not be transported"+        ]++    CubicalNotErasure q -> prettySigCubicalNotErasure q++    CubicalPrimitiveNotFullyApplied c ->+      prettyTCM c <+> "must be fully applied"++    ExpectedIntervalLiteral e -> do+      i0 <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinIZero+      i1 <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinIOne+      fsep $ concat+        [ pwords "Expected an interval literal"+        , [ parens $ fsep [ prettyTCM i0, "or", prettyTCM i1 ] ]+        , pwords "but found:"+        , [ prettyTCM e ]+        ]++    PatternInPathLambda ->+      fwords "Patterns are not allowed in Path-lambdas"++    PatternInSystem ->+      fwords "Pattern matching or path copatterns not allowed in systems"++    FaceConstraintDisjunction ->+      fwords "Cannot have disjunctions in a face constraint"++    FaceConstraintUnsatisfiable ->+      fwords "The face constraint is unsatisfiable"++    IllTypedPatternAfterWithAbstraction p -> vcat+      [ "Ill-typed pattern after with abstraction: " <+> prettyA p+      , "(perhaps you can replace it by `_`?)"+      ]++    ComatchingDisabledForRecord recName ->+      "Copattern matching is disabled for record" <+> prettyTCM recName++    IncorrectTypeForRewriteRelation v reason -> case reason of+      ShouldAcceptAtLeastTwoArguments -> sep+        [ prettyTCM v <+> " does not have the right type for a rewriting relation"+        , "because it should accept at least two arguments"+        ]+      FinalTwoArgumentsNotVisible -> sep+        [ prettyTCM v <+> " does not have the right type for a rewriting relation"+        , "because its two final arguments are not both visible."+        ]+      TypeDoesNotEndInSort core tel -> sep+        [ prettyTCM v <+> " does not have the right type for a rewriting relation"+        , "because its type does not end in a sort, but in "+          <+> do inTopContext $ addContext tel $ prettyTCM core+        ]++    UnexpectedParameter par -> do+      text "Unexpected parameter" <+> prettyA par++    NoParameterOfName x -> do+      text ("No parameter of name " ++ x)++    UnexpectedModalityAnnotationInParameter par -> do+      text "Unexpected modality/relevance annotation in" <+> prettyA par++    SortDoesNotAdmitDataDefinitions name s ->fsep+      [ "The universe"+      , prettyTCM s+      , "of"+      , prettyTCM name+      , "does not admit data or record declarations"+      ]++    SortCannotDependOnItsIndex name t -> fsep+      [ "The sort of" <+> prettyTCM name+      , "cannot depend on its indices in the type"+      , prettyTCM t+      ]++    ExpectedBindingForParameter a b -> sep+      [ "Expected binding for parameter"+      , text (absName b) <+> text ":" <+> prettyTCM (unDom a)+      ]++    UnexpectedTypeSignatureForParameter xs -> do+      fsep (pwords "Unexpected type signature for" ++ [ pluralS xs "parameter" ]) <+> sep (fmap prettyA xs)++    UnusableAtModality why mod t -> do+      compatible <- cubicalCompatibleOption+      cubical <- isJust <$> cubicalOption+      let+        context+          | cubical    = "in Cubical Agda,"+          | compatible = "to maintain compatibility with Cubical Agda,"+          | otherwise  = "when --without-K is enabled,"++        explanation what+          | cubical || compatible =+            [ ""+            , fsep ( "Note:":pwords context+                  ++ pwords what ++ pwords "must be usable at the modality"+                  ++ pwords "in which the function was defined, since it will be"+                  ++ pwords "used for computing transports"+                  )+            , ""+            ]+          | otherwise = []+      case why of+        IndexedClause ->+          vcat $+            ( fsep ( pwords "This clause has target type"+                  ++ [prettyTCM t]+                  ++ pwords "which is not usable at the required modality"+                  ++ [attributesForModality mod <> "."]+                   )+            : explanation "the target type")++        -- Arguments sometimes need to be transported too:+        IndexedClauseArg forced the_arg ->+          vcat $+            ( fsep (pwords "The argument" ++ [prettyTCM the_arg] ++ pwords "has type")+            : nest 2 (prettyTCM t)+            : fsep ( pwords "which is not usable at the required modality"+                  ++ [attributesForModality mod <> "."] )+            : explanation "this argument's type")++        -- Note: if a generated clause is modality-incorrect, that's a+        -- bug in the LHS modality check+        GeneratedClause ->+          __IMPOSSIBLE_VERBOSE__ . show =<<+                   prettyTCM t+              <+> "is not usable at the required modality"+              <+> attributesForModality mod+        _ -> prettyTCM t <+> "is not usable at the required modality"+         <+> attributesForModality mod++    CubicalCompilationNotSupported cubical -> fsep $ concat+      [ pwords $ "Compilation of code that uses"+      , [ text $ cubicalOptionString cubical ]+      , pwords $ "is not supported."+      ]++    QualifiedLocalModule -> fwords "Local modules cannot have qualified names"++    BackendDoesNotSupportOnlyScopeChecking backend -> fsep $ concat+      [ pwords "The backend"+      , [ prettyTCM backend ]+      , pwords "does not support --only-scope-checking."+      ]++    UnknownBackend backend backends -> pure $ P.vcat $ concat+      [ [ P.hcat [ "No backend called '", P.pretty backend, "' " ] ]+      , [ "Installed backend(s):" ]+      , map (("-" P.<+>) . P.pretty) $ Set.toAscList backends+      ]++    CustomBackendError backend err -> (pretty backend <> ":") <?> pure err++    GHCBackendError err -> prettyTCM err++    JSBackendError err -> prettyTCM err++    InteractionError err -> prettyTCM err++    where+    mpar n args+      | n > 0 && not (null args) = parens+      | otherwise                = id++    prettyArg :: MonadPretty m => Arg (I.Pattern' a) -> m Doc+    prettyArg (Arg info x) = case getHiding info of+      Hidden     -> braces $ prettyPat 0 x+      Instance{} -> dbraces $ prettyPat 0 x+      NotHidden  -> prettyPat 1 x++    prettyPat :: MonadPretty m => Integer -> (I.Pattern' a) -> m Doc+    prettyPat _ (I.VarP _ _) = "_"+    prettyPat _ (I.DotP _ _) = "._"+    prettyPat n (I.ConP c _ args) =+      mpar n args $+        prettyTCM c <+> fsep (map (prettyArg . fmap namedThing) args)+    prettyPat n (I.DefP o q args) =+      mpar n args $+        prettyTCM q <+> fsep (map (prettyArg . fmap namedThing) args)+    prettyPat _ (I.LitP _ l) = prettyTCM l+    prettyPat _ (I.ProjP _ p) = "." <> prettyTCM p+    prettyPat _ (I.IApplyP _ _ _ _) = "_"+++instance PrettyTCM ExecError where+  prettyTCM = \case++    ExeNotTrusted exe exes -> vcat $+      (fsep $ concat+         [ pwords "Could not find"+         , q exe+         , pwords "in list of trusted executables:"+         ]) :+      [ text $ "  - " ++ Text.unpack exe | exe <- Map.keys exes ]++    ExeNotFound exe fp -> fsep $ concat+      [ pwords "Could not find file"+      , q fp+      , pwords "for trusted executable"+      , q fp+      ]++    ExeNotExecutable exe fp -> fsep $ concat+      [ [ "File" ]+      , q fp+      , pwords "for trusted executable"+      , q exe+      , pwords "does not have permission to execute"+      ]++    where+      q :: (MonadPretty m, P.Pretty a) => a -> [m Doc]+      q = singleton . quotes . pretty++++instance PrettyTCM GHCBackendError where+  prettyTCM = \case++    ConstructorCountMismatch d cs hsCons -> fsep $ concat+      [ [ prettyTCM d, "has", text (show n), "constructors,", "but" ]+      , [ "only" | hn > 0, hn < n ]+      , pwords n_forms_are+      , pwords $ "given [" ++ unwords hsCons ++ "]"+      ]+      where+        n  = length cs+        hn = length hsCons+        n_forms_are = case hn of+          1 -> "1 Haskell constructor is"+          _ -> show hn ++ " Haskell constructors are"++    NotAHaskellType top offender -> vcat+      [ fsep $ concat+        [ pwords "The type", [ prettyTCM top ]+        , pwords "cannot be translated to a corresponding Haskell type, because it contains"+        , reason offender+        ]+      , possibleFix offender+      ]+      where+      reason (BadLambda        v) = pwords "the lambda term" ++ [prettyTCM v <> "."]+      reason (BadMeta          v) = pwords "a meta variable" ++ [prettyTCM v <> "."]+      reason (BadDontCare      v) = pwords "an erased term" ++ [prettyTCM v <> "."]+      reason (NotCompiled      x) = pwords "a name that is not compiled"+                                    ++ [parens (prettyTCM x) <> "."]+      reason (NoPragmaFor      x) = prettyTCM x : pwords "which does not have a COMPILE pragma."+      reason (WrongPragmaFor _ x) = prettyTCM x : pwords "which has the wrong kind of COMPILE pragma."++      possibleFix BadLambda{}     = empty+      possibleFix BadMeta{}       = empty+      possibleFix BadDontCare{}   = empty+      possibleFix NotCompiled{}   = empty+      possibleFix (NoPragmaFor d) = suggestPragma d $ "add a pragma"+      possibleFix (WrongPragmaFor r d) = suggestPragma d $+        sep [ "replace the value-level pragma at", nest 2 $ pretty r, "by" ]++      suggestPragma d action = do+        def    <- theDef <$> getConstInfo d+        let dataPragma n = ("data type HsD", "data HsD (" ++ intercalate " | " [ "C" ++ show i | i <- [1..n] ] ++ ")")+            (hsThing, pragma) =+              case def of+                Datatype{ dataCons = cs } -> dataPragma (length cs)+                Record{}                  -> dataPragma 1+                _                         -> ("type HsT", "type HsT")+        vcat [ sep ["Possible fix:", action]+             , nest 2 $ hsep [ "{-# COMPILE GHC", prettyTCM d, "=", text pragma, "#-}" ]+             , text ("for a suitable Haskell " ++ hsThing ++ ".")+             ]++    WrongTypeOfMain io ty -> fsep $ concat+      [ pwords "The type of main should be", [ prettyTCM io ], pwords "A, for some A."+      , pwords "The given type is:", [ prettyTCM ty ]+      ]++instance PrettyTCM JSBackendError where+  prettyTCM = \case+    BadCompilePragma -> sep+      [ "Badly formed COMPILE JS pragma. Expected"+      , "{-# COMPILE JS <name> = <js> #-}"+      ]++instance PrettyTCM InteractionError where+  prettyTCM = \case+    CannotGive e       -> fsep $ pwords "Failed to give" ++ [ prettyTCM e ]++    CannotRefine s     -> fsep $ pwords "Cannot refine" ++ pwords s++    CaseSplitError doc -> return doc++    ExpectedIdentifier e -> fsep $ concat+      [ pwords "Expected identifier, but found:"+      , pure $ pretty e+      ]++    ExpectedApplication -> fwords "Expected an argument of the form f e1 e2 .. en"++    NoActionForInteractionPoint ii -> vcat+      [ fwords $ "No type nor action available for hole " ++ prettyShow ii ++ "."+      , fwords $ "Possible cause: the hole has not been reached during type checking (do you see yellow?)"+      ]++    NoSuchInteractionPoint ii ->+      fsep [ "Unknown", "interaction", "point", prettyTCM ii ]++    UnexpectedWhere -> fwords "`where' clauses are not supported in holes"++instance PrettyTCM UnquoteError where+  prettyTCM = \case++    BlockedOnMeta _ m -> fsep $+      pwords $ "Unquote failed because of unsolved meta variables."++    CannotDeclareHiddenFunction f -> fsep $+      pwords "Cannot declare hidden function" ++ [ prettyTCM f ]++    CommitAfterDef -> fwords "Cannot use commitTC after declaring new definitions"++    ConInsteadOfDef x def con -> fsep $+      pwords ("Use " ++ con ++ " instead of " ++ def ++ " for constructor") +++      [prettyTCM x]++    DefineDataNotData x -> fsep $+      [prettyTCM x] +++      pwords "is not declared as a datatype or record, or it already has a definition."++    DefInsteadOfCon x def con -> fsep $+      pwords ("Use " ++ def ++ " instead of " ++ con ++ " for non-constructor")+      ++ [prettyTCM x]++    MissingDeclaration x -> fsep $+      pwords "Missing declaration for" ++ [ prettyTCM x ]++    MissingDefinition x -> fsep $+      pwords "Missing definition for" ++ [ prettyTCM x ]++    NakedUnquote -> fwords "`unquote' must be applied to a term"++    NonCanonical kind t ->+      fwords ("Cannot unquote non-canonical " ++ kind)+      $$ nest 2 (prettyTCM t)++    PatLamWithoutClauses _ -> fsep $+      pwords "Cannot unquote pattern lambda without clauses. Use a single `absurd-clause` for absurd lambdas."++    StaleMeta m x ->+      sep+        [ "Cannot unquote stale metavariable"+        , pretty m <> "._" <> pretty (metaId x)+        ]++    TooManyParameters npars e -> sep+      [ fsep $ concat [ pwords "Cannot shave", [pretty npars], pwords "parameters off type" ]+      , prettyTCM e+      ]++    UnboundName x -> fsep $ pwords "Unbound name:" ++ [prettyTCM x]++instance PrettyTCM MissingTypeSignatureInfo where+  prettyTCM = \case+    MissingDataSignature x       -> fsep [ "data"  , "definition", prettyTCM x ]+    MissingRecordSignature x     -> fsep [ "record", "definition", prettyTCM x ]+    MissingFunctionSignature lhs -> fsep [ "left", "hand", "side", prettyTCM lhs ]+++notCmp :: MonadPretty m => Comparison -> m Doc+notCmp cmp = "!" <> prettyTCM cmp++-- | Print two terms that are supposedly unequal.+--   If they print to the same identifier, add some explanation+--   why they are different nevertheless.+prettyInEqual :: MonadPretty m => Term -> Term -> m (Doc, Doc, Doc)+prettyInEqual t1 t2 = do+  d1 <- prettyTCM t1+  d2 <- prettyTCM t2+  (d1, d2,) <$> do+     -- if printed differently, no extra explanation needed+    if P.render d1 /= P.render d2 then empty else do+      (v1, v2) <- instantiate (t1, t2)+      case (v1, v2) of+        (I.Var i1 _, I.Var i2 _)+          | i1 == i2  -> generic -- possible, see issue 1826+          | otherwise -> varVar i1 i2+        (I.Def{}, I.Con{}) -> __IMPOSSIBLE__  -- ambiguous identifiers+        (I.Con{}, I.Def{}) -> __IMPOSSIBLE__+        (I.Var{}, I.Def{}) -> varDef+        (I.Def{}, I.Var{}) -> varDef+        (I.Var{}, I.Con{}) -> varCon+        (I.Con{}, I.Var{}) -> varCon+        (I.Def x _, I.Def y _)+          | isExtendedLambdaName x, isExtendedLambdaName y -> extLamExtLam x y+        _                  -> empty+  where+    varDef, varCon, generic :: MonadPretty m => m Doc+    varDef = parens $ fwords "because one is a variable and one a defined identifier"+    varCon = parens $ fwords "because one is a variable and one a constructor"+    generic = parens $ fwords $ "although these terms are looking the same, " +++      "they contain different but identically rendered identifiers somewhere"+    varVar :: MonadPretty m => Int -> Int -> m Doc+    varVar i j = parens $ fwords $+                   "because one has de Bruijn index " ++ show i+                   ++ " and the other " ++ show j++    extLamExtLam :: MonadPretty m => QName -> QName -> m Doc+    extLamExtLam a b = vcat+      [ fwords "Because they are distinct extended lambdas: one is defined at"+      , "  " <+> pretty (nameBindingSite (qnameName a))+      , fwords "and the other at"+      , "  " <+> (pretty (nameBindingSite (qnameName b)) <> ",")+      , fwords "so they have different internal representations."+      ]++class PrettyUnequal a where+  prettyUnequal :: MonadPretty m => a -> m Doc -> a -> m Doc++instance PrettyUnequal Term where+  prettyUnequal t1 ncmp t2 = do+    (d1, d2, d) <- prettyInEqual t1 t2+    fsep $ return d1 : ncmp : return d2 : return d : []++instance PrettyUnequal I.Type where+  prettyUnequal t1 ncmp t2 = prettyUnequal (unEl t1) ncmp (unEl t2)++instance PrettyTCM SplitError where+  prettyTCM :: forall m. MonadPretty m => SplitError -> m Doc+  prettyTCM err = case err of+    NotADatatype t -> enterClosure t $ \ t -> fsep $+      pwords "Cannot split on argument of non-datatype" ++ [prettyTCM t]++    BlockedType b t -> enterClosure t $ \ t -> fsep $+      pwords "Cannot split on argument of unresolved type" ++ [prettyTCM t]++    ErasedDatatype reason t -> enterClosure t $ \ t -> fsep $+      pwords "Cannot branch on erased argument of datatype" +++      [prettyTCM t] +++      case reason of+        NoErasedMatches ->+          pwords "because the option --erased-matches is not active"+        NoK ->+          pwords "because the K rule is turned off"+        SeveralConstructors ->+          []++    CoinductiveDatatype t -> enterClosure t $ \ t -> fsep $+      pwords "Cannot pattern match on the coinductive type" ++ [prettyTCM t]++{- UNUSED+    NoRecordConstructor t -> fsep $+      pwords "Cannot pattern match on record" ++ [prettyTCM t] +++      pwords "because it has no constructor"+ -}++    UnificationStuck b c tel cIxs gIxs errs+      | length cIxs /= length gIxs -> __IMPOSSIBLE__+      | otherwise                  -> vcat . concat $+        [ [ fsep . concat $+            [ pwords "I'm not sure if there should be a case for the constructor"+            , [prettyTCM c <> ","]+            , pwords "because I get stuck when trying to solve the following"+            , pwords "unification problems (inferred index ≟ expected index):"+            ]+          ]+        , zipWith prEq cIxs gIxs+        , if null errs then [] else+            (fsep $ [ "Possible", pluralS errs "reason" ] ++ pwords "why unification failed:")+            : map (nest 2 . prettyTCM) errs+        ]+      where+        -- Andreas, 2019-08-08, issue #3943+        -- To not print hidden indices just as {_}, we strip the Arg and print+        -- the hiding information manually.+        prEq :: Arg Term -> Arg Term -> m Doc+        prEq cIx gIx = addContext tel $ nest 2 $ hsep [ pr cIx , "≟" , pr gIx ]+        pr arg = prettyRelevance arg . prettyHiding arg id <$> prettyTCM (unArg arg)++    CosplitCatchall -> fsep $+      pwords "Cannot split into projections because not all clauses have a projection copattern"++    CosplitNoTarget -> fsep $+      pwords "Cannot split into projections because target type is unknown"++    CosplitNoRecordType t -> enterClosure t $ \t -> fsep $+      pwords "Cannot split into projections because the target type "+      ++ [prettyTCM t] ++ pwords " is not a record type"++    CannotCreateMissingClause f cl msg t -> fsep (+      pwords "Cannot generate inferred clause for" ++ [prettyTCM f <> "."] +++      pwords "Case to handle:") $$ nest 2 (vcat $ [display cl])+                                $$ ((pure msg <+> enterClosure t displayAbs) <> ".")+        where+        displayAbs :: Abs I.Type -> m Doc+        displayAbs (Abs x t) = addContext x $ prettyTCM t+        displayAbs (NoAbs x t) = prettyTCM t+        display (tel, ps) = prettyTCM $ NamedClause f True $+          empty { clauseTel = tel, namedClausePats = ps }+++    GenericSplitError s -> fsep $ pwords "Split failed:" ++ pwords s++instance PrettyTCM NegativeUnification where+  prettyTCM err = case err of+    UnifyConflict tel u v -> addContext tel $ vcat $+      [ fsep $ pwords "because unification ended with a conflicting equation "+      , nest 2 $ prettyTCM u <+> "≟" <+> prettyTCM v+      ]++    UnifyCycle tel i u -> addContext tel $ vcat $+      [ fsep $ pwords "because unification ended with a cyclic equation "+      , nest 2 $ prettyTCM (var i) <+> "≟" <+> prettyTCM u+      ]++instance PrettyTCM UnificationFailure where+  prettyTCM err = case err of+    UnifyIndicesNotVars tel a u v ixs -> addContext tel $ fsep $+      pwords "Cannot apply injectivity to the equation" ++ [prettyTCM u] +++      pwords "=" ++ [prettyTCM v] ++ pwords "of type" ++ [prettyTCM a] +++      pwords "because I cannot generalize over the indices" +++      [prettyList (map prettyTCM ixs) <> "."]++    UnifyRecursiveEq tel a i u -> addContext tel $ fsep $+      pwords "Cannot solve variable " ++ [prettyTCM (var i)] +++      pwords " of type " ++ [prettyTCM a] +++      pwords " with solution " ++ [prettyTCM u] +++      pwords " because the variable occurs in the solution," +++      pwords " or in the type of one of the variables in the solution."++    UnifyReflexiveEq tel a u -> addContext tel $ fsep $+      pwords "Cannot eliminate reflexive equation" ++ [prettyTCM u] +++      pwords "=" ++ [prettyTCM u] ++ pwords "of type" ++ [prettyTCM a] +++      pwords "because K has been disabled."++    UnifyUnusableModality tel a i u mod -> addContext tel $ fsep $+      pwords "Cannot solve variable " ++ [prettyTCM (var i)] +++      pwords "of type " ++ [prettyTCM a] +++      pwords "with solution " ++ [prettyTCM u] +++      pwords "because the solution cannot be used at" +++             [ text (verbalize $ getRelevance mod) <> ","+             , text $ verbalize $ getQuantity mod ] +++      pwords "modality"++++explainWhyInScope :: forall m. MonadPretty m => WhyInScopeData -> m Doc+explainWhyInScope (WhyInScopeData y _ Nothing [] []) = text (prettyShow  y ++ " is not in scope.")+explainWhyInScope (WhyInScopeData y _ v xs ms) = vcat+  [ text (prettyShow y ++ " is in scope as")+  , nest 2 $ vcat [variable v xs, modules ms]+  ]+  where+    -- variable :: Maybe _ -> [_] -> m Doc+    variable Nothing vs = names vs+    variable (Just x) vs+      | null vs   = asVar+      | otherwise = vcat+         [ sep [ asVar, nest 2 $ shadowing x]+         , nest 2 $ names vs+         ]+      where+        asVar :: m Doc+        asVar = do+          "* a variable bound at" <+> prettyTCM (nameBindingSite $ localVar x)+        shadowing :: LocalVar -> m Doc+        shadowing (LocalVar _ _ [])    = "shadowing"+        shadowing _ = "in conflict with"+    names   = vcat . map pName+    modules = vcat . map pMod++    pKind = \case+      ConName                  -> "constructor"+      CoConName                -> "coinductive constructor"+      FldName                  -> "record field"+      PatternSynName           -> "pattern synonym"+      GeneralizeName           -> "generalizable variable"+      DisallowedGeneralizeName -> "generalizable variable from let open"+      MacroName                -> "macro name"+      QuotableName             -> "quotable name"+      -- previously DefName:+      DataName                 -> "data type"+      RecName                  -> "record type"+      AxiomName                -> "postulate"+      PrimName                 -> "primitive function"+      FunName                  -> "defined name"+      OtherDefName             -> "defined name"++    pName :: AbstractName -> m Doc+    pName a = sep+      [ "* a"+        <+> pKind (anameKind a)+        <+> text (prettyShow $ anameName a)+      , nest 2 $ "brought into scope by"+      ] $$+      nest 2 (pWhy (nameBindingSite $ qnameName $ anameName a) (anameLineage a))+    pMod :: AbstractModule -> m Doc+    pMod  a = sep+      [ "* a module" <+> text (prettyShow $ amodName a)+      , nest 2 $ "brought into scope by"+      ] $$+      nest 2 (pWhy (nameBindingSite $ qnameName $ mnameToQName $ amodName a) (amodLineage a))++    pWhy :: Range -> WhyInScope -> m Doc+    pWhy r Defined = "- its definition at" <+> prettyTCM r+    pWhy r (Opened (C.QName x) w) | isNoName x = pWhy r w+    pWhy r (Opened m w) =+      "- the opening of"+      <+> prettyTCM m+      <+> "at"+      <+> prettyTCM (getRange m)+      $$+      pWhy r w+    pWhy r (Applied m w) =+      "- the application of"+      <+> prettyTCM m+      <+> "at"+      <+> prettyTCM (getRange m)+      $$+      pWhy r w++++---------------------------------------------------------------------------+-- * Natural language+---------------------------------------------------------------------------++class Verbalize a where+  verbalize :: a -> String++instance Verbalize Hiding where+  verbalize = hidingToString++instance Verbalize Relevance where+  verbalize = \case+      Relevant        {} -> "relevant"+      Irrelevant      {} -> "irrelevant"+      ShapeIrrelevant {} -> "shape-irrelevant"++instance Verbalize Quantity where+  verbalize = \case+    Quantity0{} -> "erased"+    Quantity1{} -> "linear"+    Quantityω{} -> "unrestricted"++instance Verbalize Cohesion where+  verbalize = \case+      Flat       -> "flat"+      Continuous -> "continuous"+      Squash     -> "squashed"++instance Verbalize ModalPolarity where+  verbalize = \case+      UnusedPolarity -> "unused"+      StrictlyPositive -> "strictly positive"+      Positive -> "positive"+      Negative -> "negative"+      MixedPolarity -> "mixed"++instance Verbalize PolarityModality where+  verbalize (PolarityModality p o l) = verbalize p++instance Verbalize Modality where+  verbalize mod | mod == defaultModality || mod == defaultCheckModality = "default"+  verbalize mod | mod == defaultModality = "default"+  verbalize (Modality rel qnt coh pol) = intercalate ", " $+    [ verbalize rel | rel /= defaultRelevance ] +++    [ verbalize qnt | qnt /= defaultQuantity ] +++    [ verbalize coh | coh /= defaultCohesion ] +++    [ verbalize pol | pol /= defaultPolarity , pol /= modPolarity defaultCheckModality ]  -- | Indefinite article. data Indefinite a = Indefinite a
src/full/Agda/TypeChecking/Errors.hs-boot view
@@ -1,12 +1,26 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.Errors where +import Agda.Syntax.Common (Cohesion, PolarityModality, Relevance) import Agda.Syntax.Abstract.Name  import Agda.TypeChecking.Monad.Base import {-# SOURCE #-} Agda.TypeChecking.Monad.Debug (MonadDebug)+import {-# SOURCE #-} Agda.TypeChecking.Pretty (PrettyTCM) +instance PrettyTCM TypeError+instance PrettyTCM TCErr+ -- Misplaced SPECIALISE pragma:--- {-# SPECIALIZE prettyError :: TCErr -> TCM String #-}-prettyError :: MonadTCM tcm => TCErr -> tcm String+-- {-# SPECIALIZE renderError :: TCErr -> TCM String #-}+renderError :: MonadTCM tcm => TCErr -> tcm String  topLevelModuleDropper :: (MonadDebug m, MonadTCEnv m, ReadTCState m) => m (QName -> QName)++class Verbalize a where+  verbalize :: a -> String++instance Verbalize Relevance+instance Verbalize Cohesion+instance Verbalize PolarityModality
+ src/full/Agda/TypeChecking/Errors/Names.hs view
@@ -0,0 +1,380 @@+-- | Convert errors to their names.++module Agda.TypeChecking.Errors.Names where++import Agda.Syntax.Concrete.Definitions.Errors as N (DeclarationException'(..))+import Agda.TypeChecking.Monad.Base            as MB+import Agda.Interaction.Options.Errors++-- | Print the name of a 'TypeError'.+--+typeErrorString :: TypeError -> String+typeErrorString = errorNameString . typeErrorName++-- | Compute the name of a 'TypeError'.+--+typeErrorName :: TypeError -> ErrorName+typeErrorName = \case+  -- Error groups (alphabetically) with named sub errors+  ExecError                err -> ExecError_             $ execErrorName                  err+  GHCBackendError          err -> GHCBackendError_       $ ghcBackendErrorName            err+  JSBackendError           err -> JSBackendError_        $ jsBackendErrorName             err+  ImpossibleConstructor _  err -> ImpossibleConstructor_ $ impossibleConstructorErrorName err+  InteractionError         err -> InteractionError_      $ interactionErrorName           err+  NicifierError            err -> NicifierError_         $ declarationExceptionName       err+  SplitError               err -> SplitError_            $ splitErrorName                 err+  UnquoteFailed            err -> UnquoteError_          $ unquoteErrorName               err+  -- Parametrized errors+  CannotQuote             what -> CannotQuote_           $ unquotableName                 what+  MissingTypeSignature    what -> MissingTypeSignature_  $ missingTypeSignatureInfoName   what+  InvalidPun            kind _ -> InvalidPun_              kind+  CannotQuoteTerm         what -> CannotQuoteTerm_         what+  NotAllowedInDotPatterns what -> NotAllowedInDotPatterns_ what+  NotAValidLetBinding     what -> NotAValidLetBinding_     what+  NotAValidLetExpression  what -> NotAValidLetExpression_  what+  PatternSynonymArgumentShadows what _ _ -> PatternSynonymArgumentShadows_ what+  -- Wrappers+  OperatorInformation _    err -> typeErrorName err+  -- Generic errors (alphabetically)+  CompilationError          {} -> CompilationError_+  CustomBackendError        {} -> CustomBackendError_+  GenericError              {} -> GenericError_+  GenericDocError           {} -> GenericDocError_+  InternalError             {} -> InternalError_+  LibraryError              {} -> LibraryError_+  NonFatalErrors            {} -> NonFatalErrors_+  NotImplemented            {} -> NotImplemented_+  NotSupported              {} -> NotSupported_+  OptionError               {} -> OptionError_+  SyntaxError               {} -> SyntaxError_+  -- Other errors (alphabetically)+  AbsentRHSRequiresAbsurdPattern                             {} -> AbsentRHSRequiresAbsurdPattern_+  AbstractConstructorNotInScope                              {} -> AbstractConstructorNotInScope_+  MB.AmbiguousConstructor                                    {} -> AmbiguousConstructor_+  AmbiguousField                                             {} -> AmbiguousField_+  AmbiguousModule                                            {} -> AmbiguousModule_+  AmbiguousName                                              {} -> AmbiguousName_+  AmbiguousOverloadedProjection                              {} -> AmbiguousOverloadedProjection_+  AmbiguousParseForApplication                               {} -> AmbiguousParseForApplication_+  AmbiguousParseForLHS                                       {} -> AmbiguousParseForLHS_+  AmbiguousProjection                                        {} -> AmbiguousProjection_+  AmbiguousTopLevelModuleName                                {} -> AmbiguousTopLevelModuleName_+  AsPatternInPatternSynonym                                  {} -> AsPatternInPatternSynonym_+  AttributeKindNotEnabled                                    {} -> AttributeKindNotEnabled_+  BackendDoesNotSupportOnlyScopeChecking                     {} -> BackendDoesNotSupportOnlyScopeChecking_+  BadArgumentsToPatternSynonym                               {} -> BadArgumentsToPatternSynonym_+  BothWithAndRHS                                             {} -> BothWithAndRHS_+  BuiltinInParameterisedModule                               {} -> BuiltinInParameterisedModule_+  BuiltinMustBeConstructor                                   {} -> BuiltinMustBeConstructor_+  BuiltinMustBeData                                          {} -> BuiltinMustBeData_+  BuiltinMustBeDef                                           {} -> BuiltinMustBeDef_+  BuiltinMustBeFunction                                      {} -> BuiltinMustBeFunction_+  BuiltinMustBePostulate                                     {} -> BuiltinMustBePostulate_+  CannotApply                                                {} -> CannotApply_+  CannotEliminateWithPattern                                 {} -> CannotEliminateWithPattern_+  CannotEliminateWithProjection                              {} -> CannotEliminateWithProjection_+  CannotGenerateHCompClause                                  {} -> CannotGenerateHCompClause_+  CannotGenerateTransportClause                              {} -> CannotGenerateTransportClause_+  CannotResolveAmbiguousPatternSynonym                       {} -> CannotResolveAmbiguousPatternSynonym_+  CannotRewriteByNonEquation                                 {} -> CannotRewriteByNonEquation_+  CannotSolveSizeConstraints                                 {} -> CannotSolveSizeConstraints_+  CantResolveOverloadedConstructorsTargetingSameDatatype     {} -> CantResolveOverloadedConstructorsTargetingSameDatatype_+  ClashingDefinition                                         {} -> ClashingDefinition_+  ClashingModule                                             {} -> ClashingModule_+  ComatchingDisabledForRecord                                {} -> ComatchingDisabledForRecord_+  ConstructorDoesNotTargetGivenType                          {} -> ConstructorDoesNotTargetGivenType_+  ConstructorNameOfNonRecord                                 {} -> ConstructorNameOfNonRecord_+  ConstructorPatternInWrongDatatype                          {} -> ConstructorPatternInWrongDatatype_+  ContradictorySizeConstraint                                {} -> ContradictorySizeConstraint_+  CopatternHeadNotProjection                                 {} -> CopatternHeadNotProjection_+  CubicalCompilationNotSupported                             {} -> CubicalCompilationNotSupported_+  CubicalNotErasure                                          {} -> CubicalNotErasure_+  CubicalPrimitiveNotFullyApplied                            {} -> CubicalPrimitiveNotFullyApplied_+  CyclicModuleDependency                                     {} -> CyclicModuleDependency_+  DatatypeIndexPolarity                                      {} -> DatatypeIndexPolarity_+  DeBruijnIndexOutOfScope                                    {} -> DeBruijnIndexOutOfScope_+  DeclarationsAfterTopLevelModule                            {} -> DeclarationsAfterTopLevelModule_+  DefinitionInDifferentModule                                {} -> DefinitionInDifferentModule_+  DefinitionIsErased                                         {} -> DefinitionIsErased_+  DefinitionIsIrrelevant                                     {} -> DefinitionIsIrrelevant_+  DoNotationError                                            {} -> DoNotationError_+  DoesNotMentionTicks                                        {} -> DoesNotMentionTicks_+  DotPatternInPatternSynonym                                 {} -> DotPatternInPatternSynonym_+  DuplicateBuiltinBinding                                    {} -> DuplicateBuiltinBinding_+  DuplicateConstructors                                      {} -> DuplicateConstructors_+  DuplicateFields                                            {} -> DuplicateFields_+  DuplicateImports                                           {} -> DuplicateImports_+  DuplicateOverlapPragma                                     {} -> DuplicateOverlapPragma_+  DuplicatePrimitiveBinding                                  {} -> DuplicatePrimitiveBinding_+  EmptyTypeOfSizes                                           {} -> EmptyTypeOfSizes_+  ExpectedBindingForParameter                                {} -> ExpectedBindingForParameter_+  ExpectedIntervalLiteral                                    {} -> ExpectedIntervalLiteral_+  FieldOutsideRecord                                         {} -> FieldOutsideRecord_+  FaceConstraintDisjunction                                  {} -> FaceConstraintDisjunction_+  FaceConstraintUnsatisfiable                                {} -> FaceConstraintUnsatisfiable_+  FileNotFound                                               {} -> FileNotFound_+  ForcedConstructorNotInstantiated                           {} -> ForcedConstructorNotInstantiated_+  FunctionTypeInSizeUniv                                     {} -> FunctionTypeInSizeUniv_+  GeneralizeCyclicDependency                                 {} -> GeneralizeCyclicDependency_+  GeneralizeNotSupportedHere                                 {} -> GeneralizeNotSupportedHere_+  GeneralizedVarInLetOpenedModule                            {} -> GeneralizedVarInLetOpenedModule_+  HidingMismatch                                             {} -> HidingMismatch_+  IdiomBracketError                                          {} -> IdiomBracketError_+  InvalidBuiltin                                             {} -> InvalidBuiltin_+  InvalidDottedExpression                                    {} -> InvalidDottedExpression_+  IllTypedPatternAfterWithAbstraction                        {} -> IllTypedPatternAfterWithAbstraction_+  IllegalDeclarationBeforeTopLevelModule                     {} -> IllegalDeclarationBeforeTopLevelModule_+  IllegalDeclarationInDataDefinition                         {} -> IllegalDeclarationInDataDefinition_+  IllegalHidingInPostfixProjection                           {} -> IllegalHidingInPostfixProjection_+  IllegalInstanceVariableInPatternSynonym                    {} -> IllegalInstanceVariableInPatternSynonym_+  IllegalLetInTelescope                                      {} -> IllegalLetInTelescope_+  IllegalPatternInTelescope                                  {} -> IllegalPatternInTelescope_+  IllformedProjectionPatternAbstract                         {} -> IllformedProjectionPatternAbstract_+  IllformedProjectionPatternConcrete                         {} -> IllformedProjectionPatternConcrete_+  IncorrectTypeForRewriteRelation                            {} -> IncorrectTypeForRewriteRelation_+  InstanceNoCandidate                                        {} -> InstanceNoCandidate_+  InstanceSearchDepthExhausted                               {} -> InstanceSearchDepthExhausted_+  InvalidFileName                                            {} -> InvalidFileName_+  InvalidModalTelescopeUse                                   {} -> InvalidModalTelescopeUse_+  InvalidPattern                                             {} -> InvalidPattern_+  InvalidProjectionParameter                                 {} -> InvalidProjectionParameter_+  InvalidTypeSort                                            {} -> InvalidTypeSort_+  LambdaIsErased                                             {} -> LambdaIsErased_+  LibTooFarDown                                              {} -> LibTooFarDown_+  LiteralTooBig                                              {} -> LiteralTooBig_+  MacroResultTypeMismatch                                    {} -> MacroResultTypeMismatch_+  MetaCannotDependOn                                         {} -> MetaCannotDependOn_+  MetaErasedSolution                                         {} -> MetaErasedSolution_+  MetaIrrelevantSolution                                     {} -> MetaIrrelevantSolution_+  MismatchedProjectionsError                                 {} -> MismatchedProjectionsError_+  ModuleArityMismatch                                        {} -> ModuleArityMismatch_+  ModuleDefinedInOtherFile                                   {} -> ModuleDefinedInOtherFile_+  ModuleNameDoesntMatchFileName                              {} -> ModuleNameDoesntMatchFileName_+  ModuleNameHashCollision                                    {} -> ModuleNameHashCollision_+  ModuleNameUnexpected                                       {} -> ModuleNameUnexpected_+  MultipleFixityDecls                                        {} -> MultipleFixityDecls_+  MultiplePolarityPragmas                                    {} -> MultiplePolarityPragmas_+  ExplicitPolarityVsPragma                                   {} -> ExplicitPolarityVsPragma_+  NamedWhereModuleInRefinedContext                           {} -> NamedWhereModuleInRefinedContext_+  NeedOptionAllowExec                                        {} -> NeedOptionAllowExec_+  NeedOptionCopatterns                                       {} -> NeedOptionCopatterns_+  NeedOptionCubical                                          {} -> NeedOptionCubical_+  NeedOptionPatternMatching                                  {} -> NeedOptionPatternMatching_+  NeedOptionProp                                             {} -> NeedOptionProp_+  NeedOptionRewriting                                        {} -> NeedOptionRewriting_+  NeedOptionSizedTypes                                       {} -> NeedOptionSizedTypes_+  NeedOptionTwoLevel                                         {} -> NeedOptionTwoLevel_+  NeedOptionUniversePolymorphism                             {} -> NeedOptionUniversePolymorphism_+  NegativeLiteralInPattern                                   {} -> NegativeLiteralInPattern_+  NoBindingForBuiltin                                        {} -> NoBindingForBuiltin_+  NoBindingForPrimitive                                      {} -> NoBindingForPrimitive_+  NoKnownRecordWithSuchFields                                {} -> NoKnownRecordWithSuchFields_+  NoParameterOfName                                          {} -> NoParameterOfName_+  NoParseForApplication                                      {} -> NoParseForApplication_+  NoParseForLHS                                              {} -> NoParseForLHS_+  NoSuchBuiltinName                                          {} -> NoSuchBuiltinName_+  NoSuchModule                                               {} -> NoSuchModule_+  NoSuchPrimitiveFunction                                    {} -> NoSuchPrimitiveFunction_+  NotAnExpression                                            {} -> NotAnExpression_+  NotInScope                                                 {} -> NotInScope_+  NotLeqSort                                                 {} -> NotLeqSort_+  NotValidBeforeField                                        {} -> NotValidBeforeField_+  OverlappingProjects                                        {} -> OverlappingProjects_+  PathAbstractionFailed                                      {} -> PathAbstractionFailed_+  PatternInPathLambda                                        {} -> PatternInPathLambda_+  PatternInSystem                                            {} -> PatternInSystem_+  PostulatedSizeInModule                                     {} -> PostulatedSizeInModule_+  PrivateRecordField                                         {} -> PrivateRecordField_+  ProjectionIsIrrelevant                                     {} -> ProjectionIsIrrelevant_+  QualifiedLocalModule                                       {} -> QualifiedLocalModule_+  QuantityMismatch                                           {} -> QuantityMismatch_+  RecordIsErased                                             {} -> RecordIsErased_+  RecursiveRecordNeedsInductivity                            {} -> RecursiveRecordNeedsInductivity_+  ReferencesFutureVariables                                  {} -> ReferencesFutureVariables_+  RelevanceMismatch                                          {} -> RelevanceMismatch_+  RepeatedNamesInImportDirective                             {} -> RepeatedNamesInImportDirective_+  RepeatedVariablesInPattern                                 {} -> RepeatedVariablesInPattern_+  ShadowedModule                                             {} -> ShadowedModule_+  ShouldBeASort                                              {} -> ShouldBeASort_+  ShouldBeEmpty                                              {} -> ShouldBeEmpty_+  ShouldBePath                                               {} -> ShouldBePath_+  ShouldBePi                                                 {} -> ShouldBePi_+  ShouldBeRecordPattern                                      {} -> ShouldBeRecordPattern_+  ShouldBeRecordType                                         {} -> ShouldBeRecordType_+  ShouldEndInApplicationOfTheDatatype                        {} -> ShouldEndInApplicationOfTheDatatype_+  SolvedButOpenHoles                                         {} -> SolvedButOpenHoles_+  SortCannotDependOnItsIndex                                 {} -> SortCannotDependOnItsIndex_+  SortDoesNotAdmitDataDefinitions                            {} -> SortDoesNotAdmitDataDefinitions_+  SortOfSplitVarError                                        {} -> SortOfSplitVarError_+  SplitInProp                                                {} -> SplitInProp_+  SplitOnAbstract                                            {} -> SplitOnAbstract_+  SplitOnCoinductive                                         {} -> SplitOnCoinductive_+  SplitOnIrrelevant                                          {} -> SplitOnIrrelevant_+  SplitOnNonEtaRecord                                        {} -> SplitOnNonEtaRecord_+  SplitOnNonVariable                                         {} -> SplitOnNonVariable_+  SplitOnPartial                                             {} -> SplitOnPartial_+  SplitOnUnchecked                                           {} -> SplitOnUnchecked_+  SplitOnUnusableCohesion                                    {} -> SplitOnUnusableCohesion_+  SplitOnUnusablePolarity                                    {} -> SplitOnUnusablePolarity_+  TacticAttributeNotAllowed                                  {} -> TacticAttributeNotAllowed_+  TooFewArgumentsToPatternSynonym                            {} -> TooFewArgumentsToPatternSynonym_+  TooFewPatternsInWithClause                                 {} -> TooFewPatternsInWithClause_+  TooManyFields                                              {} -> TooManyFields_+  TooManyPatternsInWithClause                                {} -> TooManyPatternsInWithClause_+  TriedToCopyConstrainedPrim                                 {} -> TriedToCopyConstrainedPrim_+  InvalidInstanceHeadType                                    {} -> InvalidInstanceHeadType_+  UnboundVariablesInPatternSynonym                           {} -> UnboundVariablesInPatternSynonym_+  UnequalCohesion                                            {} -> UnequalCohesion_+  UnequalFiniteness                                          {} -> UnequalFiniteness_+  UnequalHiding                                              {} -> UnequalHiding_+  UnequalLevel                                               {} -> UnequalLevel_+  UnequalQuantity                                            {} -> UnequalQuantity_+  UnequalRelevance                                           {} -> UnequalRelevance_+  UnequalPolarity                                            {} -> UnequalPolarity_+  UnequalSorts                                               {} -> UnequalSorts_+  UnequalTerms                                               {} -> UnequalTerms_+  UnexpectedModalityAnnotationInParameter                    {} -> UnexpectedModalityAnnotationInParameter_+  UnexpectedParameter                                        {} -> UnexpectedParameter_+  UnexpectedTypeSignatureForParameter                        {} -> UnexpectedTypeSignatureForParameter_+  UnexpectedWithPatterns                                     {} -> UnexpectedWithPatterns_+  UnknownBackend                                             {} -> UnknownBackend_+  UnusableAtModality                                         {} -> UnusableAtModality_+  UnusedVariableInPatternSynonym                             {} -> UnusedVariableInPatternSynonym_+  VariableIsErased                                           {} -> VariableIsErased_+  VariableIsIrrelevant                                       {} -> VariableIsIrrelevant_+  VariableIsOfUnusableCohesion                               {} -> VariableIsOfUnusableCohesion_+  VariableIsOfUnusablePolarity                               {} -> VariableIsOfUnusablePolarity_+  WithClausePatternMismatch                                  {} -> WithClausePatternMismatch_+  WithOnFreeVariable                                         {} -> WithOnFreeVariable_+  WrongAnnotationInLambda                                    {} -> WrongAnnotationInLambda_+  WrongArgInfoForPrimitive                                   {} -> WrongArgInfoForPrimitive_+  WrongCohesionInLambda                                      {} -> WrongCohesionInLambda_+  WrongPolarityInLambda                                      {} -> WrongPolarityInLambda_+  WrongHidingInApplication                                   {} -> WrongHidingInApplication_+  WrongHidingInLHS                                           {} -> WrongHidingInLHS_+  WrongHidingInLambda                                        {} -> WrongHidingInLambda_+  WrongHidingInProjection                                    {} -> WrongHidingInProjection_+  WrongIrrelevanceInLambda                                   {} -> WrongIrrelevanceInLambda_+  WrongNamedArgument                                         {} -> WrongNamedArgument_+  WrongNumberOfConstructorArguments                          {} -> WrongNumberOfConstructorArguments_+  WrongQuantityInLambda                                      {} -> WrongQuantityInLambda_+  WrongSharpArity                                            {} -> WrongSharpArity_++declarationExceptionName :: DeclarationException' -> DeclarationException_+declarationExceptionName = \case+  N.AmbiguousConstructor           {} -> AmbiguousConstructorN_+  AmbiguousFunClauses              {} -> AmbiguousFunClauses_+  BadMacroDef                      {} -> BadMacroDef_+  DisallowedInterleavedMutual      {} -> DisallowedInterleavedMutual_+  DuplicateAnonDeclaration         {} -> DuplicateAnonDeclaration_+  DuplicateDefinition              {} -> DuplicateDefinition_+  InvalidMeasureMutual             {} -> InvalidMeasureMutual_+  MissingWithClauses               {} -> MissingWithClauses_+  MultipleEllipses                 {} -> MultipleEllipses_+  OpaqueInMutual                   {} -> OpaqueInMutual_+  UnfoldingOutsideOpaque           {} -> UnfoldingOutsideOpaque_+  UnquoteDefRequiresSignature      {} -> UnquoteDefRequiresSignature_+  WrongContentBlock                {} -> WrongContentBlock_+  WrongDefinition                  {} -> WrongDefinition_++execErrorName :: ExecError -> ExecError_+execErrorName = \case+  ExeNotTrusted    {} -> ExeNotTrusted_+  ExeNotFound      {} -> ExeNotFound_+  ExeNotExecutable {} -> ExeNotExecutable_++ghcBackendErrorName :: GHCBackendError -> GHCBackendError_+ghcBackendErrorName = \case+  ConstructorCountMismatch{} -> ConstructorCountMismatch_+  NotAHaskellType _ err      -> NotAHaskellType_ $ notAHaskellTypeErrorName err+  WrongTypeOfMain{}          -> WrongTypeOfMain_++jsBackendErrorName :: JSBackendError -> JSBackendError_+jsBackendErrorName = \case+  BadCompilePragma -> BadCompilePragma_++impossibleConstructorErrorName :: NegativeUnification -> NegativeUnification_+impossibleConstructorErrorName = \case+  UnifyConflict {} -> UnifyConflict_+  UnifyCycle    {} -> UnifyCycle_++interactionErrorName :: InteractionError -> InteractionError_+interactionErrorName = \case+  CaseSplitError{}              -> CaseSplitError_+  CannotRefine{}                -> CannotRefine_+  CannotGive{}                  -> CannotGive_+  ExpectedIdentifier{}          -> ExpectedIdentifier_+  ExpectedApplication{}         -> ExpectedApplication_+  NoActionForInteractionPoint{} -> NoActionForInteractionPoint_+  NoSuchInteractionPoint{}      -> NoSuchInteractionPoint_+  UnexpectedWhere{}             -> UnexpectedWhere_++missingTypeSignatureInfoName :: MissingTypeSignatureInfo -> DataRecOrFun_+missingTypeSignatureInfoName = \case+  MissingDataSignature      {} -> DataName_+  MissingRecordSignature    {} -> RecName_+  MissingFunctionSignature  {} -> FunName_++notAHaskellTypeErrorName :: WhyNotAHaskellType -> NotAHaskellType_+notAHaskellTypeErrorName = \case+  BadDontCare               {} -> BadDontCare_+  BadLambda                 {} -> BadLambda_+  BadMeta                   {} -> BadMeta_+  NoPragmaFor               {} -> NoPragmaFor_+  NotCompiled               {} -> NotCompiled_+  WrongPragmaFor            {} -> WrongPragmaFor_++splitErrorName :: SplitError -> SplitError_+splitErrorName = \case+  ErasedDatatype reason _      -> ErasedDatatype_ reason+  GenericSplitError         {} -> GenericSplitError_+  -- Specific errors+  BlockedType               {} -> BlockedType_+  CannotCreateMissingClause {} -> CannotCreateMissingClause_+  CoinductiveDatatype       {} -> CoinductiveDatatype_+  CosplitCatchall           {} -> CosplitCatchall_+  CosplitNoRecordType       {} -> CosplitNoRecordType_+  CosplitNoTarget           {} -> CosplitNoTarget_+  NotADatatype              {} -> NotADatatype_+  UnificationStuck          {} -> UnificationStuck_++unquotableName :: CannotQuote -> CannotQuote_+unquotableName = \case+  CannotQuoteAmbiguous         {} -> CannotQuoteAmbiguous_+  CannotQuoteExpression        {} -> CannotQuoteExpression_+  CannotQuoteHidden            {} -> CannotQuoteHidden_+  CannotQuoteNothing           {} -> CannotQuoteNothing_+  CannotQuotePattern           {} -> CannotQuotePattern_++unquoteErrorName :: UnquoteError -> UnquoteError_+unquoteErrorName = \case+  BlockedOnMeta               {} -> BlockedOnMeta_+  CannotDeclareHiddenFunction {} -> CannotDeclareHiddenFunction_+  CommitAfterDef              {} -> CommitAfterDef_+  ConInsteadOfDef             {} -> ConInsteadOfDef_+  DefineDataNotData           {} -> DefineDataNotData_+  DefInsteadOfCon             {} -> DefInsteadOfCon_+  MissingDeclaration          {} -> MissingDeclaration_+  MissingDefinition           {} -> MissingDefinition_+  NakedUnquote                {} -> NakedUnquote_+  NonCanonical                {} -> NonCanonical_+  PatLamWithoutClauses        {} -> PatLamWithoutClauses_+  StaleMeta                   {} -> StaleMeta_+  TooManyParameters           {} -> TooManyParameters_+  UnboundName                 {} -> UnboundName_++-- -- * Printing names of errors++-- -- The following might not be used yet:++-- ghcBackendErrorString :: GHCBackendError -> String+-- ghcBackendErrorString = ghcBackendErrorNameString . ghcBackendErrorName++-- interactionErrorString :: InteractionError -> String+-- interactionErrorString = interactionErrorNameString . interactionErrorName++-- splitErrorString :: SplitError -> String+-- splitErrorString = splitErrorNameString . splitErrorName++-- unquoteErrorString :: UnquoteError -> String+-- unquoteErrorString = unquoteErrorNameString . unquoteErrorName
src/full/Agda/TypeChecking/EtaContract.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Compute eta short normal forms. module Agda.TypeChecking.EtaContract where
− src/full/Agda/TypeChecking/EtaExpand.hs 
@@ -1,34 +0,0 @@---- | Compute eta long normal forms.-module Agda.TypeChecking.EtaExpand where--import Agda.Syntax.Common-import Agda.Syntax.Internal--import Agda.TypeChecking.CheckInternal-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Records-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Substitute---- | Eta-expand a term if its type is a function type or an eta-record type.-etaExpandOnce :: PureTCM m => Type -> Term -> m Term-etaExpandOnce a v = reduce a >>= \case-  El _ (Pi a b) -> return $-    Lam ai $ mkAbs (absName b) $ raise 1 v `apply` [ Arg ai $ var 0 ]-    where ai = domInfo a--  a -> isEtaRecordType a >>= \case-    Just (r, pars) -> do-      def <- theDef <$> getConstInfo r-      (_, con, ci, args) <- etaExpandRecord_ r pars def v-      return $ mkCon con ci args-    Nothing -> return v---- | Eta-expand functions and expressions of eta-record--- type wherever possible.-deepEtaExpand :: Term -> Type -> TCM Term-deepEtaExpand v a = checkInternal' etaExpandAction v CmpLeq a--etaExpandAction :: PureTCM m => Action m-etaExpandAction = defaultAction { preAction = etaExpandOnce  }
src/full/Agda/TypeChecking/Forcing.hs view
@@ -63,6 +63,13 @@     isForced,     nextIsForced ) where +import Control.Monad.Reader ( MonadReader, ask, local, ReaderT, runReaderT )+import Control.Monad.State  ( MonadState, modify, StateT, execStateT )++import Data.Bifunctor+import Data.Function ((&))+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet import Data.Monoid -- for (<>) in GHC 8.0.2  import Agda.Interaction.Options@@ -71,21 +78,25 @@ import Agda.Syntax.Internal  import Agda.TypeChecking.Monad+import Agda.TypeChecking.Datatypes (consOfHIT) import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope +import Agda.Utils.Boolean (implies)+import Agda.Utils.IArray (Array, listArray)+import qualified Agda.Utils.IArray as Array import Agda.Utils.List+import Agda.Utils.Maybe import Agda.Utils.Monad-import Agda.Utils.Pretty (prettyShow)+import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Utils.Size+import Agda.Utils.Singleton  import Agda.Utils.Impossible  -- | Given the type of a constructor (excluding the parameters), --   decide which arguments are forced.---   Precondition: the type is of the form @Γ → D vs@ and the @vs@---   are in normal form. computeForcingAnnotations :: QName -> Type -> TCM [IsForced] computeForcingAnnotations c t =   ifNotM (optForcing <$> pragmaOptions {-then-}) (return []) $ {-else-} do@@ -94,44 +105,117 @@     -- Andreas, 2015-03-28  Issue 1469: Normalization too costly.     -- Instantiation also fixes Issue 1454.     -- Note that normalization of s0 below does not help.-    t <- instantiateFull t+    -- t <- instantiateFull t     -- Ulf, 2018-01-28 (#2919): We do need to reduce the target type enough to     -- get to the actual data type.     -- Also #2947: The type might reduce to a pi type.+    -- Andreas, 2024-07-07, issue #6744, iteratively reduce.     TelV tel (El _ a) <- telViewPath t+    erasureOn <- optErasure <$> pragmaOptions+    -- Modalities of constructor arguments:+    let n = size tel+        -- Candidates for forced arguments, indexed by their de Bruijn index.+        -- 'Nothing' means cannot possibly be forced.+        forcedArgCands :: ForcedVariableCandidates+        forcedArgCands = listArray (0,n-1)+          [ -- Jesper, 2023-09-20 (#6867): With --erasure, only arguments with @0 can be forced.+            if (erasureOn `implies` hasQuantity0 m)+            -- Also the argument shouldn't be irrelevant, since in that+            -- case it isn't really forced.+            && (not $ isIrrelevant m)+            then Just m else Nothing+          | m <- map getModality $ reverse $ telToList tel+          ]+    -- Computation of forced arguments:     let vs = case a of           Def _ us -> us           _        -> __IMPOSSIBLE__-        n = size tel-        xs :: [(Modality, Nat)]-        xs = forcedVariables vs-        -- #2819: We can only mark an argument as forced if it appears in the-        -- type with a relevance below (i.e. more relevant) than the one of the-        -- constructor argument. Otherwise we can't actually get the value from-        -- the type. Also the argument shouldn't be irrelevant, since in that-        -- case it isn't really forced.-        isForced :: Modality -> Nat -> Bool-        isForced m i =-               (hasQuantity0 m || noUserQuantity m)-            && (getRelevance m /= Irrelevant)-            && any (\(m', j) -> i == j-            && m' `moreUsableModality` m) xs-        forcedArgs =-          [ if isForced m i then Forced else NotForced-          | (i, m) <- zip (downFrom n) $ map getModality (telToList tel)+    forcedVars <-+          -- No candidates, no winners!+      if all isNothing forcedArgCands then pure IntSet.empty+      else runReduceM $ execForcedVariableCollection forcedArgCands $ forcedVariables vs+    let forcedArgs =+          [ if IntSet.member i forcedVars then Forced else NotForced+          | i <- downFrom n           ]     reportS "tc.force" 60       [ "Forcing analysis for " ++ prettyShow c-      , "  xs          = " ++ show (map snd xs)+      , "  forcedVars  = " ++ show (IntSet.toList forcedVars)       , "  forcedArgs  = " ++ show forcedArgs       ]     return forcedArgs +-- | Candidates for forced constructor arguments (@Just m@) with their modality (@m@)+--   in the constructor telescope.+--+type ForcedVariableCandidates = Array Nat (Maybe Modality)++-- | Environment for forced variable collection.+--+data ForcedVariableContext = ForcedVariableContext+  { fvcModality   :: Modality+      -- ^ Modality of current position.  (Accumulated from traversed 'Arg's.)+  , fvcCandidates :: ForcedVariableCandidates+      -- ^ Candidates for forced variables.  (Immutable.)+  }++-- | Which candidates are actually forced?+--+type ForcedVariableState = IntSet++-- | Monad for forced variable analysis.+--+newtype ForcedVariableCollection' a = ForcedVariableCollection+  { runForcedVariableCollection :: ReaderT ForcedVariableContext (StateT ForcedVariableState ReduceM) a }+  deriving+    ( Functor, Applicative, Monad+    , MonadReader ForcedVariableContext, MonadState ForcedVariableState+    -- Needed for HasConstInfo:+    , MonadDebug, MonadTCEnv, HasOptions+    , HasConstInfo+    -- Neded for MonadReduce:+    , ReadTCState+    , MonadReduce+    )++type ForcedVariableCollection = ForcedVariableCollection' ()++instance Semigroup ForcedVariableCollection where+  ForcedVariableCollection m <> ForcedVariableCollection m' = ForcedVariableCollection (m >> m')++instance Monoid ForcedVariableCollection where+  mempty = ForcedVariableCollection $ pure ()++instance Singleton (Nat, Modality) ForcedVariableCollection where+  singleton (i, m) = ForcedVariableCollection do+    ForcedVariableContext mc cands <- ask+    whenJust (join $ cands Array.!? i) \ m0 -> do+      -- #2819: We can only mark an argument as forced if it appears in the+      -- type with a relevance below (i.e. more relevant) than the one of the+      -- constructor argument. Otherwise we can't actually get the value from+      -- the type.+      when (composeModality mc m `moreUsableModality` m0) do+        modify $ IntSet.insert i++-- | Step into an argument labelled with the given modality.+--+underModality :: Modality -> ForcedVariableCollection -> ForcedVariableCollection+underModality m = local \ (ForcedVariableContext mc cands) -> ForcedVariableContext (composeModality mc m) cands++-- | Run the forced variable analysis monad.+execForcedVariableCollection :: ForcedVariableCandidates -> ForcedVariableCollection -> ReduceM ForcedVariableState+execForcedVariableCollection cands (ForcedVariableCollection m) =+  m & (`runReaderT` cxt)+    & (`execStateT` IntSet.empty)+  where cxt = ForcedVariableContext unitModality cands+ -- | Compute the pattern variables of a term or term-like thing. class ForcedVariables a where-  forcedVariables :: a -> [(Modality, Nat)]+  forcedVariables :: a -> ForcedVariableCollection -  default forcedVariables :: (ForcedVariables b, Foldable t, a ~ t b) => a -> [(Modality, Nat)]+  default forcedVariables ::+    (ForcedVariables b, Foldable t, a ~ t b) =>+    a -> ForcedVariableCollection   forcedVariables = foldMap forcedVariables  instance ForcedVariables a => ForcedVariables [a] where@@ -139,19 +223,21 @@ -- Note that the 'a' does not include the 'Arg' in 'Apply'. instance ForcedVariables a => ForcedVariables (Elim' a) where   forcedVariables (Apply x) = forcedVariables x-  forcedVariables IApply{}  = []  -- No forced variables in path applications-  forcedVariables Proj{}    = []+  forcedVariables IApply{}  = mempty  -- No forced variables in path applications+  forcedVariables Proj{}    = mempty  instance ForcedVariables a => ForcedVariables (Arg a) where-  forcedVariables x = [ (composeModality m m', i) | (m', i) <- forcedVariables (unArg x) ]+  forcedVariables x =+    underModality m $ forcedVariables $ unArg x     where m = getModality x  -- | Assumes that the term is in normal form. instance ForcedVariables Term where-  forcedVariables = \case-    Var i [] -> [(unitModality, i)]-    Con _ _ vs -> forcedVariables vs-    _ -> []+  -- Andreas, 2024-07-07, issue #6744, add reduction.+  forcedVariables v = reduce v >>= \case+    Var i []   -> singleton (i, unitModality)+    Con c _ vs -> ifM (consOfHIT $ conName c) mempty $ {-else-} forcedVariables vs+    _          -> mempty  isForced :: IsForced -> Bool isForced Forced    = True
src/full/Agda/TypeChecking/Free.hs view
@@ -57,7 +57,7 @@     , flexRigOccurrenceIn     , closed     , MetaSet-    , insertMetaSet, foldrMetaSet+    , insertMetaSet, foldrMetaSet, metaSetToBlocker     ) where  import Prelude hiding (null)@@ -178,17 +178,17 @@ -- ** Flexible /rigid occurrence info for a single variable.  -- | Get the full occurrence information of a free variable.-flexRigOccurrenceIn :: Free a => Nat -> a -> Maybe (FlexRig' ())+flexRigOccurrenceIn :: Free a => Nat -> a -> Maybe FlexRig flexRigOccurrenceIn = flexRigOccurrenceIn' IgnoreNot -flexRigOccurrenceIn' :: Free a => IgnoreSorts -> Nat -> a -> Maybe (FlexRig' ())+flexRigOccurrenceIn' :: Free a => IgnoreSorts -> Nat -> a -> Maybe FlexRig flexRigOccurrenceIn' ig x t = theSingleFlexRig $ runFree sg ig t   where   sg y = if x == y then oneSingleFlexRig else mempty  -- | "Collection" just keeping track of the occurrence of a single variable. --   'Nothing' means variable does not occur freely.-newtype SingleFlexRig = SingleFlexRig { theSingleFlexRig :: Maybe (FlexRig' ()) }+newtype SingleFlexRig = SingleFlexRig { theSingleFlexRig :: Maybe FlexRig }  oneSingleFlexRig :: SingleFlexRig oneSingleFlexRig = SingleFlexRig $ Just $ oneFlexRig@@ -204,8 +204,8 @@   mempty = SingleFlexRig Nothing   mappend = (<>) -instance IsVarSet () SingleFlexRig where-  withVarOcc o = SingleFlexRig . fmap (composeFlexRig $ () <$ varFlexRig o) . theSingleFlexRig+instance IsVarSet MetaSet SingleFlexRig where+  withVarOcc o = SingleFlexRig . fmap (composeFlexRig $ varFlexRig o) . theSingleFlexRig  -- ** Plain free occurrence.
src/full/Agda/TypeChecking/Free/Lazy.hs view
@@ -60,15 +60,14 @@ module Agda.TypeChecking.Free.Lazy where  import Control.Applicative hiding (empty)-import Control.Monad        ( guard ) import Control.Monad.Reader ( MonadReader(..), asks, ReaderT, Reader, runReader )  import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap-import Data.IntSet (IntSet)-import qualified Data.IntSet as IntSet-import Data.Semigroup ( Semigroup, (<>) )-+import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import Data.Set (Set)+import qualified Data.Set as Set   import Agda.Syntax.Common@@ -76,6 +75,7 @@  import Agda.Utils.Functor import Agda.Utils.Lens+import Agda.Utils.List1 (List1) import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Semigroup@@ -87,18 +87,21 @@  -- | A set of meta variables.  Forms a monoid under union. -newtype MetaSet = MetaSet { theMetaSet :: IntSet }+newtype MetaSet = MetaSet { theMetaSet :: HashSet MetaId }   deriving (Eq, Show, Null, Semigroup, Monoid)  instance Singleton MetaId MetaSet where-  singleton = MetaSet . singleton . metaId+  singleton = MetaSet . singleton  insertMetaSet :: MetaId -> MetaSet -> MetaSet-insertMetaSet (MetaId m) (MetaSet ms) = MetaSet $ IntSet.insert m ms+insertMetaSet m (MetaSet ms) = MetaSet $ HashSet.insert m ms  foldrMetaSet :: (MetaId -> a -> a) -> a -> MetaSet -> a-foldrMetaSet f e ms = IntSet.foldr (f . MetaId) e $ theMetaSet ms+foldrMetaSet f e ms = HashSet.foldr f e $ theMetaSet ms +metaSetToBlocker :: MetaSet -> Blocker+metaSetToBlocker ms = unblockOnAny $ foldrMetaSet (Set.insert . unblockOnMeta) Set.empty ms+ --------------------------------------------------------------------------- -- * Flexible and rigid occurrences (semigroup) @@ -121,28 +124,28 @@  type FlexRig = FlexRig' MetaSet -class LensFlexRig a o | o -> a where-  lensFlexRig :: Lens' (FlexRig' a) o+class LensFlexRig o a | o -> a where+  lensFlexRig :: Lens' o (FlexRig' a) -instance LensFlexRig a (FlexRig' a) where-  lensFlexRig f x = f x+instance LensFlexRig (FlexRig' a) a where+  lensFlexRig = id -isFlexible :: LensFlexRig a o => o -> Bool+isFlexible :: LensFlexRig o a => o -> Bool isFlexible o = case o ^. lensFlexRig of   Flexible {} -> True   _ -> False -isUnguarded :: LensFlexRig a o => o -> Bool+isUnguarded :: LensFlexRig o a => o -> Bool isUnguarded o = case o ^. lensFlexRig of   Unguarded -> True   _ -> False -isWeaklyRigid :: LensFlexRig a o => o -> Bool+isWeaklyRigid :: LensFlexRig o a => o -> Bool isWeaklyRigid o = case o ^. lensFlexRig of    WeaklyRigid -> True    _ -> False -isStronglyRigid :: LensFlexRig a o => o -> Bool+isStronglyRigid :: LensFlexRig o a => o -> Bool isStronglyRigid o = case o ^. lensFlexRig of   StronglyRigid -> True   _ -> False@@ -228,9 +231,9 @@ instance LensQuantity (VarOcc' a) where  -- | Access to 'varFlexRig' in 'VarOcc'.-instance LensFlexRig a (VarOcc' a) where+instance LensFlexRig (VarOcc' a) a where   lensFlexRig f (VarOcc fr m) = f fr <&> \ fr' -> VarOcc fr' m--- lensFlexRig :: Lens' (FlexRig' a) (VarOcc' a)+-- lensFlexRig :: Lens' (VarOcc' a) (FlexRig' a) -- lensFlexRig f (VarOcc fr m) = f fr <&> \ fr' -> VarOcc fr' m  @@ -402,7 +405,7 @@ feIgnoreSorts :: FreeEnv' a IgnoreSorts c -> IgnoreSorts feIgnoreSorts = feExtra -instance LensFlexRig a (FreeEnv' a b c) where+instance LensFlexRig (FreeEnv' a b c) a where   lensFlexRig f e = f (feFlexRig e) <&> \ fr -> e { feFlexRig = fr }  instance LensModality (FreeEnv' a b c) where@@ -466,19 +469,25 @@ underRelevance :: (MonadReader r m, LensRelevance r, LensRelevance o) => o -> m z -> m z underRelevance = local . mapRelevance . composeRelevance . getRelevance +-- | In the given computation the 'Quantity' is locally scaled using+-- the 'Quantity' of the first argument.+underQuantity ::+  (MonadReader r m, LensQuantity r, LensQuantity o) => o -> m a -> m a+underQuantity = local . mapQuantity . composeQuantity . getQuantity+ -- | Changing the 'FlexRig' context.-underFlexRig :: (MonadReader r m, LensFlexRig a r, Semigroup a, LensFlexRig a o) => o -> m z -> m z+underFlexRig :: (MonadReader r m, LensFlexRig r a, Semigroup a, LensFlexRig o a) => o -> m z -> m z underFlexRig = local . over lensFlexRig . composeFlexRig . view lensFlexRig  -- | What happens to the variables occurring under a constructor?-underConstructor :: (MonadReader r m, LensFlexRig a r, Semigroup a) => ConHead -> Elims -> m z -> m z+underConstructor :: (MonadReader r m, LensFlexRig r a, Semigroup a) => ConHead -> Elims -> m z -> m z underConstructor (ConHead _c _d i fs) es =   case i of     -- Coinductive (record) constructors admit infinite cycles:     CoInductive -> underFlexRig WeaklyRigid     -- Inductive constructors do not admit infinite cycles:-    Inductive   | size es == size fs -> underFlexRig StronglyRigid-                | otherwise          -> underFlexRig WeaklyRigid+    Inductive   | natSize es == natSize fs -> underFlexRig StronglyRigid+                | otherwise                -> underFlexRig WeaklyRigid     -- Jesper, 2020-10-22: Issue #4995: treat occurrences in non-fully     -- applied constructors as weakly rigid.     -- Ulf, 2019-10-18: Now the termination checker treats inductive recursive records@@ -529,7 +538,7 @@     Sort s       -> freeVars' s     Level l      -> freeVars' l     MetaV m ts   -> underFlexRig (Flexible $ singleton m) $ freeVars' ts-    DontCare mt  -> underModality (Modality Irrelevant unitQuantity unitCohesion) $ freeVars' mt+    DontCare mt  -> underModality (Modality irrelevant unitQuantity unitCohesion unitPolarity) $ freeVars' mt     Dummy{}      -> mempty  instance Free t => Free (Type' t) where@@ -542,12 +551,12 @@   freeVars' s =     ifM (asks ((IgnoreAll ==) . feIgnoreSorts)) mempty $ {- else -}     case s of-      Type a     -> freeVars' a-      Prop a     -> freeVars' a+      Univ _ a   -> freeVars' a       Inf _ _    -> mempty-      SSet a     -> freeVars' a       SizeUniv   -> mempty       LockUniv   -> mempty+      LevelUniv  -> mempty+      IntervalUniv -> mempty       PiSort a s1 s2 -> underFlexRig (Flexible mempty) (freeVars' $ unDom a) `mappend`                         underFlexRig WeaklyRigid (freeVars' (s1, s2))       FunSort s1 s2 -> freeVars' s1 `mappend` freeVars' s2@@ -562,10 +571,12 @@ instance Free t => Free (PlusLevel' t) where   freeVars' (Plus _ l)    = freeVars' l -instance Free t => Free [t]            where-instance Free t => Free (Maybe t)      where-instance Free t => Free (WithHiding t) where+instance Free t => Free [t]+instance Free t => Free (List1 t)+instance Free t => Free (Maybe t)+instance Free t => Free (WithHiding t) instance Free t => Free (Named nm t)+instance Free t => Free (Ranged t)  instance (Free t, Free u) => Free (t, u) where   freeVars' (t, u) = freeVars' t `mappend` freeVars' u@@ -599,4 +610,4 @@   freeVars' = \case     OtherType t -> freeVars' t     IdiomType t -> freeVars' t-    EqualityType s _eq l t a b -> freeVars' (s, l, [t, a, b])+    EqualityType _r s _eq l t a b -> freeVars' (s, l, [t, a, b])
src/full/Agda/TypeChecking/Free/Precompute.hs view
@@ -1,23 +1,24 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Precompute free variables in a term (and store in 'ArgInfo'). module Agda.TypeChecking.Free.Precompute   ( PrecomputeFreeVars, precomputeFreeVars   , precomputedFreeVars, precomputeFreeVars_ ) where -import Control.Monad.Writer-import Data.IntSet (IntSet)-import qualified Data.IntSet as IntSet+import Control.Monad.Writer ( Writer, runWriter, censor, listen, tell ) +import Agda.Utils.VarSet (VarSet)+import qualified Agda.Utils.VarSet as VarSet+ import Agda.Syntax.Common import Agda.Syntax.Internal ---type FV = Writer IntSet+type FV = Writer VarSet  precomputeFreeVars_ :: PrecomputeFreeVars a => a -> a precomputeFreeVars_ = fst . runWriter . precomputeFreeVars -precomputedFreeVars :: PrecomputeFreeVars a => a -> IntSet+precomputedFreeVars :: PrecomputeFreeVars a => a -> VarSet precomputedFreeVars = snd . runWriter . precomputeFreeVars  class PrecomputeFreeVars a where@@ -49,14 +50,14 @@ instance PrecomputeFreeVars a => PrecomputeFreeVars (Abs a) where   precomputeFreeVars (NoAbs x b) = NoAbs x <$> precomputeFreeVars b   precomputeFreeVars (Abs x b) =-    censor (IntSet.map (subtract 1) . IntSet.delete 0) $+    censor (VarSet.subtract 1 . VarSet.delete 0) $       Abs x <$> precomputeFreeVars b  instance PrecomputeFreeVars Term where   precomputeFreeVars t =     case t of       Var x es -> do-        tell (IntSet.singleton x)+        tell (VarSet.singleton x)         Var x <$> precomputeFreeVars es       Lam i b    -> Lam i      <$> precomputeFreeVars b       Lit{}      -> pure t@@ -74,12 +75,12 @@ instance PrecomputeFreeVars Sort where   precomputeFreeVars s =     case s of-      Type a     -> Type <$> precomputeFreeVars a-      Prop a     -> Prop <$> precomputeFreeVars a+      Univ u a   -> Univ u <$> precomputeFreeVars a       Inf _ _    -> pure s-      SSet a     -> SSet <$> precomputeFreeVars a       SizeUniv   -> pure s       LockUniv   -> pure s+      LevelUniv  -> pure s+      IntervalUniv -> pure s       PiSort a s1 s2 -> PiSort <$> precomputeFreeVars a <*> precomputeFreeVars s1 <*> precomputeFreeVars s2       FunSort s1 s2 -> uncurry FunSort <$> precomputeFreeVars (s1, s2)       UnivSort s -> UnivSort <$> precomputeFreeVars s
src/full/Agda/TypeChecking/Free/Reduce.hs view
@@ -1,12 +1,16 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Free variable check that reduces the subject to make certain variables not --   free. Used when pruning metavariables in Agda.TypeChecking.MetaVars.Occurs. module Agda.TypeChecking.Free.Reduce   ( ForceNotFree   , forceNotFree+  , reallyFree   , IsFree(..)   ) where +import Prelude hiding (null)+ import Control.Monad.Reader import Control.Monad.State @@ -22,7 +26,9 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Free import Agda.TypeChecking.Free.Precompute+ import Agda.Utils.Monad+import Agda.Utils.Null  -- | A variable can either not occur (`NotFree`) or it does occur --   (`MaybeFree`).  In the latter case, the occurrence may disappear@@ -45,6 +51,35 @@   (a, mxs) <- runStateT (runReaderT (forceNotFreeR $ precomputeFreeVars_ a) mempty) mxs   return (mxs, a) +-- | Checks if the given term contains any free variables that are in+--   the given set of variables, possibly reducing the term in the+--   process.  Returns `Right Nothing` if there are such variables,+--   `Right (Just v')` if there are none (where v' is the possibly+--   reduced version of the given term) or `Left b` if the problem is+--   blocked on a meta.+reallyFree :: (MonadReduce m, Reduce a, ForceNotFree a)+           => IntSet -> a -> m (Either Blocked_ (Maybe a))+reallyFree xs v = do+  (mxs , v') <- forceNotFree xs v+  case IntMap.foldr pickFree NotFree mxs of+    MaybeFree ms+      | null ms   -> return $ Right Nothing+      | otherwise -> return $ Left $ Blocked blocker ()+      where blocker = metaSetToBlocker ms+    NotFree -> return $ Right (Just v')++  where+    -- Check if any of the variables occur freely.+    -- Prefer occurrences that do not depend on any metas.+    pickFree :: IsFree -> IsFree -> IsFree+    pickFree f1@(MaybeFree ms1) f2+      | null ms1  = f1+    pickFree f1@(MaybeFree ms1) f2@(MaybeFree ms2)+      | null ms2  = f2+      | otherwise = f1+    pickFree f1@(MaybeFree ms1) NotFree = f1+    pickFree NotFree f2 = f2+ type MonadFreeRed m =   ( MonadReader MetaSet m   , MonadState (IntMap IsFree) m@@ -140,9 +175,7 @@   -- Reduce for sorts already goes under all sort constructors, so we can get   -- away without forceNotFreeR here.   forceNotFree' = \case-    Type l     -> Type     <$> forceNotFree' l-    Prop l     -> Prop     <$> forceNotFree' l-    SSet l     -> SSet     <$> forceNotFree' l+    Univ u l     -> Univ u <$> forceNotFree' l     PiSort a b c -> PiSort <$> forceNotFree' a <*> forceNotFree' b <*> forceNotFree' c     FunSort a b -> FunSort <$> forceNotFree' a <*> forceNotFree' b     UnivSort s -> UnivSort <$> forceNotFree' s@@ -151,4 +184,6 @@     s@(Inf _ _)-> return s     s@SizeUniv -> return s     s@LockUniv -> return s+    s@LevelUniv -> return s+    s@IntervalUniv -> return s     s@DummyS{} -> return s
src/full/Agda/TypeChecking/Functions.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Functions   ( etaExpandClause@@ -12,6 +13,7 @@ import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Context import Agda.TypeChecking.Monad.Debug+import Agda.TypeChecking.Monad.Pure import Agda.TypeChecking.Level import Agda.TypeChecking.Pretty import Agda.TypeChecking.Reduce@@ -20,7 +22,7 @@  import Agda.Utils.Impossible import Agda.Utils.Functor ( ($>) )-import Agda.Utils.Pretty ( prettyShow )+import Agda.Syntax.Common.Pretty ( prettyShow ) import Agda.Utils.Monad import Agda.Utils.Size @@ -35,12 +37,12 @@ --  This is used instead of special treatment of lambdas --  (which was unsound: Issue #121) -etaExpandClause :: MonadTCM tcm => Clause -> tcm Clause-etaExpandClause clause = liftTCM $ do+etaExpandClause :: PureTCM tcm => Clause -> tcm Clause+etaExpandClause clause = do   case clause of     Clause _  _  ctel ps _           Nothing  _ _ _ _ _ -> return clause     Clause _  _  ctel ps Nothing     (Just t) _ _ _ _ _ -> return clause-    Clause rl rf ctel ps (Just body) (Just t) catchall exact recursive unreachable ell -> do+    Clause rl rf ctel ps (Just body) (Just t) catchall recursive unreachable ell wm -> do        -- Get the telescope to expand the clause with.       TelV tel0 t' <- addContext ctel $ telView $ unArg t@@ -62,7 +64,7 @@         , "  xs      = " <+> text (prettyShow xs)         , "  new tel = " <+> prettyTCM ctel'         ]-      return $ Clause rl rf ctel' ps' (Just body') (Just (t $> t')) catchall exact recursive unreachable ell+      return $ Clause rl rf ctel' ps' (Just body') (Just (t $> t')) catchall recursive unreachable ell wm   where     -- Get all initial lambdas of the body.     peekLambdas :: Term -> [Arg ArgName]
src/full/Agda/TypeChecking/Generalize.hs view
@@ -1,4 +1,116 @@+{-# OPTIONS_GHC -Wunused-imports #-} +{-|++This module implements the type checking part of generalisable variables. When we get here we have+a type checking problem for a type (or telescope) containing a known set of generalisable variables+and we need to produce a well typed type (or telescope) with the correct generalisations. For instance,+given++@+variable+  A  : Set+  n  : Nat+  xs : Vec A n++foo : SomeType xs+@++generalisation should produce @{A : Set} {n : Nat} {xs : Vec A n} → SomeType xs@ for the type of+@foo@.++The functions `generalizeType` and `generalizeTelescope` don't have access to the abstract syntax to+be type checked (@SomeType xs@ in the example). Instead they are provided a type checking action+that delivers a `Type` or a `Telescope`. The challenge is setting up a context in which @SomeType+xs@ can be type checked successfully by this action, without knowing what the telescope of+generalised variables will be. Once we have computed this telescope the result needs to be+transformed into a well typed type abstracted over it.++__At no point are we allowed to cheat!__ Any transformation between well typed terms needs to be done+by well typed substitutions.++The key idea is to run the type checking action in the context of a single variable of an unknown+type. Once we know what variables to generalise over this type is instantiated to a fresh record+type with a field for each generalised variable. Turning the result of action into something valid+in the context of the generalised variables is then a simple substitution unpacking the record+variable.++In more detail, generalisation proceeds as follows:++- Add a variable @genTel@ of an unknown type to the context (`withGenRecVar`).++@+  (genTel : _GenTel)+@++- Create metavariables for the generalisable variables appearing in the problem and their+  dependencies (`createGenValues`). In the example this would be++@+  (genTel : _GenTel) ⊢+    _A  : Set+    _n  : Nat+    _xs : Vec _A _n+@++- Run the type checking action (`createMetasAndTypeCheck`), binding the mentioned generalisable+  variables to the corresponding newly created metavariables. This binding is stored in+  `eGeneralizedVars` and picked up in `Agda.TypeChecking.Rules.Application.inferDef`++@+  (genTel : _GenTel) ⊢ SomeType (_xs genTel)+@++- Compute the telescope of generalised variables (`computeGeneralization`). This is done by taking+  the unconstrained metavariables created by `createGenValues` or created during the type checking+  action and sorting them into a well formed telescope.++@+  {A : Set} {n : Nat} {xs : Vec A n}+@++- Create a record type @GeneralizeTel@ whose fields are the generalised variables and instantiate+  the type of @genTel@ to it (`createGenRecordType`).++@+  record GeneralizeTel : Set₁ where+    constructor mkGeneralizeTel+    field+      A  : Set+      n  : Nat+      xs : Vec A n+@++- Solve the metavariables with their corresponding projections from @genTel@.++@+  _A  := λ genTel → genTel .A+  _n  := λ genTel → genTel .n+  _xs := λ genTel → genTel .xs+@++- Build the unpacking substitution (`unpackSub`) that maps terms in @(genTel : GeneralizeTel)@ to+  terms in the context of the generalised variables by substituting a record value for @genTel@.++@+  {A : Set} {n : Nat} {xs : Vec A n} ⊢ [mkGeneralizeTel A n xs / genTel] : (genTel : GeneralizeTel)+@++- Build the final result by applying the unpacking substitution to the result of the type checking+  action and abstracting over the generalised telescope.++@+  {A : Set} {n : Nat} {xs : Vec A n} → SomeType (_xs (mkGeneralizeTel A n xs)) ==+  {A : Set} {n : Nat} {xs : Vec A n} → SomeType xs+@++- In case of `generalizeType` return the resulting pi type.+- In case of `generalizeTelescope` enter the resulting context, applying the unpacking substitution+  to let bindings (TODO #6916: and also module applications!) created in the telescope, and call the+  continuation.++-}+ module Agda.TypeChecking.Generalize   ( generalizeType   , generalizeType'@@ -6,23 +118,25 @@  import Prelude hiding (null) -import Control.Arrow (first)-import Control.Monad-import Control.Monad.Except+import Control.Monad.Except ( MonadError(..) ) -import qualified Data.IntMap as IntMap+import Data.Bifunctor (first) import qualified Data.IntSet as IntSet import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map+import qualified Data.Map.Strict as MapS import Data.List (partition, sortBy) import Data.Monoid-import Data.Function (on) +import Agda.Interaction.Options.Base+ import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty (prettyShow, singPlural) import Agda.Syntax.Concrete.Name (LensInScope(..)) import Agda.Syntax.Position+import Agda.Syntax.Info          (MetaNameSuggestion) import Agda.Syntax.Internal import Agda.Syntax.Internal.Generic import Agda.Syntax.Internal.MetaVars@@ -32,7 +146,6 @@ import Agda.TypeChecking.Constraints import Agda.TypeChecking.Conversion import Agda.TypeChecking.Free-import Agda.TypeChecking.Irrelevance import Agda.TypeChecking.InstanceArguments (postponeInstanceConstraints) import Agda.TypeChecking.MetaVars import Agda.TypeChecking.Pretty@@ -44,17 +157,19 @@ import Agda.Benchmarking (Phase(Typing, Generalize)) import Agda.Utils.Benchmark import qualified Agda.Utils.BiMap as BiMap+import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Impossible-import Agda.Utils.List   (hasElem)+import Agda.Utils.Lens+import Agda.Utils.List (downFrom, hasElem)+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null+import qualified Agda.Utils.Set1 as Set1 import Agda.Utils.Size import Agda.Utils.Permutation-import Agda.Utils.Pretty (prettyShow) - -- | Generalize a telescope over a set of generalizable variables. generalizeTelescope :: Map QName Name -> (forall a. (Telescope -> TCM a) -> TCM a) -> ([Maybe Name] -> Telescope -> TCM a) -> TCM a generalizeTelescope vars typecheckAction ret | Map.null vars = typecheckAction (ret [])@@ -62,9 +177,13 @@   let s = Map.keysSet vars   ((cxtNames, tel, letbinds), namedMetas, allmetas) <-     createMetasAndTypeCheck s $ typecheckAction $ \ tel -> do-      cxt <- take (size tel) <$> getContext+      xs <- take (size tel) <$> getContextNames'       lbs <- getLetBindings -- This gives let-bindings valid in the current context-      return (map (fst . unDom) cxt, tel, lbs)+      return (xs, tel, lbs)++  reportSDoc "tc.generalize.metas" 60 $ vcat+    [ "open metas =" <+> (text . show . fmap ((miNameSuggestion &&& miGeneralizable) . mvInfo)) (openMetas $ allmetas)+    ]   -- Translate the QName to the corresponding bound variable   (genTel, genTelNames, sub) <- computeGeneralization genRecMeta namedMetas allmetas @@ -77,16 +196,17 @@   -- level of contexts (as a Context -> Context function), so we repeat the name logic here. Take   -- care to preserve the name of named generalized variables.   let setName name d = first (const name) <$> d-      cxtEntry (mname, d) = do+      cxtEntry (mname, dom) = do+          let s = fst $ unDom dom           name <- maybe (setNotInScope <$> freshName_ s) return mname-          return $ setName name d-        where s  = fst $ unDom d+          return $ CtxVar name (snd <$> dom)       dropCxt err = updateContext (strengthenS err 1) (drop 1)   genTelCxt <- dropCxt __IMPOSSIBLE__ $ mapM cxtEntry $ reverse $ zip genTelVars $ telToList genTel    -- For the explicit module telescope we get the names from the typecheck   -- action.-  let newTelCxt = zipWith setName cxtNames $ reverse $ telToList tel'+  let newTelCxt :: [ContextEntry]+      newTelCxt = zipWith CtxVar cxtNames $ reverse $ map (fmap snd) $ telToList tel'    -- We are in context Γ (r : R) and should call the continuation in context Γ Δ Θρ passing it Δ Θρ   -- We have@@ -97,8 +217,10 @@   -- And we shouldn't forget about the let-bindings (#3470)   --   Γ (r : R) Θ ⊢ letbinds   --   Γ Δ Θρ      ⊢ letbinds' = letbinds(lift |Θ| ρ)+  -- And modules created in the telescope (#6916)+  --   TODO   letbinds' <- applySubst (liftS (size tel) sub) <$> instantiateFull letbinds-  let addLet (x, (v, dom)) = addLetBinding' x v dom+  let addLet (x, LetBinding o v dom) = addLetBinding' o x v dom    updateContext sub ((genTelCxt ++) . drop 1) $     updateContext (raiseS (size tel')) (newTelCxt ++) $@@ -116,6 +238,11 @@ generalizeType' s typecheckAction = billTo [Typing, Generalize] $ withGenRecVar $ \ genRecMeta -> do    ((t, userdata), namedMetas, allmetas) <- createMetasAndTypeCheck s typecheckAction++  reportSDoc "tc.generalize.metas" 60 $ vcat+    [ "open metas =" <+> (text . show . fmap ((miNameSuggestion &&& miGeneralizable) . mvInfo)) (openMetas $ allmetas)+    ]+   (genTel, genTelNames, sub) <- computeGeneralization genRecMeta namedMetas allmetas    t' <- abstract genTel . applySubst sub <$> instantiateFull t@@ -128,7 +255,7 @@  -- | Create metas for the generalizable variables and run the type check action. createMetasAndTypeCheck ::-  Set QName -> TCM a -> TCM (a, Map MetaId QName, MetaStore)+  Set QName -> TCM a -> TCM (a, Map MetaId QName, LocalMetaStores) createMetasAndTypeCheck s typecheckAction = do   ((namedMetas, x), allmetas) <- metasCreatedBy $ do     (metamap, genvals) <- createGenValues s@@ -147,27 +274,45 @@   genRecMeta <- newTypeMeta (mkType 0)   addContext (defaultDom ("genTel" :: String, genRecMeta)) $ ret genRecMeta --- | Compute the generalized telescope from metas created when checking the type/telescope to be+-- | Compute the generalized telescope from metas created when checking the *thing* (type or telescope) to be --   generalized. Called in the context extended with the telescope record variable (whose type is --   the first argument). Returns the telescope of generalized variables and a substitution from --   this telescope to the current context.-computeGeneralization ::-  Type -> Map MetaId name -> MetaStore ->-  TCM (Telescope, [Maybe name], Substitution)+computeGeneralization+  :: Type+       -- ^ The metavariable to be instantiated with record type containing+       --   as fields the variables generalized in the *thing*.+  -> Map MetaId name+       -- ^ Metas created from an occurrence of a @variable@. (The original free variables.)+       --   E.g. if you have+       --   @+       --     variable  l : Level; A : Set l+       --     postulate f : A → A+       --   @+       --   then @A@ would be in this @Map@, but not @l@.+  -> LocalMetaStores+       -- ^ The metas created when type-checking the *thing*.+  -> TCM (Telescope, [Maybe name], Substitution)+       -- ^ The telescope together with binder name (left-to-right order),+       --   and substitution from this telescope to the current context. computeGeneralization genRecMeta nameMap allmetas = postponeInstanceConstraints $ do    reportSDoc "tc.generalize" 10 $ "computing generalization for type" <+> prettyTCM genRecMeta    -- Pair metas with their metaInfo-  mvs <- mapM ((\ x -> (x,) <$> lookupMeta x) . MetaId) $ IntMap.keys allmetas+  let mvs :: [(MetaId, MetaVariable)]+      mvs = MapS.assocs (openMetas allmetas) +++            MapS.assocs (solvedMetas allmetas)    -- Issue 4727: filter out metavariables that were created before the   -- current checkpoint, since they are too old to be generalized.   -- TODO: make metasCreatedBy smarter so it doesn't see pruned   -- versions of old metas as new metas.   cp <- viewTC eCurrentCheckpoint-  let isFreshMeta (x,mv) = enterClosure mv $ \ _ -> isJust <$> checkpointSubstitution' cp-  mvs <- filterM isFreshMeta mvs+  let isFreshMeta :: MonadReduce m => MetaVariable -> m Bool+      isFreshMeta mv = enterClosure mv $ \ _ -> isJust <$> checkpointSubstitution' cp+  mvs :: [(MetaId, MetaVariable)] <- filterM (isFreshMeta . snd) mvs+   cs <- (++) <$> useTC stAwakeConstraints              <*> useTC stSleepingConstraints @@ -201,14 +346,14 @@     ]    -- Issue 3301: We can't generalize over sorts-  unlessNull openSortMetas $ \ ms ->-    warning $ CantGeneralizeOverSorts $ map fst ms+  List1.unlessNull openSortMetas $ \ ms ->+    warning $ CantGeneralizeOverSorts $ Set1.fromList $ fmap fst ms    -- Any meta in the solution of a generalizable meta should be generalized over (if possible).   cp <- viewTC eCurrentCheckpoint   let canGeneralize x | isConstrained x = return False       canGeneralize x = do-          mv   <- lookupMeta x+          mv   <- lookupLocalMeta x           msub <- enterClosure mv $ \ _ ->                     checkpointSubstitution' cp           let sameContext =@@ -223,10 +368,10 @@                   (Just IdS, Perm m xs)        -> xs == [0 .. m - 1]                   (Just (Wk n IdS), Perm m xs) -> xs == [0 .. m - n - 1]                   _                            -> False-          unless sameContext $ do+          unless sameContext $ reportSDoc "tc.generalize" 20 $ do             ty <- getMetaType x             let Perm m xs = mvPermutation mv-            reportSDoc "tc.generalize" 20 $ vcat+            vcat               [ text "Don't know how to generalize over"               , nest 2 $ prettyTCM x <+> text ":" <+> prettyTCM ty               , text "in context"@@ -234,23 +379,25 @@               , text "permutation:" <+> text (show (m, xs))               , text "subst:" <+> pretty msub ]           return sameContext-  inherited <- fmap Set.unions $ forM generalizableClosed $ \ (x, mv) ->++  inherited :: Set MetaId <- Set.unions <$> forM generalizableClosed \ (x, mv) ->     case mvInstantiation mv of-      InstV _ v -> do+      InstV inst -> do         parentName <- getMetaNameSuggestion x-        metas <- filterM canGeneralize . Set.toList . allMetas Set.singleton =<< instantiateFull v-        let suggestNames i [] = return ()-            suggestNames i (m : ms) = do-              -- #4291: Override existing meta name suggestion. If we solved the parent with a new-              --        meta use the parent name for that, otherwise suffix with a number.-              let suf | null ms && i == 1, MetaV{} <- v = ""-                      | otherwise                       = "." ++ show i-              setMetaNameSuggestion m (parentName ++ suf)-              suggestNames (i + 1) ms-        unless (null metas) $-          reportSDoc "tc.generalize" 40 $ hcat ["Inherited metas from ", prettyTCM x, ":"] <?> prettyList_ (map prettyTCM metas)-                                    -- Don't suggest names for explicitly named generalizable metas-        Set.fromList metas <$ suggestNames 1 (filter (`Map.notMember` nameMap) metas)+        metas <- filterM canGeneralize . Set.toList .+                 allMetas Set.singleton =<<+                 instantiateFull (instBody inst)+        unless (null metas) do+          reportSDoc "tc.generalize" 40 $+            hcat ["Inherited metas from ", prettyTCM x, ":"] <?> prettyList_ (map prettyTCM metas)+          -- #4291: Override existing meta name suggestion.+          -- Don't suggest names for explicitly named generalizable metas.+          case filter (`Map.notMember` nameMap) metas of+            -- If we solved the parent with a new meta use the parent name for that.+            [m] | MetaV{} <- instBody inst -> setMetaNameSuggestion m parentName+            -- Otherwise suffix with a number.+            ms -> zipWithM_ (\ i m -> setMetaNameSuggestion m (parentName ++ "." ++ show i)) [1..] ms+        return $ Set.fromList metas       _ -> __IMPOSSIBLE__    let (alsoGeneralize, reallyDontGeneralize) = partition (`Set.member` inherited) $ map fst nongeneralizableOpen@@ -303,11 +450,11 @@   -- Build the telescope of generalized metas   teleTypes <- do     args <- getContextArgs-    fmap concat $ forM sortedMetas $ \ m -> do-      mv   <- lookupMeta m+    concat <$> forM sortedMetas \ m -> do+      mv <- lookupLocalMeta m       let info =-            hideOrKeepInstance $-            getArgInfo $ miGeneralizable $ mvInfo mv+            (hideOrKeepInstance $+            getArgInfo $ miGeneralizable $ mvInfo mv) { argInfoOrigin = Generalization }           HasType{ jMetaType = t } = mvJudgement mv           perm = mvPermutation mv       t' <- piApplyM t $ permute (takeP (length args) perm) args@@ -315,12 +462,16 @@   let genTel = buildGeneralizeTel genRecCon teleTypes    reportSDoc "tc.generalize" 40 $ vcat-    [ text "genTel =" <+> prettyTCM genTel ]+    [ text "teleTypes =" <+> prettyTCM teleTypes+    , text "genTel    =" <+> prettyTCM genTel+    ]    -- Now we need to prune the unsolved metas to make sure they respect the new   -- dependencies (#3672). Also update interaction points to point to pruned metas.   let inscope (ii, InteractionPoint{ipMeta = Just x})-        | IntMap.member (metaId x) allmetas = Just (x, ii)+        | MapS.member x (openMetas allmetas) ||+          MapS.member x (solvedMetas allmetas) =+          Just (x, ii)       inscope _ = Nothing   ips <- Map.fromDistinctAscList . mapMaybe inscope . fst . BiMap.toDistinctAscendingLists <$> useTC stInteractionPoints   pruneUnsolvedMetas genRecName genRecCon genTel genRecFields ips shouldGeneralize allSortedMetas@@ -332,6 +483,15 @@   -- value packing up the generalized variables for the genTel variable.   let sub = unpackSub genRecCon (map (argInfo . fst) teleTypes) (length teleTypes) +  -- Instantiate all fresh meta-variables to get rid of+  -- __DUMMY_TERM__.+  genTel <- flip instantiateWhen genTel $ \m -> do+    mv <- lookupMeta m+    case mv of+      Nothing         -> __IMPOSSIBLE__+      Just Left{}     -> return False+      Just (Right mv) -> isFreshMeta mv+   return (genTel, telNames, sub)  -- | Prune unsolved metas (#3672). The input includes also the generalized metas and is sorted in@@ -345,8 +505,7 @@     prune cxt tel (x : xs) | not (isGeneralized x) = do       -- If x is a blocked term we shouldn't instantiate it.       whenM (not <$> isBlockedTerm x) $ do-        x <- if size tel > 0 then prePrune x-                             else return x+        x <- if null tel then return x else prePrune x         pruneMeta (telFromList $ reverse cxt) x       prune cxt tel xs     prune cxt (ExtendTel a tel) (x : xs) = prune (fmap (x,) a : cxt) (unAbs tel) xs@@ -373,14 +532,14 @@       r <- getMetaRange x       genericDocError =<<         (fwords (msg ++ " The problematic unsolved meta is") $$-                 (nest 2 $ prettyTCM (MetaV x []) <+> "at" <+> pretty r)+                 nest 2 (prettyTCM (MetaV x []) <+> "at" <+> pretty r)         )      -- If one of the fields depend on this meta, we have to make sure that this meta doesn't depend     -- on any variables introduced after the genRec. See test/Fail/Issue3672b.agda for a test case.     prePrune x = do       cp <- viewTC eCurrentCheckpoint-      mv <- lookupMeta x+      mv <- lookupLocalMeta x       (i, _A) <- enterClosure mv $ \ _ -> do         δ <- checkpointSubstitution cp         _A <- case mvJudgement mv of@@ -432,7 +591,7 @@      pruneMeta _Θ x = do       cp <- viewTC eCurrentCheckpoint-      mv <- lookupMeta x+      mv <- lookupLocalMeta x       -- The reason we are doing all this inside the closure of x is so that if x is an interaction       -- meta we get the right context for the pruned interaction meta.       enterClosure mv $ \ _ ->@@ -505,10 +664,10 @@         -- current context and generate fresh ones for the generalized variables in Θ.         (newCxt, rΘ) <- do           (rΔ, _ : rΓ) <- splitAt i <$> getContext-          let setName = traverse $ \ (s, ty) -> (,ty) <$> freshName_ s+          let setName dom@(Dom {unDom = (s,ty)}) = CtxVar <$> freshName_ s <*> (pure $ dom $> ty)           rΘ <- mapM setName $ reverse $ telToList _Θγ-          let rΔσ = zipWith (\ name dom -> first (const name) <$> dom)-                            (map (fst . unDom) rΔ)+          let rΔσ = zipWith (\ name dom -> CtxVar name (snd <$> dom))+                            (map ctxEntryName rΔ)                             (reverse $ telToList _Δσ)           return (rΔσ ++ rΘ ++ rΓ, rΘ) @@ -555,10 +714,15 @@     findGenRec :: MetaVariable -> TCM (Maybe Int)     findGenRec mv = do       cxt <- instantiateFull =<< getContext-      let notPruned = permute (takeP (length cxt) $ mvPermutation mv) $-               reverse $ zipWith const [0..] cxt-      case [ i | (i, Dom{unDom = (_, El _ (Def q _))}) <- zip [0..] cxt,-                 q == genRecName, i `elem` notPruned ] of+      let n         = length cxt+          notPruned = IntSet.fromList $+                      permute (takeP n $ mvPermutation mv) $+                      downFrom n+      case [ i+           | (i, CtxVar _ (Dom{unDom = (El _ (Def q _))})) <- zip [0..] cxt+           , q == genRecName+           , i `IntSet.member` notPruned+           ] of         []    -> return Nothing         _:_:_ -> __IMPOSSIBLE__         [i]   -> return (Just i)@@ -605,9 +769,11 @@           names   = map (fst . unDom) telList           late    = map (fst . unDom) $ filter (getAny . allMetas (Any . (== x))) telList           projs (Proj _ q)-            | q `elem` genRecFields = Set.fromList $ catMaybes [getGeneralizedFieldName q]-          projs _                 = Set.empty-          early = Set.toList $ flip foldTerm u $ \ case+            | q `elem` genRecFields+            , Just y <- getGeneralizedFieldName q+            = Set.singleton y+          projs _ = Set.empty+          early = flip foldTerm u \case                   Var _ es   -> foldMap projs es                   Def _ es   -> foldMap projs es                   MetaV _ es -> foldMap projs es@@ -622,11 +788,12 @@                      "clear, but simply mentioning the variables in the right order should also work."           order = sep [ fwords "Dependency analysis suggested this (likely incorrect) order:",                         nest 2 $ fwords (unwords names) ]-          guess = "After constraint solving it looks like " ++ commas late ++ " actually depend" ++ s ++-                  " on " ++ commas early-            where-              s | length late == 1 = "s"-                | otherwise        = ""+          guess = unwords+            [ "After constraint solving it looks like", commas late+            , "actually"+            , singPlural late (<> "s") id "depend"  -- NB: this is a singular "s"+            , "on", commas $ Set.toList early+            ]       genericDocError =<< vcat         [ fwords $ "Variable generalization failed."         , nest 2 $ sep ["- Probable cause", nest 4 $ fwords cause]@@ -634,11 +801,11 @@         , nest 2 $ sep $ ["- Further information"                          , nest 2 $ "-" <+> order ] ++                          [ nest 2 $ "-" <+> fwords guess | not (null late), not (null early) ] ++-                         [ nest 2 $ "-" <+> sep [ fwords "The dependency I error is", prettyTCM err' ] ]+                         [ nest 2 $ "-" <+> sep [ fwords "The dependency error is", prettyTCM err' ] ]         ]      addNamedVariablesToScope cxt =-      forM_ cxt $ \ Dom{ unDom = (x, _) } -> do+      forM_ cxt $ \ (CtxVar x _) -> do         -- Recognize named variables by lack of '.' (TODO: hacky!)         reportSLn "tc.generalize.eta.scope" 40 $ "Adding (or not) " ++ prettyShow (nameConcrete x) ++ " to the scope"         when ('.' `notElem` prettyShow (nameConcrete x)) $ do@@ -674,7 +841,7 @@ --    (x₂ : A₂ [ r := c x₁ _    .. _ ]) --    (x₃ : A₃ [ r := c x₁ x₂ _ .. _ ]) --    ...-buildGeneralizeTel :: ConHead -> [(Arg String, Type)] -> Telescope+buildGeneralizeTel :: ConHead -> [(Arg MetaNameSuggestion, Type)] -> Telescope buildGeneralizeTel con xs = go 0 xs   where     infos = map (argInfo . fst) xs@@ -685,42 +852,52 @@             dom = defaultNamedArgDom (getArgInfo name) (unArg name)  -- | Create metas for all used generalizable variables and their dependencies.-createGenValues :: Set QName -> TCM (Map MetaId QName, Map QName GeneralizedValue)+createGenValues ::+     Set QName+       -- ^ Possibly empty set of generalizable variables.+  -> TCM (Map MetaId QName, Map QName GeneralizedValue)+       -- ^ A bimap from generalizable variables to their metas. createGenValues s = do   genvals <- locallyTC eGeneralizeMetas (const YesGeneralizeVar) $-               mapM createGenValue $ sortBy (compare `on` getRange) $ Set.toList s-  let metaMap = Map.fromListWith __IMPOSSIBLE__ [ (m, x) | (x, m, _) <- genvals ]-      nameMap = Map.fromListWith __IMPOSSIBLE__ [ (x, v) | (x, _, v) <- genvals ]+    forM (sortBy (compare `on` getRange) $ Set.toList s) \ x -> do+      (x,) <$> createGenValue x+  let metaMap = Map.fromListWith __IMPOSSIBLE__ [ (m, x) | (x, (m, _)) <- genvals ]+      nameMap = Map.fromListWith __IMPOSSIBLE__ [ (x, v) | (x, (_, v)) <- genvals ]   return (metaMap, nameMap) --- | Create a generalisable meta for a generalisable variable.-createGenValue :: QName -> TCM (QName, MetaId, GeneralizedValue)+-- | Create a generalizable meta for a generalizable variable.+createGenValue ::+     QName+       -- ^ Name of a generalizable variable.+  -> TCM (MetaId, GeneralizedValue)+       -- ^ Generated metavariable and its representation as typed term. createGenValue x = setCurrentRange x $ do   cp  <- viewTC eCurrentCheckpoint+   def <- instantiateDef =<< getConstInfo x-                   -- Only prefix of generalizable arguments (for now?)-  let nGen       = case defArgGeneralizable def of-                     NoGeneralizableArgs     -> 0-                     SomeGeneralizableArgs n -> n-      ty         = defType def-      TelV tel _ = telView' ty-      -- Generalizable variables are never explicit, so if they're given as-      -- explicit we default to hidden.-      hideExplicit arg | visible arg = hide arg-                       | otherwise   = arg-      argTel     = telFromList $ map hideExplicit $ take nGen $ telToList tel+  let+    nGen = case theDef def of+      GeneralizableVar NoGeneralizableArgs       -> 0+      GeneralizableVar (SomeGeneralizableArgs n) -> n+      _ -> __IMPOSSIBLE__ +    ty         = defType def+    TelV tel _ = telView' ty+    -- Generalizable variables are never explicit, so if they're given as+    -- explicit we default to hidden.+    argTel     = telFromList $ map hideExplicit $ take nGen $ telToList tel+   args <- newTelMeta argTel   metaType <- piApplyM ty args -  let name     = prettyShow (nameConcrete $ qnameName x)+  let name = prettyShow $ nameConcrete $ qnameName x   (m, term) <- newNamedValueMeta DontRunMetaOccursCheck name CmpLeq metaType    -- Freeze the meta to prevent named generalizable metas from being   -- instantiated, and set the quantity of the meta to the declared   -- quantity of the generalisable variable.   updateMetaVar m $ \ mv ->-    setQuantity (getQuantity (defArgInfo def)) $+    setModality (getModality (defArgInfo def)) $     mv { mvFrozen = Frozen }    -- Set up names of arg metas@@ -745,14 +922,21 @@     MetaV{} -> return ()     _       -> genericDocError =<< ("Cannot generalize over" <+> prettyTCM x <+> "of eta-expandable type") <?>                                     prettyTCM metaType-  return (x, m, GeneralizedValue{ genvalCheckpoint = cp-                                , genvalTerm       = term-                                , genvalType       = metaType })+  return . (m,) $ GeneralizedValue+    { genvalCheckpoint = cp+    , genvalTerm       = term+    , genvalType       = metaType+    } +  where+    hideExplicit :: LensHiding a => a -> a+    hideExplicit = applyWhenIts visible hide++ -- | Create a not-yet correct record type for the generalized telescope. It's not yet correct since --   we haven't computed the telescope yet, and we need the record type to do it. createGenRecordType :: Type -> [MetaId] -> TCM (QName, ConHead, [QName])-createGenRecordType genRecMeta@(El genRecSort _) sortedMetas = do+createGenRecordType genRecMeta@(El genRecSort _) sortedMetas = noMutualBlock $ do   current <- currentModule   let freshQName s = qualify current <$> freshName_ (s :: String)       mkFieldName  = freshQName . (generalizedFieldName ++) <=< getMetaNameSuggestion@@ -765,45 +949,38 @@                   , conFields    = map argFromDom genRecFields                   }   projIx <- succ . size <$> getContext+  erasure <- optErasure <$> pragmaOptions   inTopContext $ forM_ (zip sortedMetas genRecFields) $ \ (meta, fld) -> do     fieldTy <- getMetaType meta     let field = unDom fld-    addConstant' field (getArgInfo fld) field fieldTy $-      let proj = Projection { projProper   = Just genRecName-                            , projOrig     = field-                            , projFromType = defaultArg genRecName-                            , projIndex    = projIx-                            , projLams     = ProjLams [defaultArg "gtel"] } in-      Function { funClauses      = []-               , funCompiled     = Nothing-               , funSplitTree    = Nothing-               , funTreeless     = Nothing-               , funInv          = NotInjective-               , funMutual       = Just []-               , funAbstr        = ConcreteDef-               , funDelayed      = NotDelayed-               , funProjection   = Just proj-               , funFlags        = Set.empty-               , funTerminates   = Just True-               , funExtLam       = Nothing-               , funWith         = Nothing-               , funCovering     = []-               }-  addConstant' (conName genRecCon) defaultArgInfo (conName genRecCon) __DUMMY_TYPE__ $ -- Filled in later+    addConstant' field (getArgInfo fld) fieldTy $ FunctionDefn $+      (emptyFunctionData_ erasure)+        { _funMutual     = Just []+        , _funTerminates = Just True+        , _funProjection = Right Projection+          { projProper   = Just genRecName+          , projOrig     = field+          , projFromType = defaultArg genRecName+          , projIndex    = projIx+          , projLams     = ProjLams [defaultArg "gtel"]+          }+        }+  addConstant' (conName genRecCon) defaultArgInfo __DUMMY_TYPE__ $ -- Filled in later     Constructor { conPars   = 0                 , conArity  = length genRecFields                 , conSrcCon = genRecCon                 , conData   = genRecName                 , conAbstr  = ConcreteDef-                , conInd    = Inductive                 , conComp   = emptyCompKit                 , conProj   = Nothing                 , conForced = []                 , conErased = Nothing+                , conErasure = erasure+                , conInline  = False                 }   let dummyTel 0 = EmptyTel       dummyTel n = ExtendTel (defaultDom __DUMMY_TYPE__) $ Abs "_" $ dummyTel (n - 1)-  addConstant' genRecName defaultArgInfo genRecName (sort genRecSort) $+  addConstant' genRecName defaultArgInfo (sort genRecSort) $     Record { recPars         = 0            , recClause       = Nothing            , recConHead      = genRecCon@@ -814,6 +991,7 @@            , recEtaEquality' = Inferred YesEta            , recPatternMatching = CopatternMatching            , recInduction    = Nothing+           , recTerminates   = Just True    -- not recursive            , recAbstr        = ConcreteDef            , recComp         = emptyCompKit            }@@ -849,7 +1027,26 @@   reportSDoc "tc.generalize" 40 $ text "Final genRecCon type:" <+> inTopContext (prettyTCM conType)   setType (conName con) conType   -- Record telescope: Includes both parameters and fields.-  modifyGlobalDefinition name $ \ r ->-    r { theDef = (theDef r) { recTel = fullTel } }+  modifyGlobalDefinition name $ set (lensTheDef . lensRecord . lensRecTel) fullTel+  -- #7380: Also add clauses to the field definitions+  let n      = length fields+      cpi    = noConPatternInfo+      fldTys = map (fmap snd . argFromDom) $ telToList fieldTel+      conPat = ConP con cpi [ fmap unnamed $ varP (DBPatVar "x" i) <$ arg | (i, arg) <- zip (downFrom n) fldTys ]+  forM_ (zip3 (downFrom n) fields fldTys) \ (i, fld, fldTy) -> do+    modifyFunClauses fld \ _ ->+      [Clause+        { clauseLHSRange    = noRange+        , clauseFullRange   = noRange+        , clauseTel         = fieldTel+        , namedClausePats   = [defaultNamedArg conPat]+        , clauseBody        = Just $ var i+        , clauseType        = Just $ raise (i + 1) fldTy+        , clauseCatchall    = empty+        , clauseRecursive   = Just False+        , clauseUnreachable = Just False+        , clauseEllipsis    = NoEllipsis+        , clauseWhereModule = Nothing+        }]   where     setType q ty = modifyGlobalDefinition q $ \ d -> d { defType = ty }
src/full/Agda/TypeChecking/IApplyConfluence.hs view
@@ -1,17 +1,21 @@ {-# LANGUAGE NondecreasingIndentation #-}+ module Agda.TypeChecking.IApplyConfluence where  import Prelude hiding (null, (!!))  -- do not use partial functions like !! -import Control.Monad-import Control.Arrow (first,second)+import Control.Monad.Except ( MonadError(..) ) -import qualified Data.List as List-import qualified Data.Map as Map+import Data.Bifunctor (first, second)+import Data.DList (DList)+import Data.Foldable (toList)+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet  import Agda.Syntax.Common import Agda.Syntax.Position-import Agda.Syntax.Internal.Generic import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern @@ -27,17 +31,17 @@ import Agda.TypeChecking.Conversion import Agda.TypeChecking.Substitute -import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Maybe+import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Impossible import Agda.Utils.Functor   checkIApplyConfluence_ :: QName -> TCM ()-checkIApplyConfluence_ f = whenM (isJust . optCubical <$> pragmaOptions) $ do+checkIApplyConfluence_ f = whenM (isJust <$> cubicalOption) $ do   -- Andreas, 2019-03-27, iapply confluence should only be checked   -- when --cubical or --erased-cubical is active. See   -- test/Succeed/CheckIApplyConfluence.agda.@@ -49,28 +53,33 @@   case theDef d of     Function{funClauses = cls', funCovering = cls} -> do       reportSDoc "tc.cover.iapply" 10 $ text "length cls =" <+> pretty (length cls)-      when (null cls && not (null $ concatMap (iApplyVars . namedClausePats) cls')) $+      when (null cls && any (not . null . iApplyVars . namedClausePats) cls') $         __IMPOSSIBLE__-      modifySignature $ updateDefinition f $ updateTheDef-        $ updateCovering (const [])+      unlessM (optKeepCoveringClauses <$> pragmaOptions) $+        modifySignature $ updateDefinition f $ updateTheDef+          $ updateCovering (const [])        traceCall (CheckFunDefCall (getRange f) f [] False) $         forM_ cls $ checkIApplyConfluence f     _ -> return () --- | @addClause f (Clause {namedClausePats = ps})@ checks that @f ps@+-- | @checkIApplyConfluence f (Clause {namedClausePats = ps})@ checks that @f ps@ -- reduces in a way that agrees with @IApply@ reductions. checkIApplyConfluence :: QName -> Clause -> TCM () checkIApplyConfluence f cl = case cl of       Clause {clauseBody = Nothing} -> return ()       Clause {clauseType = Nothing} -> __IMPOSSIBLE__+      -- Inserted clause, will respect boundaries whenever the+      -- user-written clauses do. Saves a ton of work!+      Clause {namedClausePats = ps} | hasDefP ps -> pure ()       cl@Clause { clauseTel = clTel                 , namedClausePats = ps                 , clauseType = Just t                 , clauseBody = Just body-                } -> setCurrentRange (getRange f) $ do+                } -> setCurrentRange (clauseLHSRange cl) $ do           let             trhs = unArg t+          oldCall <- asksTC envCall           reportSDoc "tc.cover.iapply" 40 $ "tel =" <+> prettyTCM clTel           reportSDoc "tc.cover.iapply" 40 $ "ps =" <+> pretty ps           ps <- normaliseProjP ps@@ -80,90 +89,60 @@             let es = patternsToElims ps             let lhs = Def f es -            reportSDoc "tc.iapply" 40 $ text "clause:" <+> pretty ps <+> "->" <+> pretty body-            reportSDoc "tc.iapply" 20 $ "body =" <+> prettyTCM body--            addContext clTel $ equalTermOnFace phi trhs lhs body--            case body of-              MetaV m es_m' | Just es_m <- allApplyElims es_m' ->-                caseMaybeM (isInteractionMeta m) (return ()) $ \ ii -> do-                cs' <- do-                  reportSDoc "tc.iapply.ip" 20 $ "clTel =" <+> prettyTCM clTel-                  mv <- lookupMeta m-                  enterClosure (getMetaInfo mv) $ \ _ -> do -- mTel ⊢-                  ty <- getMetaType m-                  mTel <- getContextTelescope-                  reportSDoc "tc.iapply.ip" 20 $ "size mTel =" <+> pretty (size mTel)-                  reportSDoc "tc.iapply.ip" 20 $ "size es_m =" <+> pretty (size es_m)--                  unless (size mTel == size es_m) $ reportSDoc "tc.iapply.ip" 20 $ "funny number of elims" <+> text (show (size mTel, size es_m))-                  unless (size mTel <= size es_m) $ __IMPOSSIBLE__-                  let over = if size mTel == size es_m then NotOverapplied else Overapplied--                  -- extend telescope to handle extra elims-                  TelV mTel1 _ <- telViewUpToPath (size es_m) ty-                  reportSDoc "tc.iapply.ip" 20 $ "mTel1 =" <+> prettyTCM mTel1--                  addContext (mTel1 `apply` teleArgs mTel) $ do-                  mTel <- getContextTelescope--                  addContext clTel $ do -- mTel.clTel ⊢-                    () <- reportSDoc "tc.iapply.ip" 40 $ "mTel.clTel =" <+> (prettyTCM =<< getContextTelescope)-                    forallFaceMaps phi __IMPOSSIBLE__ $ \ alpha -> do-                    -- mTel.clTel' ⊢-                    -- mTel.clTel  ⊢ alpha : mTel.clTel'-                    reportSDoc "tc.iapply.ip" 40 $ "mTel.clTel' =" <+> (prettyTCM =<< getContextTelescope)--                    -- TelV tel _ <- telViewUpTo (size es) ty-                    reportSDoc "tc.iapply.ip" 40 $ "i0S =" <+> pretty alpha-                    reportSDoc "tc.iapply.ip" 20 $ fsep ["es :", pretty es]-                    reportSDoc "tc.iapply.ip" 20 $ fsep ["es_alpha :", pretty (alpha `applySubst` es) ]--                    -- reducing path applications on endpoints in lhs-                    let-                       loop t@(Def _ es) = loop' t es-                       loop t@(Var _ es) = loop' t es-                       loop t@(Con _ _ es) = loop' t es-                       loop t@(MetaV _ es) = loop' t es-                       loop t = return t-                       loop' t es = ignoreBlocking <$> (reduceIApply' (pure . notBlocked) (pure . notBlocked $ t) es)-                    lhs <- liftReduce $ traverseTermM loop (Def f (alpha `applySubst` es))--                    let-                        idG = raise (size clTel) $ (teleElims mTel [])+            reportSDoc "tc.cover.iapply" 40 $ text "clause:" <+> pretty ps <+> "->" <+> pretty body+            reportSDoc "tc.cover.iapply" 20 $ "body =" <+> prettyTCM body+            inTopContext $ reportSDoc "tc.cover.iapply" 20 $ "Γ =" <+> prettyTCM clTel -                    reportSDoc "tc.iapply.ip" 20 $ fsep ["lhs :", pretty lhs]-                    reportSDoc "tc.iapply.ip" 40 $ "cxt1 =" <+> (prettyTCM =<< getContextTelescope)-                    reportSDoc "tc.iapply.ip" 40 $ prettyTCM $ alpha `applySubst` ValueCmpOnFace CmpEq phi trhs lhs (MetaV m idG)+            let+              k :: Substitution -> Comparison -> Type -> Term -> Term -> TCM ()+              -- TODO (Amy, 2023-07-08): Simplifying the LHS of a+              -- generated clause in its context is loopy, see #6722+              k phi cmp ty u v | hasDefP ps = compareTerm cmp ty u v+              k phi cmp ty u v = do+                u_e   <- simplify u+                -- Issue #6725: Print these terms in their own TC state.+                -- If printing the values before entering the conversion+                -- checker is too expensive then we could save the TC+                -- state and print them when erroring instead, but that+                -- might cause space leaks.+                (u_p, v_p) <- (,) <$> prettyTCM u_e <*> (prettyTCM =<< simplify v) -                    unifyElims (teleArgs mTel) (alpha `applySubst` es_m) $ \ sigma eqs -> do-                    -- mTel.clTel'' ⊢-                    -- mTel ⊢ clTel' ≃ clTel''.[eqs]-                    -- mTel.clTel'' ⊢ sigma : mTel.clTel'-                    reportSDoc "tc.iapply.ip" 40 $ "cxt2 =" <+> (prettyTCM =<< getContextTelescope)-                    reportSDoc "tc.iapply.ip" 40 $ "sigma =" <+> pretty sigma-                    reportSDoc "tc.iapply.ip" 20 $ "eqs =" <+> pretty eqs+                let+                  -- Make note of the context (literally): we're+                  -- checking that this specific clause in f is+                  -- confluent with IApply reductions. That way if we+                  -- can tell the user what the endpoints are.+                  why = CheckIApplyConfluence+                    (getRange cl) f+                    (applySubst phi lhs)+                    u_e v ty -                    buildClosure $ IPBoundary-                       { ipbEquations = eqs-                       , ipbValue     = sigma `applySubst` lhs-                       , ipbMetaApp   = alpha `applySubst` MetaV m es_m'-                       , ipbOverapplied = over-                       }+                  -- But if the conversion checking failed really early, we drop the extra+                  -- information. In that case, it's just noise.+                  maybeDropCall e@(TypeError loc s err)+                    | UnequalTerms _ u' v' _ <- clValue err =+                      -- Issue #6725: restore the TC state from the+                      -- error before dealing with the stored terms.+                      withTCState (const s) $ enterClosure err $ \e' -> do+                        u' <- prettyTCM =<< simplify u'+                        v' <- prettyTCM =<< simplify v' -                    -- WAS:-                    -- fmap (over,) $ buildClosure $ (eqs-                    --                , sigma `applySubst`-                    --                    (ValueCmp CmpEq (AsTermsOf (alpha `applySubst` trhs)) lhs (alpha `applySubst` MetaV m es_m)))+                        -- Specifically, we compare how the things are pretty-printed, to avoid+                        -- double-printing, rather than a more refined heuristic, since the+                        -- “failure case” here is *at worst* accidentally reminding the user of how+                        -- IApplyConfluence works.+                        if (u_p == u' && v_p == v')+                          then localTC (\e -> e { envCall = oldCall }) $ typeError e'+                          else throwError e+                  maybeDropCall x = throwError x -                let f ip = ip { ipClause = case ipClause ip of-                                             ipc@IPClause{ipcBoundary = b}-                                               -> ipc {ipcBoundary = b ++ cs'}-                                             ipc@IPNoClause{} -> ipc}-                modifyInteractionPoints (BiMap.adjust f ii)-              _ -> return ()+                -- Note: Any postponed constraint with this call *will* have the extra+                -- information. This is a feature: if the constraint is woken up later,+                -- then it's probably a good idea to remind the user of what's going on,+                -- instead of presenting a mysterious error.+                traceCall why (compareTerm cmp ty u v `catchError` maybeDropCall) +            addContext clTel $ compareTermOnFace' k CmpEq phi trhs lhs body  -- | current context is of the form Γ.Δ unifyElims :: Args@@ -177,39 +156,54 @@               -- Γ.Δ', [(x = u)] ⊢ id_g = ts[σ] : Γ            -> TCM a unifyElims vs ts k = do-                      dom <- getContext-                      let (binds' , eqs' ) = candidate (map unArg vs) (map unArg ts)-                          (binds'', eqss') =-                            unzip $ map (\ (j,t:ts) -> ((j,t),map (,var j) ts)) $ Map.toList $ Map.fromListWith (++) (map (second (:[])) binds')-                          cod   = codomain s (map fst binds) dom-                          binds = map (second (raise (size cod - size vs))) binds''-                          eqs   = map (first  (raise $ size dom - size vs)) $ eqs' ++ concat eqss'-                          s     = bindS binds-                      updateContext s (codomain s (map fst binds)) $ do-                      k s (s `applySubst` eqs)+  dom <- getContext+  let (binds' , eqs' ) = candidate (map unArg vs) (map unArg ts)+      (binds'', eqss') =+        unzip $+        map (\(j, tts) -> case toList tts of+                t : ts -> ((j, t), map (, var j) ts)+                []     -> __IMPOSSIBLE__) $+        IntMap.toList $ IntMap.fromListWith (<>) binds'+      cod'  = codomain s (IntSet.fromList $ map fst binds'')+      cod   = cod' dom+      svs   = size vs+      binds = IntMap.fromList $+              map (second (raise (size cod - svs))) binds''+      eqs   = map (first  (raise (size dom - svs))) $+              eqs' ++ concat eqss'+      s     = bindS binds+  updateContext s cod' $ k s (s `applySubst` eqs)   where-    candidate :: [Term] -> [Term] -> ([(Nat,Term)],[(Term,Term)])-    candidate (i:is) (Var j []:ts) = first ((j,i):) (candidate is ts)-    candidate (i:is) (t:ts)        = second ((i,t):) (candidate is ts)-    candidate [] [] = ([],[])-    candidate _ _ = __IMPOSSIBLE__---    bindS binds = parallelS (for [0..maximum (-1:map fst binds)] $ (\ i -> fromMaybe (deBruijnVar i) (List.lookup i binds)))+  candidate :: [Term] -> [Term] -> ([(Nat, DList Term)], [(Term, Term)])+  candidate is ts = case (is, ts) of+    (i : is, Var j [] : ts) -> first ((j, singleton i) :) $+                               candidate is ts+    (i : is, t : ts)        -> second ((i, t) :) $+                               candidate is ts+    ([],     [])            -> ([], [])+    _                       -> __IMPOSSIBLE__ -    codomain :: Substitution-             -> [Nat]  -- support-             -> Context -> Context-    codomain s vs cxt = map snd $ filter (\ (i,c) -> i `List.notElem` vs) $ zip [0..] cxt'-     where-      cxt' = zipWith (\ n d -> dropS n s `applySubst` d) [1..] cxt+  bindS binds = parallelS $+    case IntMap.lookupMax binds of+      Nothing       -> []+      Just (max, _) -> for [0 .. max] $ \i ->+        fromMaybe (deBruijnVar i) (IntMap.lookup i binds) +  codomain+    :: Substitution+    -> IntSet  -- Support.+    -> Context -> Context+  codomain s vs =+    mapMaybe (\(i, c) -> if i `IntSet.member` vs+                         then Nothing+                         else Just c) .+    zipWith (\i c -> (i, dropS (i + 1) s `applySubst` c)) [0..] --- | Like @unifyElims@ but @Γ@ is from the the meta's @MetaInfo@ and+-- | Like @unifyElims@ but @Γ@ is from the meta's @MetaInfo@ and -- the context extension @Δ@ is taken from the @Closure@. unifyElimsMeta :: MetaId -> Args -> Closure Constraint -> ([(Term,Term)] -> Constraint -> TCM a) -> TCM a-unifyElimsMeta m es_m cl k = ifM (isNothing . optCubical <$> pragmaOptions) (enterClosure cl $ k []) $ do-                  mv <- lookupMeta m+unifyElimsMeta m es_m cl k = ifM (isNothing <$> cubicalOption) (enterClosure cl $ k []) $ do+                  mv <- lookupLocalMeta m                   enterClosure (getMetaInfo mv) $ \ _ -> do -- mTel ⊢                   ty <- metaType m                   mTel0 <- getContextTelescope
src/full/Agda/TypeChecking/Implicit.hs view
@@ -8,9 +8,10 @@ import Control.Monad.Except import Control.Monad.IO.Class -import Agda.Syntax.Position (beginningOf, getRange)+import Agda.Syntax.Position (HasRange, beginningOf, getRange) import Agda.Syntax.Common import Agda.Syntax.Abstract (Binder, mkBinder_)+import Agda.Syntax.Info ( MetaKind (InstanceMeta, UnificationMeta) ) import Agda.Syntax.Internal as I  import Agda.TypeChecking.Irrelevance@@ -22,6 +23,7 @@ import Agda.TypeChecking.Pretty import Agda.TypeChecking.Telescope +import Agda.Utils.Function (applyWhen) import Agda.Utils.Functor import Agda.Utils.List1 (List1, pattern (:|)) import qualified Agda.Utils.List1 as List1@@ -30,55 +32,28 @@  -- Cut and paste from insertImplicitPatternsT: --- | Insert implicit binders in a list of binders, but not at the end.-insertImplicitBindersT-  :: (PureTCM m, MonadError TCErr m, MonadFresh NameId m, MonadTrace m)-  => [NamedArg Binder]     -- ^ Should be non-empty, otherwise nothing happens.-  -> Type                  -- ^ Function type eliminated by arguments given by binders.-  -> m [NamedArg Binder] -- ^ Padded binders.-insertImplicitBindersT = \case-  []     -> \ _ -> return []-  b : bs -> List1.toList <.> insertImplicitBindersT1 (b :| bs)+-- | Split a given Pi 'Type' until you reach the given named argument,+-- returning the number of arguments skipped to reach the right plicity+-- and name.+splitImplicitBinderT :: HasRange a => NamedArg a -> Type -> TCM (Telescope, Type)+splitImplicitBinderT narg ty = do+  -- Split off any invisible arguments at the front (so if the first+  -- argument is visible, return tel = EmptyTel)+  TelV tel ty0 <- telViewUpTo' (-1) (not . visible) ty --- | Insert implicit binders in a list of binders, but not at the end.-insertImplicitBindersT1-  :: (PureTCM m, MonadError TCErr m, MonadFresh NameId m, MonadTrace m)-  => List1 (NamedArg Binder)        -- ^ Non-empty.-  -> Type                           -- ^ Function type eliminated by arguments given by binders.-  -> m (List1 (NamedArg Binder))  -- ^ Padded binders.-insertImplicitBindersT1 bs@(b :| _) a = setCurrentRange b $ do-  TelV tel ty0 <- telViewUpTo' (-1) (not . visible) a-  reportSDoc "tc.term.lambda.imp" 20 $-    vcat [ "insertImplicitBindersT"-         , nest 2 $ "bs  = " <+> do-             brackets $ fsep $ punctuate comma $ fmap prettyA bs-         , nest 2 $ "tel = " <+> prettyTCM tel-         , nest 2 $ "ty  = " <+> addContext tel (prettyTCM ty0)-         ]-  reportSDoc "tc.term.lambda.imp" 70 $-    vcat [ "insertImplicitBindersT"-         , nest 2 $ "bs  = " <+> (text . show . List1.toList) bs-         , nest 2 $ "tel = " <+> (text . show) tel-         , nest 2 $ "ty  = " <+> (text . show) ty0-         ]-  hs <- insImp b tel-  -- Continue with implicit binders inserted before @b@.-  let bs0@(b1 :| bs1) = List1.prependList hs bs-  reduce a >>= piOrPath >>= \case-    -- If @a@ is a function (or path) type, continue inserting after @b1@.-    Left (_, ty) -> (b1 :|) <$> insertImplicitBindersT bs1 (absBody ty)-    -- Otherwise, we are done.-    Right{}      -> return bs0-  where-  insImp b EmptyTel = return []-  insImp b tel = case insertImplicit b $ telToList tel of-    BadImplicits   -> typeError WrongHidingInLHS-    NoSuchName x   -> typeError WrongHidingInLHS-    ImpInsert doms -> mapM implicitArg doms-      where-      implicitArg d = setOrigin Inserted . unnamedArg (domInfo d) . mkBinder_ <$> do-        freshNoName $ beginningOf $ getRange b+  case tel of+    -- If we didn't lob off any arguments then we can use the original+    -- type and the empty telescope+    EmptyTel -> pure (EmptyTel, ty) +    -- Otherwise we try inserting implicit arguments.+    _ -> setCurrentRange narg case insertImplicit narg $ telToList tel of+      BadImplicits   -> typeError WrongHidingInLHS+      NoSuchName x   -> typeError WrongHidingInLHS+      ImpInsert doms ->+        let (here, there) = splitTelescopeAt (length doms) tel+        in pure (here, abstract there ty0)+ -- | @implicitArgs n expand t@ generates up to @n@ implicit argument --   metas (unbounded if @n<0@), as long as @t@ is a function type --   and @expand@ holds on the hiding info of its domain.@@ -110,7 +85,7 @@     case unEl t0' of       Pi dom@Dom{domInfo = info, domTactic = tac, unDom = a} b         | let x = bareNameWithDefault "_" dom, expand (getHiding info) x -> do-          info' <- if hidden info then return info else do+          kind <- if hidden info then return UnificationMeta else do             reportSDoc "tc.term.args.ifs" 15 $               "inserting instance meta for type" <+> prettyTCM a             reportSDoc "tc.term.args.ifs" 40 $ nest 2 $ vcat@@ -118,53 +93,47 @@               , "hiding = " <+> text (show $ getHiding info)               ] -            return $ makeInstance info-          (_, v) <- newMetaArg info' x CmpLeq a+            return InstanceMeta+          (_, v) <- newMetaArg kind info x CmpLeq a           whenJust tac $ \ tac -> liftTCM $             applyModalityToContext info $ unquoteTactic tac v a           let narg = Arg info (Named (Just $ WithOrigin Inserted $ unranged x) v)           mapFst (narg :) <$> implicitNamedArgs (n-1) expand (absApp b v)       _ -> return ([], t0') --- | Create a metavariable according to the 'Hiding' info.+-- | Create a metavariable of 'MetaKind'.  newMetaArg   :: (PureTCM m, MonadMetaSolver m)-  => ArgInfo    -- ^ Kind/relevance of meta.+  => MetaKind   -- ^ Kind of meta.+  -> ArgInfo    -- ^ Rrelevance of meta.   -> ArgName    -- ^ Name suggestion for meta.   -> Comparison -- ^ Check (@CmpLeq@) or infer (@CmpEq@) the type.   -> Type       -- ^ Type of meta.   -> m (MetaId, Term)  -- ^ The created meta as id and as term.-newMetaArg info x cmp a = do+newMetaArg kind info x cmp a = do   prp <- runBlocked $ isPropM a   let irrelevantIfProp =-        if prp == Right True-        then applyRelevanceToContext Irrelevant-        else id+        applyWhen (prp == Right True) $ applyRelevanceToContext irrelevant   applyModalityToContext info $ irrelevantIfProp $-    newMeta (getHiding info) (argNameToString x) a+    newMeta (argNameToString x) kind a   where-    newMeta :: MonadMetaSolver m => Hiding -> String -> Type -> m (MetaId, Term)-    newMeta Instance{} n = newInstanceMeta n-    newMeta Hidden     n = newNamedValueMeta RunMetaOccursCheck n cmp-    newMeta NotHidden  n = newNamedValueMeta RunMetaOccursCheck n cmp+    newMeta :: MonadMetaSolver m => String -> MetaKind -> Type -> m (MetaId, Term)+    newMeta n = \case+      InstanceMeta    -> newInstanceMeta n+      UnificationMeta -> newNamedValueMeta RunMetaOccursCheck n cmp --- | Create a questionmark according to the 'Hiding' info.+-- | Create a questionmark (always 'UnificationMeta').  newInteractionMetaArg-  :: ArgInfo    -- ^ Kind/relevance of meta.+  :: ArgInfo    -- ^ Relevance of meta.   -> ArgName    -- ^ Name suggestion for meta.   -> Comparison -- ^ Check (@CmpLeq@) or infer (@CmpEq@) the type.   -> Type       -- ^ Type of meta.   -> TCM (MetaId, Term)  -- ^ The created meta as id and as term. newInteractionMetaArg info x cmp a = do   applyModalityToContext info $-    newMeta (getHiding info) (argNameToString x) a-  where-    newMeta :: Hiding -> String -> Type -> TCM (MetaId, Term)-    newMeta Instance{} n = newInstanceMeta n-    newMeta Hidden     n = newNamedValueMeta' RunMetaOccursCheck n cmp-    newMeta NotHidden  n = newNamedValueMeta' RunMetaOccursCheck n cmp+    newNamedValueMeta' RunMetaOccursCheck (argNameToString x) cmp a  ---------------------------------------------------------------------------
src/full/Agda/TypeChecking/Injectivity.hs view
@@ -41,26 +41,29 @@ module Agda.TypeChecking.Injectivity where  import Control.Applicative-import Control.Monad.Except-import Control.Monad.Fail-import Control.Monad.State-import Control.Monad.Reader-import Control.Monad.Trans.Maybe+import Control.Monad.Except       ( MonadError )+import Control.Monad.State        ( evalStateT, MonadState, gets, put )+import Control.Monad.Reader       ( runReaderT, MonadReader, ask )+import Control.Monad.Trans.Maybe  ( MaybeT(MaybeT), runMaybeT )  import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe import Data.Traversable hiding (for) import Data.Semigroup ((<>))+import Data.Foldable (fold)  import qualified Agda.Syntax.Abstract.Name as A import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern +import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Irrelevance (isIrrelevantOrPropM) import Agda.TypeChecking.Monad+import Agda.TypeChecking.Patterns.Match (properlyMatching') import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope.Path import Agda.TypeChecking.Reduce import {-# SOURCE #-} Agda.TypeChecking.MetaVars import {-# SOURCE #-} Agda.TypeChecking.Conversion@@ -68,13 +71,16 @@ import Agda.TypeChecking.Polarity import Agda.TypeChecking.Warnings +import Agda.Interaction.Options+ import Agda.Utils.Either import Agda.Utils.Functor import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Permutation-import Agda.Utils.Pretty ( prettyShow )+import Agda.Syntax.Common.Pretty ( prettyShow )+import qualified Agda.Utils.ProfileOptions as Profile  import Agda.Utils.Impossible @@ -110,7 +116,10 @@         Constructor{} -> __IMPOSSIBLE__         AbstractDefn{}-> __IMPOSSIBLE__     -- Andreas, 2019-07-10, issue #3900: canonicalName needs ignoreAbstractMode-    Con c _ _ -> ignoreAbstractMode $ Just . ConsHead <$> canonicalName (conName c)+    Con c _ _ -> ignoreAbstractMode $ do+                 q <- canonicalName (conName c)+                 ifM (isPathCons q) (return Nothing) $+                     {- else -}     return $ Just $ ConsHead q     Sort _  -> return (Just SortHead)     Pi _ _  -> return (Just PiHead)     Var i [] -> return (Just $ VarHead i) -- Only naked variables. Otherwise substituting a neutral term is not guaranteed to stay neutral.@@ -122,8 +131,28 @@     DontCare{} -> return Nothing     Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s +-- | Is this a matchable definition, or constructor, which reduces based+-- on interval substitutions?+isUnstableDef :: PureTCM m => QName -> m Bool+isUnstableDef qn = do+  defn <- getConstInfo qn+  prims <- traverse getPrimitiveName'+    [ builtinHComp+    , builtinComp+    , builtinTrans+    , builtinGlue+    , builtin_glue+    , builtin_glueU ]+  case theDef defn of+    _ | (Just qn) `elem` prims -> pure True+    Function{funIsKanOp = Just _} -> pure True+    _ -> pure False++ -- | Do a full whnf and treat neutral terms as rigid. Used on the arguments to---   an injective functions and to the right-hand side.+--   an injective functions and to the right-hand side. Only returns+--   heads which are stable under interval substitution, i.e. NOT path+--   constructors or generated hcomp/transp! headSymbol'   :: (PureTCM m, MonadError TCErr m)   => Term -> m (Maybe TermHead)@@ -132,8 +161,15 @@   case v of     Blocked{} -> return Nothing     NotBlocked _ v -> case v of-      Def g _    -> return $ Just $ ConsHead g-      Con c _ _  -> return $ Just $ ConsHead $ conName c+      Def g _    ->+        ifM (isUnstableDef g)+          (pure Nothing)+          (pure . Just $ ConsHead g)+      Con c _ _  -> do+        q <- canonicalName (conName c)+        ifM (isPathCons q)+          (pure Nothing)+          (return $ Just $ ConsHead q)       Var i _    -> return $ Just (VarHead i)       Sort _     -> return $ Just SortHead       Pi _ _     -> return $ Just PiHead@@ -163,12 +199,11 @@   where f' (h, c) = (`Map.singleton` c) <$> f h c  checkInjectivity :: QName -> [Clause] -> TCM FunctionInverse-checkInjectivity f cs0-  | not (any properlyMatchingClause cs) = do+checkInjectivity f cs0 = do+    ifM (anyM properlyMatchingClause cs) {-then-} (checkInjectivity' f cs) {-else-} do       reportSLn "tc.inj.check.pointless" 35 $         "Injectivity of " ++ prettyShow (A.qnameToConcrete f) ++ " would be pointless."       return NotInjective-  | otherwise = checkInjectivity' f cs   where     -- We can filter out absurd clauses.     cs = filter (isJust . clauseBody) cs0@@ -176,7 +211,7 @@     -- these could be catch-all clauses.     -- However, we need at least one proper match to get injectivity started.     properlyMatchingClause =-      any (properlyMatching' False False . namedArg) . namedClausePats+      anyM (properlyMatching' False False . namedArg) . namedClausePats  -- | Precondition: all the given clauses are non-absurd and contain a proper match. checkInjectivity' :: QName -> [Clause] -> TCM FunctionInverse@@ -188,13 +223,23 @@       varToArg _ h           = return h    -- We don't need to consider absurd clauses-  let computeHead c@Clause{ clauseBody = Just body , clauseType = Just tbody } = do+  let computeHead c | hasDefP (namedClausePats c) = return []+      -- hasDefP clauses are skipped, these matter only for --cubical, in which case the function will behave as NotInjective.+      computeHead c@Clause{ clauseBody = Just body , clauseType = Just tbody } = addContext (clauseTel c) $ do         maybeIrr <- fromRight (const True) <.> runBlocked $ isIrrelevantOrPropM tbody+        -- We treat ordinary clauses with IApply copatterns as *immediately*+        -- failing the injectivity check. Consider e.g.+        --   foo x = T+        --   foo (y i) = Glue U λ { (i = i0) → T , _ ; (i = i1) → T , _ }+        -- seeing foo α = Glue ... and inverting it to α = y β loses solutions. E.g. if we+        -- later had some other α = x, now we're screwed, x ≠ y β. But if we had postponed+        -- originally we'd just compare T = Glue ... which has a chance of going through.+        let ivars = iApplyVars (namedClausePats c)+        guard (null ivars)         h <- if maybeIrr then return UnknownHead else           varToArg c =<< do             lift $ fromMaybe UnknownHead <$> do-              addContext (clauseTel c) $-                headSymbol body+              headSymbol body         return [Map.singleton h [c]]       computeHead _ = return [] @@ -211,7 +256,6 @@       case uc of         [c] -> prettyTCM $ map namedArg $ namedClausePats c         _   -> "(multiple clauses)"-   return $ Inverse hdMap  -- | If a clause is over-applied we can't trust the head (Issue 2944). For@@ -272,9 +316,10 @@ functionInverse = \case   Def f es -> do     inv <- defInverse <$> getConstInfo f+    cubical <- cubicalOption     case inv of       NotInjective -> return NoInv-      Inverse m    -> maybe NoInv (Inv f es) <$> (traverse (checkOverapplication es) =<< instantiateVarHeads f es m)+      Inverse m -> maybe NoInv (Inv f es) <$> (traverse (checkOverapplication es) =<< instantiateVarHeads f es m)         -- NB: Invertible functions are never classified as         --     projection-like, so this is fine, we are not         --     missing parameters.  (Andreas, 2013-11-01)@@ -302,6 +347,7 @@       reportSDoc "tc.inj.use" 30 $ fsep $         pwords "useInjectivity on" ++         [ prettyTCM blk, prettyTCM cmp, prettyTCM neu, prettyTCM ty]+      whenProfile Profile.Conversion $ tick "compare by reduction: injectivity"       let canReduceToSelf = Map.member (ConsHead f) hdMap || Map.member UnknownHead hdMap       case neu of         -- f us == f vs  <=>  us == vs@@ -319,6 +365,7 @@           fs  <- getForcedArgs f           pol <- getPolarity' cmp f           reportSDoc "tc.inj.invert.success" 20 $ hsep ["Successful spine comparison of", prettyTCM f]+          whenProfile Profile.Conversion $ tick "compare by reduction: injectivity successful"           app (compareElims pol fs fTy (Def f [])) blkArgs neuArgs          -- f us == c vs@@ -375,7 +422,7 @@             [ "meta patterns" <+> prettyList (map prettyTCM ms)             , "  perm =" <+> text (show perm)             , "  tel  =" <+> prettyTCM tel-            , "  ps   =" <+> prettyList (map (text . show) ps)+            , "  ps   =" <+> prettyList (map (text . prettyShow) ps)             ]           -- and this is the order the variables occur in the patterns           let msAux = permute (invertP __IMPOSSIBLE__ $ compactP perm) ms@@ -400,7 +447,7 @@           compareElims pol fs fTy (Def f []) margs blkArgs'            -- Check that we made progress.-          r <- liftReduce $ unfoldDefinitionStep False (Def f []) f blkArgs+          r <- liftReduce $ unfoldDefinitionStep (Def f []) f blkArgs           case r of             YesReduction _ blk' -> do               reportSDoc "tc.inj.invert.success" 20 $ hsep ["Successful inversion of", prettyTCM f, "at", pretty hd]@@ -412,9 +459,9 @@                 ]               return RollBackMetas   where-    nextMeta :: (MonadState [Term] m, MonadFail m) => m Term+    nextMeta :: (MonadState [Term] m) => m Term     nextMeta = do-      m : ms <- get+      (m, ms) <- gets (fromMaybe __IMPOSSIBLE__ . uncons)       put ms       return m @@ -424,18 +471,18 @@       return $ applySubst sub v      metaElim-      :: (MonadState [Term] m, MonadReader Substitution m, HasConstInfo m, MonadFail m)+      :: (MonadState [Term] m, MonadReader Substitution m, HasConstInfo m)       => Arg DeBruijnPattern -> m Elim     metaElim (Arg _ (ProjP o p))  = Proj o <$> getOriginalProjection p     metaElim (Arg info p)         = Apply . Arg info <$> metaPat p      metaArgs-      :: (MonadState [Term] m, MonadReader Substitution m, MonadFail m)+      :: (MonadState [Term] m, MonadReader Substitution m)       => [NamedArg DeBruijnPattern] -> m Args     metaArgs args = mapM (traverse $ metaPat . namedThing) args      metaPat-      :: (MonadState [Term] m, MonadReader Substitution m, MonadFail m)+      :: (MonadState [Term] m, MonadReader Substitution m)       => DeBruijnPattern -> m Term     metaPat (DotP _ v)       = dotP v     metaPat (VarP _ _)       = nextMeta
src/full/Agda/TypeChecking/Inlining.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Logic for deciding which functions should be automatically inlined. module Agda.TypeChecking.Inlining (autoInline) where
src/full/Agda/TypeChecking/InstanceArguments.hs view
@@ -1,594 +1,1222 @@-{-# LANGUAGE NondecreasingIndentation #-}--module Agda.TypeChecking.InstanceArguments-  ( findInstance-  , isInstanceConstraint-  , shouldPostponeInstanceSearch-  , postponeInstanceConstraints-  ) where--import Control.Monad        ( forM )-import Control.Monad.Except ( MonadError(..) )-import Control.Monad.Trans  ( lift )--import qualified Data.IntMap as IntMap-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.List as List-import Data.Bifunctor-import Data.Foldable (toList)-import Data.Function (on)-import Data.Monoid hiding ((<>))--import Agda.Interaction.Options (optOverlappingInstances, optQualifiedInstances)--import Agda.Syntax.Common-import Agda.Syntax.Concrete.Name (isQualified)-import Agda.Syntax.Position-import Agda.Syntax.Internal as I-import Agda.Syntax.Internal.MetaVars-import Agda.Syntax.Scope.Base (isNameInScope, inverseScopeLookupName', AllowAmbiguousNames(..))--import Agda.TypeChecking.Errors () --instance only-import Agda.TypeChecking.Implicit (implicitArgs)-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Records-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope--import {-# SOURCE #-} Agda.TypeChecking.Constraints-import {-# SOURCE #-} Agda.TypeChecking.Conversion--import qualified Agda.Benchmarking as Benchmark-import Agda.TypeChecking.Monad.Benchmark (billTo)--import Agda.Utils.Either-import Agda.Utils.Lens-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Pretty (prettyShow)-import Agda.Utils.Null (empty)--import Agda.Utils.Impossible---- | Compute a list of instance candidates.---   'Nothing' if target type or any context type is a meta, error if---   type is not eligible for instance search.-initialInstanceCandidates :: Type -> TCM (Either Blocker [Candidate])-initialInstanceCandidates t = do-  (_ , otn) <- getOutputTypeName t-  case otn of-    NoOutputTypeName -> typeError $ GenericError $-      "Instance search can only be used to find elements in a named type"-    OutputTypeNameNotYetKnown b -> do-      reportSDoc "tc.instance.cands" 30 $ "Instance type is not yet known. "-      return (Left b)-    OutputTypeVisiblePi -> typeError $ GenericError $-      "Instance search cannot be used to find elements in an explicit function type"-    OutputTypeVar    -> do-      reportSDoc "tc.instance.cands" 30 $ "Instance type is a variable. "-      runBlocked getContextVars-    OutputTypeName n -> do-      reportSDoc "tc.instance.cands" 30 $ "Found instance type head: " <+> prettyTCM n-      runBlocked getContextVars >>= \case-        Left b -> return $ Left b-        Right ctxVars -> Right . (ctxVars ++) <$> getScopeDefs n-  where-    -- get a list of variables with their type, relative to current context-    getContextVars :: BlockT TCM [Candidate]-    getContextVars = do-      ctx <- getContext-      reportSDoc "tc.instance.cands" 40 $ hang "Getting candidates from context" 2 (inTopContext $ prettyTCM $ PrettyContext ctx)-          -- Context variables with their types lifted to live in the full context-      let varsAndRaisedTypes = [ (var i, raise (i + 1) t) | (i, t) <- zip [0..] ctx ]-          vars = [ Candidate LocalCandidate x t (isOverlappable info)-                 | (x, Dom{domInfo = info, unDom = (_, t)}) <- varsAndRaisedTypes-                 , isInstance info-                 ]--      -- {{}}-fields of variables are also candidates-      let cxtAndTypes = [ (LocalCandidate, x, t) | (x, Dom{unDom = (_, t)}) <- varsAndRaisedTypes ]-      fields <- concat <$> mapM instanceFields (reverse cxtAndTypes)-      reportSDoc "tc.instance.fields" 30 $-        if null fields then "no instance field candidates" else-          "instance field candidates" $$ do-            nest 2 $ vcat-              [ sep [ (if overlap then "overlap" else empty) <+> prettyTCM c <+> ":"-                    , nest 2 $ prettyTCM t-                    ]-              | c@(Candidate q v t overlap) <- fields-              ]--      -- get let bindings-      env <- asksTC envLetBindings-      env <- mapM (traverse getOpen) $ Map.toList env-      let lets = [ Candidate LocalCandidate v t False-                 | (_,(v, Dom{domInfo = info, unDom = t})) <- env-                 , isInstance info-                 , usableModality info-                 ]-      return $ vars ++ fields ++ lets--    etaExpand :: (MonadTCM m, PureTCM m)-              => Bool -> Type -> m (Maybe (QName, Args))-    etaExpand etaOnce t =-      isEtaRecordType t >>= \case-        Nothing | etaOnce -> do-          isRecordType t >>= \case-            Nothing         -> return Nothing-            Just (r, vs, _) -> do-              m <- currentModule-              -- Are we inside the record module? If so it's safe and desirable-              -- to eta-expand once (issue #2320).-              if qnameToList0 r `List.isPrefixOf` mnameToList m-                then return (Just (r, vs))-                else return Nothing-        r -> return r--    instanceFields :: (CandidateKind,Term,Type) -> BlockT TCM [Candidate]-    instanceFields = instanceFields' True--    instanceFields' :: Bool -> (CandidateKind,Term,Type) -> BlockT TCM [Candidate]-    instanceFields' etaOnce (q, v, t) =-      ifBlocked t (\ m _ -> patternViolation m) $ \ _ t -> do-      caseMaybeM (etaExpand etaOnce t) (return []) $ \ (r, pars) -> do-        (tel, args) <- lift $ forceEtaExpandRecord r pars v-        let types = map unDom $ applySubst (parallelS $ reverse $ map unArg args) (flattenTel tel)-        fmap concat $ forM (zip args types) $ \ (arg, t) ->-          ([ Candidate LocalCandidate (unArg arg) t (isOverlappable arg)-           | isInstance arg ] ++) <$>-          instanceFields' False (LocalCandidate, unArg arg, t)--    getScopeDefs :: QName -> TCM [Candidate]-    getScopeDefs n = do-      instanceDefs <- getInstanceDefs-      rel          <- asksTC getRelevance-      let qs = maybe [] Set.toList $ Map.lookup n instanceDefs-      catMaybes <$> mapM (candidate rel) qs--    candidate :: Relevance -> QName -> TCM (Maybe Candidate)-    candidate rel q = ifNotM (isNameInScope q <$> getScope) (return Nothing) $ do-      -- Jesper, 2020-03-16: When using --no-qualified-instances,-      -- filter out instances that are only in scope under a qualified-      -- name.-      filterQualified $ do-      -- Andreas, 2012-07-07:-      -- we try to get the info for q-      -- while opening a module, q may be in scope but not in the signature-      -- in this case, we just ignore q (issue 674)-      flip catchError handle $ do-        def <- getConstInfo q-        if not (getRelevance def `moreRelevant` rel) then return Nothing else do-          -- Andreas, 2017-01-14: instantiateDef is a bit of an overkill-          -- if we anyway get the freeVarsToApply-          -- WAS: t <- defType <$> instantiateDef def-          args <- freeVarsToApply q-          let t = defType def `piApply` args-              rel = getRelevance $ defArgInfo def-          let v = case theDef def of-               -- drop parameters if it's a projection function...-               Function{ funProjection = Just p } -> projDropParsApply p ProjSystem rel args-               -- Andreas, 2014-08-19: constructors cannot be declared as-               -- instances (at least as of now).-               -- I do not understand why the Constructor case is not impossible.-               -- Ulf, 2014-08-20: constructors are always instances.-               Constructor{ conSrcCon = c }       -> Con c ConOSystem []-               _                                  -> Def q $ map Apply args-          return $ Just $ Candidate (GlobalCandidate q) v t False-      where-        -- unbound constant throws an internal error-        handle (TypeError _ _ (Closure {clValue = InternalError _})) = return Nothing-        handle err                                                   = throwError err--        filterQualified :: TCM (Maybe Candidate) -> TCM (Maybe Candidate)-        filterQualified m = ifM (optQualifiedInstances <$> pragmaOptions) m $ do-          qc <- inverseScopeLookupName' AmbiguousAnything q <$> getScope-          let isQual = maybe True isQualified $ listToMaybe qc-          reportSDoc "tc.instance.qualified" 30 $-            if isQual then-              "dropping qualified instance" <+> prettyTCM q-            else-              "keeping instance" <+> prettyTCM q <+>-              "since it is in scope as" <+> prettyTCM qc-          if isQual then return Nothing else m----- | @findInstance m (v,a)s@ tries to instantiate on of the types @a@s---   of the candidate terms @v@s to the type @t@ of the metavariable @m@.---   If successful, meta @m@ is solved with the instantiation of @v@.---   If unsuccessful, the constraint is regenerated, with possibly reduced---   candidate set.---   The list of candidates is equal to @Nothing@ when the type of the meta---   wasn't known when the constraint was generated. In that case, try to find---   its type again.-findInstance :: MetaId -> Maybe [Candidate] -> TCM ()-findInstance m Nothing = do-  -- Andreas, 2015-02-07: New metas should be created with range of the-  -- current instance meta, thus, we set the range.-  mv <- lookupMeta m-  setCurrentRange mv $ do-    reportSLn "tc.instance" 20 $ "The type of the FindInstance constraint isn't known, trying to find it again."-    t <- instantiate =<< getMetaTypeInContext m-    reportSLn "tc.instance" 70 $ "findInstance 1: t: " ++ prettyShow t--    -- Issue #2577: If the target is a function type the arguments are-    -- potential candidates, so we add them to the context to make-    -- initialInstanceCandidates pick them up.-    TelV tel t <- telViewUpTo' (-1) notVisible t-    cands <- addContext tel $ initialInstanceCandidates t-    case cands of-      Left unblock -> do-        reportSLn "tc.instance" 20 "Can't figure out target of instance goal. Postponing constraint."-        addConstraint unblock $ FindInstance m Nothing-      Right cs -> findInstance m (Just cs)--findInstance m (Just cands) =                          -- Note: if no blocking meta variable this will not unblock until the end of the mutual block-  whenJustM (findInstance' m cands) $ (\ (cands, b) -> addConstraint b $ FindInstance m $ Just cands)---- | Result says whether we need to add constraint, and if so, the set of---   remaining candidates and an eventual blocking metavariable.-findInstance' :: MetaId -> [Candidate] -> TCM (Maybe ([Candidate], Blocker))-findInstance' m cands = ifM (isFrozen m) (do-    reportSLn "tc.instance" 20 "Refusing to solve frozen instance meta."-    return (Just (cands, neverUnblock))) $ do-  ifM shouldPostponeInstanceSearch (do-    reportSLn "tc.instance" 20 "Postponing possibly recursive instance search."-    return $ Just (cands, neverUnblock)) $ billTo [Benchmark.Typing, Benchmark.InstanceSearch] $ do-  -- Andreas, 2015-02-07: New metas should be created with range of the-  -- current instance meta, thus, we set the range.-  mv <- lookupMeta m-  setCurrentRange mv $ do-      reportSLn "tc.instance" 15 $-        "findInstance 2: constraint: " ++ prettyShow m ++ "; candidates left: " ++ show (length cands)-      reportSDoc "tc.instance" 60 $ nest 2 $ vcat-        [ sep [ (if overlap then "overlap" else empty) <+> prettyTCM c <+> ":"-              , nest 2 $ prettyTCM t ] | c@(Candidate q v t overlap) <- cands ]-      reportSDoc "tc.instance" 70 $ "raw" $$ do-       nest 2 $ vcat-        [ sep [ (if overlap then "overlap" else empty) <+> prettyTCM c <+> ":"-              , nest 2 $ pretty t ] | c@(Candidate q v t overlap) <- cands ]-      t <- getMetaTypeInContext m-      reportSLn "tc.instance" 70 $ "findInstance 2: t: " ++ prettyShow t-      insidePi t $ \ t -> do-      reportSDoc "tc.instance" 15 $ "findInstance 3: t =" <+> prettyTCM t-      reportSLn "tc.instance" 70 $ "findInstance 3: t: " ++ prettyShow t--      mcands <--        -- Temporarily remove other instance constraints to avoid-        -- redundant solution attempts-        holdConstraints (const isInstanceProblemConstraint) $-        checkCandidates m t cands--      debugConstraints-      case mcands of--        Just ([(_, err)], []) -> do-          reportSDoc "tc.instance" 15 $-            "findInstance 5: the only viable candidate failed..."-          throwError err-        Just (errs, []) -> do-          if null errs then reportSDoc "tc.instance" 15 $ "findInstance 5: no viable candidate found..."-                       else reportSDoc "tc.instance" 15 $ "findInstance 5: all viable candidates failed..."-          -- #3676: Sort the candidates based on the size of the range for the errors and-          --        set the range of the full error to the range of the most precise candidate-          --        error.-          let sortedErrs = List.sortBy (compare `on` precision) errs-                where precision (_, err) = maybe infinity iLength $ rangeToInterval $ getRange err-                      infinity = 1000000000-          setCurrentRange (take 1 $ map snd sortedErrs) $-            typeError $ InstanceNoCandidate t [ (candidateTerm c, err) | (c, err) <- sortedErrs ]--        Just (_, [c@(Candidate q term t' _)]) -> do-          reportSDoc "tc.instance" 15 $ vcat-            [ "findInstance 5: solved by instance search using the only candidate"-            , nest 2 $ prettyTCM c <+> "=" <+> prettyTCM term-            , "of type " <+> prettyTCM t'-            , "for type" <+> prettyTCM t-            ]--          -- If we actually solved the constraints we should wake up any held-          -- instance constraints, to make sure we don't forget about them.-          wakeupInstanceConstraints-          return Nothing  -- We’re done--        _ -> do-          let cs = maybe cands snd mcands -- keep the current candidates if Nothing-          reportSDoc "tc.instance" 15 $-            text ("findInstance 5: refined candidates: ") <+>-            prettyTCM (List.map candidateTerm cs)-          return (Just (cs, neverUnblock))--insidePi :: Type -> (Type -> TCM a) -> TCM a-insidePi t ret = reduce (unEl t) >>= \case-    Pi a b     -> addContext (absName b, a) $ insidePi (absBody b) ret-    Def{}      -> ret t-    Var{}      -> ret t-    Sort{}     -> __IMPOSSIBLE__-    Con{}      -> __IMPOSSIBLE__-    Lam{}      -> __IMPOSSIBLE__-    Lit{}      -> __IMPOSSIBLE__-    Level{}    -> __IMPOSSIBLE__-    MetaV{}    -> __IMPOSSIBLE__-    DontCare{} -> __IMPOSSIBLE__-    Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s---- | Apply the computation to every argument in turn by reseting the state every---   time. Return the list of the arguments giving the result True.------   If the resulting list contains exactly one element, then the state is the---   same as the one obtained after running the corresponding computation. In---   all the other cases, the state is reset.------   Also returns the candidates that pass type checking but fails constraints,---   so that the error messages can be reported if there are no successful---   candidates.-filterResetingState :: MetaId -> [Candidate] -> (Candidate -> TCM YesNoMaybe) -> TCM ([(Candidate, TCErr)], [Candidate])-filterResetingState m cands f = do-  ctxArgs  <- getContextArgs-  let ctxElims = map Apply ctxArgs-      tryC c = do-        ok <- f c-        v  <- instantiateFull (MetaV m ctxElims)-        return (ok, v)-  result <- mapM (\c -> do bs <- localTCStateSaving (tryC c); return (c, bs)) cands--  -- Check that there aren't any hard failures-  case [ err | (_, ((HellNo err, _), _)) <- result ] of-    err : _ -> throwError err-    []      -> return ()--  -- c : Candidate-  -- r : YesNoMaybe-  -- v : Term         (fully instantiated)-  -- a : Type         (fully instantiated)-  -- s : TCState-  let result' = [ (c, v, s) | (c, ((r, v), s)) <- result, not (isNo r) ]-  result'' <- dropSameCandidates m result'-  case result'' of-    [(c, _, s)] -> ([], [c]) <$ putTC s-    _           -> do-      let bad  = [ (c, err) | (c, ((NoBecause err, _), _)) <- result ]-          good = [ c | (c, _, _) <- result'' ]-      return (bad, good)---- Drop all candidates which are judgmentally equal to the first one.--- This is sufficient to reduce the list to a singleton should all be equal.-dropSameCandidates :: MetaId -> [(Candidate, Term, a)] -> TCM [(Candidate, Term, a)]-dropSameCandidates m cands0 = verboseBracket "tc.instance" 30 "dropSameCandidates" $ do-  metas <- getMetaStore-  -- Does `it` have any metas in the initial meta variable store?-  let freshMetas = getAny . allMetas (Any . (`IntMap.notMember` metas) . metaId)--  -- Take overlappable candidates into account-  let cands =-        case List.partition (\ (c, _, _) -> candidateOverlappable c) cands0 of-          (cand : _, []) -> [cand]  -- only overlappable candidates: pick the first one-          _              -> cands0  -- otherwise require equality--  reportSDoc "tc.instance" 50 $ vcat-    [ "valid candidates:"-    , nest 2 $ vcat [ if freshMetas v then "(redacted)" else-                      sep [ prettyTCM v ]-                    | (_, v, _) <- cands ] ]-  rel <- getMetaRelevance <$> lookupMeta m-  case cands of-    []            -> return cands-    cvd : _ | isIrrelevant rel -> do-      reportSLn "tc.instance" 30 "dropSameCandidates: Meta is irrelevant so any candidate will do."-      return [cvd]-    (_, MetaV m' _, _) : _ | m == m' -> do  -- We didn't instantiate, so can't compare-      reportSLn "tc.instance" 30 "dropSameCandidates: Meta was not instantiated so we don't filter equal candidates yet"-      return cands-    cvd@(_, v, _) : vas-      | freshMetas v -> do-          reportSLn "tc.instance" 30 "dropSameCandidates: Solution of instance meta has fresh metas so we don't filter equal candidates yet"-          return (cvd : vas)-      | otherwise -> (cvd :) <$> dropWhileM equal vas-      where-        equal :: (Candidate, Term, a) -> TCM Bool-        equal (_, v', _)-            | freshMetas v' = return False  -- If there are fresh metas we can't compare-            | otherwise     =-          verboseBracket "tc.instance" 30 "dropSameCandidates: " $ do-          reportSDoc "tc.instance" 30 $ sep [ prettyTCM v <+> "==", nest 2 $ prettyTCM v' ]-          a <- uncurry piApplyM =<< ((,) <$> getMetaType m <*> getContextArgs)-          localTCState $ dontAssignMetas $ ifNoConstraints_ (equalTerm a v v')-                             {- then -} (return True)-                             {- else -} (\ _ -> return False)-                             `catchError` (\ _ -> return False)--data YesNoMaybe = Yes | No | NoBecause TCErr | Maybe | HellNo TCErr-  deriving (Show)--isNo :: YesNoMaybe -> Bool-isNo No          = True-isNo NoBecause{} = True-isNo HellNo{}    = True-isNo _           = False---- | Given a meta @m@ of type @t@ and a list of candidates @cands@,--- @checkCandidates m t cands@ returns a refined list of valid candidates and--- candidates that failed some constraints.-checkCandidates :: MetaId -> Type -> [Candidate] -> TCM (Maybe ([(Candidate, TCErr)], [Candidate]))-checkCandidates m t cands =-  verboseBracket "tc.instance.candidates" 20 ("checkCandidates " ++ prettyShow m) $-  ifM (anyMetaTypes cands) (return Nothing) $ Just <$> do-    reportSDoc "tc.instance.candidates" 20 $ nest 2 $ "target:" <+> prettyTCM t-    reportSDoc "tc.instance.candidates" 20 $ nest 2 $ vcat-      [ "candidates"-      , vcat [ "-" <+> (if overlap then "overlap" else empty) <+> prettyTCM c <+> ":" <+> prettyTCM t-             | c@(Candidate q v t overlap) <- cands ] ]-    cands' <- filterResetingState m cands (checkCandidateForMeta m t)-    reportSDoc "tc.instance.candidates" 20 $ nest 2 $ vcat-      [ "valid candidates"-      , vcat [ "-" <+> (if overlap then "overlap" else empty) <+> prettyTCM c <+> ":" <+> prettyTCM t-             | c@(Candidate q v t overlap) <- snd cands' ] ]-    reportSDoc "tc.instance.candidates" 60 $ nest 2 $ vcat-      [ "valid candidates"-      , vcat [ "-" <+> (if overlap then "overlap" else empty) <+> prettyTCM v <+> ":" <+> prettyTCM t-             | c@(Candidate q v t overlap) <- snd cands' ] ]-    return cands'-  where-    anyMetaTypes :: [Candidate] -> TCM Bool-    anyMetaTypes [] = return False-    anyMetaTypes (Candidate _ _ a _ : cands) = do-      a <- instantiate a-      case unEl a of-        MetaV{} -> return True-        _       -> anyMetaTypes cands--    checkDepth :: Term -> Type -> TCM YesNoMaybe -> TCM YesNoMaybe-    checkDepth c a k = locallyTC eInstanceDepth succ $ do-      d        <- viewTC eInstanceDepth-      maxDepth <- maxInstanceSearchDepth-      when (d > maxDepth) $ typeError $ InstanceSearchDepthExhausted c a maxDepth-      k--    checkCandidateForMeta :: MetaId -> Type -> Candidate -> TCM YesNoMaybe-    checkCandidateForMeta m t (Candidate q term t' _) = checkDepth term t' $ do-      -- Andreas, 2015-02-07: New metas should be created with range of the-      -- current instance meta, thus, we set the range.-      mv <- lookupMeta m-      setCurrentRange mv $ do-        debugConstraints-        verboseBracket "tc.instance" 20 ("checkCandidateForMeta " ++ prettyShow m) $-          liftTCM $ runCandidateCheck $ do-            reportSLn "tc.instance" 70 $ "  t: " ++ prettyShow t ++ "\n  t':" ++ prettyShow t' ++ "\n  term: " ++ prettyShow term ++ "."-            reportSDoc "tc.instance" 20 $ vcat-              [ "checkCandidateForMeta"-              , "t    =" <+> prettyTCM t-              , "t'   =" <+> prettyTCM t'-              , "term =" <+> prettyTCM term-              ]--            -- Apply hidden and instance arguments (recursive inst. search!).-            (args, t'') <- implicitArgs (-1) (\h -> notVisible h) t'--            reportSDoc "tc.instance" 20 $-              "instance search: checking" <+> prettyTCM t''-              <+> "<=" <+> prettyTCM t-            reportSDoc "tc.instance" 70 $ vcat-              [ "instance search: checking (raw)"-              , nest 4 $ pretty t''-              , nest 2 $ "<="-              , nest 4 $ pretty t-              ]-            v <- (`applyDroppingParameters` args) =<< reduce term-            reportSDoc "tc.instance" 15 $ vcat-              [ "instance search: attempting"-              , nest 2 $ prettyTCM m <+> ":=" <+> prettyTCM v-              ]-            reportSDoc "tc.instance" 70 $ nest 2 $-              "candidate v = " <+> pretty v-            -- if constraints remain, we abort, but keep the candidate-            -- Jesper, 05-12-2014: When we abort, we should add a constraint to-            -- instantiate the meta at a later time (see issue 1377).-            ctxElims <- map Apply <$> getContextArgs-            guardConstraint (ValueCmp CmpEq (AsTermsOf t'') (MetaV m ctxElims) v) $ leqType t'' t-            -- make a pass over constraints, to detect cases where some are made-            -- unsolvable by the assignment, but don't do this for FindInstance's-            -- to prevent loops.-            debugConstraints--            let debugSolution = verboseS "tc.instance" 15 $ do-                  sol <- instantiateFull (MetaV m ctxElims)-                  case sol of-                    MetaV m' _ | m == m' ->-                      reportSDoc "tc.instance" 15 $-                        sep [ ("instance search: maybe solution for" <+> prettyTCM m) <> ":"-                            , nest 2 $ prettyTCM v ]-                    _ ->-                      reportSDoc "tc.instance" 15 $-                        sep [ ("instance search: found solution for" <+> prettyTCM m) <> ":"-                            , nest 2 $ prettyTCM sol ]--            do solveAwakeConstraints' True-               Yes <$ debugSolution-              `catchError` (return . NoBecause)--        where-          runCandidateCheck check =-            flip catchError handle $-            nowConsideringInstance $-            ifNoConstraints check-              (\ r -> case r of-                  Yes           -> r <$ debugSuccess-                  NoBecause why -> r <$ debugConstraintFail why-                  _             -> __IMPOSSIBLE__-              )-              (\ _ r -> case r of-                  Yes           -> Maybe <$ debugInconclusive-                  NoBecause why -> r <$ debugConstraintFail why-                  _             -> __IMPOSSIBLE__-              )--          debugSuccess            = reportSLn "tc.instance" 50 "assignment successful" :: TCM ()-          debugInconclusive       = reportSLn "tc.instance" 50 "assignment inconclusive" :: TCM ()-          debugConstraintFail why = reportSDoc "tc.instance" 50 $ "candidate failed constraints:" <+> prettyTCM why-          debugTypeFail err       = reportSDoc "tc.instance" 50 $ "candidate failed type check:" <+> prettyTCM err--          hardFailure :: TCErr -> Bool-          hardFailure (TypeError _ _ err) =-            case clValue err of-              InstanceSearchDepthExhausted{} -> True-              _                              -> False-          hardFailure _ = False--          handle :: TCErr -> TCM YesNoMaybe-          handle err-            | hardFailure err = return $ HellNo err-            | otherwise       = No <$ debugTypeFail err--isInstanceConstraint :: Constraint -> Bool-isInstanceConstraint FindInstance{} = True-isInstanceConstraint _              = False--shouldPostponeInstanceSearch :: (ReadTCState m, HasOptions m) => m Bool-shouldPostponeInstanceSearch =-  and2M ((^. stConsideringInstance) <$> getTCState)-        (not . optOverlappingInstances <$> pragmaOptions)-  `or2M` ((^. stPostponeInstanceSearch) <$> getTCState)--nowConsideringInstance :: (ReadTCState m) => m a -> m a-nowConsideringInstance = locallyTCState stConsideringInstance $ const True--isInstanceProblemConstraint :: ProblemConstraint -> Bool-isInstanceProblemConstraint = isInstanceConstraint . clValue . theConstraint--wakeupInstanceConstraints :: TCM ()-wakeupInstanceConstraints =-  unlessM shouldPostponeInstanceSearch $ do-    wakeConstraints (wakeUpWhen_ isInstanceProblemConstraint)-    solveSomeAwakeConstraints isInstanceProblemConstraint False--postponeInstanceConstraints :: TCM a -> TCM a-postponeInstanceConstraints m =-  locallyTCState stPostponeInstanceSearch (const True) m <* wakeupInstanceConstraints---- | To preserve the invariant that a constructor is not applied to its---   parameter arguments, we explicitly check whether function term---   we are applying to arguments is a unapplied constructor.---   In this case we drop the first 'conPars' arguments.---   See Issue670a.---   Andreas, 2013-11-07 Also do this for projections, see Issue670b.-applyDroppingParameters :: Term -> Args -> TCM Term-applyDroppingParameters t vs = do-  let fallback = return $ t `apply` vs-  case t of-    Con c ci [] -> do-      def <- theDef <$> getConInfo c-      case def of-        Constructor {conPars = n} -> return $ Con c ci (map Apply $ drop n vs)-        _ -> __IMPOSSIBLE__-    Def f [] -> do-      -- Andreas, 2022-03-07, issue #5809: don't drop parameters of irrelevant projections.-      mp <- isRelevantProjection f-      case mp of-        Just Projection{projIndex = n} -> do-          case drop n vs of-            []     -> return t-            u : us -> (`apply` us) <$> applyDef ProjPrefix f u-        _ -> fallback-    _ -> fallback+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.InstanceArguments+  ( findInstance+  , isInstanceConstraint+  , solveAwakeInstanceConstraints+  , shouldPostponeInstanceSearch+  , postponeInstanceConstraints+  , flushInstanceConstraints+  , getInstanceCandidates+  , getInstanceDefs+  , OutputTypeName(..)+  , getOutputTypeName+  , addTypedInstance+  , readdTypedInstance+  , addTypedInstance'+  , pruneTemporaryInstances+  , resolveInstanceHead+  ) where++import Control.Monad.Except   (ExceptT(..), runExceptT, MonadError(..))++import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.List as List+import Data.Function (on)+import Data.Monoid hiding ((<>))+import Data.Foldable (toList, foldrM)++import Agda.Interaction.Options (optQualifiedInstances, lensOptExperimentalLazyInstances)++import Agda.Syntax.Common+import Agda.Syntax.Concrete.Name (isQualified)+import Agda.Syntax.Position+import Agda.Syntax.Internal as I+import Agda.Syntax.Internal.MetaVars+import Agda.Syntax.Scope.Base (isNameInScope, inverseScopeLookupName', AllowAmbiguousNames(..))++import qualified Agda.TypeChecking.Monad.Benchmark as Bench+import Agda.TypeChecking.Conversion.Pure (pureEqualTermB)+import Agda.TypeChecking.Errors () --instance only+import Agda.TypeChecking.Implicit (implicitArgs)+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Records+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Warnings+import Agda.TypeChecking.Datatypes++import {-# SOURCE #-} Agda.TypeChecking.Constraints+import {-# SOURCE #-} Agda.TypeChecking.Conversion++import qualified Agda.Benchmarking as Benchmark+import Agda.TypeChecking.Monad.Benchmark (billTo)++import Agda.Utils.Lens+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Size+import Agda.Utils.Tuple+import Agda.Syntax.Common.Pretty (prettyShow)++import qualified Agda.Utils.ProfileOptions as Profile+-- import qualified Agda.Utils.HashTable as HashTable+import Agda.Utils.WithDefault (lensCollapseDefault)+import Agda.Utils.Impossible+-- import Agda.Utils.HashTable (HashTable)++import Agda.TypeChecking.DiscrimTree+-- import GHC.IO (unsafePerformIO)++-- | Compute a list of instance candidates.+--   'Nothing' if target type or any context type is a meta, error if+--   type is not eligible for instance search.+initialInstanceCandidates :: Bool -> Type -> TCM (Either Blocker [Candidate])+initialInstanceCandidates blockOverlap instTy = do+  (_, _, otn) <- getOutputTypeName instTy+  case otn of+    NoOutputTypeName -> typeError $ InvalidInstanceHeadType instTy ImproperInstHead+    OutputTypeVisiblePi -> typeError $ InvalidInstanceHeadType instTy ImproperInstTele+    OutputTypeNameNotYetKnown b -> do+      reportSDoc "tc.instance.cands" 30 $ "Instance type is not yet known. "+      return (Left b)+    OutputTypeVar -> do+      reportSDoc "tc.instance.cands" 30 $ "Instance type is a variable. "+      runBlocked (getContextCands Nothing)+    OutputTypeName n -> Bench.billTo [Bench.Typing, Bench.InstanceSearch, Bench.InitialCandidates] do+      reportSDoc "tc.instance.cands" 30 $ "Found instance type head: " <+> prettyTCM n+      runBlocked do+        local  <- getContextCands (Just n)+        global <- getScopeDefs n+        lift $ tickCandidates n $ length local + length global+        pure $ local <> global+  where+    -- Ticky profiling for statistics about a class.+    tickCandidates n size = whenProfile Profile.Instances do+      n <- prettyTCM n+      let pref = "class " <> show n++      -- Number of instance constraints of this class that have gotten a+      -- set of candidates+      tick $ pref <> ": attempts"+      -- Per-class info: number of constraints where there was only one+      -- candidate (awesome) + the total number of candidates we've gone+      -- through.+      when (size == 1) $ tick $ pref <> ": only one candidate"+      when (size >= 1) $ tickN+        (pref <> ": total candidates visited")+        (fromIntegral size)++    -- get a list of variables with their type, relative to current context+    getContextCands :: Maybe QName -> BlockT TCM [Candidate]+    getContextCands cls = do+      ctx <- getContext+      reportSDoc "tc.instance.cands" 40 $ hang "Getting candidates from context" 2 (inTopContext $ prettyTCM $ PrettyContext ctx)+          -- Context variables with their types lifted to live in the full context+      let varsAndRaisedTypes = reverse $ zip (contextTerms ctx) (flattenTel $ contextToTel ctx)+          vars = [ Candidate LocalCandidate x t (infoOverlapMode info)+                 | (x, Dom{domInfo = info, unDom = t}) <- varsAndRaisedTypes+                 , isInstance info+                 ]++      -- {{}}-fields of variables are also candidates+      let cxtAndTypes = [ (LocalCandidate, x, t) | (x, Dom{unDom = t}) <- varsAndRaisedTypes ]+      fields <- concat <$> mapM instanceFields (reverse cxtAndTypes)+      reportSDoc "tc.instance.fields" 30 $+        if null fields then "no instance field candidates" else+          "instance field candidates" $$ do+            nest 2 $ vcat (map debugCandidate fields)++      -- get let bindings+      env <- asksTC envLetBindings+      env <- mapM (traverse getOpen) $ Map.toList env+      let lets = [ Candidate LocalCandidate v t DefaultOverlap+                 | (_, LetBinding _ v Dom{domInfo = info, unDom = t}) <- env+                 , isInstance info+                 , usableModality info+                 ]+      filterM (sameHead cls . candidateType) $ vars ++ fields ++ lets++    sameHead :: Maybe QName -> Type -> BlockT TCM Bool+    sameHead Nothing _ = pure True+    sameHead (Just cls) t = lift (thd3 <$> getOutputTypeName t) >>= \case+      OutputTypeName            inst -> pure (inst == cls)+      OutputTypeNameNotYetKnown b    -> patternViolation b+      _                              -> pure False++    infoOverlapMode :: LensArgInfo a => a -> OverlapMode+    infoOverlapMode info = if isYesOverlap (getArgInfo info) then FieldOverlap else DefaultOverlap++    etaExpand :: (MonadTCM m, PureTCM m)+              => Bool -> Type -> m (Maybe (QName, Args))+    etaExpand etaOnce t =+      isEtaRecordType t >>= \case+        Nothing | etaOnce -> do+          isRecordType t >>= \case+            Nothing         -> return Nothing+            Just (r, vs, _) -> do+              m <- currentModule+              -- Are we inside the record module? If so it's safe and desirable+              -- to eta-expand once (issue #2320).+              if qnameToList0 r `List.isPrefixOf` mnameToList m+                then return (Just (r, vs))+                else return Nothing+        r -> return r++    instanceFields :: (CandidateKind,Term,Type) -> BlockT TCM [Candidate]+    instanceFields = instanceFields' True++    instanceFields' :: Bool -> (CandidateKind,Term,Type) -> BlockT TCM [Candidate]+    instanceFields' etaOnce (q, v, t) =+      ifBlocked t (\ m _ -> patternViolation m) $ \ _ t -> do+      caseMaybeM (etaExpand etaOnce t) (return []) $ \ (r, pars) -> do+        (tel, args) <- lift $ forceEtaExpandRecord r pars v+        let types = map unDom $ applySubst (parallelS $ reverse $ map unArg args) (flattenTel tel)+        fmap concat $ forM (zip args types) $ \ (arg, t) ->+          ([ Candidate LocalCandidate (unArg arg) t (infoOverlapMode arg)+           | isInstance arg+           ] ++) <$>+          instanceFields' False (LocalCandidate, unArg arg, t)++    -- Compute whether we should block this instance constraint at the+    -- discrimination tree stage.+    shouldBlockOverlap :: Blocker -> Set.Set QName -> TCM Bool+    shouldBlockOverlap bs cands = do+      let+        recursive = useTC stConsideringInstance+        hack      = useTC stInstanceHack+        enabled   = useTC (stPragmaOptions . lensOptExperimentalLazyInstances . lensCollapseDefault)+        mutual    = caseMaybeM (asksTC envMutualBlock) (pure mempty) \ mb ->+          mutualNames <$> lookupMutualBlock mb++      andM+        [ pure blockOverlap+          -- For the getInstances reflection primitive, we don't want+          -- to block on overlap, so that the user can do their thing.++        , enabled+          -- Also disable it depending on the pragma option.++        , pure $ not $ Set.null $ allBlockingMetas bs+          -- Don't block if there's no metas to block on++        , pure $ natSize cands > 1+          -- It's possible that the discrimination tree forced a+          -- metavariable even if there's exactly one candidate. In this+          -- case, we should not block, because this instance constraint+          -- might be the only thing that can solve the blocking metas.++        , not <$> hack+          -- To support 'inert improvement' (see ImproveInertRHS), we+          -- try all the candidates even if the discrimination tree+          -- thinks that there will be overlap. This is because it's+          -- possible we have e.g.+          --+          --   instance ?1 : Foo ?0, candidates {Foo T, Foo S}+          --      blocker ?0+          --   ?0 X = T X (blocked on ?0)+          --+          -- If we block ?1 on ?0 again (as we would've done during the+          -- body), then both of these go unsolved. But if we try all+          -- the candidates, we'll see that 'Foo T' is the only possible+          -- candidate, thus solving both constraints.++        , mutual <&> (`Set.disjoint` cands)+          -- Work around for #7186: the result of termination checking+          -- depends on whether we solve instance metas eagerly or late.+          -- Consider+          --+          --   instance Show-List = record { show = go }+          --   go (x ∷ xs) = show x <> show ⦃ ?0 ⦄ xs+          --+          -- If we solve ?0 eagerly, the term we use is the literal+          -- record constructor. The 'show' projection unfolds in 'go'+          -- and the termination check is happy.+          --+          -- If we solve it late, we run the risk of the clause+          -- compiler applying copattern translation to Show-List. The+          -- 'show' projection does not eagerly unfold, and the+          -- termination check explodes.++        , not <$> recursive+          -- Blocking instance selection *on a meta* while considering+          -- an instance causes the recursive instance constraint to+          -- get repeatedly woken up. Not good for performance.+        ]++    getScopeDefs :: QName -> BlockT TCM [Candidate]+    getScopeDefs n = do+      rel <- viewTC eRelevance++      InstanceTable tree counts <- lift getInstanceDefs+      QueryResult qs blocker <- lift $ lookupDT (unEl instTy) tree++      reportSDoc "tc.instance.candidates.search" 20 $ vcat+        [ "instance candidates from signature for goal:"+        , nest 2 (prettyTCM =<< instantiateFull instTy)+        , nest 2 (prettyTCM qs)+        , "length:" <+> prettyTCM (length qs)+        , "blocker:"+        , nest 2 (prettyTCM blocker)+        ]++      cands <- catMaybes <$> mapM (lift . candidate rel) (toList qs)++      should <- lift (shouldBlockOverlap blocker qs)+      when (length cands > 1 && should) do+        reportSDoc "tc.instance.defer" 20 $ vcat+          [ "Postponing because of discrimination tree overlap."+          ]+        patternViolation blocker++      -- Some more class-specific profiling.+      lift $ whenProfile Profile.Instances case Map.lookup n counts of+        Just tot -> do+          n <- prettyTCM n+          -- Record the overall total number of candidates that were+          -- skipped by lookup in the discrimination tree, and record+          -- this per-class, as well.+          let diff = fromIntegral (tot - length cands)+          tickN "instances discarded early" diff+          tickN ("class " <> show n <> ": discarded early") diff+        Nothing  -> pure ()++      pure cands++    candidate :: Relevance -> QName -> TCM (Maybe Candidate)+    candidate rel q = ifNotM (isNameInScope q <$> getScope) (return Nothing) $ do+      -- Jesper, 2020-03-16: When using --no-qualified-instances,+      -- filter out instances that are only in scope under a qualified+      -- name.+      filterQualified $ do+      -- Andreas, 2012-07-07:+      -- we try to get the info for q+      -- while opening a module, q may be in scope but not in the signature+      -- in this case, we just ignore q (issue 674)+      flip catchError handle $ do+        def <- getConstInfo q+        if not (getRelevance def `moreRelevant` rel) then return Nothing else do+          -- Andreas, 2017-01-14: instantiateDef is a bit of an overkill+          -- if we anyway get the freeVarsToApply+          -- WAS: t <- defType <$> instantiateDef def+          args <- freeVarsToApply q+          let+            t   = defType def `piApply` args+            rel = getRelevance $ defArgInfo def++            v = case theDef def of+              -- drop parameters if it's a projection function...+              Function{ funProjection = Right p } -> projDropParsApply p ProjSystem rel args++              -- Andreas, 2014-08-19: constructors cannot be declared as+              -- instances (at least as of now).+              -- I do not understand why the Constructor case is not impossible.+              -- Ulf, 2014-08-20: constructors are always instances.+              Constructor{ conSrcCon = c }       -> Con c ConOSystem []+              _                                  -> Def q $ map Apply args++            mode = case defInstance def of+              Just i  -> instanceOverlap i+              Nothing -> DefaultOverlap++          -- Amy, 2025-04-10: it's possible that an instance in the+          -- discrimination tree has a type which, in the current+          -- context, has visible quantifiers (e.g. because we're+          -- outside the parametrised module it was defined in).+          --+          -- Discard them early so that they don't count towards+          -- potentially blocking on "overlap".+          TelV tele _ <- telView t+          return do+            guard (all (not . visible) tele)+            Just $ Candidate (GlobalCandidate q) v t mode+      where+        -- unbound constant throws an internal error+        handle (TypeError _ _ (Closure {clValue = InternalError _})) = return Nothing+        handle err                                                   = throwError err++        filterQualified :: TCM (Maybe Candidate) -> TCM (Maybe Candidate)+        filterQualified m = ifM (optQualifiedInstances <$> pragmaOptions) m $ do+          qc <- inverseScopeLookupName' AmbiguousAnything q <$> getScope+          let isQual = maybe True isQualified $ listToMaybe qc+          reportSDoc "tc.instance.qualified" 30 $+            if isQual then+              "dropping qualified instance" <+> prettyTCM q+            else+              "keeping instance" <+> prettyTCM q <+>+              "since it is in scope as" <+> prettyTCM qc+          if isQual then return Nothing else m+++-- | @findInstance m (v,a)s@ tries to instantiate on of the types @a@s+--   of the candidate terms @v@s to the type @t@ of the metavariable @m@.+--   If successful, meta @m@ is solved with the instantiation of @v@.+--   If unsuccessful, the constraint is regenerated, with possibly reduced+--   candidate set.+--   The list of candidates is equal to @Nothing@ when the type of the meta+--   wasn't known when the constraint was generated. In that case, try to find+--   its type again.+findInstance :: MetaId -> Maybe [Candidate] -> TCM ()+findInstance m Nothing = do+  r <- getMetaRange m+  ifM canDropRecursiveInstance (addConstraint neverUnblock (FindInstance r m Nothing)) $ do+  -- Getting initial candidates can fail, in which case we should postpone (#7286)+  catchConstraint (FindInstance r m Nothing) $ do+  -- Andreas, 2015-02-07: New metas should be created with range of the+  -- current instance meta, thus, we set the range.+  mv <- lookupLocalMeta m+  setCurrentRange mv $ do+    reportSLn "tc.instance" 20 $ "The type of the FindInstance constraint isn't known, trying to find it again."+    t <- instantiate =<< getMetaTypeInContext m+    reportSLn "tc.instance" 70 $ "findInstance 1: t: " ++ prettyShow t++    -- Issue #2577: If the target is a function type the arguments are+    -- potential candidates, so we add them to the context to make+    -- initialInstanceCandidates pick them up.+    TelV tel t <- telViewUpTo' (-1) notVisible t+    cands <- addContext tel $ initialInstanceCandidates True t+    case cands of+      Left unblock -> do+        reportSLn "tc.instance" 20 "Can't figure out target of instance goal. Postponing constraint."+        addConstraint unblock $ FindInstance r m Nothing+      Right cs -> findInstance m (Just cs)++findInstance m (Just cands) = do                       -- Note: if no blocking meta variable this will not unblock until the end of the mutual block+  r <- getMetaRange m+  whenJustM (findInstance' m cands) $ (\ (cands, b) -> addConstraint b $ FindInstance r m $ Just cands)++-- | Entry point for `tcGetInstances` primitive+getInstanceCandidates :: MetaId -> TCM (Either Blocker [Candidate])+getInstanceCandidates m = wrapper where+  wrapper = do+    mv <- lookupLocalMeta m+    setCurrentRange mv $ do+      t <- instantiate =<< getMetaTypeInContext m+      TelV tel t' <- telViewUpTo' (-1) notVisible t+      addContext tel $ runExceptT (worker t')++  insertCandidate :: Candidate -> [Candidate] -> TCM [Candidate]+  insertCandidate x []     = pure [x]+  insertCandidate x (y:xs) = doesCandidateSpecialise x y >>= \case+    True  -> pure (x:y:xs)+    False -> (y:) <$> insertCandidate x xs++  worker :: Type -> ExceptT Blocker TCM [Candidate]+  worker t' = do+    cands <- ExceptT (initialInstanceCandidates False t')+    cands <- lift (checkCandidates m t' cands) <&> \case+      Nothing         -> cands+      Just (_, cands) -> fst <$> cands+    cands <- Bench.billTo [Bench.Typing, Bench.InstanceSearch, Bench.OrderCandidates] $+      lift (foldrM insertCandidate [] cands)++    reportSDoc "tc.instance.sort" 20 $ nest 2 $+      "sorted candidates" $$ vcat (map debugCandidate cands)++    pure cands++-- | @'doesCandidateSpecialise' c1 c2@ checks whether the instance+-- candidate @c1@ /specialises/ the instance candidate @c2@, i.e.,+-- whether the type of @c2@ is a substitution instance of @c1@'s type.+--+-- Only the final return type of the instances is considered: the+-- presence of unsolvable instance arguments in the types of @c1@ or+-- @c2@ does not affect the results of 'doesCandidateSpecialise'.+doesCandidateSpecialise :: Candidate -> Candidate -> TCM Bool+doesCandidateSpecialise c1@Candidate{candidateType = t1} c2@Candidate{candidateType = t2} = do+  whenProfile Profile.Instances $ tick "doesCandidateSpecialise"++  -- We compare+  --    c1 : ∀ {Γ} → T+  -- against+  --    c2 : ∀ {Δ} → S+  -- by moving to the context Γ ⊢, so that any variables in T's type are+  -- "rigid", but *instantiating* S[?/Δ], so its variables are+  -- "flexible"; then calling the conversion checker.++  let+    handle e = do+      reportSDoc "tc.instance.sort" 30 $ nest 2 "=> NOT specialisation"+      reportSDoc "tc.instance.sort" 40 $ prettyTCM e+      pure False++    wrap = flip catchError handle+        -- Turn failures into returning false+        . localTCState+        -- Discard any changes to the TC state (metas from+        -- instantiating t2, recursive instance constraints, etc)+        . locallyTCState stPostponeInstanceSearch (const True)+        -- Don't spend any time looking for instances in the contexts+        . nowConsideringInstance+        -- Don't execute tactics either++  TelV tel t1 <- telView t1+  addContext tel $ wrap $ do+    -- Amy, 2025-02-28: Have to raise the type of the other candidate to+    -- live in t1's context!+    (args, t2) <- implicitArgs (-1) (\h -> notVisible h) (raise (length tel) t2)++    reportSDoc "tc.instance.sort" 30 $ "Does" <+> prettyTCM (raise (length tel) c1) <+> "specialise" <+> (prettyTCM (raise (length tel) c2) <> "?")+    reportSDoc "tc.instance.sort" 60 $ vcat+      [ "Comparing candidate"+      , nest 2 (prettyTCM c1 <+> colon <+> prettyTCM t1)+      , "vs"+      , nest 2 (prettyTCM c2 <+> colon <+> prettyTCM t2)+      ]++    leqType t2 t1+    reportSDoc "tc.instance.sort" 30 $ nest 2 "=> IS specialisation"+    pure True++-- | Checks whether an instance overlaps another. This involves a strict+-- specificity check (the new instance should be more specific than the+-- old instance but not vice-versa) and the consideration of whether+-- these instances are overlappable/overlapping at all.+--+-- Fails early if the new candidate is not overlapping and the old+-- candidate is not overlappable.+doesCandidateOverlap :: Candidate -> Candidate -> TCM Bool+doesCandidateOverlap new old = if isOverlapping new || isOverlappable old+  then andM [ doesCandidateSpecialise new old+            , fmap not (doesCandidateSpecialise old new) ]+  else pure False++-- | Result says whether we need to add constraint, and if so, the set of+--   remaining candidates and an eventual blocking metavariable.+findInstance' :: MetaId -> [Candidate] -> TCM (Maybe ([Candidate], Blocker))+findInstance' m cands = do+  let+    frozen = do+      reportSLn "tc.instance.defer" 20 "Refusing to solve frozen instance meta."+      whenProfile Profile.Instances $ tick "findInstance: frozen"+      return (Just (cands, neverUnblock))++    recursive = do+      recur <- useTC stConsideringInstance+      reportSLn "tc.instance.defer" 20+        if recur+          then "Postponing recursive instance search."+          else "Postponing possibly recursive instance search."+      whenProfile Profile.Instances $ tick "findInstance: recursive"+      return $ Just (cands, neverUnblock)++  ifM (isFrozen m) frozen do+  ifM shouldPostponeInstanceSearch recursive do+  billTo [Benchmark.Typing, Benchmark.InstanceSearch] do++  -- Andreas, 2015-02-07: New metas should be created with range of the+  -- current instance meta, thus, we set the range.+  mv <- lookupLocalMeta m+  setCurrentRange mv $ do+      reportSLn "tc.instance" 15 $+        "findInstance 2: constraint: " ++ prettyShow m ++ "; candidates left: " ++ show (length cands)+      reportSDoc "tc.instance" 60 $ nest 2 $ vcat $ map debugCandidate cands+      reportSDoc "tc.instance" 70 $ "raw" $$ do+       nest 2 $ vcat $ map debugCandidateRaw cands++      t <- getMetaTypeInContext m+      reportSLn "tc.instance" 70 $ "findInstance 2: t: " ++ prettyShow t++      insidePi t $ \ t -> do+      reportSDoc "tc.instance" 15 $ "findInstance 3: t =" <+> prettyTCM t+      reportSLn "tc.instance" 70 $ "findInstance 3: t: " ++ prettyShow t++      mcands <-+        -- Temporarily remove other instance constraints to avoid+        -- redundant solution attempts+        holdConstraints (const isInstanceProblemConstraint) $+        checkCandidates m t cands++      debugConstraints+      case mcands of+        Just ([(_, err)], []) -> do+          reportSDoc "tc.instance" 15 $+            "findInstance 5: the only viable candidate failed..."+          throwError err++        Just (errs, []) -> do+          if null errs then reportSDoc "tc.instance" 15 $ "findInstance 5: no viable candidate found..."+                       else reportSDoc "tc.instance" 15 $ "findInstance 5: all viable candidates failed..."+          -- #3676: Sort the candidates based on the size of the range for the errors and+          --        set the range of the full error to the range of the most precise candidate+          --        error.+          let sortedErrs = List.sortBy (compare `on` precision) errs+                where precision (_, err) = maybe infinity iLength $ rangeToInterval $ getRange err+                      infinity = 1000000000+          setCurrentRange (take 1 $ map snd sortedErrs) $+            typeError $ InstanceNoCandidate t [ (candidateTerm c, err) | (c, err) <- sortedErrs ]++        Just (errs, [(c@(Candidate q term t' _), v)]) -> do+          reportSDoc "tc.instance" 15 $ vcat+            [ "instance search: attempting"+            , nest 2 $ prettyTCM m <+> ":=" <+> prettyTCM v+            ]++          reportSDoc "tc.instance" 70 $ nest 2 $+            "candidate v = " <+> pretty v++          ctxElims <- map Apply <$> getContextArgs+          equalTerm t (MetaV m ctxElims) v++          reportSDoc "tc.instance" 15 $ vcat+            [ "findInstance 5: solved by instance search using the only candidate"+            , nest 2 $ prettyTCM c <+> "=" <+> prettyTCM term+            , "of type " <+> prettyTCM t'+            , "for type" <+> prettyTCM t+            ]++          -- If we actually solved the constraints we should wake up any held+          -- instance constraints, to make sure we don't forget about them.+          wakeupInstanceConstraints+          return Nothing  -- We’re done++        _ -> do+          let cs = maybe cands (map fst . snd) mcands -- keep the current candidates if Nothing+          reportSDoc "tc.instance" 15 $+            text ("findInstance 5: refined candidates: ") <+>+            prettyTCM (List.map candidateTerm cs)+          whenProfile Profile.Instances $ tick "findInstance: multiple candidates"+          return (Just (cs, neverUnblock))++insidePi :: Type -> (Type -> TCM a) -> TCM a+insidePi t ret = reduce (unEl t) >>= \case+    Pi a b     -> addContext (absName b, a) $ insidePi (absBody b) ret+    Def{}      -> ret t+    Var{}      -> ret t+    Sort{}     -> __IMPOSSIBLE__+    Con{}      -> __IMPOSSIBLE__+    Lam{}      -> __IMPOSSIBLE__+    Lit{}      -> __IMPOSSIBLE__+    Level{}    -> __IMPOSSIBLE__+    MetaV{}    -> __IMPOSSIBLE__+    DontCare{} -> __IMPOSSIBLE__+    Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s++-- | Apply the computation to every argument in turn by resetting the state every+--   time. Return the list of the arguments giving the result True.+--+--   If the resulting list contains exactly one element, then the state is the+--   same as the one obtained after running the corresponding computation. In+--   all the other cases, the state is reset.+--+--   Also returns the candidates that pass type checking but fails constraints,+--   so that the error messages can be reported if there are no successful+--   candidates.+filterResettingState+  :: MetaId+  -> [Candidate]+  -> (Candidate -> TCM YesNo)+  -> TCM ([(Candidate, TCErr)], [(Candidate, Term)])+filterResettingState m cands f = do+  ctxArgs  <- getContextArgs+  let ctxElims = map Apply ctxArgs+  result <- mapM (\c -> do bs <- localTCStateSaving (f c); return (c, bs)) cands++  -- Check that there aren't any hard failures+  case [ err | (_, (HellNo err, _)) <- result ] of+    err : _ -> throwError err+    []      -> return ()++  -- c : Candidate+  -- r : YesNo+  -- a : Type         (fully instantiated)+  -- s : TCState+  let+    result' = [ (c, v, s) | (c, (r, s)) <- result, v <- maybeToList (fromYes r) ]+    overlap = flip all result \(c, (r, s)) -> case r of+      Yes _ False -> False+      _ -> True+  result'' <- dropSameCandidates m overlap result'+  case result'' of+    [(c, v, s)] -> ([], [(c, v)]) <$ putTC s+    _           -> do+      let bad  = [ (c, err) | (c, (NoBecause err, _)) <- result ]+          good = [ (c, v) | (c, v, _) <- result'' ]+      return (bad, good)++-- | The state used to reduce a list of candidates according to the+-- overlap rules.+data OverlapState item = OverlapState+  { survivingCands :: [item]+    -- ^ The reduced list.++  , guardingCands  :: [Candidate]+    -- ^ Overlapping candidates that have been discarded, which are kept+    -- around because they might still discard some overlappable+    -- candidates.+  }++-- | Apply the instance overlap rules to reduce the list of candidates.+resolveInstanceOverlap+  :: forall item.+     Bool+  -> Relevance+  -> (item -> Candidate)+  -> [item]+  -> TCM [item]+resolveInstanceOverlap overlapOk rel itemC cands = wrapper where+  wrapper+    -- If all the candidates are incoherent: choose the leftmost candidate.+    | all (isIncoherent . candidateOverlap . itemC) cands+    , (c:_) <- cands = pure [c]++    -- If all the candidates are record field overlap: choose the leftmost candidate.+    | all ((== FieldOverlap) . candidateOverlap . itemC) cands+    , (c:_) <- cands = pure [c]++    -- If none of the candidates have a special overlap mode: there's no+    -- reason to do any work.+    | all ((DefaultOverlap ==) . candidateOverlap . itemC) cands = pure cands++    | not overlapOk = pure cands++    -- If some of the candidates are overlappable/overlapping, then we+    -- should do the work.+    | otherwise = Bench.billTo [Bench.Typing, Bench.InstanceSearch, Bench.CheckOverlap] do+      reportSDoc "tc.instance.overlap" 30 $ "overlapping instances:" $$ vcat (map (debugCandidate . itemC) cands)++      sinkIncoherent . survivingCands <$> foldrM insert (OverlapState [] []) cands++  isGlobal Candidate{candidateKind = GlobalCandidate _} = True+  isGlobal _ = False++  -- At the end of the process, we might still have some incoherent and+  -- non-incoherent candidates, since the user might have an instance+  -- which fixes some arguments in a way that prevents it from serving+  -- as a specialisation (see test/Succeed/Overlap1).+  --+  -- See test/Succeed/OverlapDupe for a case where this is necessary.+  sinkIncoherent :: [item] -> [item]+  sinkIncoherent cands = case List.partition (isIncoherent . itemC) cands of+    (as, [c]) | all (isGlobal . itemC) as -> pure c+    (as, cs)  | all (isGlobal . itemC) as -> cs ++ as+    _                                     -> cands++  -- Insert a new item into the overlap state.+  insertNew+    :: OverlapState item  -- The state to insert into+    -> item               -- The item to insert+    -> [item]             -- Old items which we might overlap/be overlapped by+    -> TCM (OverlapState item)+  insertNew oldState new [] = pure oldState{ survivingCands = [new] }+  insertNew oldState newItem oldItems@(oldItem:olds) = do+    let+      new = itemC newItem+      old = itemC oldItem++    reportSDoc "tc.instance.overlap" 50 $ vcat+      [ "comparing new candidate"+      , nest 2 (debugCandidate new)+      , "versus old candidate"+      , nest 2 (debugCandidate old)+      ]++    let+      -- If the new candidate overrides the old, drop it. But if the old+      -- candidate was overlapping (and the new one isn't), we keep it+      -- as a guard, since it might knock out future candidates.+      newold = insertNew oldState newItem olds <&> \case+        OverlapState items guards ->+          if not (isOverlapping new) && isOverlapping old+            then OverlapState items guards+            else OverlapState items (old:guards)++      -- If the old candidate overrides the new, then stop inserting.+      -- But if the new candidate is overlapping, it can be added as a+      -- guard.+      oldnew = do+        if isOverlapping old || not (isOverlapping new) then pure oldState{ survivingCands = oldItems } else do+          let OverlapState{ guardingCands = guards } = oldState+          reportSDoc "tc.instance.overlap" 40 $ vcat+            [ "will become guard:"+            , nest 2 (debugCandidate new)+            , "old items:"+            , nest 2 (vcat (map (debugCandidate . itemC) oldItems))+            ]++          -- But we can't /just/ add it to the list of guards: the new+          -- item might conflict with some of the other old candidates.+          -- We must remove those.+          alive <- filterM (fmap not . doesCandidateOverlap new . itemC) oldItems+          pure $ OverlapState alive (new:guards)++      -- If neither overrides the other, keep both!+      neither = insertNew oldState newItem olds <&> \case+        OverlapState items guards -> OverlapState (oldItem:items) guards++    ifM (new `doesCandidateOverlap` old)+      {- then -} newold+      {- else -} (ifM (old `doesCandidateOverlap` new)+        {- then -} oldnew+        {- else -} neither)++  -- Insert a new instance into the given overlap set.+  insert :: item -> OverlapState item -> TCM (OverlapState item)+  insert newItem oldState@(OverlapState oldItems guards) = do+    let new = itemC newItem+    -- If the new candidate is overridden by any of the guards, we can+    -- ditch it immediately.+    guarded <- anyM (`doesCandidateOverlap` new) guards++    reportSDoc "tc.instance.overlap" 40 $ vcat+      [ "inserting new candidate:"+      , nest 2 (debugCandidate new)+      , "against old candidates"+      , nest 2 (vcat (map (debugCandidate . itemC) oldItems))+      , "and guarding candidates"+      , nest 2 (vcat (map debugCandidate guards))+      , "is guarded?" <+> prettyTCM guarded+      ]++    if guarded then pure oldState else insertNew oldState newItem oldItems++-- Drop all candidates which are judgmentally equal to the first one.+-- This is sufficient to reduce the list to a singleton should all be equal.+dropSameCandidates :: MetaId -> Bool -> [(Candidate, Term, TCState)] -> TCM [(Candidate, Term, TCState)]+dropSameCandidates m overlapOk cands0 = verboseBracket "tc.instance" 30 "dropSameCandidates" $ do+  !nextMeta    <- nextLocalMeta+  isRemoteMeta <- isRemoteMeta++  -- Does "it" contain any fresh meta-variables?+  let freshMetas = getAny . allMetas (\m -> Any (not (isRemoteMeta m || m < nextMeta)))++  rel <- getRelevance <$> lookupMetaModality m++  -- Take overlappable candidates into account+  cands <- resolveInstanceOverlap overlapOk rel fst3 cands0+  reportSDoc "tc.instance.overlap" 30 $ "instances after resolving overlap:" $$ vcat (map (debugCandidate . fst3) cands)++  reportSDoc "tc.instance" 50 $ vcat+    [ "valid candidates:"+    , nest 2 $ vcat [ if freshMetas v then "(redacted)" else+                      sep [ prettyTCM v ]+                    | (_, v, _) <- cands ] ]++  case cands of+    [] -> return cands+    cvd : _ | isIrrelevant rel -> do+      reportSLn "tc.instance" 30 "dropSameCandidates: Meta is irrelevant so any candidate will do."+      return [cvd]++    -- If there's nothing, try not to reduce the candidate.+    [cvd] -> pure [cvd]++    cvd@(_, v, _) : vas -> do+      let+        equal :: (Candidate, Term, a) -> TCM Bool+        equal (c, v', _)+            | isIncoherent c = return True   -- See 'sinkIncoherent'+            | freshMetas v'  = return False  -- If there are fresh metas we can't compare+            | otherwise      =+          verboseBracket "tc.instance" 30 "dropSameCandidates: " $ do+          reportSDoc "tc.instance" 30 $ sep [ prettyTCM v <+> "==", nest 2 $ prettyTCM v' ]+          a <- uncurry piApplyM =<< ((,) <$> getMetaType m <*> getContextArgs)+          pureEqualTermB a v v' <&> \case+            Left{}  -> False+            Right b -> b++      -- If we do actually have to remove overlap then we have to reduce+      -- the candidate to eliminate any "phantom" dependencies on fresh+      -- metas.+      v <- reduce v+      if+        | freshMetas v -> do+          reportSLn "tc.instance" 30 "dropSameCandidates: Solution of instance meta has fresh metas so we don't filter equal candidates yet"+          return (cvd : vas)+        | otherwise -> (cvd :) <$> dropWhileM equal vas++data YesNo = Yes Term Bool | No | NoBecause TCErr | HellNo TCErr+  deriving (Show)++fromYes :: YesNo -> Maybe Term+fromYes (Yes t _) = Just t+fromYes _         = Nothing++debugCandidate' :: MonadPretty m => Bool -> Bool -> Candidate -> m Doc+debugCandidate' raw term c@(Candidate q v t overlap) =+  let+    cand+      | term      = prettyTCM v+      | otherwise = prettyTCM c++    ty+      | raw       = nest 2 (pretty t)+      | otherwise = prettyTCM t++    head = fsep [ "-", pretty overlap, cand, ":" ]+  in if | raw       -> sep [ head, ty ]+        | otherwise -> head <+> ty++debugCandidate :: MonadPretty m => Candidate -> m Doc+debugCandidate = debugCandidate' False False++debugCandidateRaw :: MonadPretty m => Candidate -> m Doc+debugCandidateRaw = debugCandidate' True False++debugCandidateTerm :: MonadPretty m => Candidate -> m Doc+debugCandidateTerm = debugCandidate' False True++-- | Given a meta @m@ of type @t@ and a list of candidates @cands@,+-- @checkCandidates m t cands@ returns a refined list of valid candidates and+-- candidates that failed some constraints.+checkCandidates :: MetaId -> Type -> [Candidate] -> TCM (Maybe ([(Candidate, TCErr)], [(Candidate, Term)]))+checkCandidates m t cands =+  verboseBracket "tc.instance.candidates" 20 ("checkCandidates " ++ prettyShow m) $+  ifM (anyMetaTypes cands) (return Nothing) $ Just <$> do+    reportSDoc "tc.instance.candidates" 20 $ nest 2 $ "target:" <+> prettyTCM t+    reportSDoc "tc.instance.candidates" 20 $ nest 2 $ vcat+      [ "candidates", vcat (map debugCandidate cands) ]++    t <- instantiateFull t+    cands'@(_, okay) <- filterResettingState m cands (checkCandidateForMeta m t)++    reportSDoc "tc.instance.candidates" 20 $ nest 2 $ vcat+      [ "valid candidates", vcat (map (debugCandidate . fst) okay) ]+    reportSDoc "tc.instance.candidates" 60 $ nest 2 $ vcat+      [ "valid candidates", vcat (map (debugCandidateTerm . fst) okay) ]++    return cands'+  where+    anyMetaTypes :: [Candidate] -> TCM Bool+    anyMetaTypes [] = return False+    anyMetaTypes (Candidate _ _ a _ : cands) = do+      a <- instantiate a+      case unEl a of+        MetaV{} -> return True+        _       -> anyMetaTypes cands++    checkDepth :: Term -> Type -> TCM YesNo -> TCM YesNo+    checkDepth c a k = locallyTC eInstanceDepth succ $ do+      d        <- viewTC eInstanceDepth+      maxDepth <- maxInstanceSearchDepth+      when (d > maxDepth) $ typeError $ InstanceSearchDepthExhausted c a maxDepth+      k++    checkCandidateForMeta :: MetaId -> Type -> Candidate -> TCM YesNo+    checkCandidateForMeta m t (Candidate q term t' _) = checkDepth term t' $ do+      Bench.billTo [Bench.Typing, Bench.InstanceSearch, Bench.FilterCandidates] $ do+      whenProfile Profile.Instances $ tick "checkCandidateForMeta"++      -- Andreas, 2015-02-07: New metas should be created with range of the+      -- current instance meta, thus, we set the range.+      mv <- lookupLocalMeta m+      setCurrentRange mv $ runCandidateCheck $+        verboseBracket "tc.instance" 20 ("checkCandidateForMeta " ++ prettyShow m) $ do+          reportSDoc "tc.instance" 20 $ vcat+            [ "checkCandidateForMeta"+            , "  t    =" <+> prettyTCM t+            , "  t'   =" <+> prettyTCM t'+            , "  term =" <+> prettyTCM term+            ]+          reportSDoc "tc.instance" 70 $ vcat+            [ "  t    =" <+> pretty t+            , "  t'   =" <+> pretty t'+            , "  term =" <+> pretty term+            ]+          debugConstraints++          -- Apply hidden and instance arguments (in case of+          -- --overlapping-instances, this performs recursive+          -- inst. search!).+          (args, t'') <- implicitArgs (-1) (\h -> notVisible h) t'++          reportSDoc "tc.instance" 20 $+            "instance search: checking" <+> prettyTCM t'' <+> "<=" <+> prettyTCM t+          reportSDoc "tc.instance" 70 $ vcat+            [ "instance search: checking (raw)"+            , nest 4 $ pretty t''+            , nest 2 $ "<="+            , nest 4 $ pretty t+            ]++          -- Check whether this candidate is OK, and whether it is okay+          -- for the overlap check. For the candidate to be acceptable,+          -- its type must be a subtype of the goal type.+          (cons, overlapOk) <- ifNoConstraints_ (leqType t'' t) (pure ([], True)) \pid -> do+            -- To know if this candidate is safe for overlap, we have to+            -- check that it does not constrain the type of the instance+            -- goal. We can do this by running it in a new problem and+            -- checking whether the computation produced any constraints+            -- that are blocked by the instance goal.+            cons <- getConstraintsForProblem pid+            -- Make sure to put these constraints back if we end up+            -- solving the instance goal with this candidate.+            stealConstraints pid+            let+              blocking = foldMap (allBlockingMetas . constraintUnblocker) cons+              !ok = getAll $! flip allMetas t (All . not . flip Set.member blocking)+            pure (cons, ok)+          debugConstraints++          flip catchError (return . NoBecause) $ do+            -- make a pass over constraints, to detect cases where+            -- some are made unsolvable by the type comparison, but+            -- don't do this for FindInstance's to prevent loops.+            solveAwakeConstraints' True+            -- We need instantiateFull here to remove 'local' metas+            v <- instantiateFull =<< (term `applyDroppingParameters` args)+            reportSDoc "tc.instance" 15 $+              vcat [ sep [ ("instance search: found solution for" <+> prettyTCM m) <> ":"+                  , nest 2 $ prettyTCM v ]+                  , "app: " <+> (nest 2 $ prettyTCM =<< (term `applyDroppingParameters` args))+                  ]++            reportSDoc "tc.instance.overlap" 30 $+              "candidate" <+> prettyTCM v <+> "okay for overlap?" <+> prettyTCM overlapOk+              $$ vcat (map prettyTCM cons)++            whenProfile Profile.Instances $ tick "checkCandidateForMeta: yes"+            return $ Yes v overlapOk+      where+        runCandidateCheck = flip catchError handle . nowConsideringInstance++        hardFailure :: TCErr -> Bool+        hardFailure (TypeError _ _ err) =+          case clValue err of+            InstanceSearchDepthExhausted{} -> True+            _                              -> False+        hardFailure _ = False++        handle :: TCErr -> TCM YesNo+        handle err+          | hardFailure err = do+            whenProfile Profile.Instances $ tick "checkCandidateForMeta: no"+            return $ HellNo err+          | otherwise       = do+            reportSDoc "tc.instance" 50 $ "candidate failed type check:" <+> prettyTCM err+            whenProfile Profile.Instances $ tick "checkCandidateForMeta: no"+            return No+++nowConsideringInstance :: (ReadTCState m) => m a -> m a+nowConsideringInstance = locallyTCState stConsideringInstance $ const True++-- Rather than just the instance constraints, these are the constraints+-- which could be suspended by being under 'nowConsideringInstances',+-- which also includes unquote constraints.+isInstanceProblemConstraint :: ProblemConstraint -> Bool+isInstanceProblemConstraint c = case clValue (theConstraint c) of+  FindInstance{}  -> True+  UnquoteTactic{} -> True+  _ -> False++wakeupInstanceConstraints :: TCM ()+wakeupInstanceConstraints =+  unlessM shouldPostponeInstanceSearch $ do+    wakeConstraints (wakeUpWhen_ isInstanceProblemConstraint)+    solveAwakeInstanceConstraints++solveAwakeInstanceConstraints :: TCM ()+solveAwakeInstanceConstraints =+  solveSomeAwakeConstraints isInstanceProblemConstraint False++postponeInstanceConstraints :: TCM a -> TCM a+postponeInstanceConstraints m =+  locallyTCState stPostponeInstanceSearch (const True) m <* wakeupInstanceConstraints++flushInstanceConstraints :: TCM ()+flushInstanceConstraints = locallyTCState stInstanceHack (const True) $ wakeupInstanceConstraints++-- | To preserve the invariant that a constructor is not applied to its+--   parameter arguments, we explicitly check whether function term+--   we are applying to arguments is a unapplied constructor.+--   In this case we drop the first 'conPars' arguments.+--   See Issue670a.+--   Andreas, 2013-11-07 Also do this for projections, see Issue670b.+--   Szumi, 2025-05-05: Unapplied projections are not considered by instance+--   search since #938.+applyDroppingParameters :: Term -> Args -> TCM Term+applyDroppingParameters t vs = do+  let fallback = return $ t `apply` vs+  case t of+    Con c ci [] -> do+      def <- theDef <$> getConInfo c+      case def of+        Constructor {conPars = n, conData = d} -> do+          -- Szumi, 2025-05-05, issue #7853: don't drop parameters from the current module.+          fv <- getDefFreeVars d+          return $ Con c ci (map Apply $ drop (n - fv) vs)+        _ -> __IMPOSSIBLE__+    -- Def f [] -> do+    --   -- Andreas, 2022-03-07, issue #5809: don't drop parameters of irrelevant projections.+    --   mp <- isRelevantProjection f+    --   case mp of+    --     Just Projection{projIndex = n} -> do+    --       case drop n vs of+    --         []     -> return t+    --         u : us -> (`apply` us) <$> applyDef ProjPrefix f u+    --     _ -> fallback+    _ -> fallback++---------------------------------------------------------------------------+-- * Instance definitions+---------------------------------------------------------------------------++data OutputTypeName+  = OutputTypeName QName+  | OutputTypeVar+  | OutputTypeVisiblePi+  | OutputTypeNameNotYetKnown Blocker+  | NoOutputTypeName++-- | Strips all hidden and instance Pi's and return the argument+--   telescope, the head term, and its name, if possible.+getOutputTypeName :: Type -> TCM (Telescope, Term, OutputTypeName)+-- 2023-10-26, Jesper, issue #6941: To make instance search work correctly for+-- abstract or opaque instances, we need to ignore abstract mode when computing+-- the output type name.+getOutputTypeName t = ignoreAbstractMode $ do+  TelV tel t' <- telViewUpTo' (-1) notVisible t+  ifBlocked (unEl t') (\b t -> return (tel , __DUMMY_TERM__, OutputTypeNameNotYetKnown b)) $ \ _ v ->+    case v of+      -- Possible base types:+      Def n _  -> return (tel, v, OutputTypeName n)+      Sort{}   -> return (tel, v, NoOutputTypeName)+      Var n _  -> return (tel, v, OutputTypeVar)+      Pi{}     -> return (tel, v, OutputTypeVisiblePi)+      -- Not base types:+      Con{}    -> __IMPOSSIBLE__+      Lam{}    -> __IMPOSSIBLE__+      Lit{}    -> __IMPOSSIBLE__+      Level{}  -> __IMPOSSIBLE__+      MetaV{}  -> __IMPOSSIBLE__+      DontCare{} -> __IMPOSSIBLE__+      Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s+++-- | Register the definition with the given type as an instance.+--   Issue warnings if instance is unusable.+addTypedInstance ::+     QName  -- ^ Name of instance.+  -> Type   -- ^ Type of instance.+  -> TCM ()+addTypedInstance = addTypedInstance' True False Nothing++-- | Like 'addTypedInstance', but delete any existing entries for the+-- given name from the discrimination tree.+readdTypedInstance ::+     QName  -- ^ Name of instance.+  -> Type   -- ^ Type of instance.+  -> TCM ()+readdTypedInstance = addTypedInstance' True True Nothing++-- | Register the definition with the given type as an instance.+addTypedInstance'+  :: Bool               -- ^ Should we print warnings for unusable instance declarations?+  -> Bool               -- ^ Is this the second time we're adding this QName as an instance?+  -> Maybe InstanceInfo -- ^ Is this instance a copy?+  -> QName              -- ^ Name of instance.+  -> Type               -- ^ Type of instance.+  -> TCM ()+addTypedInstance' w readd orig inst t = do+  reportSDoc "tc.instance.add" 30 $ vcat+    [ "adding typed instance" <+> prettyTCM inst <+> "with type"+    , prettyTCM =<< flip abstract t <$> getContextTelescope+    ]++  (tel, hdt, n) <- getOutputTypeName t+  case n of+    OutputTypeName n -> addContext tel $ do+      tele <- getContextTelescope++      -- Insert the instance into the instance table, putting it in the+      -- discrimination tree *and* bumping the total number of instances+      -- for this class.+      tree <- useTC stInstanceTree++      -- Amélia, 2025-02-28: If the instance we're adding has no type+      -- signature, we end up adding it to the tree twice: once with a+      -- useless type, and once after checking the RHS (which will have+      -- narrowed the type).+      --+      -- To avoid spurious overlap, the useful key should trump the+      -- useless key, so we filter this QName out of the tree when+      -- re-adding an instance.+      let+        tree' | readd     = deleteFromDT (Set.singleton inst) tree+              | otherwise = tree++      tree' <- insertDT (length tele) hdt inst $! tree'+      setTCLens stInstanceTree tree'++      modifyTCLens' (stSignature . sigInstances . itableCounts) $+        if readd then Map.insertWith (+) n 1 else id++      let+        info = flip fromMaybe orig InstanceInfo+          { instanceClass   = n+          , instanceOverlap = DefaultOverlap+          }++      -- This is no longer used to build the instance table for imported+      -- modules, but it is still used to know if an instance should be+      -- copied when applying a section.+      modifySignature $ updateDefinition inst \ d -> d { defInstance = Just info }++      -- If there's anything visible in the context, which will+      -- eventually end up in the instance's type, let's make a note to+      -- get rid of it before serialising the instance table.+      con <- isConstructor inst+      -- However, do note that data constructors can have "visible+      -- arguments" in their global type which.. aren't actually+      -- visible: the parameters.+      when (any visible tele && not con) $ modifyTCLens' stTemporaryInstances $ Set.insert inst++    OutputTypeNameNotYetKnown b -> do+      addUnknownInstance inst+      addConstraint b $ ResolveInstanceHead inst++    NoOutputTypeName    -> when w $ warning $ WrongInstanceDeclaration+    OutputTypeVar       -> when w $ warning $ WrongInstanceDeclaration+    OutputTypeVisiblePi -> when w $ warning $ InstanceWithExplicitArg inst++resolveInstanceHead :: QName -> TCM ()+resolveInstanceHead q = do+  clearUnknownInstance q+  -- Andreas, 2022-12-04, issue #6380:+  -- Do not warn about unusable instances here.+  addTypedInstance' False True Nothing q =<< typeOfConst q++-- | Try to solve the instance definitions whose type is not yet known, report+--   an error if it doesn't work and return the instance table otherwise.+getInstanceDefs :: TCM InstanceTable+getInstanceDefs = do+  (table, pending) <- getAllInstanceDefs+  unless (null pending) $ do+    patternViolation alwaysUnblock  -- TODO: more refined unblocking+  return table++-- | Prune an 'Interface' to remove any instances that would be+-- inapplicable in child modules.+--+-- While in a section with visible arguments, we add any instances+-- defined locally to the instance table: you have to be able to find+-- them, after all! Conservatively, all of the local variables are+-- turned into 'FlexK's, i.e., wildcards.+--+-- But when we leave such a section, these instances have no more value:+-- even though they might technically be in scope, their types are+-- malformed, since they have visible pis.+--+-- This function deletes these instances from the instance tree in the+-- given signature to save on serialisation time *and* time spent+-- checking for candidate validity in client modules. It can't do this+-- directly in the TC state to prevent these instances from going out of+-- scope before interaction (see #7196).+pruneTemporaryInstances :: Interface -> TCM Interface+pruneTemporaryInstances int = do+  todo <- useTC stTemporaryInstances++  reportSDoc "tc.instance.prune" 30 $ vcat+    [ "leaving section"+    , prettyTCM =<< getContextTelescope+    , "todo:" <+> prettyTCM todo+    ]++  let sig' = over (sigInstances . itableTree) (deleteFromDT todo) (iSignature int)+  pure int{ iSignature = sig' }
+ src/full/Agda/TypeChecking/InstanceArguments.hs-boot view
@@ -0,0 +1,7 @@+module Agda.TypeChecking.InstanceArguments where++import Agda.TypeChecking.Monad.Base (TCM, InstanceInfo)++import Agda.Syntax.Internal (QName, Type)++addTypedInstance' :: Bool -> Bool -> Maybe InstanceInfo -> QName -> Type -> TCM ()
src/full/Agda/TypeChecking/Irrelevance.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE NondecreasingIndentation #-}  {-| Compile-time irrelevance.@@ -73,13 +75,7 @@  module Agda.TypeChecking.Irrelevance where -import Control.Arrow (second)--import Control.Monad.Except--import qualified Data.Map as Map--import Agda.Interaction.Options+import Control.Monad.Except ( MonadError(..), runExceptT )  import Agda.Syntax.Common import Agda.Syntax.Internal@@ -88,183 +84,13 @@ import Agda.TypeChecking.Pretty import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute.Class+import Agda.TypeChecking.Telescope -import Agda.Utils.Function-import Agda.Utils.Lens+import Agda.Utils.Either (fromRightM) import Agda.Utils.Maybe import Agda.Utils.Monad --- | data 'Relevance'---   see "Agda.Syntax.Common".---- * Operations on 'Dom'.---- | Prepare parts of a parameter telescope for abstraction in constructors---   and projections.-hideAndRelParams :: (LensHiding a, LensRelevance a) => a -> a-hideAndRelParams = hideOrKeepInstance . mapRelevance nonStrictToIrr---- * Operations on 'Context'.---- | Modify the context whenever going from the l.h.s. (term side)---   of the typing judgement to the r.h.s. (type side).-workOnTypes :: (MonadTCEnv m, HasOptions m, MonadDebug m)-            => m a -> m a-workOnTypes cont = do-  allowed <- optExperimentalIrrelevance <$> pragmaOptions-  verboseBracket "tc.irr" 60 "workOnTypes" $ workOnTypes' allowed cont---- | Internal workhorse, expects value of --experimental-irrelevance flag---   as argument.-workOnTypes' :: (MonadTCEnv m) => Bool -> m a -> m a-workOnTypes' experimental-  = (if experimental-     then modifyContextInfo (mapRelevance irrToNonStrict)-     else id)-  . applyQuantityToContext zeroQuantity-  . typeLevelReductions-  . localTC (\ e -> e { envWorkingOnTypes = True })---- | (Conditionally) wake up irrelevant variables and make them relevant.---   For instance,---   in an irrelevant function argument otherwise irrelevant variables---   may be used, so they are awoken before type checking the argument.------   Also allow the use of irrelevant definitions.-applyRelevanceToContext :: (MonadTCEnv tcm, LensRelevance r) => r -> tcm a -> tcm a-applyRelevanceToContext thing =-  case getRelevance thing of-    Relevant -> id-    rel      -> applyRelevanceToContextOnly   rel-              . applyRelevanceToJudgementOnly rel---- | (Conditionally) wake up irrelevant variables and make them relevant.---   For instance,---   in an irrelevant function argument otherwise irrelevant variables---   may be used, so they are awoken before type checking the argument.------   Precondition: @Relevance /= Relevant@-applyRelevanceToContextOnly :: (MonadTCEnv tcm) => Relevance -> tcm a -> tcm a-applyRelevanceToContextOnly rel = localTC-  $ over eContext     (map $ inverseApplyRelevance rel)-  . over eLetBindings (Map.map . fmap . second $ inverseApplyRelevance rel)---- | Apply relevance @rel@ the the relevance annotation of the (typing/equality)---   judgement.  This is part of the work done when going into a @rel@-context.------   Precondition: @Relevance /= Relevant@-applyRelevanceToJudgementOnly :: (MonadTCEnv tcm) => Relevance -> tcm a -> tcm a-applyRelevanceToJudgementOnly = localTC . over eRelevance . composeRelevance---- | Like 'applyRelevanceToContext', but only act on context if---   @--irrelevant-projections@.---   See issue #2170.-applyRelevanceToContextFunBody :: (MonadTCM tcm, LensRelevance r) => r -> tcm a -> tcm a-applyRelevanceToContextFunBody thing cont =-  case getRelevance thing of-    Relevant -> cont-    rel -> applyWhenM (optIrrelevantProjections <$> pragmaOptions)-      (applyRelevanceToContextOnly rel) $    -- enable local irr. defs only when option-      applyRelevanceToJudgementOnly rel cont -- enable global irr. defs alway---- | Sets the current quantity (unless the given quantity is 1).-applyQuantityToContext :: (MonadTCEnv tcm, LensQuantity q) => q -> tcm a -> tcm a-applyQuantityToContext thing =-  case getQuantity thing of-    Quantity1{} -> id-    q           -> applyQuantityToJudgementOnly q---- | Apply quantity @q@ the the quantity annotation of the (typing/equality)---   judgement.  This is part of the work done when going into a @q@-context.------   Precondition: @Quantity /= Quantity1@-applyQuantityToJudgementOnly :: (MonadTCEnv tcm) => Quantity -> tcm a -> tcm a-applyQuantityToJudgementOnly = localTC . over eQuantity . composeQuantity---- | Apply inverse composition with the given cohesion to the typing context.-applyCohesionToContext :: (MonadTCEnv tcm, LensCohesion m) => m -> tcm a -> tcm a-applyCohesionToContext thing =-  case getCohesion thing of-    m | m == unitCohesion -> id-      | otherwise         -> applyCohesionToContextOnly   m-                             -- Cohesion does not apply to the judgment.--applyCohesionToContextOnly :: (MonadTCEnv tcm) => Cohesion -> tcm a -> tcm a-applyCohesionToContextOnly q = localTC-  $ over eContext     (map $ inverseApplyCohesion q)-  . over eLetBindings (Map.map . fmap . second $ inverseApplyCohesion q)---- | Can we split on arguments of the given cohesion?-splittableCohesion :: (HasOptions m, LensCohesion a) => a -> m Bool-splittableCohesion a = do-  let c = getCohesion a-  pure (usableCohesion c) `and2M` (pure (c /= Flat) `or2M` do optFlatSplit <$> pragmaOptions)---- | (Conditionally) wake up irrelevant variables and make them relevant.---   For instance,---   in an irrelevant function argument otherwise irrelevant variables---   may be used, so they are awoken before type checking the argument.------   Also allow the use of irrelevant definitions.------   This function might also do something for other modalities.-applyModalityToContext :: (MonadTCEnv tcm, LensModality m) => m -> tcm a -> tcm a-applyModalityToContext thing =-  case getModality thing of-    m | m == unitModality -> id-      | otherwise         -> applyModalityToContextOnly   m-                           . applyModalityToJudgementOnly m---- | (Conditionally) wake up irrelevant variables and make them relevant.---   For instance,---   in an irrelevant function argument otherwise irrelevant variables---   may be used, so they are awoken before type checking the---   argument.------   This function might also do something for other modalities, but---   not for quantities.------   Precondition: @Modality /= Relevant@-applyModalityToContextOnly :: (MonadTCEnv tcm) => Modality -> tcm a -> tcm a-applyModalityToContextOnly m = localTC-  $ over eContext (map $ inverseApplyModalityButNotQuantity m)-  . over eLetBindings-      (Map.map . fmap . second $ inverseApplyModalityButNotQuantity m)---- | Apply modality @m@ the the modality annotation of the (typing/equality)---   judgement.  This is part of the work done when going into a @m@-context.------   Precondition: @Modality /= Relevant@-applyModalityToJudgementOnly :: (MonadTCEnv tcm) => Modality -> tcm a -> tcm a-applyModalityToJudgementOnly = localTC . over eModality . composeModality---- | Like 'applyModalityToContext', but only act on context (for Relevance) if---   @--irrelevant-projections@.---   See issue #2170.-applyModalityToContextFunBody :: (MonadTCM tcm, LensModality r) => r -> tcm a -> tcm a-applyModalityToContextFunBody thing cont = do-    ifM (optIrrelevantProjections <$> pragmaOptions)-      {-then-} (applyModalityToContext m cont)                -- enable global irr. defs always-      {-else-} (applyRelevanceToContextFunBody (getRelevance m)-               $ applyCohesionToContext (getCohesion m)-               $ applyQuantityToContext (getQuantity m) cont) -- enable local irr. defs only when option-  where-    m = getModality thing---- | Wake up irrelevant variables and make them relevant. This is used---   when type checking terms in a hole, in which case you want to be able to---   (for instance) infer the type of an irrelevant variable. In the course---   of type checking an irrelevant function argument 'applyRelevanceToContext'---   is used instead, which also sets the context relevance to 'Irrelevant'.---   This is not the right thing to do when type checking interactively in a---   hole since it also marks all metas created during type checking as---   irrelevant (issue #2568).------   Also set the current quantity to 0.-wakeIrrelevantVars :: (MonadTCEnv tcm) => tcm a -> tcm a-wakeIrrelevantVars-  = applyRelevanceToContextOnly Irrelevant-  . applyQuantityToJudgementOnly zeroQuantity+import Agda.Utils.Impossible  -- | Check whether something can be used in a position of the given relevance. --@@ -305,7 +131,7 @@     Sort s   -> usableRel rel s     Level l  -> return True     MetaV m vs -> do-      mrel <- getMetaRelevance <$> lookupMeta m+      mrel <- getRelevance <$> lookupMetaModality m       return (mrel `moreRelevant` rel) `and2M` usableRel rel vs     DontCare v -> usableRel rel v -- TODO: allow irrelevant things to be used in DontCare position?     Dummy{}  -> return True@@ -315,12 +141,12 @@  instance UsableRelevance Sort where   usableRel rel = \case-    Type l -> usableRel rel l-    Prop l -> usableRel rel l-    Inf f n -> return True-    SSet l -> usableRel rel l+    Univ _ l -> usableRel rel l+    Inf _ _ -> return True     SizeUniv -> return True     LockUniv -> return True+    LevelUniv -> return True+    IntervalUniv -> return True     PiSort a s1 s2 -> usableRel rel (a,s1,s2)     FunSort s1 s2 -> usableRel rel (s1,s2)     UnivSort s -> usableRel rel s@@ -348,7 +174,7 @@   usableRel rel (Proj _ p) = do     prel <- relOfConst p     return $ prel `moreRelevant` rel-  usableRel rel (IApply x y v) = allM [x,y,v] $ usableRel rel+  usableRel rel (IApply x y v) = usableRel rel v  instance UsableRelevance a => UsableRelevance (Arg a) where   usableRel rel (Arg info u) =@@ -392,26 +218,37 @@       return ok `and2M` usableMod mod vs     Def f vs -> do       fmod <- modalityOfConst f-      let ok = fmod `moreUsableModality` mod+      -- Pure modalities don't matter here, only positional ones, hence remove+      -- them from the equation.+      let ok = setModalPolarity (withStandardLock MixedPolarity) (setCohesion Flat fmod) `moreUsableModality` mod       reportSDoc "tc.irr" 50 $         "Definition" <+> prettyTCM (Def f []) <+>         text ("has modality " ++ show fmod ++ ", which is a " ++               (if ok then "" else "NOT ") ++ "more usable modality than " ++ show mod)       return ok `and2M` usableMod mod vs-    Con c _ vs -> usableMod mod vs+    Con c o vs -> do+      cmod <- modalityOfConst (conName c)+      let ok = cmod `moreUsableModality` mod+      reportSDoc "tc.irr" 50 $+        "The constructor" <+> prettyTCM (Con c o []) <+>+        text ("has the modality " ++ show cmod ++ ", which is " +++              (if ok then "" else "NOT ") +++              "more usable than the modality " ++ show mod ++ ".")+      return ok `and2M` usableMod mod vs     Lit l    -> return True     Lam info v  -> usableModAbs info mod v     -- Even if Pi contains Type, here we check it as a constructor for terms in the universe.     Pi a b   -> usableMod domMod (unEl $ unDom a) `and2M` usableModAbs (getArgInfo a) mod (unEl <$> b)       where         domMod = mapQuantity (composeQuantity $ getQuantity a) $-                 mapCohesion (composeCohesion $ getCohesion a) mod+                 mapCohesion (composeCohesion $ getCohesion a) $+                 mapModalPolarity (composePolarity $ getModalPolarity a) mod     -- Andrea 15/10/2020 not updating these cases yet, but they are quite suspicious,     -- do we have special typing rules for Sort and Level?     Sort s   -> usableMod mod s     Level l  -> return True     MetaV m vs -> do-      mmod <- getMetaModality <$> lookupMeta m+      mmod <- lookupMetaModality m       let ok = mmod `moreUsableModality` mod       reportSDoc "tc.irr" 50 $         "Metavariable" <+> prettyTCM (MetaV m []) <+>@@ -433,15 +270,6 @@  instance UsableModality Sort where   usableMod mod s = usableRel (getRelevance mod) s-  -- usableMod mod s = case s of-  --   Type l -> usableMod mod l-  --   Prop l -> usableMod mod l-  --   Inf    -> return True-  --   SizeUniv -> return True-  --   PiSort a s -> usableMod mod (a,s)-  --   UnivSort s -> usableMod mod s-  --   MetaS x es -> usableMod mod es-  --   DummyS{} -> return True  instance UsableModality Level where   usableMod mod (Max _ ls) = usableRel (getRelevance mod) ls@@ -461,7 +289,7 @@   usableMod mod (Proj _ p) = do     pmod <- modalityOfConst p     return $ pmod `moreUsableModality` mod-  usableMod mod (IApply x y v) = allM [x,y,v] $ usableMod mod+  usableMod mod (IApply x y v) = usableMod mod v  instance UsableModality a => UsableModality (Arg a) where   usableMod mod (Arg info u) =@@ -471,69 +299,86 @@ instance UsableModality a => UsableModality (Dom a) where   usableMod mod Dom{unDom = u} = usableMod mod u -usableAtModality :: MonadConstraint TCM => Modality -> Term -> TCM ()-usableAtModality mod t = catchConstraint (UsableAtModality mod t) $ do-  res <- runExceptT $ usableMod mod t-  case res of-    Right b -> do-      unless b $-        typeError . GenericDocError =<< (prettyTCM t <+> "is not usable at the required modality" <+> prettyTCM mod)-    Left blocker -> patternViolation blocker+usableAtModality' :: MonadConstraint TCM+  -- Note: This weird-looking constraint is to trick GHC into accepting+  -- that an instance of MonadConstraint TCM will exist, even if we+  -- can't import the module in which it is defined.+  => Maybe Sort -> WhyCheckModality -> Modality -> Term -> TCM ()+usableAtModality' ms why mod t =+  catchConstraint (UsableAtModality why ms mod t) $ do+    whenM (maybe (pure True) isFibrant ms) $ do+      res <- runExceptT $ usableMod mod t+      case res of+        Right b -> unless b $ typeError $ UnusableAtModality why mod t+        Left blocker -> patternViolation blocker +usableAtModality :: MonadConstraint TCM => WhyCheckModality -> Modality -> Term -> TCM ()+usableAtModality = usableAtModality' Nothing + -- * Propositions  -- | Is a type a proposition?  (Needs reduction.) -isPropM-  :: (LensSort a, PrettyTCM a, PureTCM m, MonadBlock m)-  => a -> m Bool+{-# SPECIALIZE isPropM :: Dom Type -> TCM Bool #-}+isPropM :: (LensSort a, PrettyTCM a, PureTCM m, MonadBlock m) => a -> m Bool isPropM a = do-  traceSDoc "tc.prop" 80 ("Is " <+> prettyTCM a <+> "of sort" <+> prettyTCM (getSort a) <+> "in Prop?") $ do-  abortIfBlocked (getSort a) <&> \case-    Prop{} -> True-    _      -> False+  let s = getSort a+  traceSDoc "tc.prop" 80 ("Is " <+> prettyTCM a <+> "of sort" <+> prettyTCM s <+> "in Prop?") do+  isProp <$> abortIfBlocked s +{-# SPECIALIZE isIrrelevantOrPropM :: Dom Type -> TCM Bool #-} isIrrelevantOrPropM   :: (LensRelevance a, LensSort a, PrettyTCM a, PureTCM m, MonadBlock m)   => a -> m Bool isIrrelevantOrPropM x = return (isIrrelevant x) `or2M` isPropM x +allIrrelevantOrPropTel+  :: (PureTCM m, MonadBlock m)+  => Telescope -> m Bool+allIrrelevantOrPropTel =+  foldrTelescopeM (and2M . isIrrelevantOrPropM . fmap snd) (return True)+ -- * Fibrant types  -- | Is a type fibrant (i.e. Type, Prop)? -isFibrant-  :: (LensSort a, PureTCM m, MonadBlock m)-  => a -> m Bool-isFibrant a = abortIfBlocked (getSort a) <&> \case-  Type{}     -> True-  Prop{}     -> True-  Inf f _    -> f == IsFibrant-  SSet{}     -> False-  SizeUniv{} -> False-  LockUniv{} -> False-  PiSort{}   -> False-  FunSort{}  -> False-  UnivSort{} -> False-  MetaS{}    -> False-  DefS{}     -> False-  DummyS{}   -> False+isFibrant :: (LensSort a, PureTCM m, MonadBlock m) => a -> m Bool+isFibrant = fromRightM patternViolation . isFibrant' +isFibrant' :: (LensSort a, PureTCM m) => a -> m (Either Blocker Bool)+isFibrant' s =+  ifBlocked (getSort s) (\ blocker _ -> return $ Left blocker) \ _ ->+    return . Right . \case+      Univ u _       -> univFibrancy u == IsFibrant+      Inf u _        -> univFibrancy u == IsFibrant+      SizeUniv{}     -> False+      LockUniv{}     -> False+      LevelUniv{}    -> False+      IntervalUniv{} -> False+      PiSort{}       -> __IMPOSSIBLE__+      FunSort{}      -> __IMPOSSIBLE__+      UnivSort{}     -> __IMPOSSIBLE__+      MetaS{}        -> __IMPOSSIBLE__+      DefS{}         -> False+      DummyS{}       -> False + -- | Cofibrant types are those that could be the domain of a fibrant --   pi type. (Notion by C. Sattler).-isCoFibrantSort :: (LensSort a, PureTCM m, MonadBlock m) => a -> m Bool-isCoFibrantSort a = abortIfBlocked (getSort a) <&> \case-  Type{}     -> True-  Prop{}     -> True-  Inf f _    -> f == IsFibrant-  SSet{}     -> False-  SizeUniv{} -> False-  LockUniv{} -> True-  PiSort{}   -> False-  FunSort{}  -> False-  UnivSort{} -> False-  MetaS{}    -> False-  DefS{}     -> False-  DummyS{}   -> False+isCoFibrantSort :: (LensSort a, PureTCM m) => a -> m (Either Blocker Bool)+isCoFibrantSort s =+  ifBlocked (getSort s) (\ blocker _ -> return $ Left blocker) \ _ ->+    return . Right . \case+      Univ u _       -> univFibrancy u == IsFibrant+      Inf u _        -> univFibrancy u == IsFibrant+      SizeUniv{}     -> False+      LockUniv{}     -> True+      LevelUniv{}    -> False+      IntervalUniv{} -> True+      PiSort{}       -> __IMPOSSIBLE__+      FunSort{}      -> __IMPOSSIBLE__+      UnivSort{}     -> __IMPOSSIBLE__+      MetaS{}        -> __IMPOSSIBLE__+      DefS{}         -> False+      DummyS{}       -> False
src/full/Agda/TypeChecking/Irrelevance.hs-boot view
@@ -1,14 +1,13 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Irrelevance where  import Agda.Syntax.Internal (LensSort) -import Agda.TypeChecking.Monad.Base (MonadTCEnv, HasOptions, MonadBlock)-import Agda.TypeChecking.Monad.Debug (MonadDebug)+import Agda.TypeChecking.Monad.Base (MonadBlock) import {-# SOURCE #-} Agda.TypeChecking.Pretty (PrettyTCM) import Agda.TypeChecking.Monad.Pure (PureTCM) -workOnTypes :: (MonadTCEnv m, HasOptions m, MonadDebug m) => m a -> m a isPropM   :: (LensSort a, PrettyTCM a, PureTCM m, MonadBlock m)   => a -> m Bool
src/full/Agda/TypeChecking/Level.hs view
@@ -3,7 +3,6 @@  import Data.Maybe import qualified Data.List as List-import Data.List.NonEmpty (NonEmpty(..)) import Data.Traversable (Traversable)  import Agda.Syntax.Common@@ -14,6 +13,7 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Reduce +import Agda.Utils.List1 ( List1, pattern (:|) ) import Agda.Utils.Maybe ( caseMaybeM, allJustM ) import Agda.Utils.Monad ( tryMaybe ) import Agda.Utils.Singleton@@ -31,42 +31,69 @@   , zeroName :: QName   } --- | Get the 'primLevel' as a 'Type'.-levelType :: (HasBuiltins m) => m Type-levelType = El (mkType 0) . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevel+{-# SPECIALIZE levelType :: TCM Type #-}+-- | Get the 'primLevel' as a 'Type'.  Aborts if any of the level BUILTINs is undefined.+levelType :: (HasBuiltins m, MonadTCError m) => m Type+levelType =+  El LevelUniv . lvlType <$> requireLevels+  -- Andreas, 2022-10-11, issue #6168+  -- It seems superfluous to require all level builtins here,+  -- but since we are in MonadTCError here, this is our chance to make sure+  -- that all level builtins are defined.+  -- Otherwise, we might run into an __IMPOSSIBLE__ later,+  -- e.g. if only BUILTIN LEVEL was defined by reallyUnLevelView requires all builtins. +{-# SPECIALIZE levelType' :: TCM Type #-}+-- | Get the 'primLevel' as a 'Type'.  Unsafe, crashes if the BUILTIN LEVEL is undefined.+levelType' :: (HasBuiltins m) => m Type+levelType' =+  El LevelUniv . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevel++{-# SPECIALIZE isLevelType :: Type -> TCM Bool #-} isLevelType :: PureTCM m => Type -> m Bool isLevelType a = reduce (unEl a) >>= \case   Def f [] -> do-    Def lvl [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevel+    lvl <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinLevel     return $ f == lvl   _ -> return False -levelSucFunction :: TCM (Term -> Term)-levelSucFunction = apply1 <$> primLevelSuc- {-# SPECIALIZE builtinLevelKit :: TCM LevelKit #-} {-# SPECIALIZE builtinLevelKit :: ReduceM LevelKit #-} builtinLevelKit :: (HasBuiltins m) => m LevelKit builtinLevelKit = do-    level@(Def l []) <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevel-    zero@(Def z [])  <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelZero-    suc@(Def s [])   <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelSuc-    max@(Def m [])   <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelMax+    level <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinLevel+    zero  <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinLevelZero+    suc   <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinLevelSuc+    max   <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinLevelMax     return $ LevelKit-      { lvlType  = level-      , lvlSuc   = \ a -> suc `apply1` a-      , lvlMax   = \ a b -> max `applys` [a, b]-      , lvlZero  = zero-      , typeName = l-      , sucName  = s-      , maxName  = m-      , zeroName = z+      { lvlType  = Def level []+      , lvlSuc   = \ a -> Def suc [] `apply1` a+      , lvlMax   = \ a b -> Def max [] `applys` [a, b]+      , lvlZero  = Def zero []+      , typeName = level+      , sucName  = suc+      , maxName  = max+      , zeroName = zero       } +{-# SPECIALIZE requireLevels :: TCM LevelKit #-} -- | Raises an error if no level kit is available.-requireLevels :: HasBuiltins m => m LevelKit-requireLevels = builtinLevelKit+requireLevels :: (HasBuiltins m, MonadTCError m) => m LevelKit+requireLevels = do+    level <- getBuiltinName_ builtinLevel+    zero  <- getBuiltinName_ builtinLevelZero+    suc   <- getBuiltinName_ builtinLevelSuc+    max   <- getBuiltinName_ builtinLevelMax+    return $ LevelKit+      { lvlType  = Def level []+      , lvlSuc   = \ a -> Def suc [] `apply1` a+      , lvlMax   = \ a b -> Def max [] `applys` [a, b]+      , lvlZero  = Def zero []+      , typeName = level+      , sucName  = suc+      , maxName  = max+      , zeroName = zero+      }  -- | Checks whether level kit is fully available. haveLevels :: HasBuiltins m => m Bool@@ -75,7 +102,8 @@     (\ _bs -> return True)   where   levelBuiltins =-    [ builtinLevel+    [ builtinLevelUniv+    , builtinLevel     , builtinLevelZero     , builtinLevelSuc     , builtinLevelMax@@ -90,19 +118,13 @@ {-# SPECIALIZE reallyUnLevelView :: Level -> TCM Term #-} {-# SPECIALIZE reallyUnLevelView :: Level -> ReduceM Term #-} reallyUnLevelView :: (HasBuiltins m) => Level -> m Term-reallyUnLevelView nv = do-  suc <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelSuc-  zer <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelZero-  case nv of-    Max n []       -> return $ unConstV zer (apply1 suc) n-    Max 0 [a]      -> return $ unPlusV (apply1 suc) a-    _              -> (`unlevelWithKit` nv) <$> builtinLevelKit+reallyUnLevelView nv = (`unlevelWithKit` nv) <$> builtinLevelKit  unlevelWithKit :: LevelKit -> Level -> Term-unlevelWithKit LevelKit{ lvlZero = zer, lvlSuc = suc, lvlMax = max } = \case+unlevelWithKit LevelKit{ lvlZero = zer, lvlSuc = suc, lvlMax } = \case   Max m []  -> unConstV zer suc m   Max 0 [a] -> unPlusV suc a-  Max m as  -> foldl1 max $ [ unConstV zer suc m | m > 0 ] ++ map (unPlusV suc) as+  Max m as  -> foldl1 lvlMax $ [ unConstV zer suc m | m > 0 ] ++ map (unPlusV suc) as  unConstV :: Term -> (Term -> Term) -> Integer -> Term unConstV zer suc n = foldr ($) zer (List.genericReplicate n suc)@@ -110,16 +132,7 @@ unPlusV :: (Term -> Term) -> PlusLevel -> Term unPlusV suc (Plus n a) = foldr ($) a (List.genericReplicate n suc) -maybePrimCon :: TCM Term -> TCM (Maybe ConHead)-maybePrimCon prim = tryMaybe $ do-    Con c ci [] <- prim-    return c--maybePrimDef :: TCM Term -> TCM (Maybe QName)-maybePrimDef prim = tryMaybe $ do-    Def f [] <- prim-    return f-+{-# SPECIALIZE levelView :: Term -> TCM Level #-} levelView :: PureTCM m => Term -> m Level levelView a = do   reportSLn "tc.level.view" 50 $ "{ levelView " ++ show a@@ -127,11 +140,12 @@   reportSLn "tc.level.view" 50 $ "  view: " ++ show v ++ "}"   return v +{-# SPECIALIZE levelView' :: Term -> TCM Level #-} levelView' :: PureTCM m => Term -> m Level levelView' a = do-  Def lzero [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelZero-  Def lsuc  [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelSuc-  Def lmax  [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelMax+  lzero <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinLevelZero+  lsuc  <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinLevelSuc+  lmax  <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinLevelMax   let view a = do         ba <- reduceB a         case ignoreBlocking ba of@@ -223,7 +237,7 @@     n = maximum $ 0 : [m | SingleClosed m <- ls]     as = [a | SinglePlus a <- ls] -levelMaxView :: Level' t -> NonEmpty (SingleLevel' t)+levelMaxView :: Level' t -> List1 (SingleLevel' t) levelMaxView (Max n [])     = singleton $ SingleClosed n levelMaxView (Max 0 (a:as)) = SinglePlus a :| map SinglePlus as levelMaxView (Max n as)     = SingleClosed n :| map SinglePlus as
src/full/Agda/TypeChecking/Level.hs-boot view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Level where
src/full/Agda/TypeChecking/Level/Solve.hs view
@@ -1,11 +1,10 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Level.Solve where -import Control.Monad-import Control.Monad.Except+import Control.Monad.Except ( catchError ) -import qualified Data.IntMap as IntMap+import qualified Data.Map.Strict as MapS import Data.Maybe  import Agda.Interaction.Options@@ -22,21 +21,25 @@ import Agda.Utils.Functor import Agda.Utils.Monad --- | Run the given action. At the end take all new metavariables of+-- | Run the given action.+--   If @--cumulativity@ is off, that's it.+--+--   Otherwise, at the end, take all new metavariables of --   type level for which the only constraints are upper bounds on the --   level, and instantiate them to the lowest level. defaultOpenLevelsToZero :: (PureTCM m, MonadMetaSolver m) => m a -> m a defaultOpenLevelsToZero f = ifNotM (optCumulativity <$> pragmaOptions) f $ do-  (result , newMetas) <- metasCreatedBy f-  defaultLevelsToZero newMetas+  (result, newMetas) <- metasCreatedBy f+  defaultLevelsToZero (openMetas newMetas)   return result -defaultLevelsToZero :: forall m. (PureTCM m, MonadMetaSolver m) => MetaStore -> m ()-defaultLevelsToZero xs = loop =<< openLevelMetas (map MetaId $ IntMap.keys xs)+defaultLevelsToZero ::+  forall m. (PureTCM m, MonadMetaSolver m) => LocalMetaStore -> m ()+defaultLevelsToZero xs = loop =<< openLevelMetas (MapS.keys xs)   where     loop :: [MetaId] -> m ()     loop xs = do-      let isOpen x = isOpenMeta . mvInstantiation <$> lookupMeta x+      let isOpen x = isOpenMeta <$> lookupMetaInstantiation x       xs <- filterM isOpen xs       allMetaTypes <- getOpenMetas >>= traverse metaType       let notInTypeOfMeta x = not $ mentionsMeta x allMetaTypes
src/full/Agda/TypeChecking/LevelConstraints.hs view
@@ -1,8 +1,9 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.LevelConstraints ( simplifyLevelConstraint ) where  import qualified Data.List as List-import Data.Maybe+ import Agda.Syntax.Internal import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Substitute@@ -11,6 +12,7 @@  import Agda.Utils.Impossible import Agda.Utils.List (nubOn)+import Agda.Utils.List1 (List1) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Update @@ -23,7 +25,7 @@ --   takes care of renaming variables when checking for matches. simplifyLevelConstraint   :: Constraint          -- ^ Constraint @c@ to simplify.-  -> [Constraint]        -- ^ Other constraints, enable simplification.+  -> List1 Constraint    -- ^ Other constraints, enable simplification.   -> Maybe [Constraint]  -- ^ @Just@: list of constraints equal to the original @c@.                          --   @Nothing@: no simplification possible. simplifyLevelConstraint c others = do@@ -37,7 +39,7 @@     simpl (a :=< b)       | any (matchLeq (b :=< a)) leqs = dirty  $ LevelCmp CmpEq  (unSingleLevel a) (unSingleLevel b)       | otherwise                     = return $ LevelCmp CmpLeq (unSingleLevel a) (unSingleLevel b)-    leqs = concat $ mapMaybe inequalities others+    leqs = concat $ List1.mapMaybe inequalities others  data Leq = SingleLevel :=< SingleLevel   deriving (Show, Eq)@@ -58,7 +60,7 @@         go _ [] = IdS         go y ren0@((y', x) : ren)           | y == y'   = Var x [] :# go (y + 1) ren-          | otherwise = Strengthen impossible $ go (y + 1) ren0+          | otherwise = strengthenS' impossible 1 $ go (y + 1) ren0  -- | Turn a level constraint into a list of inequalities between --   single levels, if possible.
src/full/Agda/TypeChecking/Lock.hs view
@@ -1,45 +1,35 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE NondecreasingIndentation #-}+ module Agda.TypeChecking.Lock   ( isTimeless   , checkLockedVars   , checkEarlierThan-  , requireGuarded   ) where -import Control.Monad            ( filterM, forM, forM_ )- import qualified Data.IntMap as IMap import qualified Data.IntSet as ISet import qualified Data.Set as Set - import Agda.Syntax.Common import Agda.Syntax.Internal -import Agda.Interaction.Options ( optGuarded )- import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Constraints+import Agda.TypeChecking.Constraints () -- instance MonadConstraint TCM import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute.Class import Agda.TypeChecking.Free +import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.VarSet as VSet+import Agda.Utils.Functor import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Size-import Agda.Utils.VarSet as VSet -import Agda.Utils.Impossible--requireGuarded :: String -> TCM ()-requireGuarded s = do-  guarded <- optGuarded <$> pragmaOptions-  unless guarded $-    typeError $ GenericError $ "Missing option --guarded " ++ s-- checkLockedVars   :: Term      -- ^ term to check@@ -51,6 +41,12 @@      -- ^ type of the lock   -> TCM () checkLockedVars t ty lk lk_ty = catchConstraint (CheckLockedVars t ty lk lk_ty) $ do+  -- Have to instantiate the lock, otherwise we might block on it even+  -- after it's been solved (e.g.: it's an interaction point, see #6528)+  -- Update (Andreas, 2023-10-23, issue #6913): need even full instantiation.+  -- Since @lk@ is typically just a variable, 'instantiateFull' is not expensive here.+  -- In #6913 it was a postulate applied to a meta, thus, 'instantiate' was not enough.+  lk <- instantiateFull lk   reportSDoc "tc.term.lock" 40 $ "Checking locked vars.."   reportSDoc "tc.term.lock" 50 $ nest 2 $ vcat      [ text "t     = " <+> pretty t@@ -61,7 +57,7 @@    -- Strategy: compute allowed variables, check that @t@ doesn't use more.   mi <- getLockVar (unArg lk)-  caseMaybe mi (return ()) $ \ i -> do+  caseMaybe mi (typeError (DoesNotMentionTicks t ty lk)) $ \ i -> do    cxt <- getContext   let toCheck = zip [0..] $ zipWith raise [1..] (take i cxt)@@ -71,11 +67,11 @@     rigid = rigidVars fv     -- flexible = IMap.keysSet $ flexibleVars fv     termVars = allVars fv -- ISet.union rigid flexible-    earlierVars = ISet.fromList [i+1 .. size cxt - 1]+    earlierVars = ISet.fromList [i + 1 .. size cxt - 1]   if termVars `ISet.isSubsetOf` earlierVars then return () else do -  checked <- fmap catMaybes . forM toCheck $ \ (j,dom) -> do-    ifM (isTimeless (snd . unDom $ dom))+  checked <- fmap catMaybes . forM toCheck $ \ (j,ce) -> do+    ifM (isTimeless (ctxEntryType ce))         (return $ Just j)         (return $ Nothing) @@ -91,19 +87,28 @@     -- flexVars = flexibleVars fv     -- blockingMetas = map (`lookupVarMap` flexVars) (ISet.toList $ termVars ISet.\\ allowedVars)     patternViolation alwaysUnblock-  else do-    notAllowedVarsError (unArg lk) (ISet.toList illegalVars)+  else+    typeError $ ReferencesFutureVariables t (List1.fromList (ISet.toList illegalVars)) lk i+    -- List1.fromList is guarded by not (null illegalVars)  +-- | Precondition: 'Term' is fully instantiated. getLockVar :: Term -> TCMT IO (Maybe Int) getLockVar lk = do   let     fv = freeVarsIgnore IgnoreInAnnotations lk     flex = flexibleVars fv +    isLock i = fmap (getLock . domInfo) (domOfBV i) <&> \case+      IsLock{} -> True+      IsNotLock{} -> False+   unless (IMap.null flex) $ do     let metas = Set.unions $ map (foldrMetaSet Set.insert Set.empty) $ IMap.elems flex-    patternViolation $ unblockOnAnyMeta $ metas+    patternViolation $ unblockOnAnyMeta metas+      -- Andreas, 2023-10-23, issue #6913:+      -- We should not block on solved metas, so we need @lk@ to be fully instantiated,+      -- otherwise it may mention solved metas which end up here.    is <- filterM isLock $ ISet.toList $ rigidVars fv @@ -113,12 +118,7 @@   let mi | Prelude.null is   = Nothing          | otherwise = Just $ maximum is -  return $ mi--  where-   isLock i = do-     islock <- getLock . domInfo <$> lookupBV i-     return $ islock == IsLock+  pure mi  isTimeless :: Type -> TCM Bool isTimeless t = do@@ -128,18 +128,11 @@     Def q _ | Just q `elem` timeless -> return True     _                                -> return False -notAllowedVarsError :: Term -> [Int] -> TCM b-notAllowedVarsError lk is = do-        typeError . GenericDocError =<<-         ("The following vars are not allowed in a later value applied to"-          <+> prettyTCM lk <+> ":" <+> prettyTCM (map var $ is))--checkEarlierThan :: Term -> VarSet -> TCM ()+-- | If the first argument is a lock variable, check that all variables in the given set+--   are either earlier than this variable or are timeless.+--+checkEarlierThan :: Term -> VSet.VarSet -> TCM Bool checkEarlierThan lk fvs = do-  mv <- getLockVar lk-  caseMaybe mv (return ()) $ \ i -> do-    let problems = filter (<= i) $ VSet.toList fvs-    forM_ problems $ \ j -> do-      ty <- typeOfBV j-      unlessM (isTimeless ty) $-        notAllowedVarsError lk [j]+  getLockVar lk >>= \case+    Nothing -> return True+    Just i  -> allM (isTimeless <=< typeOfBV) $ filter (<= i) $ VSet.toList fvs
src/full/Agda/TypeChecking/Lock.hs-boot view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE NondecreasingIndentation #-} module Agda.TypeChecking.Lock where
src/full/Agda/TypeChecking/MetaVars.hs view
@@ -1,18 +1,18 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE GADTs #-}  module Agda.TypeChecking.MetaVars where  import Prelude hiding (null) -import Control.Monad        ( foldM, forM, forM_, liftM2, void ) import Control.Monad.Except ( MonadError(..), ExceptT, runExceptT )-import Control.Monad.Trans  ( lift )+import Control.Monad.Trans.Maybe -import Data.Function-import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet+import qualified Data.IntMap as IntMap import qualified Data.List as List+import qualified Data.Map.Strict as MapS import qualified Data.Set as Set import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav@@ -21,6 +21,8 @@  import Agda.Syntax.Abstract.Name as A import Agda.Syntax.Common+import Agda.Syntax.Info ( MetaKind( InstanceMeta, UnificationMeta ), MetaNameSuggestion)+import qualified Agda.Syntax.Info as A import Agda.Syntax.Internal import Agda.Syntax.Internal.Generic import Agda.Syntax.Internal.MetaVars@@ -40,7 +42,6 @@ import Agda.TypeChecking.Level (levelType) import Agda.TypeChecking.Records import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Irrelevance import Agda.TypeChecking.EtaContract import Agda.TypeChecking.SizedTypes (boundedSizeMetaHook, isSizeProblem) import {-# SOURCE #-} Agda.TypeChecking.CheckInternal@@ -50,20 +51,23 @@ -- import {-# SOURCE #-} Agda.TypeChecking.CheckInternal (checkInternal) import Agda.TypeChecking.MetaVars.Occurs +import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Function import Agda.Utils.Lens import Agda.Utils.List+import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Size import Agda.Utils.Tuple import Agda.Utils.Permutation-import Agda.Utils.Pretty ( Pretty, prettyShow )+import Agda.Syntax.Common.Pretty (Pretty, prettyShow, render)+import qualified Agda.Utils.ProfileOptions as Profile import Agda.Utils.Singleton import qualified Agda.Utils.Graph.TopSort as Graph import Agda.Utils.VarSet (VarSet) import qualified Agda.Utils.VarSet as VarSet-import Agda.Utils.WithDefault  import Agda.Utils.Impossible @@ -90,32 +94,33 @@ findIdx :: Eq a => [a] -> a -> Maybe Int findIdx vs v = List.elemIndex v (reverse vs) +-- | Does the given local meta-variable have a twin meta-variable?+ hasTwinMeta :: MetaId -> TCM Bool hasTwinMeta x = do-    m <- lookupMeta x+    m <- lookupLocalMeta x     return $ isJust $ mvTwin m  -- | Check whether a meta variable is a place holder for a blocked term. isBlockedTerm :: MetaId -> TCM Bool isBlockedTerm x = do     reportSLn "tc.meta.blocked" 12 $ "is " ++ prettyShow x ++ " a blocked term? "-    i <- mvInstantiation <$> lookupMeta x+    i <- lookupMetaInstantiation x     let r = case i of             BlockedConst{}                 -> True             PostponedTypeCheckingProblem{} -> True             InstV{}                        -> False-            Open{}                         -> False-            OpenInstance{}                 -> False+            OpenMeta{}                     -> False     reportSLn "tc.meta.blocked" 12 $-      if r then "  yes, because " ++ show i else "  no"+      if r then "  yes, because " ++ prettyShow i else "  no"     return r -isEtaExpandable :: [MetaKind] -> MetaId -> TCM Bool-isEtaExpandable kinds x = do-    i <- mvInstantiation <$> lookupMeta x+isEtaExpandable :: [MetaClass] -> MetaId -> TCM Bool+isEtaExpandable classes x = do+    i <- lookupMetaInstantiation x     return $ case i of-      Open{}                         -> True-      OpenInstance{}                 -> Records `notElem` kinds+      OpenMeta UnificationMeta       -> True+      OpenMeta InstanceMeta          -> Records `notElem` classes       InstV{}                        -> False       BlockedConst{}                 -> False       PostponedTypeCheckingProblem{} -> False@@ -143,13 +148,21 @@      -- verify (new) invariants     whenM (not <$> asksTC envAssignMetas) __IMPOSSIBLE__ -    verboseS "profile.metas" 10 $ liftTCM $ return () {-tickMax "max-open-metas" . (fromIntegral . size) =<< getOpenMetas-}-    modifyMetaStore $ ins x $ InstV tel $ killRange v+    whenProfile Profile.Metas $ liftTCM $ return () {-tickMax "max-open-metas" . (fromIntegral . size) =<< getOpenMetas-}+    updateMetaVarTCM x $ \ mv ->+      mv { mvInstantiation = InstV $ Instantiation+             { instTel = tel+             , instBody = v+             -- Andreas, 2022-04-28, issue #5875:+             -- Can't killRange the meta-solution, since this will destroy+             -- ranges of termination errors (and potentially other passes+             -- that run on internal syntax)!+             -- , instBody = killRange v+             }+         }     etaExpandListeners x     wakeupConstraints x     reportSLn "tc.meta.assign" 20 $ "completed assignment of " ++ prettyShow x-  where-    ins x i = IntMap.adjust (\ mv -> mv { mvInstantiation = i }) $ metaId x  -- * Creating meta variables. @@ -160,6 +173,7 @@   hasBiggerSort x   return x +{-# SPECIALIZE newSortMeta :: TCM Sort #-} -- | Create a sort meta that may be instantiated with 'Inf' (Setω). newSortMeta :: MonadMetaSolver m => m Sort newSortMeta =@@ -196,6 +210,7 @@ -- that it has a sort.  The sort comes from the solution. -- newTypeMeta_  = newTypeMeta Inf +{-# SPECIALIZE newLevelMeta :: TCM Level #-} newLevelMeta :: MonadMetaSolver m => m Level newLevelMeta = do   (x, v) <- newValueMeta RunMetaOccursCheck CmpEq =<< levelType@@ -203,6 +218,7 @@     Level l    -> l     _          -> atomicLevel v +{-# SPECIALIZE newInstanceMeta :: MetaNameSuggestion -> Type -> TCM (MetaId, Term) #-} -- | @newInstanceMeta s t cands@ creates a new instance metavariable --   of type the output type of @t@ with name suggestion @s@. newInstanceMeta@@ -226,15 +242,13 @@   let i = i0 { miNameSuggestion = s }   TelV tel _ <- telView t   let perm = idP (size tel)-  x <- newMeta' OpenInstance Instantiable i normalMetaPriority perm (HasType () CmpLeq t)+  x <- newMeta' (OpenMeta InstanceMeta) Instantiable i normalMetaPriority perm (HasType () CmpLeq t)   reportSDoc "tc.meta.new" 50 $ fsep     [ nest 2 $ pretty x <+> ":" <+> prettyTCM t     ]-  let c = FindInstance x Nothing-  -- If we're not already solving instance constraints we should add this-  -- to the awake constraints to make sure we don't forget about it. If we-  -- are solving constraints it will get woken up later (see #2690)-  ifM isSolvingConstraints (addConstraint alwaysUnblock c) (addAwakeConstraint alwaysUnblock c)+  r <- getMetaRange x+  let c = FindInstance r x Nothing+  addAwakeConstraint alwaysUnblock c   etaExpandMetaSafe x   return (x, MetaV x $ map Apply vs) @@ -252,6 +266,18 @@   setMetaNameSuggestion x s   return (x, v) +{-# SPECIALIZE newValueMetaOfKind :: A.MetaInfo -> RunMetaOccursCheck -> Comparison -> Type -> TCM (MetaId, Term) #-}+newValueMetaOfKind :: MonadMetaSolver m+  => A.MetaInfo+  -> RunMetaOccursCheck  -- ^ Ignored for instance metas.+  -> Comparison          -- ^ Ignored for instance metas.+  -> Type+  -> m (MetaId, Term)+newValueMetaOfKind info = case A.metaKind info of+  UnificationMeta -> newValueMeta+  InstanceMeta -> \ _run _cmp -> newInstanceMeta (A.metaNameSuggestion info)++{-# SPECIALIZE newValueMeta :: RunMetaOccursCheck -> Comparison -> Type -> TCM (MetaId, Term) #-} -- | Create a new metavariable, possibly η-expanding in the process. newValueMeta :: MonadMetaSolver m => RunMetaOccursCheck -> Comparison -> Type -> m (MetaId, Term) newValueMeta b cmp t = do@@ -265,6 +291,7 @@ newValueMetaCtx frozen b cmp t tel perm ctx =   mapSndM instantiateFull =<< newValueMetaCtx' frozen b cmp t tel perm ctx +{-# SPECIALIZE newValueMeta' :: RunMetaOccursCheck -> Comparison -> Type -> TCM (MetaId, Term) #-} -- | Create a new value meta without η-expanding. newValueMeta'   :: MonadMetaSolver m@@ -281,7 +308,7 @@   i <- createMetaInfo' b   let t     = telePi_ tel a   x <- newMeta frozen i normalMetaPriority perm (HasType () cmp t)-  modality <- viewTC eModality+  modality <- currentModality   reportSDoc "tc.meta.new" 50 $ fsep     [ text $ "new meta (" ++ show (i ^. lensIsAbstract) ++ "):"     , nest 2 $ prettyTCM vs <+> "|-"@@ -301,9 +328,11 @@ trueCondition :: Condition trueCondition _ _ = True +{-# SPECIALIZE newArgsMeta :: Type -> TCM Args #-} newArgsMeta :: MonadMetaSolver m => Type -> m Args newArgsMeta = newArgsMeta' trueCondition +{-# SPECIALIZE newArgsMeta' :: Condition -> Type -> TCM Args #-} newArgsMeta' :: MonadMetaSolver m => Condition -> Type -> m Args newArgsMeta' condition t = do   args <- getContextArgs@@ -313,10 +342,10 @@ newArgsMetaCtx :: Type -> Telescope -> Permutation -> Args -> TCM Args newArgsMetaCtx = newArgsMetaCtx' Instantiable trueCondition -newArgsMetaCtx'+newArgsMetaCtx''   :: MonadMetaSolver m-  => Frozen -> Condition -> Type -> Telescope -> Permutation -> Args -> m Args-newArgsMetaCtx' frozen condition (El s tm) tel perm ctx = do+  => MetaNameSuggestion -> Frozen -> Condition -> Type -> Telescope -> Permutation -> Args -> m Args+newArgsMetaCtx'' pref frozen condition (El s tm) tel perm ctx = do   tm <- reduce tm   case tm of     Pi dom@(Dom{domInfo = info, unDom = a}) codom | condition dom codom -> do@@ -335,29 +364,39 @@       -- as they should keep the defaul modality (see #5363).       whenM ((== YesGeneralizeVar) <$> viewTC eGeneralizeMetas) $         setMetaGeneralizableArgInfo m $ hideOrKeepInstance info-      setMetaNameSuggestion m (absName codom)-      args <- newArgsMetaCtx' frozen condition (codom `absApp` u) tel perm ctx+      setMetaNameSuggestion m (suffixNameSuggestion pref (absName codom))+      args <- newArgsMetaCtx'' pref frozen condition (codom `absApp` u) tel perm ctx       return $ Arg info u : args     _  -> return [] +newArgsMetaCtx'+  :: MonadMetaSolver m+  => Frozen -> Condition -> Type -> Telescope -> Permutation -> Args -> m Args+newArgsMetaCtx' = newArgsMetaCtx'' mempty+ -- | Create a metavariable of record type. This is actually one metavariable --   for each field. newRecordMeta :: QName -> Args -> TCM Term newRecordMeta r pars = do   args <- getContextArgs   tel  <- getContextTelescope-  newRecordMetaCtx Instantiable r pars tel (idP $ size tel) args+  newRecordMetaCtx mempty Instantiable r pars tel (idP $ size tel) args  newRecordMetaCtx-  :: Frozen  -- ^ Should the meta be created frozen?+  :: MetaNameSuggestion+  -- ^ Name suggestion to be used as a /prefix/ of the name suggestions+  -- for the metas that represent each field+  -> Frozen  -- ^ Should the meta be created frozen?   -> QName   -- ^ Name of record type   -> Args    -- ^ Parameters of record type.   -> Telescope -> Permutation -> Args -> TCM Term-newRecordMetaCtx frozen r pars tel perm ctx = do-  ftel   <- flip apply pars <$> getRecordFieldTypes r-  fields <- newArgsMetaCtx' frozen trueCondition+newRecordMetaCtx pref frozen r pars tel perm ctx = do+  rdef   <- getRecordDef r+  let con = killRange $ _recConHead rdef+  -- Get the record field types as telescope.+  let ftel = apply (_recTel rdef) pars+  fields <- newArgsMetaCtx'' pref frozen trueCondition               (telePi_ ftel __DUMMY_TYPE__) tel perm ctx-  con    <- getRecordConstructor r   return $ Con con ConOSystem (map Apply fields)  newQuestionMark :: InteractionId -> Comparison -> Type -> TCM (MetaId, Term)@@ -394,17 +433,19 @@     MetaVar       { mvInfo = MetaInfo{ miClosRange = Closure{ clEnv = TCEnv{ envContext = gamma }}}       , mvPermutation = p-      } <- fromMaybe __IMPOSSIBLE__ <$> lookupMeta' x+      } <- fromMaybe __IMPOSSIBLE__ <$> lookupLocalMeta' x     -- Get the current context Δ.     delta <- getContext     -- A bit hazardous:     -- we base our decisions on the names of the context entries.     -- Ideally, Agda would organize contexts in ancestry trees     -- with substitutions to move between parent and child.-    let glen = length gamma-    let dlen = length delta-    let gxs  = map (fst . unDom) gamma-    let dxs  = map (fst . unDom) delta+    let gxs  = contextNames' gamma+    let dxs  = contextNames' delta+    let gys  = map nameCanonical gxs+    let dys  = map nameCanonical dxs+    let glen = length gxs+    let dlen = length dxs     reportSDoc "tc.interaction" 20 $ vcat       [ "reusing meta"       , nest 2 $ "creation context:" <+> pretty gxs@@ -420,7 +461,7 @@       -- Case: no record variable in the context.       -- Test whether Δ is an extension of Γ.       Nothing -> do-        unless (gxs `List.isSuffixOf` dxs) $ do+        unless (gys `List.isSuffixOf` dys) $ do           reportSDoc "impossible" 10 $ vcat             [ "expecting meta-creation context"             , nest 2 $ pretty gxs@@ -443,10 +484,8 @@         let g0len = length dxs - k - 1         -- Find out the Δ₂ and Γ₁ parts.         -- However, as they do not share common ancestry, the @nameId@s differ,-        -- so we consider only the original concrete names.+        -- so we consider only the original concrete names in gys and dys.         -- This is a bit risky... blame goes to #434.-        let gys = map nameCanonical gxs-        let dys = map nameCanonical dxs         let (d2len, g1len) = findOverlap (take k dys) gys         reportSDoc "tc.interaction" 30 $ vcat $ map (nest 2)           [ "glen  =" <+> pretty glen@@ -477,7 +516,7 @@         let numFields = glen - g1len - g0len         if numFields <= 0 then return $ vs1 ++ vs0 else do           -- Get the record type.-          let t = snd . unDom . fromMaybe __IMPOSSIBLE__ $ delta !!! k+          let t = (unDom . ctxEntryDom) $ fromMaybe __IMPOSSIBLE__ $ delta !!! k           -- Get the record field names.           fs <- getRecordTypeFields t           -- Field arguments to the original meta are projections from the record var.@@ -486,13 +525,14 @@           return $ vs1 ++ reverse (take numFields vfs) ++ vs0      -- Use ArgInfo from Γ.-    let args = reverse $ zipWith (<$) rev_args $ map argFromDom gamma+    let args = zipWith (<$) (reverse rev_args) $ contextArgs gamma     -- Take the permutation into account (see TC.Monad.MetaVars.getMetaContextArgs).     let vs = permute (takeP (length args) p) args     reportSDoc "tc.interaction" 20 $ vcat       [ "meta reuse arguments:" <+> prettyTCM vs ]     return (x, MetaV x $ map Apply vs) +{-# SPECIALIZE blockTerm :: Type -> TCM Term -> TCM Term #-} -- | Construct a blocked constant if there are constraints. blockTerm   :: (MonadMetaSolver m, MonadConstraint m, MonadFresh Nat m, MonadFresh ProblemId m)@@ -501,6 +541,7 @@   (pid, v) <- newProblem blocker   blockTermOnProblem t v pid +{-# SPECIALIZE blockTermOnProblem :: Type -> Term -> ProblemId -> TCM Term #-} blockTermOnProblem   :: (MonadMetaSolver m, MonadFresh Nat m)   => Type -> Term -> ProblemId -> m Term@@ -549,6 +590,7 @@         listenToMeta (CheckConstraint i cmp) x         return v +{-# SPECIALIZE blockTypeOnProblem :: Type -> ProblemId -> TCM Type #-} blockTypeOnProblem   :: (MonadMetaSolver m, MonadFresh Nat m)   => Type -> ProblemId -> m Type@@ -568,9 +610,10 @@   where     unblock (CheckExpr _ _ t)         = unblockedTester t     unblock (CheckArgs _ _ _ _ t _ _) = unblockedTester t  -- The type of the head of the application.-    unblock (CheckProjAppToKnownPrincipalArg _ _ _ _ _ _ _ _ t _) = unblockedTester t -- The type of the principal argument+    unblock (CheckProjAppToKnownPrincipalArg _ _ _ _ _ _ _ _ _ t _) = unblockedTester t -- The type of the principal argument     unblock (CheckLambda _ _ _ t)     = unblockedTester t     unblock (DoQuoteTerm _ _ _)       = __IMPOSSIBLE__     -- also quoteTerm problems+    unblock (DisambiguateConstructor _ _) = __IMPOSSIBLE__  -- Used with explicit blocker only.  -- | Create a postponed type checking problem @e : t@ that waits for conditon --   @unblock@.  A new meta is created in the current context that has as@@ -613,33 +656,14 @@ problemType :: TypeCheckingProblem -> Type problemType (CheckExpr _ _ t         ) = t problemType (CheckArgs _ _ _ _ _ t _ ) = t  -- The target type of the application.-problemType (CheckProjAppToKnownPrincipalArg _ _ _ _ _ t _ _ _ _) = t -- The target type of the application+problemType (CheckProjAppToKnownPrincipalArg _ _ _ _ _ _ t _ _ _ _) = t -- The target type of the application problemType (CheckLambda _ _ _ t     ) = t problemType (DoQuoteTerm _ _ t)        = t---- | Eta expand metavariables listening on the current meta.-etaExpandListeners :: MetaId -> TCM ()-etaExpandListeners m = do-  ls <- getMetaListeners m-  clearMetaListeners m  -- we don't really have to do this-  mapM_ wakeupListener ls---- | Wake up a meta listener and let it do its thing-wakeupListener :: Listener -> TCM ()-  -- Andreas 2010-10-15: do not expand record mvars, lazyness needed for irrelevance-wakeupListener (EtaExpand x)         = etaExpandMetaSafe x-wakeupListener (CheckConstraint _ c) = do-  reportSDoc "tc.meta.blocked" 20 $ "waking boxed constraint" <+> prettyTCM c-  modifyAwakeConstraints (c:)-  solveAwakeConstraints---- | Do safe eta-expansions for meta (@SingletonRecords,Levels@).-etaExpandMetaSafe :: (MonadMetaSolver m) => MetaId -> m ()-etaExpandMetaSafe = etaExpandMeta [SingletonRecords,Levels]+problemType (DisambiguateConstructor (ConstructorDisambiguationData _ _ _ t) _) = t --- | Eta expand a metavariable, if it is of the specified kind.---   Don't do anything if the metavariable is a blocked term.-etaExpandMetaTCM :: [MetaKind] -> MetaId -> TCM ()+-- | Eta-expand a local meta-variable, if it is of the specified kind.+--   Don't do anything if the meta-variable is a blocked term.+etaExpandMetaTCM :: [MetaClass] -> MetaId -> TCM () etaExpandMetaTCM kinds m = whenM ((not <$> isFrozen m) `and2M` asksTC envAssignMetas `and2M` isEtaExpandable kinds m) $ do   verboseBracket "tc.meta.eta" 20 ("etaExpandMeta " ++ prettyShow m) $ do     let waitFor b = do@@ -647,12 +671,12 @@             "postponing eta-expansion of meta variable" <+>               prettyTCM m <+>               "which is blocked by" <+> prettyTCM b-          mapM_ (listenToMeta (EtaExpand m)) $ Set.toList $ allBlockingMetas b+          mapM_ (listenToMeta (EtaExpand m)) $ allBlockingMetas b         dontExpand = do           reportSDoc "tc.meta.eta" 20 $ do             "we do not expand meta variable" <+> prettyTCM m <+>               text ("(requested was expansion of " ++ show kinds ++ ")")-    meta <- lookupMeta m+    meta <- lookupLocalMeta m     case mvJudgement meta of       IsSort{} -> dontExpand       HasType _ cmp a -> do@@ -676,7 +700,7 @@         -- they go unsolved: conversion will compare them at the         -- different cases for the domain, so it will not find the         -- solution for the whole meta.-        if any domFinite (flattenTel tel) then dontExpand else do+        if any domIsFinite (flattenTel tel) then dontExpand else do          -- Issue #3774: continue with the right context for b         addContext tel $ do@@ -693,7 +717,8 @@               let ps = fromMaybe __IMPOSSIBLE__ $ allApplyElims es               let expand = do                     u <- withMetaInfo' meta $-                      newRecordMetaCtx (mvFrozen meta) r ps tel (idP $ size tel) $ teleArgs tel+                      newRecordMetaCtx (miNameSuggestion (mvInfo meta))+                        (mvFrozen meta) r ps tel (idP $ size tel) $ teleArgs tel                     -- Andreas, 2019-03-18, AIM XXIX, issue #3597                     -- When meta is frozen instantiate it with in-turn frozen metas.                     inTopContext $ do@@ -731,18 +756,19 @@ etaExpandBlocked t@(Blocked _ v) | Just{} <- isMeta v = return t etaExpandBlocked (Blocked b t)  = do   reportSDoc "tc.meta.eta" 30 $ "Eta expanding blockers" <+> pretty b-  mapM_ (etaExpandMeta [Records]) $ Set.toList $ allBlockingMetas b+  mapM_ (etaExpandMeta [Records]) $ allBlockingMetas b   t <- reduceB t   case t of     Blocked b' _ | b /= b' -> etaExpandBlocked t     _                      -> return t +{-# SPECIALIZE assignWrapper :: CompareDirection -> MetaId -> Elims -> Term -> TCM () -> TCM () #-} assignWrapper :: (MonadMetaSolver m, MonadConstraint m, MonadError TCErr m, MonadDebug m, HasOptions m)               => CompareDirection -> MetaId -> Elims -> Term -> m () -> m () assignWrapper dir x es v doAssign = do   ifNotM (asksTC envAssignMetas) dontAssign $ {- else -} do     reportSDoc "tc.meta.assign" 10 $ do-      "term" <+> prettyTCM (MetaV x es) <+> text (":" ++ show dir) <+> prettyTCM v+      "term" <+> prettyTCM (MetaV x es) <+> text (":" ++ prettyShow dir) <+> prettyTCM v     nowSolvingConstraints doAssign `finally` solveAwakeConstraints    where dontAssign = do@@ -768,7 +794,7 @@ assign :: CompareDirection -> MetaId -> Args -> Term -> CompareAs -> TCM () assign dir x args v target = addOrUnblocker (unblockOnMeta x) $ do -  mvar <- lookupMeta x  -- information associated with meta x+  mvar <- lookupLocalMeta x  -- information associated with meta x   let t = jMetaType $ mvJudgement mvar    -- Andreas, 2011-05-20 TODO!@@ -782,7 +808,9 @@   -- check will first try without unfolding any definitions (treating   -- arguments to definitions as flexible), if that fails it tries again   -- with full unfolding.+  reportSDoc "tc.meta.assign" 25 $ "v = " <+> prettyTCM v   v <- instantiate v+  reportSDoc "tc.meta.assign" 25 $ "v = " <+> prettyTCM v   reportSDoc "tc.meta.assign" 45 $     "MetaVars.assign: assigning meta " <+> prettyTCM (MetaV x []) <+>     " with args " <+> prettyList_ (map (prettyTCM . unArg) args) <+>@@ -793,6 +821,14 @@   reportSDoc "tc.meta.assign" 75 $     text "MetaVars.assign: assigning meta  " <> pretty x <> text "  with args  " <> pretty args <> text "  to  " <> pretty v +  let+    boundary v = do+      cubical <- cubicalOption+      isip <- isInteractionMetaB x args+      case (,) <$> cubical <*> isip of+        Just (_, (x, ip, args)) -> tryAddBoundary dir x ip args v target+        _ -> pure ()+   case (v, mvJudgement mvar) of       (Sort s, HasType{}) -> hasBiggerSort s       _                   -> return ()@@ -831,7 +867,7 @@     -- Case 1 (comparing term to meta as types)     (AsTypes{}   , HasType _ cmp0 t) -> do         let cmp   = if cumulativity then cmp0 else CmpEq-            abort = patternViolation $ unblockOnAnyMetaIn t -- TODO: make piApplyM' compute unblocker+            abort = patternViolation =<< updateBlocker (unblockOnAnyMetaIn t) -- TODO: make piApplyM' compute unblocker         t' <- piApplyM' abort t args         s <- shouldBeSort t'         checkSolutionSort cmp s v@@ -839,7 +875,7 @@     -- Case 2 (comparing term to type-level meta as terms, with --cumulativity)     (AsTermsOf{} , HasType _ cmp t)       | cumulativity -> do-          let abort = patternViolation $ unblockOnAnyMetaIn t+          let abort = patternViolation =<< updateBlocker (unblockOnAnyMetaIn t)           t' <- piApplyM' abort t args           TelV tel t'' <- telView t'           addContext tel $ ifNotSort t'' (return ()) $ \s -> do@@ -855,6 +891,8 @@   -- We don't instantiate frozen mvars   when (mvFrozen mvar == Frozen) $ do     reportSLn "tc.meta.assign" 25 $ "aborting: meta is frozen!"+    -- IApplyConfluence can contribute boundary conditions to frozen metas+    boundary v     patternViolation neverUnblock    -- We never get blocked terms here anymore. TODO: we actually do. why?@@ -869,12 +907,14 @@     case v0 of       Blocked m0 _ -> "r.h.s. blocked on:" <+> prettyTCM m0       NotBlocked{} -> "r.h.s. not blocked"+  reportSDoc "tc.meta.assign" 25 $ "v = " <+> prettyTCM v    -- Turn the assignment problem @_X args >= SizeLt u@ into   -- @_X args = SizeLt (_Y args@ and constraint   -- @_Y args >= u@.   subtypingForSizeLt dir x mvar t args v $ \ v -> do +    reportSDoc "tc.meta.assign" 25 $ "v = " <+> prettyTCM v     reportSDoc "tc.meta.assign.proj" 45 $ do       cxt <- getContextTelescope       vcat@@ -931,10 +971,10 @@       -- even though the lhs is not a pattern, we can prune the y from _2        let-                vars        = freeVars args-                relVL       = filterVarMapToList isRelevant  vars-                nonstrictVL = filterVarMapToList isNonStrict vars-                irrVL       = filterVarMapToList (liftM2 (&&) isIrrelevant isUnguarded) vars+                vars              = freeVars args+                relevantVL        = filterVarMapToList isRelevant vars+                shapeIrrelevantVL = filterVarMapToList isShapeIrrelevant vars+                irrelevantVL      = filterVarMapToList (liftM2 (&&) isIrrelevant isUnguarded) vars             -- Andreas, 2011-10-06 only irrelevant vars that are direct             -- arguments to the meta, hence, can be abstracted over, may             -- appear on the rhs.  (test/fail/Issue483b)@@ -957,9 +997,9 @@               pr _          = ".."           in vcat                [ "mvar args:" <+> sep (map (pr . unArg) args)-               , "fvars lhs (rel):" <+> sep (map (text . show) relVL)-               , "fvars lhs (nonstrict):" <+> sep (map (text . show) nonstrictVL)-               , "fvars lhs (irr):" <+> sep (map (text . show) irrVL)+               , "fvars lhs (relevant)        :" <+> sep (map (text . show) relevantVL)+               , "fvars lhs (shape-irrelevant):" <+> sep (map (text . show) shapeIrrelevantVL)+               , "fvars lhs (irrelevant)      :" <+> sep (map (text . show) irrelevantVL)                ]        -- Check that the x doesn't occur in the right hand side.@@ -967,10 +1007,11 @@       -- Herein, distinguish relevant and irrelevant vars,       -- since when abstracting irrelevant lhs vars, they may only occur       -- irrelevantly on rhs.-      -- v <- liftTCM $ occursCheck x (relVL, nonstrictVL, irrVL) v+      -- v <- liftTCM $ occursCheck x (relevantVL, nonstrictVL, irrelevantVL) v       v <- liftTCM $ occursCheck x vars v        reportSLn "tc.meta.assign" 15 "passed occursCheck"+      reportSDoc "tc.meta.assign" 25 $ "v = " <+> prettyTCM v       verboseS "tc.meta.assign" 30 $ do         let n = termSize v         when (n > 200) $ reportSDoc "tc.meta.assign" 30 $@@ -990,7 +1031,7 @@        -- Check that the arguments are variables       mids <- do-        res <- runExceptT $ inverseSubst args+        res <- runExceptT $ inverseSubst' (const False) args         case res of           -- all args are variables           Right ids -> do@@ -1004,7 +1045,7 @@               else return Nothing           -- we have proper values as arguments which could be cased on           -- here, we cannot prune, since offending vars could be eliminated-          Left CantInvert  -> return Nothing+          Left (CantInvert tm) -> Nothing <$ boundary v           -- we have non-variables, but these are not eliminateable           Left NeutralArg  -> Just <$> attemptPruning x args fvs           -- we have a projected variable which could not be eta-expanded away:@@ -1012,7 +1053,7 @@           Left ProjVar{}   -> Just <$> attemptPruning x args fvs        case mids of  -- vv Ulf 2014-07-13: actually not needed after all: attemptInertRHSImprovement x args v-        Nothing  -> patternViolation (unblockOnAnyMetaIn v)  -- TODO: more precise+        Nothing  -> patternViolation =<< updateBlocker (unblockOnAnyMetaIn v)  -- TODO: more precise         Just ids -> do           -- Check linearity           ids <- do@@ -1024,7 +1065,9 @@               -- If pruning fails we need to unblock on any meta in the rhs, since they might get               -- rid of the dependency on the non-linear variable. TODO: be more precise (all metas               -- using non-linear variables need to be solved).-              Left ()   -> addOrUnblocker (unblockOnAnyMetaIn v) $ attemptPruning x args fvs+              Left ()   -> do+                block <- updateBlocker $ unblockOnAnyMetaIn v+                addOrUnblocker block $ attemptPruning x args fvs            -- Check ids is time respecting.           () <- do@@ -1033,14 +1076,15 @@             let earlierThan l j = j > l             TelV tel' _ <- telViewUpToPath (length args) t             forM_ ids $ \(i,u) -> do-              d <- lookupBV i-              when (getLock (getArgInfo d) == IsLock) $ do+              d <- domOfBV i+              case getLock (getArgInfo d) of+                IsNotLock -> pure ()+                IsLock{} -> do                 let us = IntSet.unions $ map snd $ filter (earlierThan i . fst) idvars                 -- us Earlier than u-                addContext tel' $ checkEarlierThan u us-                  `catchError` \case-                     TypeError{} -> patternViolation (unblockOnMeta x) -- If the earlier check hard-fails we need to-                     err         -> throwError err                     -- solve this meta in some other way.+                unlessM (addContext tel' $ checkEarlierThan u us) $+                  patternViolation (unblockOnMeta x)  -- If the earlier check hard-fails we need to+                                                      -- solve this meta in some other way.            let n = length args           TelV tel' _ <- telViewUpToPath n t@@ -1057,7 +1101,7 @@           --   @           -- we need to check that @A <: A'@ (due to contravariance).           let sigma = parallelS $ reverse $ map unArg args-          hasSubtyping <- collapseDefault . optSubtyping <$> pragmaOptions+          hasSubtyping <- optCumulativity <$> pragmaOptions           when hasSubtyping $ forM_ ids $ \(i , u) -> do             -- @u@ is a (projected) variable, so we can infer its type             a  <- applySubst sigma <$> addContext tel' (infer u)@@ -1083,11 +1127,47 @@       let success = killResult `elem` [PrunedSomething,PrunedEverything]       reportSDoc "tc.meta.assign" 10 $         "pruning" <+> prettyTCM x <+> do text $ if success then "succeeded" else "failed"-      patternViolation (if success then alwaysUnblock  -- If pruning succeeded we want to retry right away-                                   else unblockOnAnyMetaIn $ MetaV x $ map Apply args)-                                        -- TODO: could be more precise: only unblock on metas-                                        --       applied to offending variables+      blocker <- if+        | success   -> return alwaysUnblock  -- If pruning succeeded we want to retry right away+        | otherwise -> unblockOnAnyMetaIn . MetaV x . map Apply <$> instantiateFull args+             -- TODO: could be more precise: only unblock on metas+             --       applied to offending variables+      patternViolation blocker +-- | Is the given metavariable application secretly an interaction point+-- application? Ugly.+isInteractionMetaB+  :: forall m. (ReadTCState m, MonadReduce m, MonadPretty m)+  => MetaId+  -> Args+  -> m (Maybe (MetaId, InteractionId, Args))+isInteractionMetaB mid args =+  runMaybeT $ here mid args `mplus` do+    -- If the meta isn't literally an interaction point it might still+    -- be instantiable to an interaction point, as long as we ignore+    -- blocking+    lift (instantiateBlockingFull (MetaV mid (Apply <$> args))) >>= there+  where+    here mid args = do+      iid <- MaybeT (isInteractionMeta mid)+      pure (mid, iid, args)++    instantiateBlockingFull = locallyTCState stInstantiateBlocking (const True) . instantiateFull++    there :: Term -> MaybeT m (MetaId, InteractionId, Args)+    there (MetaV m args) = do+      iid  <- MaybeT (isInteractionMeta m)+      args <- MaybeT (pure (allApplyElims args))+      pure (m, iid, args)+    -- It might be the case that the inner meta (the interaction point)+    -- exists in a larger context, so instantiating the outer meta (the+    -- original argument) will produce lambdas.+    --+    -- Since the boundary code runs in the inner, larger context, we can+    -- peel off the lambdas without running afoul of the scope.+    there (Lam _ as) = there (absApp as (var 0))+    there _ = mzero+ {- UNUSED -- | When faced with @_X us == D vs@ for an inert D we can solve this by --   @_X xs := D _Ys@ with new constraints @_Yi us == vi@. This is important@@ -1223,8 +1303,8 @@   -- ALT 2: O(m)   let assocToList i = \case         _           | i >= m -> []-        ((j,u) : l) | i == j -> Just u  : assocToList (i+1) l-        l                    -> Nothing : assocToList (i+1) l+        ((j,u) : l) | i == j -> Just u  : assocToList (i + 1) l+        l                    -> Nothing : assocToList (i + 1) l       ivs = assocToList 0 ids       rho = prependS impossible ivs $ raiseS n       v'  = applySubst rho v@@ -1254,7 +1334,7 @@      -- Andreas, 2013-10-25 double check solution before assigning     whenM (optDoubleCheck  <$> pragmaOptions) $ do-      m <- lookupMeta x+      m <- lookupLocalMeta x       reportSDoc "tc.meta.check" 30 $ "double checking solution"       catchConstraint (CheckMetaInst x) $         addContext tel' $ checkSolutionForMeta x m v' a@@ -1267,11 +1347,12 @@     assignTerm x (telToArgs tel') v'   where     blockOnBoundary :: TelView -> Boundary -> Term -> TCM Term-    blockOnBoundary telv         [] v = return v-    blockOnBoundary (TelV tel t) bs v = addContext tel $+    blockOnBoundary telv         (Boundary []) v = return v+    blockOnBoundary (TelV tel t) (Boundary bs) v = addContext tel $       blockTerm t $ do         neg <- primINeg-        forM_ bs $ \ (r,(x,y)) -> do+        forM_ bs $ \ (i,(x,y)) -> do+          let r = var i           equalTermOnFace (neg `apply1` r) t x v           equalTermOnFace r  t y v         return v@@ -1281,18 +1362,18 @@ --   instantiated, add a constraint to check the instantiation later. checkMetaInst :: MetaId -> TCM () checkMetaInst x = do-  m <- lookupMeta x+  m <- lookupLocalMeta x   let postpone = addConstraint (unblockOnMeta x) $ CheckMetaInst x   case mvInstantiation m of     BlockedConst{} -> postpone     PostponedTypeCheckingProblem{} -> postpone-    Open{} -> postpone-    OpenInstance{} -> postpone-    InstV xs v -> do-      let n = size xs+    OpenMeta{} -> postpone+    InstV inst -> do+      let n = size (instTel inst)           t = jMetaType $ mvJudgement m       (telv@(TelV tel a),bs) <- telViewUpToPathBoundary n t-      catchConstraint (CheckMetaInst x) $ addContext tel $ checkSolutionForMeta x m v a+      catchConstraint (CheckMetaInst x) $ addContext tel $+        checkSolutionForMeta x m (instBody inst) a  -- | Check that the instantiation of the metavariable with the given --   term is well-typed.@@ -1313,7 +1394,7 @@         prettyTCM x <+> ":=" <+> prettyTCM v <+> " is a sort"       s <- shouldBeSort (El __DUMMY_SORT__ v)       traceCall (CheckMetaSolution (getRange m) x (sort (univSort s)) (Sort s)) $-        checkSort defaultAction s+        inferInternal s  -- | Given two types @a@ and @b@ with @a <: b@, check that @a == b@. checkSubtypeIsEqual :: Type -> Type -> TCM ()@@ -1321,8 +1402,7 @@   reportSDoc "tc.meta.subtype" 30 $     "checking that subtype" <+> prettyTCM a <+>     "of" <+> prettyTCM b <+> "is actually equal."-  ((a, b), equal) <- SynEq.checkSyntacticEquality a b-  unless equal $ do+  SynEq.checkSyntacticEquality a b (\_ _ -> return ()) $ \a b -> do     cumulativity <- optCumulativity <$> pragmaOptions     abortIfBlocked (unEl b) >>= \case       Sort sb -> abortIfBlocked (unEl a) >>= \case@@ -1331,19 +1411,20 @@         Dummy{} -> return () -- TODO: this shouldn't happen but                              -- currently does because of generalized                              -- metas being created in a dummy context-        a -> patternViolation (unblockOnAnyMetaIn a) -- TODO: can this happen?+        a -> patternViolation =<< updateBlocker (unblockOnAnyMetaIn a) -- TODO: can this happen?       Pi b1 b2 -> abortIfBlocked (unEl a) >>= \case         Pi a1 a2           | getRelevance a1 /= getRelevance b1 -> patternViolation neverUnblock -- Can we recover from this?           | getQuantity  a1 /= getQuantity  b1 -> patternViolation neverUnblock           | getCohesion  a1 /= getCohesion  b1 -> patternViolation neverUnblock+          | getModalPolarity a1 /= getModalPolarity b1 -> patternViolation neverUnblock           | otherwise -> do               checkSubtypeIsEqual (unDom b1) (unDom a1)               underAbstractionAbs a1 a2 $ \a2' -> checkSubtypeIsEqual a2' (absBody b2)         Dummy{} -> return () -- TODO: this shouldn't happen but                              -- currently does because of generalized                              -- metas being created in a dummy context-        a -> patternViolation (unblockOnAnyMetaIn a)+        a -> patternViolation =<< updateBlocker (unblockOnAnyMetaIn a)       -- TODO: check subtyping for Size< types       _ -> return () @@ -1353,8 +1434,8 @@ -- @_Y args <= u@. subtypingForSizeLt   :: CompareDirection -- ^ @dir@-  -> MetaId           -- ^ The meta variable @x@.-  -> MetaVariable     -- ^ Its associated information @mvar <- lookupMeta x@.+  -> MetaId           -- ^ The local meta-variable @x@.+  -> MetaVariable     -- ^ Its associated information @mvar <- lookupLocalMeta x@.   -> Type             -- ^ Its type @t = jMetaType $ mvJudgement mvar@   -> Args             -- ^ Its arguments.   -> Term             -- ^ Its to-be-assigned value @v@, such that @x args `dir` v@.@@ -1466,10 +1547,14 @@  instance ReduceAndEtaContract Term where   reduceAndEtaContract u = do-    reduce u >>= \case+    reportSDoc "tc.meta" 30 $ "trying to eta-contract u =" <+> prettyTCM u+    u <- reduce u+    reportSDoc "tc.meta" 30 $ "               reduced u =" <+> prettyTCM u+    case u of       -- In case of lambda or record constructor, it makes sense to       -- reduce further.-      Lam ai (Abs x b) -> etaLam ai x =<< reduceAndEtaContract b+      Lam ai bAbs -> underAbstraction_ bAbs $ \b ->+        etaLam ai (absName bAbs) =<< reduceAndEtaContract b       Con c ci es -> etaCon c ci es $ \ r c ci args -> do         args <- reduceAndEtaContract args         etaContractRecord r c ci args@@ -1533,19 +1618,17 @@ -- | Turn non-det substitution into proper substitution, if possible. --   Otherwise, raise the error. checkLinearity :: SubstCand -> ExceptT () TCM SubstCand-checkLinearity ids0 = do-  let ids = List.sortBy (compare `on` fst) ids0  -- see issue 920-  let grps = groupOn fst ids-  concat <$> mapM makeLinear grps+checkLinearity ids = do+  -- see issue #920+  List1.toList <$> mapM makeLinear (List1.groupOn fst ids)   where     -- Non-determinism can be healed if type is singleton. [Issue 593]     -- (Same as for irrelevance.)-    makeLinear :: SubstCand -> ExceptT () TCM SubstCand-    makeLinear []            = __IMPOSSIBLE__-    makeLinear grp@[_]       = return grp-    makeLinear (p@(i,t) : _) =+    makeLinear :: List1 (Int, Term) -> ExceptT () TCM (Int, Term)+    makeLinear (p       :| []) = return p+    makeLinear (p@(i,t) :| _ ) =       ifM ((Right True ==) <$> do lift . runBlocked . isSingletonTypeModuloRelevance =<< typeOfBV i)-        (return [p])+        (return p)         (throwError ())  -- Intermediate result in the following function@@ -1553,7 +1636,7 @@  -- | Exceptions raised when substitution cannot be inverted. data InvertExcept-  = CantInvert                -- ^ Cannot recover.+  = CantInvert Term           -- ^ Cannot recover.   | NeutralArg                -- ^ A potentially neutral arg: can't invert, but can try pruning.   | ProjVar ProjectedVar      -- ^ Try to eta-expand var to remove projs. @@ -1568,91 +1651,238 @@ --   Linearity, i.e., whether the substitution is deterministic, --   has to be checked separately. ---inverseSubst :: Args -> ExceptT InvertExcept TCM SubstCand-inverseSubst args = map (mapFst unArg) <$> loop (zip args terms)+inverseSubst' :: (Term -> Bool) -> Args -> ExceptT InvertExcept TCM SubstCand+inverseSubst' skip args = map (mapFst unArg) <$> loop (zip args terms)   where-    loop  = foldM isVarOrIrrelevant []-    terms = map var (downFrom (size args))-    failure = do-      lift $ reportSDoc "tc.meta.assign" 15 $ vcat-        [ "not all arguments are variables: " <+> prettyTCM args-        , "  aborting assignment" ]-      throwError CantInvert-    neutralArg = throwError NeutralArg+  loop  = foldM isVarOrIrrelevant []+  terms = map var (downFrom (size args))+  failure c = do+    lift $ reportSDoc "tc.meta.assign" 15 $ vcat+      [ "not all arguments are variables: " <+> prettyTCM args+      , "  aborting assignment" ]+    throwError (CantInvert c)+  neutralArg = throwError NeutralArg -    isVarOrIrrelevant :: Res -> (Arg Term, Term) -> ExceptT InvertExcept TCM Res-    isVarOrIrrelevant vars (Arg info v, t) = do-      let irr | isIrrelevant info = True-              | DontCare{} <- v   = True-              | otherwise         = False-      case stripDontCare v of-        -- i := x-        Var i [] -> return $ (Arg info i, t) `cons` vars+  isVarOrIrrelevant :: Res -> (Arg Term, Term) -> ExceptT InvertExcept TCM Res+  isVarOrIrrelevant vars (Arg info v, t) = do+    let irr | isIrrelevant info = True+            | DontCare{} <- v   = True+            | otherwise         = False+    ineg <- getPrimitiveName' builtinINeg+    case stripDontCare v of+      -- i := x+      Var i [] -> return $ (Arg info i, t) `cons` vars -        -- π i := x  try to eta-expand projection π away!-        Var i es | Just qs <- mapM isProjElim es ->-          throwError $ ProjVar $ ProjectedVar i qs+      -- π i := x  try to eta-expand projection π away!+      Var i es | Just qs <- mapM isProjElim es ->+        throwError $ ProjVar $ ProjectedVar i qs -        -- (i, j) := x  becomes  [i := fst x, j := snd x]-        -- Andreas, 2013-09-17 but only if constructor is fully applied-        Con c ci es -> do-          let fallback-               | isIrrelevant info = return vars-               | otherwise                              = failure-          irrProj <- optIrrelevantProjections <$> pragmaOptions-          lift (isRecordConstructor $ conName c) >>= \case-            Just (_, r@Record{ recFields = fs })-              | YesEta <- recEtaEquality r  -- Andreas, 2019-11-10, issue #4185: only for eta-records-              , length fs == length es-              , hasQuantity0 info || all usableQuantity fs     -- Andreas, 2019-11-12/17, issue #4168b-              , irrProj || all isRelevant fs -> do-                let aux (Arg _ v) Dom{domInfo = info', unDom = f} = (Arg ai v,) $ t `applyE` [Proj ProjSystem f] where-                     ai = ArgInfo-                       { argInfoHiding   = min (getHiding info) (getHiding info')-                       , argInfoModality = Modality-                         { modRelevance  = max (getRelevance info) (getRelevance info')-                         , modQuantity   = max (getQuantity  info) (getQuantity  info')-                         , modCohesion   = max (getCohesion  info) (getCohesion  info')-                         }-                       , argInfoOrigin   = min (getOrigin info) (getOrigin info')-                       , argInfoFreeVariables = unknownFreeVariables-                       , argInfoAnnotation    = argInfoAnnotation info'-                       }-                    vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-                res <- loop $ zipWith aux vs fs-                return $ res `append` vars-              | otherwise -> fallback-            _ -> fallback+      -- (i, j) := x  becomes  [i := fst x, j := snd x]+      -- Andreas, 2013-09-17 but only if constructor is fully applied+      tm@(Con c ci es) -> do+        let fallback+             | isIrrelevant info = return vars+             | skip tm           = return vars+             | otherwise         = failure tm+        irrProj <- optIrrelevantProjections <$> pragmaOptions+        lift (isEtaRecordConstructor $ conName c) >>= \case+          -- Andreas, 2019-11-10, issue #4185: only for eta-records+          Just (_, RecordData{ _recFields = fs })+            | length fs == length es+            , hasQuantity0 info || all usableQuantity fs     -- Andreas, 2019-11-12/17, issue #4168b+            , irrProj || all isRelevant fs -> do+              let aux (Arg _ v) Dom{domInfo = info', unDom = f} =+                    (Arg ai v,) $ t `applyE` [Proj ProjSystem f]+                    where+                    ai = ArgInfo+                      { argInfoHiding   = min (getHiding info) (getHiding info')+                      , argInfoModality = Modality+                        { modRelevance  = max (getRelevance info) (getRelevance info')+                        , modQuantity   = max (getQuantity  info) (getQuantity  info')+                        , modCohesion   = max (getCohesion  info) (getCohesion  info')+                        , modPolarity   = addPolarity (getModalPolarity info) (getModalPolarity info') -- XXX+                        }+                      , argInfoOrigin   = min (getOrigin info) (getOrigin info')+                      , argInfoFreeVariables = unknownFreeVariables+                      , argInfoAnnotation    = argInfoAnnotation info'+                      }+                  vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+              res <- loop $ zipWith aux vs fs+              return $ res `append` vars+            | otherwise -> fallback+          _ -> fallback -        -- An irrelevant argument which is not an irrefutable pattern is dropped-        _ | irr -> return vars+      -- An irrelevant argument which is not an irrefutable pattern is dropped+      _ | irr -> return vars -        -- Distinguish args that can be eliminated (Con,Lit,Lam,unsure) ==> failure-        -- from those that can only put somewhere as a whole ==> neutralArg-        Var{}      -> neutralArg-        Def{}      -> neutralArg  -- Note that this Def{} is in normal form and might be prunable.-        Lam{}      -> failure-        Lit{}      -> failure-        MetaV{}    -> failure-        Pi{}       -> neutralArg-        Sort{}     -> neutralArg-        Level{}    -> neutralArg-        DontCare{} -> __IMPOSSIBLE__ -- Ruled out by stripDontCare-        Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s+      -- Distinguish args that can be eliminated (Con,Lit,Lam,unsure) ==> failure+      -- from those that can only put somewhere as a whole ==> neutralArg+      Var{}      -> neutralArg -    -- managing an assoc list where duplicate indizes cannot be irrelevant vars-    append :: Res -> Res -> Res-    append res vars = foldr cons vars res+      -- primINeg i := x becomes i := primINeg x+      -- (primINeg is a definitional involution)+      Def qn es | Just [Arg _ (Var i [])] <- allApplyElims es, Just qn == ineg ->+        pure $ (Arg info i, Def qn [Apply (defaultArg t)]) `cons` vars -    -- adding an irrelevant entry only if not present-    cons :: (Arg Nat, Term) -> Res -> Res-    cons a@(Arg ai i, t) vars-      | isIrrelevant ai = applyUnless (any ((i==) . unArg . fst) vars) (a :) vars-      | otherwise       = a :  -- adding a relevant entry-          -- filter out duplicate irrelevants-          filter (not . (\ a@(Arg info j, t) -> isIrrelevant info && i == j)) vars+      Def{}      -> neutralArg  -- Note that this Def{} is in normal form and might be prunable.+      t@Lam{}    -> failure t+      t@Lit{}    -> failure t+      t@MetaV{}  -> failure t+      Pi{}       -> neutralArg+      Sort{}     -> neutralArg+      Level{}    -> neutralArg+      DontCare{} -> __IMPOSSIBLE__ -- Ruled out by stripDontCare+      Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s +  -- managing an assoc list where duplicate indizes cannot be irrelevant vars+  append :: Res -> Res -> Res+  append res vars = foldr cons vars res +  -- adding an irrelevant entry only if not present+  cons :: (Arg Nat, Term) -> Res -> Res+  cons a@(Arg ai i, t) vars+    | isIrrelevant ai = applyUnless (any ((i ==) . unArg . fst) vars) (a :) vars+    | otherwise       = a :  -- adding a relevant entry+        -- filter out duplicate irrelevants+        filter (not . (\ a@(Arg info j, t) -> isIrrelevant info && i == j)) vars++-- | If the given metavariable application represents a face, return:+--+--    * The metavariable information;+--    * The actual face, as an assignment of booleans to variables;+--+--    * The substitution candidate resulting from @inverseSubst'@. This+--    is guaranteed to be linear and deterministic.+--+--    * The actual substitution, mapping from the constraint context to+--    the metavariable's context.+--+--  Put concisely, a face constraint is an equation in the pattern+--  fragment modulo the presence of endpoints (@i0@ and @i1@) in the+--  telescope. In more detail, a face constraint has the form+--+--    @?0 Δ (i = i0) (j = i0) Γ (k = i1) Θ (l = i0) = t@+--+--  where all the greek letters consist entirely of distinct bound+--  variables (and, of course, arbitrarily many endpoints are allowed+--  between each substitution fragment).+isFaceConstraint+  :: MetaId+  -> Args+  -> TCM (Maybe (MetaVariable, IntMap.IntMap Bool, SubstCand, Substitution))+isFaceConstraint mid args = runMaybeT $ do+  iv   <- intervalView'+  mvar <- lookupLocalMeta mid  -- information associated with meta x+  -- Make sure that this is actually an interaction point:+  (_, _, _) <- MaybeT $ isInteractionMetaB mid args++  let+    t = jMetaType $ mvJudgement mvar+    n = length args++    isEndpoint tm = isJust (fin (defaultArg tm) 0)++    fin (Arg _ tm) i = case iv tm of+      IOne  -> Just (i, True)+      IZero -> Just (i, False)+      _     -> Nothing++  -- The logic here is essentially the same as for actually solving the+  -- meta.. We just return the pieces instead of doing the assignment.+  -- We must check the "face condition" (the relaxed pattern condition)+  -- and check linearity of the substitution candidate, otherwise the+  -- equation can't be inverted into a face constraint.+  sub <- MaybeT $ either (const Nothing) Just <$> runExceptT (inverseSubst' isEndpoint args)+  ids <- MaybeT $ either (const Nothing) Just <$> runExceptT (checkLinearity sub)++  m           <- getContextSize+  TelV tel' _ <- telViewUpToPath n t+  tel''       <- enterClosure mvar $ \_ -> getContextTelescope++  let+    assocToList i = \case+      _           | i >= m -> []+      ((j,u) : l) | i == j -> Just u  : assocToList (i + 1) l+      l                    -> Nothing : assocToList (i + 1) l+    ivs = assocToList 0 ids+    rho = prependS impossible ivs $ raiseS n++    over  = size tel' - size tel''+    endps = IntMap.fromList $ catMaybes $ zipWith (\a i -> fin a (i - over)) args (downFrom n)++  reportSDoc "tc.ip.boundary" 45 $ vcat+    [ "ivs   =" <+> prettyTCM ivs+    , "tel'  =" <+> prettyTCM tel'+    , "tel'' =" <+> prettyTCM tel''+    , "ids   =" <+> prettyTCM ids+    , "sub   =" <+> prettyTCM sub+    , "endps =" <+> pretty endps+    ]++  guard (not (IntMap.null endps))+  -- Can happen when the metavariable's context does not yet know about+  -- an interval variable it will be applied to later, eg in the partial+  -- argument to hcomp:+  guard (all (>= 0) (IntMap.keys endps))+  -- In that case we fail here — when the user writes some more+  -- patterns, they'll become positive+  pure (mvar, endps, ids, rho)++-- | Record a "face" equation onto an interaction point into the actual+-- interaction point boundary. Takes all the same arguments as+-- @assignMeta'@.+tryAddBoundary :: CompareDirection -> MetaId -> InteractionId -> Args -> Term -> CompareAs -> TCM ()+tryAddBoundary dir x iid args v target = do+  reportSDoc "tc.ip.boundary" 30 $ vcat+    [ "boundary: looking at equational constraint"+    , prettyTCM (MetaV x (Apply <$> args)) <+> "=?" <+> prettyTCM v+    ]+  iv   <- intervalView'+  mvar <- lookupLocalMeta x  -- information associated with meta x++  let+    t = jMetaType $ mvJudgement mvar+    n = length args+    rhsv = allFreeVars v++    allVars :: SubstCand -> Bool+    allVars sub = rhsv `VarSet.isSubsetOf` VarSet.fromList (map fst sub)++  TelV tel' _ <- telViewUpToPath n t++  void . runMaybeT $ do+    -- Make sure we're looking at a face constraint:+    (_, endps, ids, rho) <- MaybeT $ isFaceConstraint x args+    -- And that the non-endpoint parts of the 'Args' cover the free+    -- variables of the RHS:+    guard (allVars ids)++    -- ρ is a substitution from the "constraint context" (the context+    -- we're in) to the metavariable's context. moreover, v[ρ] is+    -- well-scoped in the meta's context.+    let v' = abstract tel' $ applySubst rho v+    -- We store the boundary faces directly as lambdas for simplicity.++    enterClosure mvar $ \_ -> do+      reportSDoc "tc.ip.boundary" 30 $ vcat+        [ "recovered interaction point boundary"+        , "  endps =" <+> pretty endps+        , "  rho   =" <+> pretty rho+        , "  t     =" <+> inTopContext (prettyTCM t)+        , "  v'    =" <+> inTopContext (prettyTCM v')+        ]++      let+        -- Always store the constraint with the smaller termSize:+        upd (IPBoundary m) = case MapS.lookup endps m of+          Just t -> if termSize t < termSize v'+            then IPBoundary m+            else IPBoundary $ MapS.insert endps v' m+          Nothing -> IPBoundary $ MapS.insert endps v' m+        f ip = ip{ ipBoundary = upd (ipBoundary ip) }++      lift $ modifyInteractionPoints (BiMap.adjust f iid)+ -- | Turn open metas into postulates. -- --   Preconditions:@@ -1666,42 +1896,42 @@   m <- asksTC envCurrentModule    -- Go through all open metas.-  ms <- IntMap.assocs <$> useTC stMetaStore+  ms <- MapS.assocs <$> useTC stOpenMetaStore   forM_ ms $ \ (x, mv) -> do-    when (isOpenMeta $ mvInstantiation mv) $ do-      let t = dummyTypeToOmega $ jMetaType $ mvJudgement mv+    let t = dummyTypeToOmega $ jMetaType $ mvJudgement mv -      -- Create a name for the new postulate.-      let r = clValue $ miClosRange $ mvInfo mv-      -- s <- render <$> prettyTCM x -- Using _ is a bad idea, as it prints as prefix op-      let s = "unsolved#meta." ++ prettyShow x-      n <- freshName r s-      let q = A.QName m n+    -- Create a name for the new postulate.+    let r = clValue $ miClosRange $ mvInfo mv+    s' <- render <$> prettyTCM x -- Using _ is a bad idea, as it prints as prefix op+    let s = "unsolved#meta." ++ filter (/= '_') s'+    n <- freshName r s+    let q = A.QName m n -      -- Debug.-      reportSDoc "meta.postulate" 20 $ vcat-        [ text ("Turning " ++ if isSortMeta_ mv then "sort" else "value" ++ " meta ")-            <+> prettyTCM (MetaId x) <+> " into postulate."-        , nest 2 $ vcat-          [ "Name: " <+> prettyTCM q-          , "Type: " <+> prettyTCM t-          ]+    -- Debug.+    reportSDoc "meta.postulate" 20 $ vcat+      [ text ("Turning " ++ if isSortMeta_ mv then "sort" else "value" ++ " meta ")+          <+> prettyTCM x <+> " into postulate."+      , nest 2 $ vcat+        [ "Name: " <+> prettyTCM q+        , "Type: " <+> prettyTCM t         ]+      ] -      -- Add the new postulate to the signature.-      addConstant' q defaultArgInfo q t defaultAxiom+    -- Add the new postulate to the signature.+    addConstant' q defaultArgInfo t defaultAxiom -      -- Solve the meta.-      let inst = InstV [] $ Def q []-      updateMetaVar (MetaId x) $ \ mv0 -> mv0 { mvInstantiation = inst }-      return ()+    -- Solve the meta.+    let inst = InstV $ Instantiation+                 { instTel = [], instBody = Def q [] }+    updateMetaVar x $ \ mv0 -> mv0 { mvInstantiation = inst }+    return ()   where     -- Unsolved sort metas can have a type ending in a Dummy if they are allowed to be instantiated     -- to Setω. This will crash the serializer (issue #3730). To avoid this we replace dummy type     -- codomains by Setω.     dummyTypeToOmega t =       case telView' t of-        TelV tel (El _ Dummy{}) -> abstract tel (sort $ Inf IsFibrant 0)+        TelV tel (El _ Dummy{}) -> abstract tel (sort $ Inf UType 0)         _ -> t  -- | Sort metas in dependency order.@@ -1709,15 +1939,20 @@ dependencySortMetas metas = do   metaGraph <- concat <$> do     forM metas $ \ m -> do-      deps <- allMetas (\ m' -> if m' `elem` metas then singleton m' else mempty) <$> getType m+      deps <- allMetas (\m' -> if m' `Set.member` metas'+                               then singleton m'+                               else mempty) <$>+                getType m       return [ (m, m') | m' <- Set.toList deps ] -  return $ Graph.topSort metas metaGraph+  return $ Graph.topSort metas' metaGraph    where+    metas' = Set.fromList metas+     -- Sort metas don't have types, but we still want to sort them.     getType m = do-      mv <- lookupMeta m-      case mvJudgement mv of+      j <- lookupMetaJudgement m+      case j of         IsSort{}                 -> return Nothing         HasType{ jMetaType = t } -> Just <$> instantiateFull t
src/full/Agda/TypeChecking/MetaVars.hs-boot view
@@ -1,17 +1,21 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.MetaVars where  import Agda.Syntax.Common           ( Arg )-import Agda.Syntax.Internal         ( MetaId, Term, Type, Args, Dom, Abs, Telescope, Sort )-import Agda.TypeChecking.Monad.Base ( TCM, RunMetaOccursCheck, Comparison, CompareAs, CompareDirection )+import Agda.Syntax.Internal         ( MetaId, Term, Type, Args, Dom, Abs, Telescope, Sort, Substitution )+import Agda.TypeChecking.Monad.Base ( TCM, RunMetaOccursCheck, Comparison, CompareAs, CompareDirection, MetaVariable ) import Agda.TypeChecking.Monad.MetaVars (MonadMetaSolver)+import Data.IntMap (IntMap)  instance MonadMetaSolver TCM  type Condition = Dom Type -> Abs Type -> Bool+type SubstCand = [(Int,Term)]+ newArgsMeta'      :: MonadMetaSolver m => Condition -> Type -> m Args newArgsMeta       :: MonadMetaSolver m => Type -> m Args assignTerm        :: MonadMetaSolver m => MetaId -> [Arg String] -> Term -> m ()-etaExpandMetaSafe :: MonadMetaSolver m => MetaId -> m () assign            :: CompareDirection -> MetaId -> Args -> Term -> CompareAs -> TCM () newInstanceMeta   :: MonadMetaSolver m => String -> Type -> m (MetaId, Term) newValueMeta      :: MonadMetaSolver m => RunMetaOccursCheck -> Comparison -> Type -> m (MetaId, Term)@@ -20,3 +24,4 @@ newTelMeta        :: MonadMetaSolver m => Telescope -> m Args newSortMeta       :: MonadMetaSolver m => m Sort checkMetaInst     :: MetaId -> TCM ()+isFaceConstraint  :: MetaId -> Args -> TCM (Maybe (MetaVariable, IntMap Bool, SubstCand, Substitution))
src/full/Agda/TypeChecking/MetaVars/Mention.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.MetaVars.Mention where @@ -43,18 +44,19 @@   mentionsMetas xs (UnblockOnAny bs)  = mentionsMetas xs $ Set.toList bs   mentionsMetas xs (UnblockOnMeta x)  = HashSet.member x xs   mentionsMetas xs UnblockOnProblem{} = False+  mentionsMetas xs UnblockOnDef{}     = False  instance MentionsMeta Type where     mentionsMetas xs (El s t) = mentionsMetas xs (s, t)  instance MentionsMeta Sort where   mentionsMetas xs = \case-    Type l     -> mentionsMetas xs l-    Prop l     -> mentionsMetas xs l+    Univ _ l   -> mentionsMetas xs l     Inf _ _    -> False-    SSet l     -> mentionsMetas xs l     SizeUniv   -> False     LockUniv   -> False+    LevelUniv  -> False+    IntervalUniv -> False     PiSort a s1 s2 -> mentionsMetas xs (a, s1, s2)     FunSort s1 s2 -> mentionsMetas xs (s1, s2)     UnivSort s -> mentionsMetas xs s@@ -111,16 +113,18 @@                                   -- problem and we don't have a handle on                                   -- what metas it depends on     FindInstance{}      -> True   -- this needs to be woken up for any meta+    ResolveInstanceHead q -> True -- TODO     IsEmpty r t         -> mm t     CheckSizeLtSat t    -> mm t     CheckFunDef{}       -> True   -- not sure what metas this depends on     HasBiggerSort a     -> mm a     HasPTSRule a b      -> mm (a, b)     UnquoteTactic tac hole goal -> False+    CheckDataSort q s   -> mm s     CheckMetaInst m     -> True   -- TODO     CheckType t         -> mm t     CheckLockedVars a b c d -> mm ((a, b), (c, d))-    UsableAtModality mod t -> mm t+    UsableAtModality _ ms mod t -> mm (ms, t)     where       mm :: forall t. MentionsMeta t => t -> Bool       mm = mentionsMetas xs
src/full/Agda/TypeChecking/MetaVars/Occurs.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE NondecreasingIndentation  #-}  {- | The occurs check for unification.  Does pruning on the fly.@@ -13,9 +15,8 @@  module Agda.TypeChecking.MetaVars.Occurs where -import Control.Monad-import Control.Monad.Except-import Control.Monad.Reader+import Control.Monad.Except ( ExceptT, runExceptT, catchError, throwError )+import Control.Monad.Reader ( ReaderT, runReaderT, ask, asks, local )  import Data.Foldable (traverse_) import Data.Functor@@ -23,8 +24,6 @@ import Data.Set (Set) import qualified Data.Set as Set import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet-import Data.IntSet (IntSet)  import qualified Agda.Benchmarking as Bench @@ -32,7 +31,7 @@ import Agda.Syntax.Internal import Agda.Syntax.Internal.MetaVars -import Agda.TypeChecking.Constraints () -- instances+import Agda.TypeChecking.Constraints import Agda.TypeChecking.Monad import qualified Agda.TypeChecking.Monad.Benchmark as Bench import Agda.TypeChecking.Reduce@@ -40,19 +39,24 @@ import Agda.TypeChecking.Free import Agda.TypeChecking.Free.Lazy import Agda.TypeChecking.Free.Reduce+import Agda.TypeChecking.ProjectionLike import Agda.TypeChecking.Substitute import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Records import {-# SOURCE #-} Agda.TypeChecking.MetaVars+import Agda.Interaction.Options (optFirstOrder)  import Agda.Utils.Either+import Agda.Utils.Function import Agda.Utils.Lens import Agda.Utils.List (downFrom) import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Permutation-import Agda.Utils.Pretty (prettyShow)+import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Utils.Size+import Agda.Utils.VarSet (VarSet)+import qualified Agda.Utils.VarSet as VarSet  import Agda.Utils.Impossible @@ -134,8 +138,9 @@ -- | Extra environment for the occurs check.  (Complements 'FreeEnv'.) data OccursExtra = OccursExtra   { occUnfold  :: UnfoldStrategy-  , occVars    :: VarMap          -- ^ The allowed variables with their variance.-  , occMeta    :: MetaId          -- ^ The meta we want to solve.+  , occMeta    :: MetaId          -- ^ The meta @m@ we want to solve.+  , occVars    :: VarMap          -- ^ The allowed variables @xs@ with their variance.+  , occRHS     :: Term            -- ^ The proposed solution @v@ for the meta (@m xs := v@).   , occCxtSize :: Nat             -- ^ The size of the typing context upon invocation.   } @@ -190,17 +195,17 @@         [ "occursCheck: definition"         , prettyTCM d         , "has relevance"-        , prettyTCM (getRelevance dmod)+        , text . show $ getRelevance dmod         ]-      abort neverUnblock $ MetaIrrelevantSolution m $ Def d []+      abort neverUnblock $ MetaIrrelevantSolution m $ occRHS $ feExtra cxt     unless (er || usableQuantity dmod) $ do       reportSDoc "tc.meta.occurs" 35 $ hsep         [ "occursCheck: definition"         , prettyTCM d         , "has quantity"-        , prettyTCM (getQuantity dmod)+        , text . show $ getQuantity dmod         ]-      abort neverUnblock $ MetaErasedSolution m $ Def d []+      abort neverUnblock $ MetaErasedSolution m $ occRHS $ feExtra cxt  metaCheck :: MetaId -> OccursM MetaId metaCheck m = do@@ -223,19 +228,20 @@   -- WAS:   -- when (m == m') $ if ctx == Top then patternViolation else   --   abort ctx $ MetaOccursInItself m'+  -- Andreas, 2024-09-28: removed error MetaOccursInItself from code base.   when (m == m0) $ patternViolation' neverUnblock 50 $ "occursCheck failed: Found " ++ prettyShow m -  mv <- lookupMeta m-  let mmod = getMetaModality mv+  mv <- lookupLocalMeta m+  let mmod = getModality mv       mmod' = setRelevance rel $ setQuantity qnt $ mmod   if (mmod `moreUsableModality` mmod') then return m else do     reportSDoc "tc.meta.occurs" 35 $ hsep       [ "occursCheck: meta variable"       , prettyTCM m       , "has relevance"-      , prettyTCM (getRelevance mmod)+      , text . show $ getRelevance mmod       , "and quantity"-      , prettyTCM (getQuantity mmod)+      , text . show $ getQuantity mmod       ]     allowAssign <- asksTC envAssignMetas     -- Jesper, 2020-11-10: if we encounter a metavariable that is@@ -249,26 +255,31 @@     -- - If it is in a top-level position, we can instead solve the     --   equation by instantiating the other way around, so promotion     --   is not necessary.++    -- Actually, this is not the case anymore, no new meta is created and+    -- instead the metavar itself gets modified with the new modality.     let fail reason = do           reportSDoc "tc.meta.occurs" 20 $ "Meta occurs check found bad relevance"           reportSDoc "tc.meta.occurs" 20 $ "aborting because" <+> reason           patternViolation $ unblockOnMeta m     when (mvFrozen mv == Frozen)             $ fail "meta is frozen"     unless (isOpenMeta $ mvInstantiation mv) $ fail "meta is already solved"-    unless allowAssign                       $ fail "assigning metas is not allowed here"-    when (isFlexible cxt)                    $ fail "occurrence is flexible"+    unlessM (asksTC envAssignMetas)          $ fail "assigning metas is not allowed here"+    -- Jesper, 2023-09-03, issue #6759: When --lossy-unification is enabled,+    -- we already lose the guarantee that we only throw an error when a+    -- problem is really unsolvable in favor of taking the "obvious" solution.+    -- In this case the "obvious" solution is to promote the meta even if+    -- it is in a flexible position, so that is what we do.+    whenM (pure (isFlexible cxt) `and2M` (not . optFirstOrder <$> pragmaOptions))+                                             $ fail "occurrence is flexible"     when (isUnguarded cxt)                   $ fail "occurrence is unguarded"      reportSDoc "tc.meta.occurs" 20 $ "Promoting meta" <+> prettyTCM m <+> "to modality" <+> prettyTCM mmod'-    let info' = setModality mmod' $ mvInfo mv-    m' <- liftTCM $ newMeta Instantiable info' (mvPriority mv) (mvPermutation mv) (mvJudgement mv)-    reportSDoc "tc.meta.occurs.qnt" 20 $ hsep-       [ "occursCheck: new meta variable"-       , prettyTCM m'-       ]-    liftTCM $ assignTerm m [] $ MetaV m' []-    reportSDoc "tc.meta.occurs" 35 $ "New name for" <+> prettyTCM m <+> "is" <+> prettyTCM m'-    return m'+    -- The meta gets updated here+    updateMetaVar m $ \ mv -> mv { mvInfo = setModality mmod' $ mvInfo mv }+    etaExpandListeners m+    wakeupConstraints m+    return m  -- | Construct a test whether a de Bruijn index is allowed --   or needs to be pruned.@@ -276,9 +287,9 @@ allowedVars = do   -- @n@ is the number of binders we have stepped under.   n  <- liftM2 (-) getContextSize (asks (occCxtSize . feExtra))-  xs <- asks ((IntMap.keysSet . theVarMap) . (occVars . feExtra))+  xs <- asks (theVarMap . occVars . feExtra)   -- Bound variables are allowed, and those mentioned in occVars.-  return $ \ i -> i < n || (i - n) `IntSet.member` xs+  return $ \ i -> i < n || (i - n) `IntMap.member` xs  -- ** Unfolding during occurs check. @@ -355,99 +366,67 @@   occurs :: t -> OccursM t   metaOccurs :: MetaId -> t -> TCM ()  -- raise exception if meta occurs in t -  default occurs :: (Traversable f, Occurs a, f a ~ t) => t -> OccursM t-  occurs = traverse occurs-   default metaOccurs :: (Foldable f, Occurs a, f a ~ t) => MetaId -> t -> TCM ()   metaOccurs = traverse_ . metaOccurs +occurs_ :: (Occurs t, TypeOf t ~ ()) => t -> OccursM t+occurs_ t = occurs t++metaOccurs2 :: (Occurs a, Occurs b) => MetaId -> a -> b -> TCM ()+metaOccurs2 m x y = metaOccurs m x >> metaOccurs m y++metaOccurs3 :: (Occurs a, Occurs b, Occurs c) => MetaId -> a -> b -> c -> TCM ()+metaOccurs3 m x y z = metaOccurs m x >> metaOccurs m y >> metaOccurs m z+ -- | When assigning @m xs := v@, check that @m@ does not occur in @v@ --   and that the free variables of @v@ are contained in @xs@. occursCheck-  :: (Occurs a, InstantiateFull a, PrettyTCM a)-  => MetaId -> VarMap -> a -> TCM a+  :: MetaId -> VarMap -> Term -> TCM Term occursCheck m xs v = Bench.billTo [ Bench.Typing, Bench.OccursCheck ] $ do-  mv <- lookupMeta m+  mv <- lookupLocalMeta m   n  <- getContextSize-  reportSLn "tc.meta.occurs" 35 $ "occursCheck " ++ show m ++ " " ++ show xs+  reportSDoc "tc.meta.occurs" 65 $ "occursCheck" <+> pretty m <+> text (show xs)   let initEnv unf = FreeEnv-        {  feExtra = OccursExtra+        { feExtra = OccursExtra           { occUnfold  = unf-          , occVars    = xs           , occMeta    = m+          , occVars    = xs+          , occRHS     = v           , occCxtSize = n           }         , feFlexRig   = StronglyRigid -- ? Unguarded-        , feModality  = getMetaModality mv+        , feModality  = getModality mv         , feSingleton = variableCheck xs         }   initOccursCheck mv-  nicerErrorMessage $ do+  do     -- First try without normalising the term     (occurs v `runReaderT` initEnv NoUnfold) `catchError` \err -> do       -- If first run is inconclusive, try again with normalization       -- (unless metavariable is irrelevant, in which case the       -- constraint will anyway be dropped)       case err of-        PatternErr{} | not (isIrrelevant $ getMetaModality mv) -> do+        PatternErr{} | not (isIrrelevant $ getModality mv) -> do           initOccursCheck mv           occurs v `runReaderT` initEnv YesUnfold         _ -> throwError err -  where-    -- Produce nicer error messages-    nicerErrorMessage :: TCM a -> TCM a-    nicerErrorMessage f = f `catchError` \ err -> case err of-      TypeError _ _ cl -> case clValue cl of-        MetaOccursInItself{} ->-          typeError . GenericDocError =<<-            fsep [ text ("Refuse to construct infinite term by instantiating " ++ prettyShow m ++ " to")-                 , prettyTCM =<< instantiateFull v-                 ]-        MetaCannotDependOn _ i ->-          ifM (isSortMeta m `and2M` (not <$> hasUniversePolymorphism))-          ( typeError . GenericDocError =<<-            fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to")-                 , prettyTCM v-                 , "since universe polymorphism is disabled"-                 ]-          ) {- else -}-          ( typeError . GenericDocError =<<-              fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to solution")-                   , prettyTCM v-                   , "since it contains the variable"-                   , enterClosure cl $ \_ -> prettyTCM (Var i [])-                   , "which is not in scope of the metavariable"-                   ]-            )-        MetaIrrelevantSolution _ _ ->-          typeError . GenericDocError =<<-            fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to solution")-                 , prettyTCM v-                 , "since (part of) the solution was created in an irrelevant context"-                 ]-        MetaErasedSolution _ _ ->-          typeError . GenericDocError =<<-            fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to solution")-                 , prettyTCM v-                 , "since (part of) the solution was created in an erased context"-                 ]-        _ -> throwError err-      _ -> throwError err- instance Occurs Term where   occurs v = do     vb  <- unfoldB v-    -- occurs' ctx $ ignoreBlocking v  -- fails test/succeed/DontPruneBlocked-    let flexIfBlocked = case vb of-          -- Don't fail on blocked terms or metas-          Blocked _ MetaV{} -> id-          Blocked b _ -> flexibly . addOrUnblocker b+    let block = getBlocker vb+        -- On a failure, we should retry when any meta that is blocking+        -- the term is solved.+        flexIfBlocked = if+          -- In the metavariable case we should not yet become flexible+          -- because otherwise pruning won't fire.+          | MetaV{} <- ignoreBlocking vb -> addOrUnblocker block+          | block /= neverUnblock -> flexibly . addOrUnblocker block           -- Re #3594, do not fail hard when Underapplied:           -- the occurrence could be computed away after eta expansion.-          NotBlocked{blockingStatus = Underapplied} -> flexibly-          NotBlocked{} -> id-    let v = ignoreBlocking vb+          | NotBlocked{blockingStatus = Underapplied} <- vb -> flexibly+          | otherwise -> id+    v <- reduceProjectionLike $ ignoreBlocking vb     flexIfBlocked $ do         ctx <- ask         let m = occMeta . feExtra $ ctx@@ -464,7 +443,7 @@               reportSDoc "tc.meta.occurs" 35 $ "offending variable: " <+> prettyTCM (var i)               t <-  typeOfBV i               reportSDoc "tc.meta.occurs" 35 $ nest 2 $ "of type " <+> prettyTCM t-              isST <- isSingletonType t+              isST <- typeLevelReductions $ isSingletonType t               reportSDoc "tc.meta.occurs" 35 $ nest 2 $ "(after singleton test)"               case isST of                 -- not a singleton type@@ -473,30 +452,28 @@                   -- could potentially be salvaged by eta expansion.                   ifM (($ i) <$> allowedVars) -- vv TODO: neverUnblock is not correct! What could trigger this eta expansion though?                       (patternViolation' neverUnblock 70 $ "Disallowed var " ++ show i ++ " due to modality/relevance")-                      (strongly $ abort neverUnblock $ MetaCannotDependOn m i)+                      (strongly $ abort neverUnblock $ MetaCannotDependOn m (occRHS $ feExtra ctx) i)                 -- is a singleton type with unique inhabitant sv                 (Just sv) -> return $ sv `applyE` es-          Lam h f     -> Lam h <$> occurs f-          Level l     -> Level <$> occurs l+          Lam h f     -> do+            Lam h <$> occurs f+          Level l     -> Level <$> occurs_ l           Lit l       -> return v           Dummy{}     -> return v-          DontCare v  -> dontCare <$> do underRelevance Irrelevant $ occurs v+          DontCare v  -> dontCare <$> do+            onlyReduceTypes $ underRelevance irrelevant $ occurs v           Def d es    -> do             definitionCheck d             Def d <$> occDef d es           Con c ci vs -> do             definitionCheck (conName c)             Con c ci <$> conArgs vs (occurs vs)  -- if strongly rigid, remain so, except with unreduced IApply arguments.-          Pi a b      -> uncurry Pi <$> occurs (a,b)-          Sort s      -> Sort <$> do underRelevance NonStrict $ occurs s+          Pi a b      -> Pi <$> occurs_ a <*> occurs b+          Sort s      -> Sort <$> do underRelevance shapeIrrelevant $ occurs_ s           MetaV m' es -> do             m' <- metaCheck m'--            addOrUnblocker (unblockOnMeta m') $ do-                         -- If getting stuck here, we need to trigger wakeup if this meta is-                         -- solved.-              -- The arguments of a meta are in a flexible position-              (MetaV m' <$> do flexibly $ occurs es) `catchError` \ err -> do+            -- The arguments of a meta are in a flexible position+            (MetaV m' <$> do flexibly $ occurs es) `catchError` \ err -> do                 ctx <- ask                 reportSDoc "tc.meta.kill" 25 $ vcat                   [ text $ "error during flexible occurs check, we are " ++ show (ctx ^. lensFlexRig)@@ -512,10 +489,12 @@                     -- Do not prune when meta is projected!                     caseMaybe (allApplyElims es) (throwError err) $ \ vs -> do                       killResult <- lift . prune m' vs =<< allowedVars-                      if (killResult == PrunedEverything)+                      if (killResult == PrunedEverything) then do                         -- after successful pruning, restart occurs check-                        then occurs =<< instantiate (MetaV m' es)-                        else throwError err+                        reportSDoc "tc.meta.prune" 40 $ "Pruned everything"+                        v' <- instantiate (MetaV m' es)+                        occurs v'+                      else throwError err                   _ -> throwError err           where             -- a data or record type constructor propagates strong occurrences@@ -536,9 +515,9 @@       Lit l      -> return ()       Dummy{}    -> return ()       DontCare v -> metaOccurs m v-      Def d vs   -> metaOccurs m d >> metaOccurs m vs+      Def d vs   -> metaOccurs2 m d vs       Con c _ vs -> metaOccurs m vs-      Pi a b     -> metaOccurs m (a,b)+      Pi a b     -> metaOccurs2 m a b       Sort s     -> metaOccurs m s              -- vv m is already an unblocker       MetaV m' vs | m == m'   -> patternViolation' neverUnblock 50 $ "Found occurrence of " ++ prettyShow m                   | otherwise -> addOrUnblocker (unblockOnMeta m') $ metaOccurs m vs@@ -548,7 +527,7 @@    metaOccurs m d = whenM (defNeedsChecking d) $ do     tallyDef d-    reportSLn "tc.meta.occurs" 30 $ "Checking for occurrences in " ++ show d+    reportSDoc "tc.meta.occurs" 30 $ "Checking for occurrences in " <+> prettyTCM d     metaOccursQName m d  metaOccursQName :: MetaId -> QName -> TCM ()@@ -563,7 +542,7 @@    metaOccurs m Axiom{}                      = return ()   metaOccurs m DataOrRecSig{}               = return ()-  metaOccurs m Function{ funClauses = cls } = metaOccurs m cls+  metaOccurs m Function{ funClauses = cls } = traverse_ (metaOccurs m) cls   -- since a datatype is isomorphic to the sum of its constructor types   -- we check the constructor types   metaOccurs m Datatype{ dataCons = cs }    = mapM_ (metaOccursQName m) cs@@ -577,43 +556,45 @@ instance Occurs Clause where   occurs cl = __IMPOSSIBLE__ -  metaOccurs m = metaOccurs m . clauseBody+  metaOccurs m cl = whenJust (clauseBody cl) $ metaOccurs m  instance Occurs Level where-  occurs (Max n as) = Max n <$> occurs as+  occurs (Max n as) = Max n <$> traverse occurs_ as -  metaOccurs m (Max _ as) = addOrUnblocker (unblockOnAnyMetaIn as) $ metaOccurs m as-                            -- TODO: Should only be blocking metas in as. But any meta that can-                            --       let the Max make progress needs to be included. For instance,-                            --       _1 ⊔ _2 = _1 should unblock on _2, even though _1 is the meta-                            --       failing occurs check.+  metaOccurs m (Max _ as) =+    addOrUnblocker (unblockOnAnyMetaIn as) $ traverse_ (metaOccurs m) as+    -- TODO: Should only be blocking metas in as. But any meta that can+    --       let the Max make progress needs to be included. For instance,+    --       _1 ⊔ _2 = _1 should unblock on _2, even though _1 is the meta+    --       failing occurs check.  instance Occurs PlusLevel where-  occurs (Plus n l) = Plus n <$> occurs l+  occurs (Plus n l) = do+    Plus n <$> occurs l    metaOccurs m (Plus n l) = metaOccurs m l  instance Occurs Type where-  occurs (El s v) = uncurry El <$> occurs (s,v)+  occurs (El s v) = El <$> occurs_ s <*> occurs v -  metaOccurs m (El s v) = metaOccurs m (s,v)+  metaOccurs m (El s v) = metaOccurs2 m s v  instance Occurs Sort where   occurs s = do     unfold s >>= \case       PiSort a s1 s2 -> do-        s1' <- flexibly $ occurs s1-        a'  <- (a $>) <$> do flexibly $ occurs $ unDom a-        s2' <- mapAbstraction (El s1' <$> a') (flexibly . underBinder . occurs) s2+        s1' <- flexibly $ occurs_ s1+        a'  <- (a $>) <$> do flexibly $ occurs (unDom a)+        s2' <- mapAbstraction (El s1' <$> a') (flexibly . underBinder . occurs_) s2         return $ PiSort a' s1' s2'-      FunSort s1 s2 -> FunSort <$> flexibly (occurs s1) <*> flexibly (occurs s2)-      Type a     -> Type <$> occurs a-      Prop a     -> Prop <$> occurs a+      FunSort s1 s2 -> FunSort <$> flexibly (occurs_ s1) <*> flexibly (occurs_ s2)+      Univ u a   -> Univ u <$> occurs_ a       s@Inf{}    -> return s-      SSet a     -> SSet <$> occurs a       s@SizeUniv -> return s       s@LockUniv -> return s-      UnivSort s -> UnivSort <$> do flexibly $ occurs s+      s@LevelUniv -> return s+      s@IntervalUniv -> return s+      UnivSort s -> UnivSort <$> do flexibly $ occurs_ s       MetaS x es -> do         MetaV x es <- occurs (MetaV x es)         return $ MetaS x es@@ -625,52 +606,70 @@   metaOccurs m s = do     s <- instantiate s     case s of-      PiSort a s1 s2 -> metaOccurs m (a,s1,s2)-      FunSort s1 s2 -> metaOccurs m (s1,s2)-      Type a     -> metaOccurs m a-      Prop a     -> metaOccurs m a+      PiSort a s1 s2 -> do+        metaOccurs m a+        metaOccurs m s1+        metaOccurs m (absBody s2)+      FunSort s1 s2 -> metaOccurs2 m s1 s2+      Univ _ a   -> metaOccurs m a       Inf _ _    -> return ()-      SSet a     -> metaOccurs m a       SizeUniv   -> return ()       LockUniv   -> return ()+      LevelUniv  -> return ()+      IntervalUniv -> return ()       UnivSort s -> metaOccurs m s       MetaS x es -> metaOccurs m $ MetaV x es       DefS d es  -> metaOccurs m $ Def d es       DummyS{}   -> return () -instance Occurs a => Occurs (Elim' a) where-  occurs e@(Proj _ f)   = e <$ definitionCheck f-  occurs (Apply a)      = Apply  <$> occurs a-  occurs (IApply x y a) = IApply <$> occurs x <*> occurs y <*> occurs a+instance Occurs Elims where+  occurs []     = return []+  occurs (e:es) = do+    reportSDoc "tc.meta.occurs.elim" 45 $ "occurs" <+> prettyTCM e+    reportSDoc "tc.meta.occurs.elim" 70 $ "occurs" <+> pretty e+    e' <- case e of+      (Proj o f)     -> do+        definitionCheck f+        return e+      (Apply u)      -> do+        u' <- occurs u+        return (Apply u')+      (IApply x y u) -> do+        x' <- occurs x+        y' <- occurs y+        u' <- occurs u+        return (IApply x' y' u')+    (e':) <$> occurs es -  metaOccurs m (Proj{} ) = return ()-  metaOccurs m (Apply a) = metaOccurs m a-  metaOccurs m (IApply x y a) = metaOccurs m (x,(y,a))+  metaOccurs m es = forM_ es $ \case+    Proj{} -> return ()+    Apply a -> metaOccurs m a+    IApply x y a -> metaOccurs3 m x y a -instance (Occurs a, Subst a) => Occurs (Abs a) where-  occurs b@(Abs s _) = Abs   s <$> do underAbstraction_ b $ underBinder . occurs+instance Occurs (Abs Term) where   occurs (NoAbs s x) = NoAbs s <$> occurs x+  occurs x = mapAbstraction_ (\body -> underBinder $ occurs body) x    metaOccurs m (Abs   _ x) = metaOccurs m x   metaOccurs m (NoAbs _ x) = metaOccurs m x +instance Occurs (Abs Type) where+  occurs (NoAbs s x) = NoAbs s <$> occurs_ x+  occurs x = mapAbstraction_ (\body -> underBinder $ occurs_ body) x++  metaOccurs m (Abs   _ x) = metaOccurs m x+  metaOccurs m (NoAbs _ x) = metaOccurs m x+ instance Occurs a => Occurs (Arg a) where-  occurs (Arg info v) = Arg info <$> do underModality info $ occurs v+  occurs (Arg info v) = Arg info <$> do+    applyWhen (isIrrelevant info) onlyReduceTypes $+      underModality info $ occurs v   metaOccurs m = metaOccurs m . unArg  instance Occurs a => Occurs (Dom a) where-instance Occurs a => Occurs [a] where-instance Occurs a => Occurs (Maybe a) where--instance (Occurs a, Occurs b) => Occurs (a,b) where-  occurs (x,y) = (,) <$> occurs x <*> occurs y--  metaOccurs m (x,y) = metaOccurs m x >> metaOccurs m y--instance (Occurs a, Occurs b, Occurs c) => Occurs (a,b,c) where-  occurs (x,y,z) = (,,) <$> occurs x <*> occurs y <*> occurs z--  metaOccurs m (x,y,z) = metaOccurs m x >> metaOccurs m y >> metaOccurs m z+  occurs :: Occurs a => Dom a -> OccursM (Dom a)+  occurs (Dom info n f t x) =+    Dom info n f t <$> underQuantity info (occurs x)  --------------------------------------------------------------------------- -- * Pruning: getting rid of flexible occurrences.@@ -822,7 +821,7 @@         -- If the definition is incomplete, arguments might disappear         -- by reductions that come with more clauses, thus, these         -- arguments are not rigid.-        NotBlocked MissingClauses _ -> return False+        NotBlocked (MissingClauses _) _ -> return False         -- _        -> mempty -- breaks: ImproveInertRHS, Issue442, PruneRecord, PruningNonMillerPattern         _        -> anyRigid f es       Con _ _ ts -> anyRigid f ts@@ -839,12 +838,12 @@ instance AnyRigid Sort where   anyRigid f s =     case s of-      Type l     -> anyRigid f l-      Prop l     -> anyRigid f l+      Univ _ l   -> anyRigid f l       Inf _ _    -> return False-      SSet l     -> anyRigid f l       SizeUniv   -> return False       LockUniv   -> return False+      LevelUniv  -> return False+      IntervalUniv -> return False       PiSort a s1 s2 -> return False       FunSort s1 s2 -> return False       UnivSort s -> anyRigid f s@@ -856,22 +855,21 @@   anyRigid f (Max _ ls) = anyRigid f ls  instance AnyRigid PlusLevel where-  anyRigid f (Plus _ l)    = anyRigid f l+  anyRigid f (Plus _ l) = anyRigid f l  instance (Subst a, AnyRigid a) => AnyRigid (Abs a) where   anyRigid f b = underAbstraction_ b $ anyRigid f  instance AnyRigid a => AnyRigid (Arg a) where   anyRigid f a =-    case getRelevance a of       -- Irrelevant arguments are definitionally equal to       -- values, so the variables there are not considered       -- "definitely rigid".-      Irrelevant -> return False-      _          -> anyRigid f $ unArg a+    if isIrrelevant a then return False else+      anyRigid f $ unArg a  instance AnyRigid a => AnyRigid (Dom a) where-  anyRigid f dom = anyRigid f $ unDom dom+  anyRigid f = anyRigid f . unDom  instance AnyRigid a => AnyRigid (Elim' a) where   anyRigid f (Apply a)      = anyRigid f a@@ -879,7 +877,7 @@   anyRigid f Proj{}         = return False  instance AnyRigid a => AnyRigid [a] where-  anyRigid f xs = anyM xs $ anyRigid f+  anyRigid = anyM . anyRigid  instance (AnyRigid a, AnyRigid b) => AnyRigid (a,b) where   anyRigid f (a,b) = anyRigid f a `or2M` anyRigid f b@@ -898,7 +896,7 @@ killArgs kills _   | not (or kills) = return NothingToPrune  -- nothing to kill killArgs kills m = do-  mv <- lookupMeta m+  mv <- lookupLocalMeta m   allowAssign <- asksTC envAssignMetas   if mvFrozen mv == Frozen || not allowAssign then return PrunedNothing else do       -- Andreas 2011-04-26, we allow pruning in MetaV and MetaS@@ -940,9 +938,12 @@ killedType :: (MonadReduce m) => [(Dom (ArgName, Type), Bool)] -> Type -> m ([Arg Bool], Type) killedType args b = do -  -- Turn list of bools into an IntSet containing the variables we want to kill+  let n = length args+  let iargs = zip (downFrom n) args++  -- Turn list of bools into an VarSet containing the variables we want to kill   -- (indices relative to b).-  let tokill = IntSet.fromList [ i | ((_, True), i) <- zip (reverse args) [0..] ]+  let tokill = VarSet.fromList [ i | (i, (_, True)) <- iargs ]    -- First, check the free variables of b to see if they prevent any kills.   (tokill, b) <- reallyNotFreeIn tokill b@@ -950,13 +951,13 @@   -- Then recurse over the telescope (right-to-left), building up the final type.   (killed, b) <- go (reverse $ map fst args) tokill b -  -- Turn the IntSet of killed variables into the list of Arg Bool's to return.-  let kills = [ Arg (getArgInfo dom) (IntSet.member i killed)-              | (i, (dom, _)) <- reverse $ zip [0..] $ reverse args ]+  -- Turn the VarSet of killed variables into the list of Arg Bool's to return.+  let kills = [ Arg (getArgInfo dom) (VarSet.member i killed)+              | (i, (dom, _)) <- iargs ]   return (kills, b)   where-    down = IntSet.map pred-    up   = IntSet.map succ+    down = VarSet.mapMonotonic pred+    up   = VarSet.mapMonotonic succ      -- go Δ xs B     -- Invariants:@@ -968,19 +969,19 @@     --    where Δ' ⊆ Δ  (possibly reduced to remove dependencies, see #3177)     --          ys ⊆ xs are the variables that were dropped from Δ     --          B' = strengthen ys B-    go :: (MonadReduce m) => [Dom (ArgName, Type)] -> IntSet -> Type -> m (IntSet, Type)-    go [] xs b | IntSet.null xs = return (xs, b)+    go :: (MonadReduce m) => [Dom (ArgName, Type)] -> VarSet -> Type -> m (VarSet, Type)+    go [] xs b | VarSet.null xs = return (xs, b)                | otherwise      = __IMPOSSIBLE__     go (arg : args) xs b  -- go (Δ (x : A)) xs B, (x = deBruijn index 0)-      | IntSet.member 0 xs = do+      | VarSet.member 0 xs = do           -- Case x ∈ xs. We know x ∉ FV(B), so we can safely drop x from the           -- telescope. Drop x from xs (and shift indices) and recurse with           -- `strengthen x B`.-          let ys = down (IntSet.delete 0 xs)+          let ys = down (VarSet.delete 0 xs)           (ys, b) <- go args ys $ strengthen impossible b           -- We need to return a set of killed variables relative to Δ (x : A), so           -- shift ys and add x back in.-          return (IntSet.insert 0 $ up ys, b)+          return (VarSet.insert 0 $ up ys, b)       | otherwise = do           -- Case x ∉ xs. We either can't or don't want to get rid of x. In           -- this case we have to check A for potential dependencies preventing@@ -990,27 +991,27 @@           (ys, a) <- reallyNotFreeIn xs' a           -- Recurse on Δ, ys, and (x : A') → B, where A reduces to A' and ys ⊆ xs'           -- not free in A'. We already know ys not free in B.-          (zs, b) <- go args ys (mkPi ((name, a) <$ arg) b)+          (zs, b) <- go args ys $ mkPi ((name, a) <$ arg) b           -- Shift back up to make it relative to Δ (x : A) again.           return (up zs, b) -reallyNotFreeIn :: (MonadReduce m) => IntSet -> Type -> m (IntSet, Type)-reallyNotFreeIn xs a | IntSet.null xs = return (xs, a) -- Shortcut+reallyNotFreeIn :: (MonadReduce m) => VarSet -> Type -> m (VarSet, Type)+reallyNotFreeIn xs a | VarSet.null xs = return (xs, a) -- Shortcut reallyNotFreeIn xs a = do   let fvs      = freeVars a       anywhere = allVars fvs-      rigid    = IntSet.unions [stronglyRigidVars fvs, unguardedVars fvs]-      nonrigid = IntSet.difference anywhere rigid-      hasNo    = IntSet.disjoint xs+      rigid    = VarSet.unions [stronglyRigidVars fvs, unguardedVars fvs]+      nonrigid = VarSet.difference anywhere rigid+      hasNo    = VarSet.disjoint xs   if hasNo nonrigid     then        -- No non-rigid occurrences. We can't do anything about the rigid        -- occurrences so drop those and leave `a` untouched.-       return (IntSet.difference xs rigid, a)+       return (VarSet.difference xs rigid, a)     else do       -- If there are non-rigid occurrences we need to reduce a to see if       -- we can get rid of them (#3177).-      (fvs, a) <- forceNotFree (IntSet.difference xs rigid) a+      (fvs, a) <- forceNotFree (VarSet.difference xs rigid) a       let xs = IntMap.keysSet $ IntMap.filter (== NotFree) fvs       return (xs, a) @@ -1024,7 +1025,7 @@   -> Type          -- ^ The pruned type of the new meta var.   -> m () performKill kills m a = do-  mv <- lookupMeta m+  mv <- lookupLocalMeta m   when (mvFrozen mv == Frozen) __IMPOSSIBLE__   -- Arity of the old meta.   let n = size kills
+ src/full/Agda/TypeChecking/Modalities.hs view
@@ -0,0 +1,99 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Modalities+  ( checkModality'+  , checkModality+  , checkModalityArgs+  ) where++import Control.Applicative ((<|>))++import Agda.Interaction.Options++import Agda.Syntax.Common+import Agda.Syntax.Internal++import Agda.TypeChecking.Conversion+import Agda.TypeChecking.Free+import Agda.TypeChecking.Free.Lazy+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Substitute++import Agda.Utils.Function+import Agda.Utils.Lens+import Agda.Utils.Maybe+import Agda.Utils.Monad++-- | The second argument is the definition of the first.+--   Returns 'Nothing' if ok, otherwise the error message.+checkRelevance' :: (MonadConversion m) => QName -> Definition -> m (Maybe TypeError)+checkRelevance' x def = do+  case getRelevance def of+    Relevant{} -> return Nothing -- relevance functions can be used in any context.+    drel -> do+      -- Andreas,, 2018-06-09, issue #2170+      -- irrelevant projections are only allowed if --irrelevant-projections+      let isProj = theDef def ^. funProj+      ifM (pure isProj `and2M`+           (not . optIrrelevantProjections <$> pragmaOptions)) {-then-} needIrrProj {-else-} $ do+        rel <- viewTC eRelevance+        reportSDoc "tc.irr" 50 $ vcat+          [ "declaration relevance =" <+> text (show drel)+          , "context     relevance =" <+> text (show rel)+          , prettyTCM x <+> "is" <+> applyUnless isProj ("not" <+>) "a projection"+          ]+        return $ boolToMaybe (not $ drel `moreRelevant` rel) $ DefinitionIsIrrelevant x+  where+  needIrrProj = return $ Just $ ProjectionIsIrrelevant x++-- | The second argument is the definition of the first.+--   Returns 'Nothing' if ok, otherwise the error message.+checkQuantity' :: (MonadConversion m) => QName -> Definition -> m (Maybe TypeError)+checkQuantity' x def = do+  case getQuantity def of+    dq@Quantityω{} -> do+      reportSDoc "tc.irr" 50 $ vcat+        [ "declaration quantity =" <+> text (show dq)+        -- , "context     quantity =" <+> text (show q)+        ]+      return Nothing -- Abundant definitions can be used in any context.+    dq -> do+      q <- viewTC eQuantity+      reportSDoc "tc.irr" 50 $ vcat+        [ "declaration quantity =" <+> text (show dq)+        , "context     quantity =" <+> text (show q)+        ]+      return $ boolToMaybe (not $ dq `moreQuantity` q) $ DefinitionIsErased x++-- | The second argument is the definition of the first.+checkModality' :: (MonadConversion m) => QName -> Definition -> m (Maybe TypeError)+checkModality' x def = do+  relOk <- checkRelevance' x def+  qtyOk <- checkQuantity' x def+  return $ relOk <|> qtyOk++-- | The second argument is the definition of the first.+checkModality :: (MonadConversion m) => QName -> Definition -> m ()+checkModality x def = checkModality' x def >>= mapM_ typeError++-- | Checks that the given implicitely inserted arguments, are used in a modally+--   correct way.+checkModalityArgs :: (MonadConversion m) => Definition -> Args -> m ()+checkModalityArgs d vs = do+  let+    vmap :: VarMap+    vmap = freeVars vs++  -- we iterate over all vars in the context and their ArgInfo,+  -- checking for each that "vs" uses them as allowed.+  as <- getContextArgs+  forM_ as $ \ (Arg avail t) -> do+    let m = do+          v <- deBruijnView t+          varModality <$> lookupVarMap v vmap+    whenJust m $ \ used -> do+      let availPosMod = positionalModalityComponent (getModality avail)+          usedPosMod = positionalModalityComponent (getModality used)+      unless (availPosMod `moreUsableModality` usedPosMod) $+         typeError $ InvalidModalTelescopeUse t usedPosMod availPosMod d
src/full/Agda/TypeChecking/Monad.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.Monad     ( module Agda.TypeChecking.Monad.Base     , module Agda.TypeChecking.Monad.Builtin@@ -8,6 +10,7 @@     , module Agda.TypeChecking.Monad.Env     , module Agda.TypeChecking.Monad.Imports     , module Agda.TypeChecking.Monad.MetaVars+    , module Agda.TypeChecking.Monad.Modality     , module Agda.TypeChecking.Monad.Mutual     , module Agda.TypeChecking.Monad.Open     , module Agda.TypeChecking.Monad.Options@@ -29,6 +32,7 @@ import Agda.TypeChecking.Monad.Env import Agda.TypeChecking.Monad.Imports import Agda.TypeChecking.Monad.MetaVars+import Agda.TypeChecking.Monad.Modality import Agda.TypeChecking.Monad.Mutual import Agda.TypeChecking.Monad.Options import Agda.TypeChecking.Monad.Open
src/full/Agda/TypeChecking/Monad/Base.hs view
@@ -3,4762 +3,6692 @@  module Agda.TypeChecking.Monad.Base   ( module Agda.TypeChecking.Monad.Base-  , HasOptions (..)-  ) where--import Prelude hiding (null)--import Control.Applicative hiding (empty)-import qualified Control.Concurrent as C-import Control.DeepSeq-import qualified Control.Exception as E--import qualified Control.Monad.Fail as Fail--import Control.Monad                ( void )-import Control.Monad.Except-import Control.Monad.IO.Class       ( MonadIO(..) )-import Control.Monad.State          ( MonadState(..), modify, StateT(..), runStateT )-import Control.Monad.Reader         ( MonadReader(..), ReaderT(..), runReaderT )-import Control.Monad.Writer         ( WriterT )-import Control.Monad.Trans          ( MonadTrans(..), lift )-import Control.Monad.Trans.Control  ( MonadTransControl(..), liftThrough )-import Control.Monad.Trans.Identity ( IdentityT(..), runIdentityT )-import Control.Monad.Trans.Maybe    ( MaybeT(..) )--import Control.Parallel             ( pseq )--import Data.Array (Ix)-import Data.Function-import Data.Int-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import qualified Data.List as List-import Data.Maybe-import Data.Map (Map)-import qualified Data.Map as Map -- hiding (singleton, null, empty)-import Data.Sequence (Seq)-import Data.Set (Set)-import qualified Data.Set as Set -- hiding (singleton, null, empty)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HMap-import Data.Semigroup ( Semigroup, (<>)) --, Any(..) )-import Data.Data (Data)-import Data.String-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL--import Data.IORef--import GHC.Generics (Generic)--import Agda.Benchmarking (Benchmark, Phase)--import Agda.Syntax.Concrete (TopLevelModuleName)-import Agda.Syntax.Common-import qualified Agda.Syntax.Concrete as C-import Agda.Syntax.Concrete.Definitions-  (NiceDeclaration, DeclarationWarning, dwWarning, declarationWarningName)-import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Internal as I-import Agda.Syntax.Internal.MetaVars-import Agda.Syntax.Internal.Generic (TermLike(..))-import Agda.Syntax.Parser (ParseWarning)-import Agda.Syntax.Parser.Monad (parseWarningName)-import Agda.Syntax.Treeless (Compiled)-import Agda.Syntax.Notation-import Agda.Syntax.Position-import Agda.Syntax.Scope.Base-import qualified Agda.Syntax.Info as Info--import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.Coverage.SplitTree-import Agda.TypeChecking.Positivity.Occurrence-import Agda.TypeChecking.Free.Lazy (Free(freeVars'), underBinder', underBinder)---- Args, defined in Agda.Syntax.Treeless and exported from Agda.Compiler.Backend--- conflicts with Args, defined in Agda.Syntax.Internal and also imported here.--- This only matters when interpreted in ghci, which sees all of the module's--- exported symbols, not just the ones defined in the `.hs-boot`. See the--- comment in ../../Compiler/Backend.hs-boot-import {-# SOURCE #-} Agda.Compiler.Backend hiding (Args)--import Agda.Interaction.Options-import Agda.Interaction.Options.Warnings-import {-# SOURCE #-} Agda.Interaction.Response-  (InteractionOutputCallback, defaultInteractionOutputCallback)-import Agda.Interaction.Highlighting.Precise-  (HighlightingInfo, NameKind)-import Agda.Interaction.Library--import Agda.Utils.Benchmark (MonadBench(..))-import Agda.Utils.BiMap (BiMap, HasTag(..))-import qualified Agda.Utils.BiMap as BiMap-import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack )-import Agda.Utils.FileName-import Agda.Utils.Functor-import Agda.Utils.Hash-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.ListT-import Agda.Utils.List1 (List1, pattern (:|))-import Agda.Utils.List2 (List2, pattern List2)-import qualified Agda.Utils.List1 as List1-import qualified Agda.Utils.Maybe.Strict as Strict-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Permutation-import Agda.Utils.Pretty-import Agda.Utils.Singleton-import Agda.Utils.SmallSet (SmallSet)-import qualified Agda.Utils.SmallSet as SmallSet-import Agda.Utils.Update-import Agda.Utils.WithDefault ( collapseDefault )--import Agda.Utils.Impossible-------------------------------------------------------------------------------- * Type checking state------------------------------------------------------------------------------data TCState = TCSt-  { stPreScopeState   :: !PreScopeState-    -- ^ The state which is frozen after scope checking.-  , stPostScopeState  :: !PostScopeState-    -- ^ The state which is modified after scope checking.-  , stPersistentState :: !PersistentTCState-    -- ^ State which is forever, like a diamond.-  }-  deriving Generic--class Monad m => ReadTCState m where-  getTCState :: m TCState-  locallyTCState :: Lens' a TCState -> (a -> a) -> m b -> m b--  withTCState :: (TCState -> TCState) -> m a -> m a-  withTCState = locallyTCState id--  default getTCState :: (MonadTrans t, ReadTCState n, t n ~ m) => m TCState-  getTCState = lift getTCState--  default locallyTCState-    :: (MonadTransControl t, ReadTCState n, t n ~ m)-    => Lens' a TCState -> (a -> a) -> m b -> m b-  locallyTCState l = liftThrough . locallyTCState l--instance ReadTCState m => ReadTCState (ListT m) where-  locallyTCState l = mapListT . locallyTCState l--instance ReadTCState m => ReadTCState (ChangeT m)-instance ReadTCState m => ReadTCState (ExceptT err m)-instance ReadTCState m => ReadTCState (IdentityT m)-instance ReadTCState m => ReadTCState (MaybeT m)-instance ReadTCState m => ReadTCState (ReaderT r m)-instance ReadTCState m => ReadTCState (StateT s m)-instance (Monoid w, ReadTCState m) => ReadTCState (WriterT w m)---instance Show TCState where-  show _ = "TCSt{}"--data PreScopeState = PreScopeState-  { stPreTokens             :: !HighlightingInfo-    -- ^ Highlighting info for tokens and Happy parser warnings (but-    -- not for those tokens/warnings for which highlighting exists in-    -- 'stPostSyntaxInfo').-  , stPreImports            :: !Signature  -- XX populated by scope checker-    -- ^ Imported declared identifiers.-    --   Those most not be serialized!-  , stPreImportedModules    :: !(Set ModuleName)  -- imports logic-  , stPreModuleToSource     :: !ModuleToSource   -- imports-  , stPreVisitedModules     :: !VisitedModules   -- imports-  , stPreScope              :: !ScopeInfo-    -- generated by scope checker, current file:-    -- which modules you have, public definitions, current file, maps concrete names to abstract names.-  , stPrePatternSyns        :: !A.PatternSynDefns-    -- ^ Pattern synonyms of the current file.  Serialized.-  , stPrePatternSynImports  :: !A.PatternSynDefns-    -- ^ Imported pattern synonyms.  Must not be serialized!-  , stPreGeneralizedVars    :: !(Strict.Maybe (Set QName))-    -- ^ Collected generalizable variables; used during scope checking of terms-  , stPrePragmaOptions      :: !PragmaOptions-    -- ^ Options applying to the current file. @OPTIONS@-    -- pragmas only affect this field.-  , stPreImportedBuiltins   :: !(BuiltinThings PrimFun)-  , stPreImportedDisplayForms :: !DisplayForms-    -- ^ Display forms added by someone else to imported identifiers-  , stPreImportedInstanceDefs :: !InstanceTable-  , stPreForeignCode        :: !(Map BackendName [ForeignCode])-    -- ^ @{-\# FOREIGN \#-}@ code that should be included in the compiled output.-    -- Does not include code for imported modules.-  , stPreFreshInteractionId :: !InteractionId-  , stPreImportedUserWarnings :: !(Map A.QName Text)-    -- ^ Imported @UserWarning@s, not to be stored in the @Interface@-  , stPreLocalUserWarnings    :: !(Map A.QName Text)-    -- ^ Locally defined @UserWarning@s, to be stored in the @Interface@-  , stPreWarningOnImport      :: !(Strict.Maybe Text)-    -- ^ Whether the current module should raise a warning when opened-  , stPreImportedPartialDefs :: !(Set QName)-    -- ^ Imported partial definitions, not to be stored in the @Interface@-  , stPreProjectConfigs :: !(Map FilePath ProjectConfig)-    -- ^ Map from directories to paths of closest enclosing .agda-lib-    --   files (or @Nothing@ if there are none).-  , stPreAgdaLibFiles   :: !(Map FilePath AgdaLibFile)-    -- ^ Contents of .agda-lib files that have already been parsed.-  }-  deriving Generic---- | Name disambiguation for the sake of highlighting.-data DisambiguatedName = DisambiguatedName NameKind A.QName-  deriving Generic-type DisambiguatedNames = IntMap DisambiguatedName--type ConcreteNames = Map Name [C.Name]--data PostScopeState = PostScopeState-  { stPostSyntaxInfo          :: !HighlightingInfo-    -- ^ Highlighting info.-  , stPostDisambiguatedNames  :: !DisambiguatedNames-    -- ^ Disambiguation carried out by the type checker.-    --   Maps position of first name character to disambiguated @'A.QName'@-    --   for each @'A.AmbiguousQName'@ already passed by the type checker.-  , stPostMetaStore           :: !MetaStore-  , stPostInteractionPoints   :: !InteractionPoints -- scope checker first-  , stPostAwakeConstraints    :: !Constraints-  , stPostSleepingConstraints :: !Constraints-  , stPostDirty               :: !Bool -- local-    -- ^ Dirty when a constraint is added, used to prevent pointer update.-    -- Currently unused.-  , stPostOccursCheckDefs     :: !(Set QName) -- local-    -- ^ Definitions to be considered during occurs check.-    --   Initialized to the current mutual block before the check.-    --   During occurs check, we remove definitions from this set-    --   as soon we have checked them.-  , stPostSignature           :: !Signature-    -- ^ Declared identifiers of the current file.-    --   These will be serialized after successful type checking.-  , stPostModuleCheckpoints   :: !(Map ModuleName CheckpointId)-    -- ^ For each module remember the checkpoint corresponding to the orignal-    --   context of the module parameters.-  , stPostImportsDisplayForms :: !DisplayForms-    -- ^ Display forms we add for imported identifiers-  , stPostCurrentModule       :: !(Strict.Maybe ModuleName)-    -- ^ The current module is available after it has been type-    -- checked.-  , stPostInstanceDefs        :: !TempInstanceTable-  , stPostConcreteNames       :: !ConcreteNames-    -- ^ Map keeping track of concrete names assigned to each abstract name-    --   (can be more than one name in case the first one is shadowed)-  , stPostUsedNames           :: !(Map RawName [RawName])-    -- ^ Map keeping track for each name root (= name w/o numeric-    -- suffixes) what names with the same root have been used during a-    -- TC computation. This information is used to build the-    -- @ShadowingNames@ map.-  , stPostShadowingNames      :: !(Map Name [RawName])-    -- ^ Map keeping track for each (abstract) name the list of all-    -- (raw) names that it could maybe be shadowed by.-  , stPostStatistics          :: !Statistics-    -- ^ Counters to collect various statistics about meta variables etc.-    --   Only for current file.-  , stPostTCWarnings          :: ![TCWarning]-  , stPostMutualBlocks        :: !(Map MutualId MutualBlock)-  , stPostLocalBuiltins       :: !(BuiltinThings PrimFun)-  , stPostFreshMetaId         :: !MetaId-  , stPostFreshMutualId       :: !MutualId-  , stPostFreshProblemId      :: !ProblemId-  , stPostFreshCheckpointId   :: !CheckpointId-  , stPostFreshInt            :: !Int-  , stPostFreshNameId         :: !NameId-  , stPostAreWeCaching        :: !Bool-  , stPostPostponeInstanceSearch :: !Bool-  , stPostConsideringInstance :: !Bool-  , stPostInstantiateBlocking :: !Bool-    -- ^ Should we instantiate away blocking metas?-    --   This can produce ill-typed terms but they are often more readable. See issue #3606.-    --   Best set to True only for calls to pretty*/reify to limit unwanted reductions.-  , stPostLocalPartialDefs    :: !(Set QName)-    -- ^ Local partial definitions, to be stored in the @Interface@-  }-  deriving (Generic)---- | A mutual block of names in the signature.-data MutualBlock = MutualBlock-  { mutualInfo  :: Info.MutualInfo-    -- ^ The original info of the mutual block.-  , mutualNames :: Set QName-  } deriving (Show, Eq, Generic)--instance Null MutualBlock where-  empty = MutualBlock empty empty---- | A part of the state which is not reverted when an error is thrown--- or the state is reset.-data PersistentTCState = PersistentTCSt-  { stDecodedModules    :: !DecodedModules-  , stPersistentOptions :: CommandLineOptions-  , stInteractionOutputCallback  :: InteractionOutputCallback-    -- ^ Callback function to call when there is a response-    --   to give to the interactive frontend.-    --   See the documentation of 'InteractionOutputCallback'.-  , stBenchmark         :: !Benchmark-    -- ^ Structure to track how much CPU time was spent on which Agda phase.-    --   Needs to be a strict field to avoid space leaks!-  , stAccumStatistics   :: !Statistics-    -- ^ Should be strict field.-  , stPersistLoadedFileCache :: !(Strict.Maybe LoadedFileCache)-    -- ^ Cached typechecking state from the last loaded file.-    --   Should be @Nothing@ when checking imports.-  , stPersistBackends   :: [Backend]-    -- ^ Current backends with their options-  }-  deriving Generic--data LoadedFileCache = LoadedFileCache-  { lfcCached  :: !CachedTypeCheckLog-  , lfcCurrent :: !CurrentTypeCheckLog-  }-  deriving Generic---- | A log of what the type checker does and states after the action is--- completed.  The cached version is stored first executed action first.-type CachedTypeCheckLog = [(TypeCheckAction, PostScopeState)]---- | Like 'CachedTypeCheckLog', but storing the log for an ongoing type--- checking of a module.  Stored in reverse order (last performed action--- first).-type CurrentTypeCheckLog = [(TypeCheckAction, PostScopeState)]---- | A complete log for a module will look like this:------   * 'Pragmas'------   * 'EnterSection', entering the main module.------   * 'Decl'/'EnterSection'/'LeaveSection', for declarations and nested---     modules------   * 'LeaveSection', leaving the main module.-data TypeCheckAction-  = EnterSection !ModuleName !A.Telescope-  | LeaveSection !ModuleName-  | Decl !A.Declaration-    -- ^ Never a Section or ScopeDecl-  | Pragmas !PragmaOptions-  deriving (Generic)---- | Empty persistent state.--initPersistentState :: PersistentTCState-initPersistentState = PersistentTCSt-  { stPersistentOptions         = defaultOptions-  , stDecodedModules            = Map.empty-  , stInteractionOutputCallback = defaultInteractionOutputCallback-  , stBenchmark                 = empty-  , stAccumStatistics           = Map.empty-  , stPersistLoadedFileCache    = empty-  , stPersistBackends           = []-  }---- | Empty state of type checker.--initPreScopeState :: PreScopeState-initPreScopeState = PreScopeState-  { stPreTokens               = mempty-  , stPreImports              = emptySignature-  , stPreImportedModules      = Set.empty-  , stPreModuleToSource       = Map.empty-  , stPreVisitedModules       = Map.empty-  , stPreScope                = emptyScopeInfo-  , stPrePatternSyns          = Map.empty-  , stPrePatternSynImports    = Map.empty-  , stPreGeneralizedVars      = mempty-  , stPrePragmaOptions        = defaultInteractionOptions-  , stPreImportedBuiltins     = Map.empty-  , stPreImportedDisplayForms = HMap.empty-  , stPreImportedInstanceDefs = Map.empty-  , stPreForeignCode          = Map.empty-  , stPreFreshInteractionId   = 0-  , stPreImportedUserWarnings = Map.empty-  , stPreLocalUserWarnings    = Map.empty-  , stPreWarningOnImport      = empty-  , stPreImportedPartialDefs  = Set.empty-  , stPreProjectConfigs       = Map.empty-  , stPreAgdaLibFiles         = Map.empty-  }--initPostScopeState :: PostScopeState-initPostScopeState = PostScopeState-  { stPostSyntaxInfo           = mempty-  , stPostDisambiguatedNames   = IntMap.empty-  , stPostMetaStore            = IntMap.empty-  , stPostInteractionPoints    = empty-  , stPostAwakeConstraints     = []-  , stPostSleepingConstraints  = []-  , stPostDirty                = False-  , stPostOccursCheckDefs      = Set.empty-  , stPostSignature            = emptySignature-  , stPostModuleCheckpoints    = Map.empty-  , stPostImportsDisplayForms  = HMap.empty-  , stPostCurrentModule        = empty-  , stPostInstanceDefs         = (Map.empty , Set.empty)-  , stPostConcreteNames        = Map.empty-  , stPostUsedNames            = Map.empty-  , stPostShadowingNames       = Map.empty-  , stPostStatistics           = Map.empty-  , stPostTCWarnings           = []-  , stPostMutualBlocks         = Map.empty-  , stPostLocalBuiltins        = Map.empty-  , stPostFreshMetaId          = 0-  , stPostFreshMutualId        = 0-  , stPostFreshProblemId       = 1-  , stPostFreshCheckpointId    = 1-  , stPostFreshInt             = 0-  , stPostFreshNameId          = NameId 0 noModuleNameHash-  , stPostAreWeCaching         = False-  , stPostPostponeInstanceSearch = False-  , stPostConsideringInstance  = False-  , stPostInstantiateBlocking  = False-  , stPostLocalPartialDefs     = Set.empty-  }--initState :: TCState-initState = TCSt-  { stPreScopeState   = initPreScopeState-  , stPostScopeState  = initPostScopeState-  , stPersistentState = initPersistentState-  }---- * st-prefixed lenses---------------------------------------------------------------------------stTokens :: Lens' HighlightingInfo TCState-stTokens f s =-  f (stPreTokens (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreTokens = x}}--stImports :: Lens' Signature TCState-stImports f s =-  f (stPreImports (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImports = x}}--stImportedModules :: Lens' (Set ModuleName) TCState-stImportedModules f s =-  f (stPreImportedModules (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedModules = x}}--stModuleToSource :: Lens' ModuleToSource TCState-stModuleToSource f s =-  f (stPreModuleToSource (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreModuleToSource = x}}--stVisitedModules :: Lens' VisitedModules TCState-stVisitedModules f s =-  f (stPreVisitedModules (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreVisitedModules = x}}--stScope :: Lens' ScopeInfo TCState-stScope f s =-  f (stPreScope (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreScope = x}}--stPatternSyns :: Lens' A.PatternSynDefns TCState-stPatternSyns f s =-  f (stPrePatternSyns (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPrePatternSyns = x}}--stPatternSynImports :: Lens' A.PatternSynDefns TCState-stPatternSynImports f s =-  f (stPrePatternSynImports (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPrePatternSynImports = x}}--stGeneralizedVars :: Lens' (Maybe (Set QName)) TCState-stGeneralizedVars f s =-  f (Strict.toLazy $ stPreGeneralizedVars (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreGeneralizedVars = Strict.toStrict x}}--stPragmaOptions :: Lens' PragmaOptions TCState-stPragmaOptions f s =-  f (stPrePragmaOptions (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPrePragmaOptions = x}}--stImportedBuiltins :: Lens' (BuiltinThings PrimFun) TCState-stImportedBuiltins f s =-  f (stPreImportedBuiltins (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedBuiltins = x}}--stForeignCode :: Lens' (Map BackendName [ForeignCode]) TCState-stForeignCode f s =-  f (stPreForeignCode (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreForeignCode = x}}--stFreshInteractionId :: Lens' InteractionId TCState-stFreshInteractionId f s =-  f (stPreFreshInteractionId (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreFreshInteractionId = x}}--stImportedUserWarnings :: Lens' (Map A.QName Text) TCState-stImportedUserWarnings f s =-  f (stPreImportedUserWarnings (stPreScopeState s)) <&>-  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedUserWarnings = x}}--stLocalUserWarnings :: Lens' (Map A.QName Text) TCState-stLocalUserWarnings f s =-  f (stPreLocalUserWarnings (stPreScopeState s)) <&>-  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreLocalUserWarnings = x}}--getUserWarnings :: ReadTCState m => m (Map A.QName Text)-getUserWarnings = do-  iuw <- useR stImportedUserWarnings-  luw <- useR stLocalUserWarnings-  return $ iuw `Map.union` luw--stWarningOnImport :: Lens' (Maybe Text) TCState-stWarningOnImport f s =-  f (Strict.toLazy $ stPreWarningOnImport (stPreScopeState s)) <&>-  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreWarningOnImport = Strict.toStrict x}}--stImportedPartialDefs :: Lens' (Set QName) TCState-stImportedPartialDefs f s =-  f (stPreImportedPartialDefs (stPreScopeState s)) <&>-  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedPartialDefs = x}}--stLocalPartialDefs :: Lens' (Set QName) TCState-stLocalPartialDefs f s =-  f (stPostLocalPartialDefs (stPostScopeState s)) <&>-  \ x -> s {stPostScopeState = (stPostScopeState s) {stPostLocalPartialDefs = x}}--getPartialDefs :: ReadTCState m => m (Set QName)-getPartialDefs = do-  ipd <- useR stImportedPartialDefs-  lpd <- useR stLocalPartialDefs-  return $ ipd `Set.union` lpd--stLoadedFileCache :: Lens' (Maybe LoadedFileCache) TCState-stLoadedFileCache f s =-  f (Strict.toLazy $ stPersistLoadedFileCache (stPersistentState s)) <&>-  \x -> s {stPersistentState = (stPersistentState s) {stPersistLoadedFileCache = Strict.toStrict x}}--stBackends :: Lens' [Backend] TCState-stBackends f s =-  f (stPersistBackends (stPersistentState s)) <&>-  \x -> s {stPersistentState = (stPersistentState s) {stPersistBackends = x}}--stProjectConfigs :: Lens' (Map FilePath ProjectConfig) TCState-stProjectConfigs f s =-  f (stPreProjectConfigs (stPreScopeState s)) <&>-  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreProjectConfigs = x}}--stAgdaLibFiles :: Lens' (Map FilePath AgdaLibFile) TCState-stAgdaLibFiles f s =-  f (stPreAgdaLibFiles (stPreScopeState s)) <&>-  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreAgdaLibFiles = x}}--stFreshNameId :: Lens' NameId TCState-stFreshNameId f s =-  f (stPostFreshNameId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshNameId = x}}--stSyntaxInfo :: Lens' HighlightingInfo TCState-stSyntaxInfo f s =-  f (stPostSyntaxInfo (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostSyntaxInfo = x}}--stDisambiguatedNames :: Lens' DisambiguatedNames TCState-stDisambiguatedNames f s =-  f (stPostDisambiguatedNames (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostDisambiguatedNames = x}}--stMetaStore :: Lens' MetaStore TCState-stMetaStore f s =-  f (stPostMetaStore (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostMetaStore = x}}--stInteractionPoints :: Lens' InteractionPoints TCState-stInteractionPoints f s =-  f (stPostInteractionPoints (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostInteractionPoints = x}}--stAwakeConstraints :: Lens' Constraints TCState-stAwakeConstraints f s =-  f (stPostAwakeConstraints (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostAwakeConstraints = x}}--stSleepingConstraints :: Lens' Constraints TCState-stSleepingConstraints f s =-  f (stPostSleepingConstraints (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostSleepingConstraints = x}}--stDirty :: Lens' Bool TCState-stDirty f s =-  f (stPostDirty (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostDirty = x}}--stOccursCheckDefs :: Lens' (Set QName) TCState-stOccursCheckDefs f s =-  f (stPostOccursCheckDefs (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostOccursCheckDefs = x}}--stSignature :: Lens' Signature TCState-stSignature f s =-  f (stPostSignature (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostSignature = x}}--stModuleCheckpoints :: Lens' (Map ModuleName CheckpointId) TCState-stModuleCheckpoints f s =-  f (stPostModuleCheckpoints (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostModuleCheckpoints = x}}--stImportsDisplayForms :: Lens' DisplayForms TCState-stImportsDisplayForms f s =-  f (stPostImportsDisplayForms (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostImportsDisplayForms = x}}--stImportedDisplayForms :: Lens' DisplayForms TCState-stImportedDisplayForms f s =-  f (stPreImportedDisplayForms (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedDisplayForms = x}}--stCurrentModule :: Lens' (Maybe ModuleName) TCState-stCurrentModule f s =-  f (Strict.toLazy $ stPostCurrentModule (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostCurrentModule = Strict.toStrict x}}--stImportedInstanceDefs :: Lens' InstanceTable TCState-stImportedInstanceDefs f s =-  f (stPreImportedInstanceDefs (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedInstanceDefs = x}}--stInstanceDefs :: Lens' TempInstanceTable TCState-stInstanceDefs f s =-  f (stPostInstanceDefs (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostInstanceDefs = x}}--stConcreteNames :: Lens' ConcreteNames TCState-stConcreteNames f s =-  f (stPostConcreteNames (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostConcreteNames = x}}--stUsedNames :: Lens' (Map RawName [RawName]) TCState-stUsedNames f s =-  f (stPostUsedNames (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostUsedNames = x}}--stShadowingNames :: Lens' (Map Name [RawName]) TCState-stShadowingNames f s =-  f (stPostShadowingNames (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostShadowingNames = x}}--stStatistics :: Lens' Statistics TCState-stStatistics f s =-  f (stPostStatistics (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostStatistics = x}}--stTCWarnings :: Lens' [TCWarning] TCState-stTCWarnings f s =-  f (stPostTCWarnings (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostTCWarnings = x}}--stMutualBlocks :: Lens' (Map MutualId MutualBlock) TCState-stMutualBlocks f s =-  f (stPostMutualBlocks (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostMutualBlocks = x}}--stLocalBuiltins :: Lens' (BuiltinThings PrimFun) TCState-stLocalBuiltins f s =-  f (stPostLocalBuiltins (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostLocalBuiltins = x}}--stFreshMetaId :: Lens' MetaId TCState-stFreshMetaId f s =-  f (stPostFreshMetaId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshMetaId = x}}--stFreshMutualId :: Lens' MutualId TCState-stFreshMutualId f s =-  f (stPostFreshMutualId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshMutualId = x}}--stFreshProblemId :: Lens' ProblemId TCState-stFreshProblemId f s =-  f (stPostFreshProblemId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshProblemId = x}}--stFreshCheckpointId :: Lens' CheckpointId TCState-stFreshCheckpointId f s =-  f (stPostFreshCheckpointId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshCheckpointId = x}}--stFreshInt :: Lens' Int TCState-stFreshInt f s =-  f (stPostFreshInt (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshInt = x}}---- use @areWeCaching@ from the Caching module instead.-stAreWeCaching :: Lens' Bool TCState-stAreWeCaching f s =-  f (stPostAreWeCaching (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostAreWeCaching = x}}--stPostponeInstanceSearch :: Lens' Bool TCState-stPostponeInstanceSearch f s =-  f (stPostPostponeInstanceSearch (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostPostponeInstanceSearch = x}}--stConsideringInstance :: Lens' Bool TCState-stConsideringInstance f s =-  f (stPostConsideringInstance (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostConsideringInstance = x}}--stInstantiateBlocking :: Lens' Bool TCState-stInstantiateBlocking f s =-  f (stPostInstantiateBlocking (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostInstantiateBlocking = x}}--stBuiltinThings :: TCState -> BuiltinThings PrimFun-stBuiltinThings s = (s^.stLocalBuiltins) `Map.union` (s^.stImportedBuiltins)----- * Fresh things---------------------------------------------------------------------------class Enum i => HasFresh i where-    freshLens :: Lens' i TCState-    nextFresh' :: i -> i-    nextFresh' = succ--nextFresh :: HasFresh i => TCState -> (i, TCState)-nextFresh s =-  let !c = s^.freshLens-  in (c, set freshLens (nextFresh' c) s)--class Monad m => MonadFresh i m where-  fresh :: m i--  default fresh :: (MonadTrans t, MonadFresh i n, t n ~ m) => m i-  fresh = lift fresh--instance MonadFresh i m => MonadFresh i (ReaderT r m)-instance MonadFresh i m => MonadFresh i (StateT s m)-instance MonadFresh i m => MonadFresh i (ListT m)-instance MonadFresh i m => MonadFresh i (IdentityT m)--instance HasFresh i => MonadFresh i TCM where-  fresh = do-        !s <- getTC-        let (!c , !s') = nextFresh s-        putTC s'-        return c--instance HasFresh MetaId where-  freshLens = stFreshMetaId--instance HasFresh MutualId where-  freshLens = stFreshMutualId--instance HasFresh InteractionId where-  freshLens = stFreshInteractionId--instance HasFresh NameId where-  freshLens = stFreshNameId-  -- nextFresh increments the current fresh name by 2 so @NameId@s used-  -- before caching starts do not overlap with the ones used after.-  nextFresh' = succ . succ--instance HasFresh Int where-  freshLens = stFreshInt--instance HasFresh ProblemId where-  freshLens = stFreshProblemId--newtype CheckpointId = CheckpointId Int-  deriving (Data, Eq, Ord, Enum, Real, Integral, Num, NFData)--instance Show CheckpointId where-  show (CheckpointId n) = show n--instance Pretty CheckpointId where-  pretty (CheckpointId n) = pretty n--instance HasFresh CheckpointId where-  freshLens = stFreshCheckpointId--freshName :: MonadFresh NameId m => Range -> String -> m Name-freshName r s = do-  i <- fresh-  return $ mkName r i s--freshNoName :: MonadFresh NameId m => Range -> m Name-freshNoName r =-    do  i <- fresh-        return $ makeName i (C.NoName noRange i) r noFixity' False--freshNoName_ :: MonadFresh NameId m => m Name-freshNoName_ = freshNoName noRange--freshRecordName :: MonadFresh NameId m => m Name-freshRecordName = do-  i <- fresh-  return $ makeName i (C.setNotInScope $ C.simpleName "r") noRange noFixity' True---- | Create a fresh name from @a@.-class FreshName a where-  freshName_ :: MonadFresh NameId m => a -> m Name--instance FreshName (Range, String) where-  freshName_ = uncurry freshName--instance FreshName String where-  freshName_ = freshName noRange--instance FreshName Range where-  freshName_ = freshNoName--instance FreshName () where-  freshName_ () = freshNoName_-------------------------------------------------------------------------------- ** Managing file names-------------------------------------------------------------------------------- | Maps top-level module names to the corresponding source file--- names.--type ModuleToSource = Map TopLevelModuleName AbsolutePath---- | Maps source file names to the corresponding top-level module--- names.--type SourceToModule = Map AbsolutePath TopLevelModuleName---- | Creates a 'SourceToModule' map based on 'stModuleToSource'.------   O(n log n).------   For a single reverse lookup in 'stModuleToSource',---   rather use 'lookupModuleFromSourse'.--sourceToModule :: TCM SourceToModule-sourceToModule =-  Map.fromListWith __IMPOSSIBLE__-     .  List.map (\(m, f) -> (f, m))-     .  Map.toList-    <$> useTC stModuleToSource---- | Lookup an 'AbsolutePath' in 'sourceToModule'.------   O(n).--lookupModuleFromSource :: ReadTCState m => AbsolutePath -> m (Maybe TopLevelModuleName)-lookupModuleFromSource f =-  fmap fst . List.find ((f ==) . snd) . Map.toList <$> useR stModuleToSource--------------------------------------------------------------------------------- ** Associating concrete names to an abstract name-------------------------------------------------------------------------------- | A monad that has read and write access to the stConcreteNames---   part of the TCState. Basically, this is a synonym for `MonadState---   ConcreteNames m` (which cannot be used directly because of the---   limitations of Haskell's typeclass system).-class Monad m => MonadStConcreteNames m where-  runStConcreteNames :: StateT ConcreteNames m a -> m a--  useConcreteNames :: m ConcreteNames-  useConcreteNames = runStConcreteNames get--  modifyConcreteNames :: (ConcreteNames -> ConcreteNames) -> m ()-  modifyConcreteNames = runStConcreteNames . modify--instance MonadStConcreteNames TCM where-  runStConcreteNames m = stateTCLensM stConcreteNames $ runStateT m--instance MonadStConcreteNames m => MonadStConcreteNames (IdentityT m) where-  runStConcreteNames m = IdentityT $ runStConcreteNames $ StateT $ runIdentityT . runStateT m--instance MonadStConcreteNames m => MonadStConcreteNames (ReaderT r m) where-  runStConcreteNames m = ReaderT $ runStConcreteNames . StateT . flip (runReaderT . runStateT m)--instance MonadStConcreteNames m => MonadStConcreteNames (StateT s m) where-  runStConcreteNames m = StateT $ \s -> runStConcreteNames $ StateT $ \ns -> do-    ((x,ns'),s') <- runStateT (runStateT m ns) s-    return ((x,s'),ns')-------------------------------------------------------------------------------- ** Interface--------------------------------------------------------------------------------- | Distinguishes between type-checked and scope-checked interfaces---   when stored in the map of `VisitedModules`.-data ModuleCheckMode-  = ModuleScopeChecked-  | ModuleTypeChecked-  deriving (Eq, Ord, Bounded, Enum, Show, Generic)---data ModuleInfo = ModuleInfo-  { miInterface  :: Interface-  , miWarnings   :: [TCWarning]-    -- ^ Warnings were encountered when the module was type checked.-    --   These might include warnings not stored in the interface itself,-    --   specifically unsolved interaction metas.-    --   See "Agda.Interaction.Imports"-  , miPrimitive  :: Bool-    -- ^ 'True' if the module is a primitive module, which should always-    -- be importable.-  , miMode       :: ModuleCheckMode-    -- ^ The `ModuleCheckMode` used to create the `Interface`-  }-  deriving Generic---- Note that the use of 'C.TopLevelModuleName' here is a potential--- performance problem, because these names do not contain unique--- identifiers.--type VisitedModules = Map C.TopLevelModuleName ModuleInfo-type DecodedModules = Map C.TopLevelModuleName ModuleInfo--data ForeignCode = ForeignCode Range String-  deriving (Show, Generic)--data Interface = Interface-  { iSourceHash      :: Hash-    -- ^ Hash of the source code.-  , iSource          :: TL.Text-    -- ^ The source code. The source code is stored so that the HTML-    -- and LaTeX backends can generate their output without having to-    -- re-read the (possibly out of date) source code.-  , iFileType        :: FileType-    -- ^ Source file type, determined from the file extension-  , iImportedModules :: [(ModuleName, Hash)]-    -- ^ Imported modules and their hashes.-  , iModuleName      :: ModuleName-    -- ^ Module name of this interface.-  , iScope           :: Map ModuleName Scope-    -- ^ Scope defined by this module.-    ---    --   Andreas, AIM XX: Too avoid duplicate serialization, this field is-    --   not serialized, so if you deserialize an interface, @iScope@-    --   will be empty.-    --   But 'constructIScope' constructs 'iScope' from 'iInsideScope'.-  , iInsideScope     :: ScopeInfo-    -- ^ Scope after we loaded this interface.-    --   Used in 'Agda.Interaction.BasicOps.AtTopLevel'-    --   and     'Agda.Interaction.CommandLine.interactionLoop'.-  , iSignature       :: Signature-  , iDisplayForms    :: DisplayForms-    -- ^ Display forms added for imported identifiers.-  , iUserWarnings    :: Map A.QName Text-    -- ^ User warnings for imported identifiers-  , iImportWarning   :: Maybe Text-    -- ^ Whether this module should raise a warning when imported-  , iBuiltin         :: BuiltinThings (String, QName)-  , iForeignCode     :: Map BackendName [ForeignCode]-  , iHighlighting    :: HighlightingInfo-  , iDefaultPragmaOptions :: [OptionsPragma]-    -- ^ Pragma options set in library files.-  , iFilePragmaOptions    :: [OptionsPragma]-    -- ^ Pragma options set in the file.-  , iOptionsUsed     :: PragmaOptions-    -- ^ Options/features used when checking the file (can be different-    --   from options set directly in the file).-  , iPatternSyns     :: A.PatternSynDefns-  , iWarnings        :: [TCWarning]-  , iPartialDefs     :: Set QName-  }-  deriving (Show, Generic)--instance Pretty Interface where-  pretty (Interface-            sourceH source fileT importedM moduleN scope insideS signature-            display userwarn importwarn builtin foreignCode highlighting-            libPragmaO filePragmaO-            oUsed patternS warnings partialdefs) =--    hang "Interface" 2 $ vcat-      [ "source hash:"         <+> (pretty . show) sourceH-      , "source:"              $$  nest 2 (text $ TL.unpack source)-      , "file type:"           <+> (pretty . show) fileT-      , "imported modules:"    <+> (pretty . show) importedM-      , "module name:"         <+> pretty moduleN-      , "scope:"               <+> (pretty . show) scope-      , "inside scope:"        <+> (pretty . show) insideS-      , "signature:"           <+> (pretty . show) signature-      , "display:"             <+> (pretty . show) display-      , "user warnings:"       <+> (pretty . show) userwarn-      , "import warning:"      <+> (pretty . show) importwarn-      , "builtin:"             <+> (pretty . show) builtin-      , "Foreign code:"        <+> (pretty . show) foreignCode-      , "highlighting:"        <+> (pretty . show) highlighting-      , "library pragma options:" <+> (pretty . show) libPragmaO-      , "file pragma options:" <+> (pretty . show) filePragmaO-      , "options used:"        <+> (pretty . show) oUsed-      , "pattern syns:"        <+> (pretty . show) patternS-      , "warnings:"            <+> (pretty . show) warnings-      , "partial definitions:" <+> (pretty . show) partialdefs-      ]---- | Combines the source hash and the (full) hashes of the imported modules.-iFullHash :: Interface -> Hash-iFullHash i = combineHashes $ iSourceHash i : List.map snd (iImportedModules i)---- | A lens for the 'iSignature' field of the 'Interface' type.--intSignature :: Lens' Signature Interface-intSignature f i = f (iSignature i) <&> \s -> i { iSignature = s }-------------------------------------------------------------------------------- ** Closure------------------------------------------------------------------------------data Closure a = Closure-  { clSignature        :: Signature-  , clEnv              :: TCEnv-  , clScope            :: ScopeInfo-  , clModuleCheckpoints :: Map ModuleName CheckpointId-  , clValue            :: a-  }-    deriving (Functor, Foldable, Generic)--instance Show a => Show (Closure a) where-  show cl = "Closure { clValue = " ++ show (clValue cl) ++ " }"--instance HasRange a => HasRange (Closure a) where-  getRange = getRange . clValue--class LensClosure a b | b -> a where-  lensClosure :: Lens' (Closure a) b--instance LensClosure a (Closure a) where-  lensClosure = id--instance LensTCEnv (Closure a) where-  lensTCEnv f cl = (f $! clEnv cl) <&> \ env -> cl { clEnv = env }--buildClosure :: (MonadTCEnv m, ReadTCState m) => a -> m (Closure a)-buildClosure x = do-    env   <- askTC-    sig   <- useR stSignature-    scope <- useR stScope-    cps   <- useR stModuleCheckpoints-    return $ Closure sig env scope cps x-------------------------------------------------------------------------------- ** Constraints------------------------------------------------------------------------------type Constraints = [ProblemConstraint]--data ProblemConstraint = PConstr-  { constraintProblems  :: Set ProblemId-  , constraintUnblocker :: Blocker-  , theConstraint       :: Closure Constraint-  }-  deriving (Show, Generic)--instance HasRange ProblemConstraint where-  getRange = getRange . theConstraint--data Constraint-  = ValueCmp Comparison CompareAs Term Term-  | ValueCmpOnFace Comparison Term Type Term Term-  | ElimCmp [Polarity] [IsForced] Type Term [Elim] [Elim]-  | SortCmp Comparison Sort Sort-  | LevelCmp Comparison Level Level---  | ShortCut MetaId Term Type---    -- ^ A delayed instantiation.  Replaces @ValueCmp@ in 'postponeTypeCheckingProblem'.-  | HasBiggerSort Sort-  | HasPTSRule (Dom Type) (Abs Sort)-  | CheckMetaInst MetaId-  | CheckType Type-  | UnBlock MetaId-    -- ^ Meta created for a term blocked by a postponed type checking problem or unsolved-    --   constraints. The 'MetaInstantiation' for the meta (when unsolved) is either 'BlockedConst'-    --   or 'PostponedTypeCheckingProblem'.-  | IsEmpty Range Type-    -- ^ The range is the one of the absurd pattern.-  | CheckSizeLtSat Term-    -- ^ Check that the 'Term' is either not a SIZELT or a non-empty SIZELT.-  | FindInstance MetaId (Maybe [Candidate])-    -- ^ the first argument is the instance argument and the second one is the list of candidates-    --   (or Nothing if we haven’t determined the list of candidates yet)-  | CheckFunDef Delayed A.DefInfo QName [A.Clause] TCErr-    -- ^ Last argument is the error causing us to postpone.-  | UnquoteTactic Term Term Type   -- ^ First argument is computation and the others are hole and goal type-  | CheckLockedVars Term Type (Arg Term) Type     -- ^ @CheckLockedVars t ty lk lk_ty@ with @t : ty@, @lk : lk_ty@ and @t lk@ well-typed.-  | UsableAtModality Modality Term   -- ^ is the term usable at the given modality?-  deriving (Show, Generic)--instance HasRange Constraint where-  getRange (IsEmpty r t) = r-  getRange _ = noRange-{- no Range instances for Term, Type, Elm, Tele, Sort, Level, MetaId-  getRange (ValueCmp cmp a u v) = getRange (a,u,v)-  getRange (ElimCmp pol a v es es') = getRange (a,v,es,es')-  getRange (TelCmp a b cmp tel tel') = getRange (a,b,tel,tel')-  getRange (SortCmp cmp s s') = getRange (s,s')-  getRange (LevelCmp cmp l l') = getRange (l,l')-  getRange (UnBlock x) = getRange x-  getRange (FindInstance x cands) = getRange x--}--instance Free Constraint where-  freeVars' c =-    case c of-      ValueCmp _ t u v      -> freeVars' (t, (u, v))-      ValueCmpOnFace _ p t u v -> freeVars' (p, (t, (u, v)))-      ElimCmp _ _ t u es es'  -> freeVars' ((t, u), (es, es'))-      SortCmp _ s s'        -> freeVars' (s, s')-      LevelCmp _ l l'       -> freeVars' (l, l')-      UnBlock _             -> mempty-      IsEmpty _ t           -> freeVars' t-      CheckSizeLtSat u      -> freeVars' u-      FindInstance _ cs     -> freeVars' cs-      CheckFunDef{}         -> mempty-      HasBiggerSort s       -> freeVars' s-      HasPTSRule a s        -> freeVars' (a , s)-      CheckLockedVars a b c d -> freeVars' ((a,b),(c,d))-      UnquoteTactic t h g   -> freeVars' (t, (h, g))-      CheckMetaInst m       -> mempty-      CheckType t           -> freeVars' t-      UsableAtModality mod t -> freeVars' t--instance TermLike Constraint where-  foldTerm f = \case-      ValueCmp _ t u v       -> foldTerm f (t, u, v)-      ValueCmpOnFace _ p t u v -> foldTerm f (p, t, u, v)-      ElimCmp _ _ t u es es' -> foldTerm f (t, u, es, es')-      LevelCmp _ l l'        -> foldTerm f (Level l, Level l')  -- Note wrapping as term, to ensure f gets to act on l and l'-      IsEmpty _ t            -> foldTerm f t-      CheckSizeLtSat u       -> foldTerm f u-      UnquoteTactic t h g    -> foldTerm f (t, h, g)-      SortCmp _ s1 s2        -> foldTerm f (Sort s1, Sort s2)   -- Same as LevelCmp case-      UnBlock _              -> mempty-      CheckLockedVars a b c d -> foldTerm f (a, b, c, d)-      FindInstance _ _       -> mempty-      CheckFunDef{}          -> mempty-      HasBiggerSort s        -> foldTerm f s-      HasPTSRule a s         -> foldTerm f (a, Sort <$> s)-      CheckMetaInst m        -> mempty-      CheckType t            -> foldTerm f t-      UsableAtModality m t   -> foldTerm f t--  traverseTermM f c = __IMPOSSIBLE__ -- Not yet implemented--instance AllMetas Constraint--data Comparison = CmpEq | CmpLeq-  deriving (Eq, Data, Show, Generic)--instance Pretty Comparison where-  pretty CmpEq  = "="-  pretty CmpLeq = "=<"---- | An extension of 'Comparison' to @>=@.-data CompareDirection = DirEq | DirLeq | DirGeq-  deriving (Eq, Show)--instance Pretty CompareDirection where-  pretty = text . \case-    DirEq  -> "="-    DirLeq -> "=<"-    DirGeq -> ">="---- | Embed 'Comparison' into 'CompareDirection'.-fromCmp :: Comparison -> CompareDirection-fromCmp CmpEq  = DirEq-fromCmp CmpLeq = DirLeq---- | Flip the direction of comparison.-flipCmp :: CompareDirection -> CompareDirection-flipCmp DirEq  = DirEq-flipCmp DirLeq = DirGeq-flipCmp DirGeq = DirLeq---- | Turn a 'Comparison' function into a 'CompareDirection' function.------   Property: @dirToCmp f (fromCmp cmp) = f cmp@-dirToCmp :: (Comparison -> a -> a -> c) -> CompareDirection -> a -> a -> c-dirToCmp cont DirEq  = cont CmpEq-dirToCmp cont DirLeq = cont CmpLeq-dirToCmp cont DirGeq = flip $ cont CmpLeq---- | We can either compare two terms at a given type, or compare two---   types without knowing (or caring about) their sorts.-data CompareAs-  = AsTermsOf Type -- ^ @Type@ should not be @Size@.-                   --   But currently, we do not rely on this invariant.-  | AsSizes        -- ^ Replaces @AsTermsOf Size@.-  | AsTypes-  deriving (Data, Show, Generic)--instance Free CompareAs where-  freeVars' (AsTermsOf a) = freeVars' a-  freeVars' AsSizes       = mempty-  freeVars' AsTypes       = mempty--instance TermLike CompareAs where-  foldTerm f (AsTermsOf a) = foldTerm f a-  foldTerm f AsSizes       = mempty-  foldTerm f AsTypes       = mempty--  traverseTermM f = \case-    AsTermsOf a -> AsTermsOf <$> traverseTermM f a-    AsSizes     -> return AsSizes-    AsTypes     -> return AsTypes--instance AllMetas CompareAs-------------------------------------------------------------------------------- * Open things-------------------------------------------------------------------------------- | A thing tagged with the context it came from. Also keeps the substitution from previous---   checkpoints. This lets us handle the case when an open thing was created in a context that we---   have since exited. Remember which module it's from to make sure we don't get confused by---   checkpoints from other files.-data Open a = OpenThing { openThingCheckpoint    :: CheckpointId-                        , openThingCheckpointMap :: Map CheckpointId Substitution-                        , openThingModule        :: ModuleNameHash-                        , openThing              :: a }-    deriving (Show, Functor, Foldable, Traversable, Generic)--instance Decoration Open where-  traverseF f (OpenThing cp env m x) = OpenThing cp env m <$> f x--instance Pretty a => Pretty (Open a) where-  prettyPrec p (OpenThing cp env _ x) = mparens (p > 9) $-    "OpenThing" <+> pretty cp <+> pretty (Map.toList env) <?> prettyPrec 10 x-------------------------------------------------------------------------------- * Judgements------ Used exclusively for typing of meta variables.-------------------------------------------------------------------------------- | Parametrized since it is used without MetaId when creating a new meta.-data Judgement a-  = HasType-    { jMetaId     :: a-    , jComparison :: Comparison -- ^ are we checking (@CmpLeq@) or inferring (@CmpEq@) the type?-    , jMetaType   :: Type-    }-  | IsSort-    { jMetaId   :: a-    , jMetaType :: Type -- Andreas, 2011-04-26: type needed for higher-order sort metas-    }-  deriving Generic--instance Pretty a => Pretty (Judgement a) where-    pretty (HasType a cmp t) = hsep [ pretty a, ":"    , pretty t ]-    pretty (IsSort  a t)     = hsep [ pretty a, ":sort", pretty t ]---------------------------------------------------------------------------------- ** Generalizable variables--------------------------------------------------------------------------------data DoGeneralize-  = YesGeneralizeVar  -- ^ Generalize because it is a generalizable variable.-  | YesGeneralizeMeta -- ^ Generalize because it is a metavariable and-                      --   we're currently checking the type of a generalizable variable-                      --   (this should get the default modality).-  | NoGeneralize      -- ^ Don't generalize.-  deriving (Eq, Ord, Show, Data, Generic)---- | The value of a generalizable variable. This is created to be a---   generalizable meta before checking the type to be generalized.-data GeneralizedValue = GeneralizedValue-  { genvalCheckpoint :: CheckpointId-  , genvalTerm       :: Term-  , genvalType       :: Type-  } deriving (Show, Data, Generic)-------------------------------------------------------------------------------- ** Meta variables------------------------------------------------------------------------------data MetaVariable =-        MetaVar { mvInfo          :: MetaInfo-                , mvPriority      :: MetaPriority -- ^ some metavariables are more eager to be instantiated-                , mvPermutation   :: Permutation-                  -- ^ a metavariable doesn't have to depend on all variables-                  --   in the context, this "permutation" will throw away the-                  --   ones it does not depend on-                , mvJudgement     :: Judgement MetaId-                , mvInstantiation :: MetaInstantiation-                , mvListeners     :: Set Listener -- ^ meta variables scheduled for eta-expansion but blocked by this one-                , mvFrozen        :: Frozen -- ^ are we past the point where we can instantiate this meta variable?-                , mvTwin          :: Maybe MetaId-                  -- ^ @Just m@ means that this meta-variable will be-                  -- equated to @m@ when the latter is unblocked. See-                  -- 'Agda.TypeChecking.MetaVars.blockTermOnProblem'.-                }-  deriving Generic--data Listener = EtaExpand MetaId-              | CheckConstraint Nat ProblemConstraint-  deriving Generic--instance Eq Listener where-  EtaExpand       x   == EtaExpand       y   = x == y-  CheckConstraint x _ == CheckConstraint y _ = x == y-  _ == _ = False--instance Ord Listener where-  EtaExpand       x   `compare` EtaExpand       y   = x `compare` y-  CheckConstraint x _ `compare` CheckConstraint y _ = x `compare` y-  EtaExpand{} `compare` CheckConstraint{} = LT-  CheckConstraint{} `compare` EtaExpand{} = GT---- | Frozen meta variable cannot be instantiated by unification.---   This serves to prevent the completion of a definition by its use---   outside of the current block.---   (See issues 118, 288, 399).-data Frozen-  = Frozen        -- ^ Do not instantiate.-  | Instantiable-    deriving (Eq, Show, Generic)--data MetaInstantiation-        = InstV [Arg String] Term -- ^ solved by term (abstracted over some free variables)-        | Open               -- ^ unsolved-        | OpenInstance       -- ^ open, to be instantiated by instance search-        | BlockedConst Term  -- ^ solution blocked by unsolved constraints-        | PostponedTypeCheckingProblem (Closure TypeCheckingProblem)-  deriving Generic---- | Solving a 'CheckArgs' constraint may or may not check the target type. If---   it did, it returns a handle to any unsolved constraints.-data CheckedTarget = CheckedTarget (Maybe ProblemId)-                   | NotCheckedTarget--data PrincipalArgTypeMetas = PrincipalArgTypeMetas-  { patmMetas     :: Args -- ^ metas created for hidden and instance arguments-                          --   in the principal argument's type-  , patmRemainder :: Type -- ^ principal argument's type, stripped of hidden and-                          --   instance arguments-  }-  deriving Generic--data TypeCheckingProblem-  = CheckExpr Comparison A.Expr Type-  | CheckArgs Comparison ExpandHidden Range [NamedArg A.Expr] Type Type (ArgsCheckState CheckedTarget -> TCM Term)-  | CheckProjAppToKnownPrincipalArg Comparison A.Expr ProjOrigin (List1 QName) A.Args Type Int Term Type PrincipalArgTypeMetas-  | CheckLambda Comparison (Arg (List1 (WithHiding Name), Maybe Type)) A.Expr Type-    -- ^ @(λ (xs : t₀) → e) : t@-    --   This is not an instance of 'CheckExpr' as the domain type-    --   has already been checked.-    --   For example, when checking-    --     @(λ (x y : Fin _) → e) : (x : Fin n) → ?@-    --   we want to postpone @(λ (y : Fin n) → e) : ?@ where @Fin n@-    --   is a 'Type' rather than an 'A.Expr'.-  | DoQuoteTerm Comparison Term Type -- ^ Quote the given term and check type against `Term`-  deriving Generic--instance Show MetaInstantiation where-  show (InstV tel t) = "InstV " ++ show tel ++ " (" ++ show t ++ ")"-  show Open      = "Open"-  show OpenInstance = "OpenInstance"-  show (BlockedConst t) = "BlockedConst (" ++ show t ++ ")"-  show (PostponedTypeCheckingProblem{}) = "PostponedTypeCheckingProblem (...)"---- | Meta variable priority:---   When we have an equation between meta-variables, which one---   should be instantiated?------   Higher value means higher priority to be instantiated.-newtype MetaPriority = MetaPriority Int-    deriving (Eq, Ord, Show, NFData)--data RunMetaOccursCheck-  = RunMetaOccursCheck-  | DontRunMetaOccursCheck-  deriving (Eq, Ord, Show, Generic)---- | @MetaInfo@ is cloned from one meta to the next during pruning.-data MetaInfo = MetaInfo-  { miClosRange       :: Closure Range -- TODO: Not so nice. But we want both to have the environment of the meta (Closure) and its range.-  , miModality        :: Modality           -- ^ Instantiable with irrelevant/erased solution?-  , miMetaOccursCheck :: RunMetaOccursCheck -- ^ Run the extended occurs check that goes in definitions?-  , miNameSuggestion  :: MetaNameSuggestion-    -- ^ Used for printing.-    --   @Just x@ if meta-variable comes from omitted argument with name @x@.-  , miGeneralizable   :: Arg DoGeneralize-    -- ^ Should this meta be generalized if unsolved? If so, at what ArgInfo?-  }-  deriving Generic--instance LensModality MetaInfo where-  getModality = miModality-  setModality mod mi = mi { miModality = mod }-  mapModality f mi = mi { miModality = f $ miModality mi }--instance LensQuantity MetaInfo where-  getQuantity   = getQuantity . getModality-  mapQuantity f = mapModality (mapQuantity f)---- | Name suggestion for meta variable.  Empty string means no suggestion.-type MetaNameSuggestion = String---- | For printing, we couple a meta with its name suggestion.-data NamedMeta = NamedMeta-  { nmSuggestion :: MetaNameSuggestion-  , nmid         :: MetaId-  }--instance Pretty NamedMeta where-  pretty (NamedMeta "" x) = pretty x-  pretty (NamedMeta "_" x) = pretty x-  pretty (NamedMeta s  x) = text $ "_" ++ s ++ prettyShow x--type MetaStore = IntMap MetaVariable--instance HasRange MetaInfo where-  getRange = clValue . miClosRange--instance HasRange MetaVariable where-    getRange m = getRange $ getMetaInfo m--instance SetRange MetaInfo where-  setRange r m = m { miClosRange = (miClosRange m) { clValue = r }}--instance SetRange MetaVariable where-  setRange r m = m { mvInfo = setRange r (mvInfo m) }--instance LensModality MetaVariable where-  getModality = getModality . mvInfo-  setModality mod mv = mv { mvInfo = setModality mod $ mvInfo mv }-  mapModality f mv = mv { mvInfo = mapModality f $ mvInfo mv }--instance LensQuantity MetaVariable where-  getQuantity   = getQuantity . getModality-  mapQuantity f = mapModality (mapQuantity f)--normalMetaPriority :: MetaPriority-normalMetaPriority = MetaPriority 0--lowMetaPriority :: MetaPriority-lowMetaPriority = MetaPriority (-10)--highMetaPriority :: MetaPriority-highMetaPriority = MetaPriority 10--getMetaInfo :: MetaVariable -> Closure Range-getMetaInfo = miClosRange . mvInfo--getMetaScope :: MetaVariable -> ScopeInfo-getMetaScope m = clScope $ getMetaInfo m--getMetaEnv :: MetaVariable -> TCEnv-getMetaEnv m = clEnv $ getMetaInfo m--getMetaSig :: MetaVariable -> Signature-getMetaSig m = clSignature $ getMetaInfo m--getMetaRelevance :: MetaVariable -> Relevance-getMetaRelevance = getRelevance . getModality--getMetaModality :: MetaVariable -> Modality-getMetaModality = getModality---- Lenses--metaFrozen :: Lens' Frozen MetaVariable-metaFrozen f mv = f (mvFrozen mv) <&> \ x -> mv { mvFrozen = x }--_mvInfo :: Lens' MetaInfo MetaVariable-_mvInfo f mv = (f $! mvInfo mv) <&> \ mi -> mv { mvInfo = mi }---- Lenses onto Closure Range--instance LensClosure Range MetaInfo where-  lensClosure f mi = (f $! miClosRange mi) <&> \ cl -> mi { miClosRange = cl }--instance LensClosure Range MetaVariable where-  lensClosure = _mvInfo . lensClosure---- Lenses onto IsAbstract--instance LensIsAbstract TCEnv where-  lensIsAbstract f env =-     -- Andreas, 2019-08-19-     -- Using $! to prevent space leaks like #1829.-     -- This can crash when trying to get IsAbstract from IgnoreAbstractMode.-    (f $! fromMaybe __IMPOSSIBLE__ (aModeToDef $ envAbstractMode env))-    <&> \ a -> env { envAbstractMode = aDefToMode a }--instance LensIsAbstract (Closure a) where-  lensIsAbstract = lensTCEnv . lensIsAbstract--instance LensIsAbstract MetaInfo where-  lensIsAbstract = lensClosure . lensIsAbstract-------------------------------------------------------------------------------- ** Interaction meta variables-------------------------------------------------------------------------------- | Interaction points are created by the scope checker who sets the range.---   The meta variable is created by the type checker and then hooked up to the---   interaction point.-data InteractionPoint = InteractionPoint-  { ipRange :: Range        -- ^ The position of the interaction point.-  , ipMeta  :: Maybe MetaId -- ^ The meta variable, if any, holding the type etc.-  , ipSolved:: Bool         -- ^ Has this interaction point already been solved?-  , ipClause:: IPClause-      -- ^ The clause of the interaction point (if any).-      --   Used for case splitting.-  }-  deriving Generic--instance Eq InteractionPoint where (==) = (==) `on` ipMeta--instance HasTag InteractionPoint where-  type Tag InteractionPoint = MetaId-  tag = ipMeta---- | Data structure managing the interaction points.------   We never remove interaction points from this map, only set their---   'ipSolved' to @True@.  (Issue #2368)-type InteractionPoints = BiMap InteractionId InteractionPoint---- | Flag to indicate whether the meta is overapplied in the---   constraint.  A meta is overapplied if it has more arguments than---   the size of the telescope in its creation environment---   (as stored in MetaInfo).-data Overapplied = Overapplied | NotOverapplied-  deriving (Eq, Show, Data, Generic)---- | Datatype representing a single boundary condition:---   x_0 = u_0, ... ,x_n = u_n ⊢ t = ?n es-data IPBoundary' t = IPBoundary-  { ipbEquations :: [(t,t)] -- ^ [x_0 = u_0, ... ,x_n = u_n]-  , ipbValue     :: t          -- ^ @t@-  , ipbMetaApp   :: t          -- ^ @?n es@-  , ipbOverapplied :: Overapplied -- ^ Is @?n@ overapplied in @?n es@ ?-  }-  deriving (Show, Data, Functor, Foldable, Traversable, Generic)--type IPBoundary = IPBoundary' Term---- | Which clause is an interaction point located in?-data IPClause = IPClause-  { ipcQName    :: QName              -- ^ The name of the function.-  , ipcClauseNo :: Int                -- ^ The number of the clause of this function.-  , ipcType     :: Type               -- ^ The type of the function-  , ipcWithSub  :: Maybe Substitution -- ^ Module parameter substitution-  , ipcClause   :: A.SpineClause      -- ^ The original AST clause.-  , ipcClosure  :: Closure ()         -- ^ Environment for rechecking the clause.-  , ipcBoundary :: [Closure IPBoundary] -- ^ The boundary imposed by the LHS.-  }-  | IPNoClause -- ^ The interaction point is not in the rhs of a clause.-  deriving (Generic)--instance Eq IPClause where-  IPNoClause           == IPNoClause             = True-  IPClause x i _ _ _ _ _ == IPClause x' i' _ _ _ _ _ = x == x' && i == i'-  _                    == _                      = False-------------------------------------------------------------------------------- ** Signature------------------------------------------------------------------------------data Signature = Sig-      { _sigSections    :: Sections-      , _sigDefinitions :: Definitions-      , _sigRewriteRules:: RewriteRuleMap  -- ^ The rewrite rules defined in this file.-      }-  deriving (Show, Generic)--sigSections :: Lens' Sections Signature-sigSections f s =-  f (_sigSections s) <&>-  \x -> s {_sigSections = x}--sigDefinitions :: Lens' Definitions Signature-sigDefinitions f s =-  f (_sigDefinitions s) <&>-  \x -> s {_sigDefinitions = x}--sigRewriteRules :: Lens' RewriteRuleMap Signature-sigRewriteRules f s =-  f (_sigRewriteRules s) <&>-  \x -> s {_sigRewriteRules = x}--type Sections    = Map ModuleName Section-type Definitions = HashMap QName Definition-type RewriteRuleMap = HashMap QName RewriteRules-type DisplayForms = HashMap QName [LocalDisplayForm]--newtype Section = Section { _secTelescope :: Telescope }-  deriving (Data, Show, NFData)--instance Pretty Section where-  pretty = pretty . _secTelescope--secTelescope :: Lens' Telescope Section-secTelescope f s =-  f (_secTelescope s) <&>-  \x -> s {_secTelescope = x}--emptySignature :: Signature-emptySignature = Sig Map.empty HMap.empty HMap.empty---- | A @DisplayForm@ is in essence a rewrite rule @q ts --> dt@ for a defined symbol (could be a---   constructor as well) @q@. The right hand side is a 'DisplayTerm' which is used to 'reify' to a---   more readable 'Abstract.Syntax'.------   The patterns @ts@ are just terms, but the first @dfPatternVars@ variables are pattern variables---   that matches any term.-data DisplayForm = Display-  { dfPatternVars :: Nat-    -- ^ Number @n@ of pattern variables in 'dfPats'.-  , dfPats :: Elims-    -- ^ Left hand side patterns, the @n@ first free variables are pattern variables,-    --   any variables above @n@ are fixed and only match that particular variable. This-    --   happens when you have display forms inside parameterised modules that match on the module-    --   parameters. The 'ArgInfo' is ignored in these patterns.-  , dfRHS :: DisplayTerm-    -- ^ Right hand side.-  }-  deriving (Data, Show, Generic)--type LocalDisplayForm = Open DisplayForm---- | A structured presentation of a 'Term' for reification into---   'Abstract.Syntax'.-data DisplayTerm-  = DWithApp DisplayTerm [DisplayTerm] Elims-    -- ^ @(f vs | ws) es@.-    --   The first 'DisplayTerm' is the parent function @f@ with its args @vs@.-    --   The list of 'DisplayTerm's are the with expressions @ws@.-    --   The 'Elims' are additional arguments @es@-    --   (possible in case the with-application is of function type)-    --   or projections (if it is of record type).-  | DCon ConHead ConInfo [Arg DisplayTerm]-    -- ^ @c vs@.-  | DDef QName [Elim' DisplayTerm]-    -- ^ @d vs@.-  | DDot Term-    -- ^ @.v@.-  | DTerm Term-    -- ^ @v@.-  deriving (Data, Show, Generic)--instance Free DisplayForm where-  freeVars' (Display n ps t) = underBinder (freeVars' ps) `mappend` underBinder' n (freeVars' t)--instance Free DisplayTerm where-  freeVars' (DWithApp t ws es) = freeVars' (t, (ws, es))-  freeVars' (DCon _ _ vs)      = freeVars' vs-  freeVars' (DDef _ es)        = freeVars' es-  freeVars' (DDot v)           = freeVars' v-  freeVars' (DTerm v)          = freeVars' v--instance Pretty DisplayTerm where-  prettyPrec p v =-    case v of-      DTerm v          -> prettyPrec p v-      DDot v           -> "." <> prettyPrec 10 v-      DDef f es        -> pretty f `pApp` es-      DCon c _ vs      -> pretty (conName c) `pApp` map Apply vs-      DWithApp h ws es ->-        mparens (p > 0)-          (sep [ pretty h-              , nest 2 $ fsep [ "|" <+> pretty w | w <- ws ] ])-        `pApp` es-    where-      pApp :: Pretty el => Doc -> [el] -> Doc-      pApp d els = mparens (not (null els) && p > 9) $-                   sep [d, nest 2 $ fsep (map (prettyPrec 10) els)]--instance Pretty DisplayForm where-  prettyPrec p (Display fv lhs rhs) = mparens (p > 9) $-    "Display" <?> fsep [ pshow fv, prettyPrec 10 lhs, prettyPrec 10 rhs ]---- | By default, we have no display form.-defaultDisplayForm :: QName -> [LocalDisplayForm]-defaultDisplayForm c = []---- | Non-linear (non-constructor) first-order pattern.-data NLPat-  = PVar !Int [Arg Int]-    -- ^ Matches anything (modulo non-linearity) that only contains bound-    --   variables that occur in the given arguments.-  | PDef QName PElims-    -- ^ Matches @f es@-  | PLam ArgInfo (Abs NLPat)-    -- ^ Matches @λ x → t@-  | PPi (Dom NLPType) (Abs NLPType)-    -- ^ Matches @(x : A) → B@-  | PSort NLPSort-    -- ^ Matches a sort of the given shape.-  | PBoundVar {-# UNPACK #-} !Int PElims-    -- ^ Matches @x es@ where x is a lambda-bound variable-  | PTerm Term-    -- ^ Matches the term modulo β (ideally βη).-  deriving (Data, Show, Generic)-type PElims = [Elim' NLPat]--data NLPType = NLPType-  { nlpTypeSort :: NLPSort-  , nlpTypeUnEl :: NLPat-  } deriving (Data, Show, Generic)--data NLPSort-  = PType NLPat-  | PProp NLPat-  | PInf IsFibrant Integer-  | PSizeUniv-  | PLockUniv-  deriving (Data, Show, Generic)--type RewriteRules = [RewriteRule]---- | Rewrite rules can be added independently from function clauses.-data RewriteRule = RewriteRule-  { rewName    :: QName      -- ^ Name of rewrite rule @q : Γ → f ps ≡ rhs@-                             --   where @≡@ is the rewrite relation.-  , rewContext :: Telescope  -- ^ @Γ@.-  , rewHead    :: QName      -- ^ @f@.-  , rewPats    :: PElims     -- ^ @Γ ⊢ f ps : t@.-  , rewRHS     :: Term       -- ^ @Γ ⊢ rhs : t@.-  , rewType    :: Type       -- ^ @Γ ⊢ t@.-  , rewFromClause :: Bool    -- ^ Was this rewrite rule created from a clause in the definition of the function?-  }-    deriving (Data, Show, Generic)--data Definition = Defn-  { defArgInfo        :: ArgInfo -- ^ Hiding should not be used.-  , defName           :: QName   -- ^ The canonical name, used e.g. in compilation.-  , defType           :: Type    -- ^ Type of the lifted definition.-  , defPolarity       :: [Polarity]-    -- ^ Variance information on arguments of the definition.-    --   Does not include info for dropped parameters to-    --   projection(-like) functions and constructors.-  , defArgOccurrences :: [Occurrence]-    -- ^ Positivity information on arguments of the definition.-    --   Does not include info for dropped parameters to-    --   projection(-like) functions and constructors.--    --   Sometimes Agda looks up 'Occurrence's in these lists based on-    --   their position, so one might consider replacing the list-    --   with, say, an 'IntMap'. However, presumably these lists tend-    --   to be short, in which case 'IntMap's could be slower than-    --   lists. For instance, at one point the longest list-    --   encountered for the standard library (in serialised-    --   interfaces) had length 27. Distribution:-    ---    --   Length, number of lists-    --   ------------------------    ---    --    0, 2444-    --    1,  721-    --    2,  433-    --    3,  668-    --    4,  602-    --    5,  624-    --    6,  626-    --    7,  484-    --    8,  375-    --    9,  264-    --   10,  305-    --   11,  188-    --   12,  171-    --   13,  108-    --   14,   84-    --   15,   80-    --   16,   38-    --   17,   23-    --   18,   16-    --   19,    8-    --   20,    7-    --   21,    5-    --   22,    2-    --   23,    3-    --   27,    1--  , defArgGeneralizable :: NumGeneralizableArgs-    -- ^ How many arguments should be generalised.-  , defGeneralizedParams :: [Maybe Name]-    -- ^ Gives the name of the (bound variable) parameter for named generalized-    --   parameters. This is needed to bring it into scope when type checking-    --   the data/record definition corresponding to a type with generalized-    --   parameters.-  , defDisplay        :: [LocalDisplayForm]-  , defMutual         :: MutualId-  , defCompiledRep    :: CompiledRepresentation-  , defInstance       :: Maybe QName-    -- ^ @Just q@ when this definition is an instance of class q-  , defCopy           :: Bool-    -- ^ Has this function been created by a module-                         -- instantiation?-  , defMatchable      :: Set QName-    -- ^ The set of symbols with rewrite rules that match against this symbol-  , defNoCompilation  :: Bool-    -- ^ should compilers skip this? Used for e.g. cubical's comp-  , defInjective      :: Bool-    -- ^ Should the def be treated as injective by the pattern matching unifier?-  , defCopatternLHS   :: Bool-    -- ^ Is this a function defined by copatterns?-  , defBlocked        :: Blocked_-    -- ^ What blocking tag to use when we cannot reduce this def?-    --   Used when checking a function definition is blocked on a meta-    --   in the type.-  , defLanguage       :: !Language-    -- ^ The language used for the definition.-  , theDef            :: Defn-  }-    deriving (Show, Generic)--instance LensArgInfo Definition where-  getArgInfo = defArgInfo-  mapArgInfo f def = def { defArgInfo = f $ defArgInfo def }--instance LensModality  Definition where-instance LensQuantity  Definition where-instance LensRelevance Definition where--data NumGeneralizableArgs-  = NoGeneralizableArgs-  | SomeGeneralizableArgs !Int-    -- ^ When lambda-lifting new args are generalizable if-    --   'SomeGeneralizableArgs', also when the number is zero.-  deriving (Data, Show)--theDefLens :: Lens' Defn Definition-theDefLens f d = f (theDef d) <&> \ df -> d { theDef = df }---- | Create a definition with sensible defaults.-defaultDefn ::-  ArgInfo -> QName -> Type -> Language -> Defn -> Definition-defaultDefn info x t lang def = Defn-  { defArgInfo        = info-  , defName           = x-  , defType           = t-  , defPolarity       = []-  , defArgOccurrences = []-  , defArgGeneralizable = NoGeneralizableArgs-  , defGeneralizedParams = []-  , defDisplay        = defaultDisplayForm x-  , defMutual         = 0-  , defCompiledRep    = noCompiledRep-  , defInstance       = Nothing-  , defCopy           = False-  , defMatchable      = Set.empty-  , defNoCompilation  = False-  , defInjective      = False-  , defCopatternLHS   = False-  , defBlocked        = NotBlocked ReallyNotBlocked ()-  , defLanguage       = lang-  , theDef            = def-  }---- | Polarity for equality and subtype checking.-data Polarity-  = Covariant      -- ^ monotone-  | Contravariant  -- ^ antitone-  | Invariant      -- ^ no information (mixed variance)-  | Nonvariant     -- ^ constant-  deriving (Data, Show, Eq, Generic)--instance Pretty Polarity where-  pretty = text . \case-    Covariant     -> "+"-    Contravariant -> "-"-    Invariant     -> "*"-    Nonvariant    -> "_"---- | Information about whether an argument is forced by the type of a function.-data IsForced-  = Forced-  | NotForced-  deriving (Data, Show, Eq, Generic)---- | The backends are responsible for parsing their own pragmas.-data CompilerPragma = CompilerPragma Range String-  deriving (Data, Show, Eq, Generic)--instance HasRange CompilerPragma where-  getRange (CompilerPragma r _) = r--type BackendName    = String--jsBackendName, ghcBackendName :: BackendName-jsBackendName  = "JS"-ghcBackendName = "GHC"--type CompiledRepresentation = Map BackendName [CompilerPragma]--noCompiledRep :: CompiledRepresentation-noCompiledRep = Map.empty---- A face represented as a list of equality constraints.--- (r,False) ↦ (r = i0)--- (r,True ) ↦ (r = i1)-type Face = [(Term,Bool)]---- | An alternative representation of partial elements in a telescope:---   Γ ⊢ λ Δ. [φ₁ u₁, ... , φₙ uₙ] : Δ → PartialP (∨_ᵢ φᵢ) T---   see cubicaltt paper (however we do not store the type T).-data System = System-  { systemTel :: Telescope-    -- ^ the telescope Δ, binding vars for the clauses, Γ ⊢ Δ-  , systemClauses :: [(Face,Term)]-    -- ^ a system [φ₁ u₁, ... , φₙ uₙ] where Γ, Δ ⊢ φᵢ and Γ, Δ, φᵢ ⊢ uᵢ-  } deriving (Data, Show, Generic)---- | Additional information for extended lambdas.-data ExtLamInfo = ExtLamInfo-  { extLamModule    :: ModuleName-    -- ^ For complicated reasons the scope checker decides the QName of a-    --   pattern lambda, and thus its module. We really need to decide the-    --   module during type checking though, since if the lambda appears in a-    --   refined context the module picked by the scope checker has very much-    --   the wrong parameters.-  , extLamAbsurd :: Bool-    -- ^ Was this definition created from an absurd lambda @λ ()@?-  , extLamSys :: !(Strict.Maybe System)-  } deriving (Data, Show, Generic)--modifySystem :: (System -> System) -> ExtLamInfo -> ExtLamInfo-modifySystem f e = let !e' = e { extLamSys = f <$> extLamSys e } in e'---- | Additional information for projection 'Function's.-data Projection = Projection-  { projProper    :: Maybe QName-    -- ^ @Nothing@ if only projection-like, @Just r@ if record projection.-    --   The @r@ is the name of the record type projected from.-    --   This field is updated by module application.-  , projOrig      :: QName-    -- ^ The original projection name-    --   (current name could be from module application).-  , projFromType  :: Arg QName-    -- ^ Type projected from. Original record type if @projProper = Just{}@.-    --   Also stores @ArgInfo@ of the principal argument.-    --   This field is unchanged by module application.-  , projIndex     :: Int-    -- ^ Index of the record argument.-    --   Start counting with 1, because 0 means that-    --   it is already applied to the record value.-    --   This can happen in module instantiation, but-    --   then either the record value is @var 0@, or @funProjection == Nothing@.-  , projLams :: ProjLams-    -- ^ Term @t@ to be be applied to record parameters and record value.-    --   The parameters will be dropped.-    --   In case of a proper projection, a postfix projection application-    --   will be created: @t = \ pars r -> r .p@-    --   (Invariant: the number of abstractions equals 'projIndex'.)-    --   In case of a projection-like function, just the function symbol-    --   is returned as 'Def':  @t = \ pars -> f@.-  } deriving (Data, Show, Generic)---- | Abstractions to build projection function (dropping parameters).-newtype ProjLams = ProjLams { getProjLams :: [Arg ArgName] }-  deriving (Data, Show, Null, Generic)---- | Building the projection function (which drops the parameters).-projDropPars :: Projection -> ProjOrigin -> Term--- Proper projections:-projDropPars (Projection Just{} d _ _ lams) o =-  case initLast $ getProjLams lams of-    Nothing -> Def d []-    Just (pars, Arg i y) ->-      let core = Lam i $ Abs y $ Var 0 [Proj o d] in-      List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) core pars--- Projection-like functions:-projDropPars (Projection Nothing d _ _ lams) o =-  List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) (Def d []) $-    initWithDefault __IMPOSSIBLE__ $ getProjLams lams---- | The info of the principal (record) argument.-projArgInfo :: Projection -> ArgInfo-projArgInfo (Projection _ _ _ _ lams) =-  maybe __IMPOSSIBLE__ getArgInfo $ lastMaybe $ getProjLams lams---- | Should a record type admit eta-equality?-data EtaEquality-  = Specified { theEtaEquality :: !HasEta }  -- ^ User specifed 'eta-equality' or 'no-eta-equality'.-  | Inferred  { theEtaEquality :: !HasEta }  -- ^ Positivity checker inferred whether eta is safe.-  deriving (Data, Show, Eq, Generic)--instance PatternMatchingAllowed EtaEquality where-  patternMatchingAllowed = patternMatchingAllowed . theEtaEquality--instance CopatternMatchingAllowed EtaEquality where-  copatternMatchingAllowed = copatternMatchingAllowed . theEtaEquality---- | Make sure we do not overwrite a user specification.-setEtaEquality :: EtaEquality -> HasEta -> EtaEquality-setEtaEquality e@Specified{} _ = e-setEtaEquality _ b = Inferred b--data FunctionFlag-  = FunStatic  -- ^ Should calls to this function be normalised at compile-time?-  | FunInline  -- ^ Should calls to this function be inlined by the compiler?-  | FunMacro   -- ^ Is this function a macro?-  deriving (Data, Eq, Ord, Enum, Show, Generic)--data CompKit = CompKit-  { nameOfHComp :: Maybe QName-  , nameOfTransp :: Maybe QName-  }-  deriving (Data, Eq, Ord, Show, Generic)--emptyCompKit :: CompKit-emptyCompKit = CompKit Nothing Nothing--defaultAxiom :: Defn-defaultAxiom = Axiom False--constTranspAxiom :: Defn-constTranspAxiom = Axiom True--data Defn = Axiom -- ^ Postulate-            { axiomConstTransp :: Bool-              -- ^ Can transp for this postulate be constant?-              --   Set to @True@ for bultins like String.-            }-          | DataOrRecSig-            { datarecPars :: Int }-            -- ^ Data or record type signature that doesn't yet have a definition-          | GeneralizableVar -- ^ Generalizable variable (introduced in `generalize` block)-          | AbstractDefn Defn-            -- ^ Returned by 'getConstInfo' if definition is abstract.-          | Function-            { funClauses        :: [Clause]-            , funCompiled       :: Maybe CompiledClauses-              -- ^ 'Nothing' while function is still type-checked.-              --   @Just cc@ after type and coverage checking and-              --   translation to case trees.-            , funSplitTree      :: Maybe SplitTree-              -- ^ The split tree constructed by the coverage-              --   checker. Needed to re-compile the clauses after-              --   forcing translation.-            , funTreeless       :: Maybe Compiled-              -- ^ Intermediate representation for compiler backends.-            , funCovering       :: [Clause]-              -- ^ Covering clauses computed by coverage checking.-              --   Erased by (IApply) confluence checking(?)-            , funInv            :: FunctionInverse-            , funMutual         :: Maybe [QName]-              -- ^ Mutually recursive functions, @data@s and @record@s.-              --   Does include this function.-              --   Empty list if not recursive.-              --   @Nothing@ if not yet computed (by positivity checker).-            , funAbstr          :: IsAbstract-            , funDelayed        :: Delayed-              -- ^ Are the clauses of this definition delayed?-            , funProjection     :: Maybe Projection-              -- ^ Is it a record projection?-              --   If yes, then return the name of the record type and index of-              --   the record argument.  Start counting with 1, because 0 means that-              --   it is already applied to the record. (Can happen in module-              --   instantiation.) This information is used in the termination-              --   checker.-            , funFlags          :: Set FunctionFlag-            , funTerminates     :: Maybe Bool-              -- ^ Has this function been termination checked?  Did it pass?-            , funExtLam         :: Maybe ExtLamInfo-              -- ^ Is this function generated from an extended lambda?-              --   If yes, then return the number of hidden and non-hidden lambda-lifted arguments-            , funWith           :: Maybe QName-              -- ^ Is this a generated with-function? If yes, then what's the-              --   name of the parent function.-            }-          | Datatype-            { dataPars           :: Nat            -- ^ Number of parameters.-            , dataIxs            :: Nat            -- ^ Number of indices.-            , dataClause         :: (Maybe Clause) -- ^ This might be in an instantiated module.-            , dataCons           :: [QName]-              -- ^ Constructor names , ordered according to the order of their definition.-            , dataSort           :: Sort-            , dataMutual         :: Maybe [QName]-              -- ^ Mutually recursive functions, @data@s and @record@s.-              --   Does include this data type.-              --   Empty if not recursive.-              --   @Nothing@ if not yet computed (by positivity checker).-            , dataAbstr          :: IsAbstract-            , dataPathCons       :: [QName]        -- ^ Path constructor names (subset of dataCons)-            }-          | Record-            { recPars           :: Nat-              -- ^ Number of parameters.-            , recClause         :: Maybe Clause-              -- ^ Was this record type created by a module application?-              --   If yes, the clause is its definition (linking back to the original record type).-            , recConHead        :: ConHead-              -- ^ Constructor name and fields.-            , recNamedCon       :: Bool-              -- ^ Does this record have a @constructor@?-            , recFields         :: [Dom QName]-              -- ^ The record field names.-            , recTel            :: Telescope-              -- ^ The record field telescope. (Includes record parameters.)-              --   Note: @TelV recTel _ == telView' recConType@.-              --   Thus, @recTel@ is redundant.-            , recMutual         :: Maybe [QName]-              -- ^ Mutually recursive functions, @data@s and @record@s.-              --   Does include this record.-              --   Empty if not recursive.-              --   @Nothing@ if not yet computed (by positivity checker).-            , recEtaEquality'    :: EtaEquality-              -- ^ Eta-expand at this record type?-              --   @False@ for unguarded recursive records and coinductive records-              --   unless the user specifies otherwise.-            , recPatternMatching :: PatternOrCopattern-              -- ^ In case eta-equality is off, do we allow pattern matching on the-              --   constructor or construction by copattern matching?-              --   Having both loses subject reduction, see issue #4560.-              --   After positivity checking, this field is obsolete, part of 'EtaEquality'.-            , recInduction      :: Maybe Induction-              -- ^ 'Inductive' or 'CoInductive'?  Matters only for recursive records.-              --   'Nothing' means that the user did not specify it, which is an error-              --   for recursive records.-            , recAbstr          :: IsAbstract-            , recComp           :: CompKit-            }-          | Constructor-            { conPars   :: Int         -- ^ Number of parameters.-            , conArity  :: Int         -- ^ Number of arguments (excluding parameters).-            , conSrcCon :: ConHead     -- ^ Name of (original) constructor and fields. (This might be in a module instance.)-            , conData   :: QName       -- ^ Name of datatype or record type.-            , conAbstr  :: IsAbstract-            , conInd    :: Induction   -- ^ Inductive or coinductive?-            , conComp   :: CompKit     -- ^ Cubical composition.-            , conProj   :: Maybe [QName] -- ^ Projections. 'Nothing' if not yet computed.-            , conForced :: [IsForced]-              -- ^ Which arguments are forced (i.e. determined by the type of the constructor)?-              --   Either this list is empty (if the forcing analysis isn't run), or its length is @conArity@.-            , conErased :: Maybe [Bool]-              -- ^ Which arguments are erased at runtime (computed during compilation to treeless)?-              --   'True' means erased, 'False' means retained.-              --   'Nothing' if no erasure analysis has been performed yet.-              --   The length of the list is @conArity@.-            }-          | Primitive  -- ^ Primitive or builtin functions.-            { primAbstr :: IsAbstract-            , primName  :: String-            , primClauses :: [Clause]-              -- ^ 'null' for primitive functions, @not null@ for builtin functions.-            , primInv      :: FunctionInverse-              -- ^ Builtin functions can have inverses. For instance, natural number addition.-            , primCompiled :: Maybe CompiledClauses-              -- ^ 'Nothing' for primitive functions,-              --   @'Just' something@ for builtin functions.-            }-          | PrimitiveSort-            { primName :: String-            , primSort :: Sort-            }-    deriving (Data, Show, Generic)--instance Pretty Definition where-  pretty Defn{..} =-    "Defn {" <?> vcat-      [ "defArgInfo        =" <?> pshow defArgInfo-      , "defName           =" <?> pretty defName-      , "defType           =" <?> pretty defType-      , "defPolarity       =" <?> pshow defPolarity-      , "defArgOccurrences =" <?> pshow defArgOccurrences-      , "defGeneralizedParams =" <?> pshow defGeneralizedParams-      , "defDisplay        =" <?> pretty defDisplay-      , "defMutual         =" <?> pshow defMutual-      , "defCompiledRep    =" <?> pshow defCompiledRep-      , "defInstance       =" <?> pshow defInstance-      , "defCopy           =" <?> pshow defCopy-      , "defMatchable      =" <?> pshow (Set.toList defMatchable)-      , "defInjective      =" <?> pshow defInjective-      , "defCopatternLHS   =" <?> pshow defCopatternLHS-      , "theDef            =" <?> pretty theDef ] <+> "}"--instance Pretty Defn where-  pretty Axiom{} = "Axiom"-  pretty (DataOrRecSig n)   = "DataOrRecSig" <+> pretty n-  pretty GeneralizableVar{} = "GeneralizableVar"-  pretty (AbstractDefn def) = "AbstractDefn" <?> parens (pretty def)-  pretty Function{..} =-    "Function {" <?> vcat-      [ "funClauses      =" <?> vcat (map pretty funClauses)-      , "funCompiled     =" <?> pretty funCompiled-      , "funSplitTree    =" <?> pretty funSplitTree-      , "funTreeless     =" <?> pshow funTreeless-      , "funInv          =" <?> pretty funInv-      , "funMutual       =" <?> pshow funMutual-      , "funAbstr        =" <?> pshow funAbstr-      , "funDelayed      =" <?> pshow funDelayed-      , "funProjection   =" <?> pretty funProjection-      , "funFlags        =" <?> pshow funFlags-      , "funTerminates   =" <?> pshow funTerminates-      , "funWith         =" <?> pretty funWith ] <?> "}"-  pretty Datatype{..} =-    "Datatype {" <?> vcat-      [ "dataPars       =" <?> pshow dataPars-      , "dataIxs        =" <?> pshow dataIxs-      , "dataClause     =" <?> pretty dataClause-      , "dataCons       =" <?> pshow dataCons-      , "dataSort       =" <?> pretty dataSort-      , "dataMutual     =" <?> pshow dataMutual-      , "dataAbstr      =" <?> pshow dataAbstr ] <?> "}"-  pretty Record{..} =-    "Record {" <?> vcat-      [ "recPars         =" <?> pshow recPars-      , "recClause       =" <?> pretty recClause-      , "recConHead      =" <?> pretty recConHead-      , "recNamedCon     =" <?> pretty recNamedCon-      , "recFields       =" <?> pretty recFields-      , "recTel          =" <?> pretty recTel-      , "recMutual       =" <?> pshow recMutual-      , "recEtaEquality' =" <?> pshow recEtaEquality'-      , "recInduction    =" <?> pshow recInduction-      , "recAbstr        =" <?> pshow recAbstr ] <?> "}"-  pretty Constructor{..} =-    "Constructor {" <?> vcat-      [ "conPars   =" <?> pshow conPars-      , "conArity  =" <?> pshow conArity-      , "conSrcCon =" <?> pretty conSrcCon-      , "conData   =" <?> pretty conData-      , "conAbstr  =" <?> pshow conAbstr-      , "conInd    =" <?> pshow conInd-      , "conErased =" <?> pshow conErased ] <?> "}"-  pretty Primitive{..} =-    "Primitive {" <?> vcat-      [ "primAbstr    =" <?> pshow primAbstr-      , "primName     =" <?> pshow primName-      , "primClauses  =" <?> pshow primClauses-      , "primCompiled =" <?> pshow primCompiled ] <?> "}"-  pretty PrimitiveSort{..} =-    "PrimitiveSort {" <?> vcat-      [ "primName =" <?> pshow primName-      , "primSort =" <?> pshow primSort-      ] <?> "}"--instance Pretty Projection where-  pretty Projection{..} =-    "Projection {" <?> vcat-      [ "projProper   =" <?> pretty projProper-      , "projOrig     =" <?> pretty projOrig-      , "projFromType =" <?> pretty projFromType-      , "projIndex    =" <?> pshow projIndex-      , "projLams     =" <?> pretty projLams-      ]--instance Pretty c => Pretty (FunctionInverse' c) where-  pretty NotInjective = "NotInjective"-  pretty (Inverse inv) = "Inverse" <?>-    vcat [ pretty h <+> "->" <?> pretty cs-         | (h, cs) <- Map.toList inv ]--instance Pretty ProjLams where-  pretty (ProjLams args) = pretty args---- | Is the record type recursive?-recRecursive :: Defn -> Bool-recRecursive (Record { recMutual = Just qs }) = not $ null qs-recRecursive _ = __IMPOSSIBLE__--recEtaEquality :: Defn -> HasEta-recEtaEquality = theEtaEquality . recEtaEquality'---- | A template for creating 'Function' definitions, with sensible defaults.-emptyFunction :: Defn-emptyFunction = Function-  { funClauses     = []-  , funCompiled    = Nothing-  , funSplitTree   = Nothing-  , funTreeless    = Nothing-  , funInv         = NotInjective-  , funMutual      = Nothing-  , funAbstr       = ConcreteDef-  , funDelayed     = NotDelayed-  , funProjection  = Nothing-  , funFlags       = Set.empty-  , funTerminates  = Nothing-  , funExtLam      = Nothing-  , funWith        = Nothing-  , funCovering    = []-  }--funFlag :: FunctionFlag -> Lens' Bool Defn-funFlag flag f def@Function{ funFlags = flags } =-  f (Set.member flag flags) <&>-  \ b -> def{ funFlags = (if b then Set.insert else Set.delete) flag flags }-funFlag _ f def = f False $> def--funStatic, funInline, funMacro :: Lens' Bool Defn-funStatic       = funFlag FunStatic-funInline       = funFlag FunInline-funMacro        = funFlag FunMacro--isMacro :: Defn -> Bool-isMacro = (^. funMacro)---- | Checking whether we are dealing with a function yet to be defined.-isEmptyFunction :: Defn -> Bool-isEmptyFunction def =-  case def of-    Function { funClauses = [] } -> True-    _ -> False--isCopatternLHS :: [Clause] -> Bool-isCopatternLHS = List.any (List.any (isJust . A.isProjP) . namedClausePats)--recCon :: Defn -> QName-recCon Record{ recConHead } = conName recConHead-recCon _ = __IMPOSSIBLE__--defIsRecord :: Defn -> Bool-defIsRecord Record{} = True-defIsRecord _        = False--defIsDataOrRecord :: Defn -> Bool-defIsDataOrRecord Record{}   = True-defIsDataOrRecord Datatype{} = True-defIsDataOrRecord _          = False--defConstructors :: Defn -> [QName]-defConstructors Datatype{dataCons = cs} = cs-defConstructors Record{recConHead = c} = [conName c]-defConstructors _ = __IMPOSSIBLE__--newtype Fields = Fields [(C.Name, Type)]-  deriving Null---- | Did we encounter a simplifying reduction?---   In terms of CIC, that would be a iota-reduction.---   In terms of Agda, this is a constructor or literal---   pattern that matched.---   Just beta-reduction (substitution) or delta-reduction---   (unfolding of definitions) does not count as simplifying?--data Simplification = YesSimplification | NoSimplification-  deriving (Data, Eq, Show, Generic)--instance Null Simplification where-  empty = NoSimplification-  null  = (== NoSimplification)--instance Semigroup Simplification where-  YesSimplification <> _ = YesSimplification-  NoSimplification  <> s = s--instance Monoid Simplification where-  mempty = NoSimplification-  mappend = (<>)--data Reduced no yes-  = NoReduction no-  | YesReduction Simplification yes-  deriving Functor--redReturn :: a -> ReduceM (Reduced a' a)-redReturn = return . YesReduction YesSimplification---- | Conceptually: @redBind m f k = either (return . Left . f) k =<< m@--redBind :: ReduceM (Reduced a a') -> (a -> b) ->-           (a' -> ReduceM (Reduced b b')) -> ReduceM (Reduced b b')-redBind ma f k = do-  r <- ma-  case r of-    NoReduction x    -> return $ NoReduction $ f x-    YesReduction _ y -> k y---- | Three cases: 1. not reduced, 2. reduced, but blocked, 3. reduced, not blocked.-data IsReduced-  = NotReduced-  | Reduced    (Blocked ())--data MaybeReduced a = MaybeRed-  { isReduced     :: IsReduced-  , ignoreReduced :: a-  }-  deriving (Functor)--instance IsProjElim e => IsProjElim (MaybeReduced e) where-  isProjElim = isProjElim . ignoreReduced--type MaybeReducedArgs = [MaybeReduced (Arg Term)]-type MaybeReducedElims = [MaybeReduced Elim]--notReduced :: a -> MaybeReduced a-notReduced x = MaybeRed NotReduced x--reduced :: Blocked (Arg Term) -> MaybeReduced (Arg Term)-reduced b = MaybeRed (Reduced $ () <$ b) $ ignoreBlocking b---- | Controlling 'reduce'.-data AllowedReduction-  = ProjectionReductions     -- ^ (Projection and) projection-like functions may be reduced.-  | InlineReductions         -- ^ Functions marked INLINE may be reduced.-  | CopatternReductions      -- ^ Copattern definitions may be reduced.-  | FunctionReductions       -- ^ Non-recursive functions and primitives may be reduced.-  | RecursiveReductions      -- ^ Even recursive functions may be reduced.-  | LevelReductions          -- ^ Reduce @'Level'@ terms.-  | TypeLevelReductions      -- ^ Allow @allReductions@ in types, even-                             --   if not allowed at term level (used-                             --   by confluence checker)-  | UnconfirmedReductions    -- ^ Functions whose termination has not (yet) been confirmed.-  | NonTerminatingReductions -- ^ Functions that have failed termination checking.-  deriving (Show, Eq, Ord, Enum, Bounded, Ix, Data, Generic)--type AllowedReductions = SmallSet AllowedReduction---- | Not quite all reductions (skip non-terminating reductions)-allReductions :: AllowedReductions-allReductions = SmallSet.delete NonTerminatingReductions reallyAllReductions--reallyAllReductions :: AllowedReductions-reallyAllReductions = SmallSet.total--data ReduceDefs-  = OnlyReduceDefs (Set QName)-  | DontReduceDefs (Set QName)-  deriving (Data, Generic)--reduceAllDefs :: ReduceDefs-reduceAllDefs = DontReduceDefs empty--locallyReduceDefs :: MonadTCEnv m => ReduceDefs -> m a -> m a-locallyReduceDefs = locallyTC eReduceDefs . const--locallyReduceAllDefs :: MonadTCEnv m => m a -> m a-locallyReduceAllDefs = locallyReduceDefs reduceAllDefs--shouldReduceDef :: (MonadTCEnv m) => QName -> m Bool-shouldReduceDef f = asksTC envReduceDefs <&> \case-  OnlyReduceDefs defs -> f `Set.member` defs-  DontReduceDefs defs -> not $ f `Set.member` defs--instance Semigroup ReduceDefs where-  OnlyReduceDefs qs1 <> OnlyReduceDefs qs2 = OnlyReduceDefs $ Set.intersection qs1 qs2-  OnlyReduceDefs qs1 <> DontReduceDefs qs2 = OnlyReduceDefs $ Set.difference   qs1 qs2-  DontReduceDefs qs1 <> OnlyReduceDefs qs2 = OnlyReduceDefs $ Set.difference   qs2 qs1-  DontReduceDefs qs1 <> DontReduceDefs qs2 = DontReduceDefs $ Set.union        qs1 qs2--instance Monoid ReduceDefs where-  mempty  = reduceAllDefs-  mappend = (<>)---locallyReconstructed :: MonadTCEnv m => m a -> m a-locallyReconstructed = locallyTC eReconstructed . const $ True--isReconstructed :: (MonadTCEnv m) => m Bool-isReconstructed = asksTC envReconstructed---- | Primitives--data PrimitiveImpl = PrimImpl Type PrimFun--data PrimFun = PrimFun-  { primFunName           :: QName-  , primFunArity          :: Arity-  , primFunImplementation :: [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term)-  }-  deriving Generic--primFun :: QName -> Arity -> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun-primFun q ar imp = PrimFun q ar (\ args _ -> imp args)--defClauses :: Definition -> [Clause]-defClauses Defn{theDef = Function{funClauses = cs}}        = cs-defClauses Defn{theDef = Primitive{primClauses = cs}}      = cs-defClauses Defn{theDef = Datatype{dataClause = Just c}}    = [c]-defClauses Defn{theDef = Record{recClause = Just c}}       = [c]-defClauses _                                               = []--defCompiled :: Definition -> Maybe CompiledClauses-defCompiled Defn{theDef = Function {funCompiled  = mcc}} = mcc-defCompiled Defn{theDef = Primitive{primCompiled = mcc}} = mcc-defCompiled _ = Nothing--defParameters :: Definition -> Maybe Nat-defParameters Defn{theDef = Datatype{dataPars = n}} = Just n-defParameters Defn{theDef = Record  {recPars  = n}} = Just n-defParameters _                                     = Nothing--defInverse :: Definition -> FunctionInverse-defInverse Defn{theDef = Function { funInv  = inv }} = inv-defInverse Defn{theDef = Primitive{ primInv = inv }} = inv-defInverse _                                         = NotInjective--defCompilerPragmas :: BackendName -> Definition -> [CompilerPragma]-defCompilerPragmas b = reverse . fromMaybe [] . Map.lookup b . defCompiledRep-  -- reversed because we add new pragmas to the front of the list---- | Are the clauses of this definition delayed?-defDelayed :: Definition -> Delayed-defDelayed Defn{theDef = Function{funDelayed = d}} = d-defDelayed _                                       = NotDelayed---- | Has the definition failed the termination checker?-defNonterminating :: Definition -> Bool-defNonterminating Defn{theDef = Function{funTerminates = Just False}} = True-defNonterminating _                                                   = False---- | Has the definition not termination checked or did the check fail?-defTerminationUnconfirmed :: Definition -> Bool-defTerminationUnconfirmed Defn{theDef = Function{funTerminates = Just True}} = False-defTerminationUnconfirmed Defn{theDef = Function{funTerminates = _        }} = True-defTerminationUnconfirmed _ = False--defAbstract :: Definition -> IsAbstract-defAbstract d = case theDef d of-    Axiom{}                   -> ConcreteDef-    DataOrRecSig{}            -> ConcreteDef-    GeneralizableVar{}        -> ConcreteDef-    AbstractDefn{}            -> AbstractDef-    Function{funAbstr = a}    -> a-    Datatype{dataAbstr = a}   -> a-    Record{recAbstr = a}      -> a-    Constructor{conAbstr = a} -> a-    Primitive{primAbstr = a}  -> a-    PrimitiveSort{}           -> ConcreteDef--defForced :: Definition -> [IsForced]-defForced d = case theDef d of-    Constructor{conForced = fs} -> fs-    Axiom{}                     -> []-    DataOrRecSig{}              -> []-    GeneralizableVar{}          -> []-    AbstractDefn{}              -> []-    Function{}                  -> []-    Datatype{}                  -> []-    Record{}                    -> []-    Primitive{}                 -> []-    PrimitiveSort{}             -> []-------------------------------------------------------------------------------- ** Injectivity------------------------------------------------------------------------------type FunctionInverse = FunctionInverse' Clause-type InversionMap c = Map TermHead [c]--data FunctionInverse' c-  = NotInjective-  | Inverse (InversionMap c)-  deriving (Data, Show, Functor, Generic)--data TermHead = SortHead-              | PiHead-              | ConsHead QName-              | VarHead Nat-              | UnknownHead-  deriving (Data, Eq, Ord, Show, Generic)--instance Pretty TermHead where-  pretty = \ case-    SortHead    -> "SortHead"-    PiHead      -> "PiHead"-    ConsHead q  -> "ConsHead" <+> pretty q-    VarHead i   -> text ("VarHead " ++ show i)-    UnknownHead -> "UnknownHead"-------------------------------------------------------------------------------- ** Mutual blocks------------------------------------------------------------------------------newtype MutualId = MutId Int32-  deriving (Data, Eq, Ord, Show, Num, Enum, NFData)-------------------------------------------------------------------------------- ** Statistics------------------------------------------------------------------------------type Statistics = Map String Integer-------------------------------------------------------------------------------- ** Trace------------------------------------------------------------------------------data Call-  = CheckClause Type A.SpineClause-  | CheckLHS A.SpineLHS-  | CheckPattern A.Pattern Telescope Type-  | CheckPatternLinearityType C.Name-  | CheckPatternLinearityValue C.Name-  | CheckLetBinding A.LetBinding-  | InferExpr A.Expr-  | CheckExprCall Comparison A.Expr Type-  | CheckDotPattern A.Expr Term-  | CheckProjection Range QName Type-  | IsTypeCall Comparison A.Expr Sort-  | IsType_ A.Expr-  | InferVar Name-  | InferDef QName-  | CheckArguments Range [NamedArg A.Expr] Type (Maybe Type)-  | CheckMetaSolution Range MetaId Type Term-  | CheckTargetType Range Type Type-  | CheckDataDef Range QName [A.LamBinding] [A.Constructor]-  | CheckRecDef Range QName [A.LamBinding] [A.Constructor]-  | CheckConstructor QName Telescope Sort A.Constructor-  | CheckConstructorFitsIn QName Type Sort-  | CheckFunDefCall Range QName [A.Clause] Bool-    -- ^ Highlight (interactively) if and only if the boolean is 'True'.-  | CheckPragma Range A.Pragma-  | CheckPrimitive Range QName A.Expr-  | CheckIsEmpty Range Type-  | CheckConfluence QName QName-  | CheckWithFunctionType Type-  | CheckSectionApplication Range ModuleName A.ModuleApplication-  | CheckNamedWhere ModuleName-  | ScopeCheckExpr C.Expr-  | ScopeCheckDeclaration NiceDeclaration-  | ScopeCheckLHS C.QName C.Pattern-  | NoHighlighting-  | ModuleContents  -- ^ Interaction command: show module contents.-  | SetRange Range  -- ^ used by 'setCurrentRange'-  deriving (Data, Generic)--instance Pretty Call where-    pretty CheckClause{}             = "CheckClause"-    pretty CheckLHS{}                = "CheckLHS"-    pretty CheckPattern{}            = "CheckPattern"-    pretty CheckPatternLinearityType{}  = "CheckPatternLinearityType"-    pretty CheckPatternLinearityValue{} = "CheckPatternLinearityValue"-    pretty InferExpr{}               = "InferExpr"-    pretty CheckExprCall{}           = "CheckExprCall"-    pretty CheckLetBinding{}         = "CheckLetBinding"-    pretty CheckProjection{}         = "CheckProjection"-    pretty IsTypeCall{}              = "IsTypeCall"-    pretty IsType_{}                 = "IsType_"-    pretty InferVar{}                = "InferVar"-    pretty InferDef{}                = "InferDef"-    pretty CheckArguments{}          = "CheckArguments"-    pretty CheckMetaSolution{}       = "CheckMetaSolution"-    pretty CheckTargetType{}         = "CheckTargetType"-    pretty CheckDataDef{}            = "CheckDataDef"-    pretty CheckRecDef{}             = "CheckRecDef"-    pretty CheckConstructor{}        = "CheckConstructor"-    pretty CheckConstructorFitsIn{}  = "CheckConstructorFitsIn"-    pretty CheckFunDefCall{}         = "CheckFunDefCall"-    pretty CheckPragma{}             = "CheckPragma"-    pretty CheckPrimitive{}          = "CheckPrimitive"-    pretty CheckWithFunctionType{}   = "CheckWithFunctionType"-    pretty CheckNamedWhere{}         = "CheckNamedWhere"-    pretty ScopeCheckExpr{}          = "ScopeCheckExpr"-    pretty ScopeCheckDeclaration{}   = "ScopeCheckDeclaration"-    pretty ScopeCheckLHS{}           = "ScopeCheckLHS"-    pretty CheckDotPattern{}         = "CheckDotPattern"-    pretty SetRange{}                = "SetRange"-    pretty CheckSectionApplication{} = "CheckSectionApplication"-    pretty CheckIsEmpty{}            = "CheckIsEmpty"-    pretty CheckConfluence{}         = "CheckConfluence"-    pretty NoHighlighting{}          = "NoHighlighting"-    pretty ModuleContents{}          = "ModuleContents"--instance HasRange Call where-    getRange (CheckClause _ c)               = getRange c-    getRange (CheckLHS lhs)                  = getRange lhs-    getRange (CheckPattern p _ _)            = getRange p-    getRange (CheckPatternLinearityType x)   = getRange x-    getRange (CheckPatternLinearityValue x)  = getRange x-    getRange (InferExpr e)                   = getRange e-    getRange (CheckExprCall _ e _)           = getRange e-    getRange (CheckLetBinding b)             = getRange b-    getRange (CheckProjection r _ _)         = r-    getRange (IsTypeCall cmp e s)            = getRange e-    getRange (IsType_ e)                     = getRange e-    getRange (InferVar x)                    = getRange x-    getRange (InferDef f)                    = getRange f-    getRange (CheckArguments r _ _ _)        = r-    getRange (CheckMetaSolution r _ _ _)     = r-    getRange (CheckTargetType r _ _)         = r-    getRange (CheckDataDef i _ _ _)          = getRange i-    getRange (CheckRecDef i _ _ _)           = getRange i-    getRange (CheckConstructor _ _ _ c)      = getRange c-    getRange (CheckConstructorFitsIn c _ _)  = getRange c-    getRange (CheckFunDefCall i _ _ _)       = getRange i-    getRange (CheckPragma r _)               = r-    getRange (CheckPrimitive i _ _)          = getRange i-    getRange CheckWithFunctionType{}         = noRange-    getRange (CheckNamedWhere m)             = getRange m-    getRange (ScopeCheckExpr e)              = getRange e-    getRange (ScopeCheckDeclaration d)       = getRange d-    getRange (ScopeCheckLHS _ p)             = getRange p-    getRange (CheckDotPattern e _)           = getRange e-    getRange (SetRange r)                    = r-    getRange (CheckSectionApplication r _ _) = r-    getRange (CheckIsEmpty r _)              = r-    getRange (CheckConfluence rule1 rule2)   = max (getRange rule1) (getRange rule2)-    getRange NoHighlighting                  = noRange-    getRange ModuleContents                  = noRange-------------------------------------------------------------------------------- ** Instance table-------------------------------------------------------------------------------- | The instance table is a @Map@ associating to every name of---   record/data type/postulate its list of instances-type InstanceTable = Map QName (Set QName)---- | When typechecking something of the following form:------     instance---       x : _---       x = y------   it's not yet known where to add @x@, so we add it to a list of---   unresolved instances and we'll deal with it later.-type TempInstanceTable = (InstanceTable , Set QName)-------------------------------------------------------------------------------- ** Builtin things------------------------------------------------------------------------------data BuiltinDescriptor-  = BuiltinData (TCM Type) [String]-  | BuiltinDataCons (TCM Type)-  | BuiltinPrim String (Term -> TCM ())-  | BuiltinSort String-  | BuiltinPostulate Relevance (TCM Type)-  | BuiltinUnknown (Maybe (TCM Type)) (Term -> Type -> TCM ())-    -- ^ Builtin of any kind.-    --   Type can be checked (@Just t@) or inferred (@Nothing@).-    --   The second argument is the hook for the verification function.--data BuiltinInfo =-   BuiltinInfo { builtinName :: String-               , builtinDesc :: BuiltinDescriptor }--type BuiltinThings pf = Map String (Builtin pf)--data Builtin pf-        = Builtin Term-        | Prim pf-    deriving (Show, Functor, Foldable, Traversable, Generic)-------------------------------------------------------------------------------- * Highlighting levels-------------------------------------------------------------------------------- | How much highlighting should be sent to the user interface?--data HighlightingLevel-  = None-  | NonInteractive-  | Interactive-    -- ^ This includes both non-interactive highlighting and-    -- interactive highlighting of the expression that is currently-    -- being type-checked.-    deriving (Eq, Ord, Show, Read, Data, Generic)---- | How should highlighting be sent to the user interface?--data HighlightingMethod-  = Direct-    -- ^ Via stdout.-  | Indirect-    -- ^ Both via files and via stdout.-    deriving (Eq, Show, Read, Data, Generic)---- | @ifTopLevelAndHighlightingLevelIs l b m@ runs @m@ when we're--- type-checking the top-level module (or before we've started doing--- this) and either the highlighting level is /at least/ @l@ or @b@ is--- 'True'.--ifTopLevelAndHighlightingLevelIsOr ::-  MonadTCEnv tcm => HighlightingLevel -> Bool -> tcm () -> tcm ()-ifTopLevelAndHighlightingLevelIsOr l b m = do-  e <- askTC-  when (envHighlightingLevel e >= l || b) $-    case (envImportPath e) of-      -- Below the main module.-      (_:_:_) -> pure ()-      -- In or before the top-level module.-      _ -> m---- | @ifTopLevelAndHighlightingLevelIs l m@ runs @m@ when we're--- type-checking the top-level module (or before we've started doing--- this) and the highlighting level is /at least/ @l@.--ifTopLevelAndHighlightingLevelIs ::-  MonadTCEnv tcm => HighlightingLevel -> tcm () -> tcm ()-ifTopLevelAndHighlightingLevelIs l =-  ifTopLevelAndHighlightingLevelIsOr l False-------------------------------------------------------------------------------- * Type checking environment------------------------------------------------------------------------------data TCEnv =-    TCEnv { envContext             :: Context-          , envLetBindings         :: LetBindings-          , envCurrentModule       :: ModuleName-          , envCurrentPath         :: Maybe AbsolutePath-            -- ^ The path to the file that is currently being-            -- type-checked.  'Nothing' if we do not have a file-            -- (like in interactive mode see @CommandLine@).-          , envAnonymousModules    :: [(ModuleName, Nat)] -- ^ anonymous modules and their number of free variables-          , envImportPath          :: [C.TopLevelModuleName]-            -- ^ The module stack with the entry being the top-level module as-            --   Agda chases modules. It will be empty if there is no main-            --   module, will have a single entry for the top level module, or-            --   more when descending past the main module. This is used to-            --   detect import cycles and in some cases highlighting behavior.-            --   The level of a given module is not necessarily the same as the-            --   length, in the module dependency graph, of the shortest path-            --   from the top-level module; it depends on in which order Agda-            --   chooses to chase dependencies.-          , envMutualBlock         :: Maybe MutualId -- ^ the current (if any) mutual block-          , envTerminationCheck    :: TerminationCheck ()  -- ^ are we inside the scope of a termination pragma-          , envCoverageCheck       :: CoverageCheck        -- ^ are we inside the scope of a coverage pragma-          , envMakeCase            :: Bool                 -- ^ are we inside a make-case (if so, ignore forcing analysis in unifier)-          , envSolvingConstraints  :: Bool-                -- ^ Are we currently in the process of solving active constraints?-          , envCheckingWhere       :: Bool-                -- ^ Have we stepped into the where-declarations of a clause?-                --   Everything under a @where@ will be checked with this flag on.-          , envWorkingOnTypes      :: Bool-                -- ^ Are we working on types? Turned on by 'workOnTypes'.-          , envAssignMetas         :: Bool-            -- ^ Are we allowed to assign metas?-          , envActiveProblems      :: Set ProblemId-          , envAbstractMode        :: AbstractMode-                -- ^ When checking the typesignature of a public definition-                --   or the body of a non-abstract definition this is true.-                --   To prevent information about abstract things leaking-                --   outside the module.-          , envModality            :: Modality-                -- ^ 'Relevance' component:-                -- Are we checking an irrelevant argument? (=@Irrelevant@)-                -- Then top-level irrelevant declarations are enabled.-                -- Other value: @Relevant@, then only relevant decls. are available.-                ---                -- 'Quantity' component:-                -- Are we checking a runtime-irrelevant thing? (='Quantity0')-                -- Then runtime-irrelevant things are usable.-                -- Other value: @Quantity1@, runtime relevant.-                -- @Quantityω@ is not allowed here, see Bob Atkey, LiCS 2018.-          , envSplitOnStrict       :: Bool-                -- ^ Are we currently case-splitting on a strict-                --   datatype (i.e. in SSet)? If yes, the-                --   pattern-matching unifier will solve reflexive-                --   equations even --without-K.-          , envDisplayFormsEnabled :: Bool-                -- ^ Sometimes we want to disable display forms.-          , envRange :: Range-          , envHighlightingRange :: Range-                -- ^ Interactive highlighting uses this range rather-                --   than 'envRange'.-          , envClause :: IPClause-                -- ^ What is the current clause we are type-checking?-                --   Will be recorded in interaction points in this clause.-          , envCall  :: Maybe (Closure Call)-                -- ^ what we're doing at the moment-          , envHighlightingLevel  :: HighlightingLevel-                -- ^ Set to 'None' when imported modules are-                --   type-checked.-          , envHighlightingMethod :: HighlightingMethod-          , envExpandLast :: ExpandHidden-                -- ^ When type-checking an alias f=e, we do not want-                -- to insert hidden arguments in the end, because-                -- these will become unsolved metas.-          , envAppDef :: Maybe QName-                -- ^ We are reducing an application of this function.-                -- (For debugging of incomplete matches only.)-          , envSimplification :: Simplification-                -- ^ Did we encounter a simplification (proper match)-                --   during the current reduction process?-          , envAllowedReductions :: AllowedReductions-          , envReduceDefs :: ReduceDefs-          , envReconstructed :: Bool-          , envInjectivityDepth :: Int-                -- ^ Injectivity can cause non-termination for unsolvable contraints-                --   (#431, #3067). Keep a limit on the nesting depth of injectivity-                --   uses.-          , envCompareBlocked :: Bool-                -- ^ When @True@, the conversion checker will consider-                --   all term constructors as injective, including-                --   blocked function applications and metas. Warning:-                --   this should only be used when not assigning any-                --   metas (e.g. when @envAssignMetas@ is @False@ or-                --   when running @pureEqualTerms@) or else we get-                --   non-unique meta solutions.-          , envPrintDomainFreePi :: Bool-                -- ^ When @True@, types will be omitted from printed pi types if they-                --   can be inferred.-          , envPrintMetasBare :: Bool-                -- ^ When @True@, throw away meta numbers and meta elims.-                --   This is used for reifying terms for feeding into the-                --   user's source code, e.g., for the interaction tactics @solveAll@.-          , envInsideDotPattern :: Bool-                -- ^ Used by the scope checker to make sure that certain forms-                --   of expressions are not used inside dot patterns: extended-                --   lambdas and let-expressions.-          , envUnquoteFlags :: UnquoteFlags-          , envInstanceDepth :: !Int-                -- ^ Until we get a termination checker for instance search (#1743) we-                --   limit the search depth to ensure termination.-          , envIsDebugPrinting :: Bool-          , envPrintingPatternLambdas :: [QName]-                -- ^ #3004: pattern lambdas with copatterns may refer to themselves. We-                --   don't have a good story for what to do in this case, but at least-                --   printing shouldn't loop. Here we keep track of which pattern lambdas-                --   we are currently in the process of printing.-          , envCallByNeed :: Bool-                -- ^ Use call-by-need evaluation for reductions.-          , envCurrentCheckpoint :: CheckpointId-                -- ^ Checkpoints track the evolution of the context as we go-                -- under binders or refine it by pattern matching.-          , envCheckpoints :: Map CheckpointId Substitution-                -- ^ Keeps the substitution from each previous checkpoint to-                --   the current context.-          , envGeneralizeMetas :: DoGeneralize-                -- ^ Should new metas generalized over.-          , envGeneralizedVars :: Map QName GeneralizedValue-                -- ^ Values for used generalizable variables.-          , envActiveBackendName :: Maybe BackendName-                -- ^ Is some backend active at the moment, and if yes, which?-                --   NB: we only store the 'BackendName' here, otherwise-                --   @instance Data TCEnv@ is not derivable.-                --   The actual backend can be obtained from the name via 'stBackends'.-          , envConflComputingOverlap :: Bool-                -- ^ Are we currently computing the overlap between-                --   two rewrite rules for the purpose of confluence checking?-          , envCurrentlyElaborating :: Bool-                -- ^ Are we currently in the process of executing an-                --   elaborate-and-give interactive command?-          }-    deriving (Generic)--initEnv :: TCEnv-initEnv = TCEnv { envContext             = []-                , envLetBindings         = Map.empty-                , envCurrentModule       = noModuleName-                , envCurrentPath         = Nothing-                , envAnonymousModules    = []-                , envImportPath          = []-                , envMutualBlock         = Nothing-                , envTerminationCheck    = TerminationCheck-                , envCoverageCheck       = YesCoverageCheck-                , envMakeCase            = False-                , envSolvingConstraints  = False-                , envCheckingWhere       = False-                , envActiveProblems      = Set.empty-                , envWorkingOnTypes      = False-                , envAssignMetas         = True-                , envAbstractMode        = ConcreteMode-  -- Andreas, 2013-02-21:  This was 'AbstractMode' until now.-  -- However, top-level checks for mutual blocks, such as-  -- constructor-headedness, should not be able to look into-  -- abstract definitions unless abstract themselves.-  -- (See also discussion on issue 796.)-  -- The initial mode should be 'ConcreteMode', ensuring you-  -- can only look into abstract things in an abstract-  -- definition (which sets 'AbstractMode').-                , envModality               = unitModality-                , envSplitOnStrict          = False-                , envDisplayFormsEnabled    = True-                , envRange                  = noRange-                , envHighlightingRange      = noRange-                , envClause                 = IPNoClause-                , envCall                   = Nothing-                , envHighlightingLevel      = None-                , envHighlightingMethod     = Indirect-                , envExpandLast             = ExpandLast-                , envAppDef                 = Nothing-                , envSimplification         = NoSimplification-                , envAllowedReductions      = allReductions-                , envReduceDefs             = reduceAllDefs-                , envReconstructed          = False-                , envInjectivityDepth       = 0-                , envCompareBlocked         = False-                , envPrintDomainFreePi      = False-                , envPrintMetasBare         = False-                , envInsideDotPattern       = False-                , envUnquoteFlags           = defaultUnquoteFlags-                , envInstanceDepth          = 0-                , envIsDebugPrinting        = False-                , envPrintingPatternLambdas = []-                , envCallByNeed             = True-                , envCurrentCheckpoint      = 0-                , envCheckpoints            = Map.singleton 0 IdS-                , envGeneralizeMetas        = NoGeneralize-                , envGeneralizedVars        = Map.empty-                , envActiveBackendName      = Nothing-                , envConflComputingOverlap  = False-                , envCurrentlyElaborating   = False-                }--class LensTCEnv a where-  lensTCEnv :: Lens' TCEnv a--instance LensTCEnv TCEnv where-  lensTCEnv = id--instance LensModality TCEnv where-  -- Cohesion shouldn't have an environment component.-  getModality = setCohesion defaultCohesion . envModality-  mapModality f e = e { envModality = setCohesion defaultCohesion $ f $ envModality e }--instance LensRelevance TCEnv where-instance LensQuantity  TCEnv where--data UnquoteFlags = UnquoteFlags-  { _unquoteNormalise :: Bool }-  deriving (Data, Generic)--defaultUnquoteFlags :: UnquoteFlags-defaultUnquoteFlags = UnquoteFlags-  { _unquoteNormalise = False }--unquoteNormalise :: Lens' Bool UnquoteFlags-unquoteNormalise f e = f (_unquoteNormalise e) <&> \ x -> e { _unquoteNormalise = x }--eUnquoteNormalise :: Lens' Bool TCEnv-eUnquoteNormalise = eUnquoteFlags . unquoteNormalise---- * e-prefixed lenses---------------------------------------------------------------------------eContext :: Lens' Context TCEnv-eContext f e = f (envContext e) <&> \ x -> e { envContext = x }--eLetBindings :: Lens' LetBindings TCEnv-eLetBindings f e = f (envLetBindings e) <&> \ x -> e { envLetBindings = x }--eCurrentModule :: Lens' ModuleName TCEnv-eCurrentModule f e = f (envCurrentModule e) <&> \ x -> e { envCurrentModule = x }--eCurrentPath :: Lens' (Maybe AbsolutePath) TCEnv-eCurrentPath f e = f (envCurrentPath e) <&> \ x -> e { envCurrentPath = x }--eAnonymousModules :: Lens' [(ModuleName, Nat)] TCEnv-eAnonymousModules f e = f (envAnonymousModules e) <&> \ x -> e { envAnonymousModules = x }--eImportPath :: Lens' [C.TopLevelModuleName] TCEnv-eImportPath f e = f (envImportPath e) <&> \ x -> e { envImportPath = x }--eMutualBlock :: Lens' (Maybe MutualId) TCEnv-eMutualBlock f e = f (envMutualBlock e) <&> \ x -> e { envMutualBlock = x }--eTerminationCheck :: Lens' (TerminationCheck ()) TCEnv-eTerminationCheck f e = f (envTerminationCheck e) <&> \ x -> e { envTerminationCheck = x }--eCoverageCheck :: Lens' CoverageCheck TCEnv-eCoverageCheck f e = f (envCoverageCheck e) <&> \ x -> e { envCoverageCheck = x }--eMakeCase :: Lens' Bool TCEnv-eMakeCase f e = f (envMakeCase e) <&> \ x -> e { envMakeCase = x }--eSolvingConstraints :: Lens' Bool TCEnv-eSolvingConstraints f e = f (envSolvingConstraints e) <&> \ x -> e { envSolvingConstraints = x }--eCheckingWhere :: Lens' Bool TCEnv-eCheckingWhere f e = f (envCheckingWhere e) <&> \ x -> e { envCheckingWhere = x }--eWorkingOnTypes :: Lens' Bool TCEnv-eWorkingOnTypes f e = f (envWorkingOnTypes e) <&> \ x -> e { envWorkingOnTypes = x }--eAssignMetas :: Lens' Bool TCEnv-eAssignMetas f e = f (envAssignMetas e) <&> \ x -> e { envAssignMetas = x }--eActiveProblems :: Lens' (Set ProblemId) TCEnv-eActiveProblems f e = f (envActiveProblems e) <&> \ x -> e { envActiveProblems = x }--eAbstractMode :: Lens' AbstractMode TCEnv-eAbstractMode f e = f (envAbstractMode e) <&> \ x -> e { envAbstractMode = x }---- Andrea 23/02/2020: use get/setModality to enforce invariants of the---                    envModality field.-eModality :: Lens' Modality TCEnv-eModality f e = f (getModality e) <&> \ x -> setModality x e--eRelevance :: Lens' Relevance TCEnv-eRelevance = eModality . lModRelevance--eQuantity :: Lens' Quantity TCEnv-eQuantity = eModality . lModQuantity--eSplitOnStrict :: Lens' Bool TCEnv-eSplitOnStrict f e = f (envSplitOnStrict e) <&> \ x -> e { envSplitOnStrict = x }--eDisplayFormsEnabled :: Lens' Bool TCEnv-eDisplayFormsEnabled f e = f (envDisplayFormsEnabled e) <&> \ x -> e { envDisplayFormsEnabled = x }--eRange :: Lens' Range TCEnv-eRange f e = f (envRange e) <&> \ x -> e { envRange = x }--eHighlightingRange :: Lens' Range TCEnv-eHighlightingRange f e = f (envHighlightingRange e) <&> \ x -> e { envHighlightingRange = x }--eCall :: Lens' (Maybe (Closure Call)) TCEnv-eCall f e = f (envCall e) <&> \ x -> e { envCall = x }--eHighlightingLevel :: Lens' HighlightingLevel TCEnv-eHighlightingLevel f e = f (envHighlightingLevel e) <&> \ x -> e { envHighlightingLevel = x }--eHighlightingMethod :: Lens' HighlightingMethod TCEnv-eHighlightingMethod f e = f (envHighlightingMethod e) <&> \ x -> e { envHighlightingMethod = x }--eExpandLast :: Lens' ExpandHidden TCEnv-eExpandLast f e = f (envExpandLast e) <&> \ x -> e { envExpandLast = x }--eAppDef :: Lens' (Maybe QName) TCEnv-eAppDef f e = f (envAppDef e) <&> \ x -> e { envAppDef = x }--eSimplification :: Lens' Simplification TCEnv-eSimplification f e = f (envSimplification e) <&> \ x -> e { envSimplification = x }--eAllowedReductions :: Lens' AllowedReductions TCEnv-eAllowedReductions f e = f (envAllowedReductions e) <&> \ x -> e { envAllowedReductions = x }--eReduceDefs :: Lens' ReduceDefs TCEnv-eReduceDefs f e = f (envReduceDefs e) <&> \ x -> e { envReduceDefs = x }--eReconstructed :: Lens' Bool TCEnv-eReconstructed f e = f (envReconstructed e) <&> \ x -> e { envReconstructed = x }--eInjectivityDepth :: Lens' Int TCEnv-eInjectivityDepth f e = f (envInjectivityDepth e) <&> \ x -> e { envInjectivityDepth = x }--eCompareBlocked :: Lens' Bool TCEnv-eCompareBlocked f e = f (envCompareBlocked e) <&> \ x -> e { envCompareBlocked = x }--ePrintDomainFreePi :: Lens' Bool TCEnv-ePrintDomainFreePi f e = f (envPrintDomainFreePi e) <&> \ x -> e { envPrintDomainFreePi = x }--ePrintMetasBare :: Lens' Bool TCEnv-ePrintMetasBare f e = f (envPrintMetasBare e) <&> \ x -> e { envPrintMetasBare = x }--eInsideDotPattern :: Lens' Bool TCEnv-eInsideDotPattern f e = f (envInsideDotPattern e) <&> \ x -> e { envInsideDotPattern = x }--eUnquoteFlags :: Lens' UnquoteFlags TCEnv-eUnquoteFlags f e = f (envUnquoteFlags e) <&> \ x -> e { envUnquoteFlags = x }--eInstanceDepth :: Lens' Int TCEnv-eInstanceDepth f e = f (envInstanceDepth e) <&> \ x -> e { envInstanceDepth = x }--eIsDebugPrinting :: Lens' Bool TCEnv-eIsDebugPrinting f e = f (envIsDebugPrinting e) <&> \ x -> e { envIsDebugPrinting = x }--ePrintingPatternLambdas :: Lens' [QName] TCEnv-ePrintingPatternLambdas f e = f (envPrintingPatternLambdas e) <&> \ x -> e { envPrintingPatternLambdas = x }--eCallByNeed :: Lens' Bool TCEnv-eCallByNeed f e = f (envCallByNeed e) <&> \ x -> e { envCallByNeed = x }--eCurrentCheckpoint :: Lens' CheckpointId TCEnv-eCurrentCheckpoint f e = f (envCurrentCheckpoint e) <&> \ x -> e { envCurrentCheckpoint = x }--eCheckpoints :: Lens' (Map CheckpointId Substitution) TCEnv-eCheckpoints f e = f (envCheckpoints e) <&> \ x -> e { envCheckpoints = x }--eGeneralizeMetas :: Lens' DoGeneralize TCEnv-eGeneralizeMetas f e = f (envGeneralizeMetas e) <&> \ x -> e { envGeneralizeMetas = x }--eGeneralizedVars :: Lens' (Map QName GeneralizedValue) TCEnv-eGeneralizedVars f e = f (envGeneralizedVars e) <&> \ x -> e { envGeneralizedVars = x }--eActiveBackendName :: Lens' (Maybe BackendName) TCEnv-eActiveBackendName f e = f (envActiveBackendName e) <&> \ x -> e { envActiveBackendName = x }--eConflComputingOverlap :: Lens' Bool TCEnv-eConflComputingOverlap f e = f (envConflComputingOverlap e) <&> \ x -> e { envConflComputingOverlap = x }--eCurrentlyElaborating :: Lens' Bool TCEnv-eCurrentlyElaborating f e = f (envCurrentlyElaborating e) <&> \ x -> e { envCurrentlyElaborating = x }-------------------------------------------------------------------------------- ** Context-------------------------------------------------------------------------------- | The @Context@ is a stack of 'ContextEntry's.-type Context      = [ContextEntry]-type ContextEntry = Dom (Name, Type)-------------------------------------------------------------------------------- ** Let bindings------------------------------------------------------------------------------type LetBindings = Map Name (Open (Term, Dom Type))-------------------------------------------------------------------------------- ** Abstract mode------------------------------------------------------------------------------data AbstractMode-  = AbstractMode        -- ^ Abstract things in the current module can be accessed.-  | ConcreteMode        -- ^ No abstract things can be accessed.-  | IgnoreAbstractMode  -- ^ All abstract things can be accessed.-  deriving (Data, Show, Eq, Generic)--aDefToMode :: IsAbstract -> AbstractMode-aDefToMode AbstractDef = AbstractMode-aDefToMode ConcreteDef = ConcreteMode--aModeToDef :: AbstractMode -> Maybe IsAbstract-aModeToDef AbstractMode = Just AbstractDef-aModeToDef ConcreteMode = Just ConcreteDef-aModeToDef _ = Nothing-------------------------------------------------------------------------------- ** Insertion of implicit arguments------------------------------------------------------------------------------data ExpandHidden-  = ExpandLast      -- ^ Add implicit arguments in the end until type is no longer hidden 'Pi'.-  | DontExpandLast  -- ^ Do not append implicit arguments.-  | ReallyDontExpandLast -- ^ Makes 'doExpandLast' have no effect. Used to avoid implicit insertion of arguments to metavariables.-  deriving (Eq, Data, Generic)--isDontExpandLast :: ExpandHidden -> Bool-isDontExpandLast ExpandLast           = False-isDontExpandLast DontExpandLast       = True-isDontExpandLast ReallyDontExpandLast = True--data CandidateKind-  = LocalCandidate-  | GlobalCandidate QName-  deriving (Show, Data, Generic)---- | A candidate solution for an instance meta is a term with its type.---   It may be the case that the candidate is not fully applied yet or---   of the wrong type, hence the need for the type.-data Candidate  = Candidate { candidateKind :: CandidateKind-                            , candidateTerm :: Term-                            , candidateType :: Type-                            , candidateOverlappable :: Bool-                            }-  deriving (Show, Data, Generic)--instance Free Candidate where-  freeVars' (Candidate _ t u _) = freeVars' (t, u)--------------------------------------------------------------------------------- ** Checking arguments------------------------------------------------------------------------------data ArgsCheckState a = ACState-       { acRanges :: [Maybe Range]-         -- ^ Ranges of checked arguments, where present.-         -- e.g. inserted implicits have no correponding abstract syntax.-       , acElims  :: Elims-         -- ^ Checked and inserted arguments so far.-       , acConstraints :: [Maybe (Abs Constraint)]-         -- ^ Constraints for the head so far,-         -- i.e. before applying the correponding elim.-       , acType   :: Type-         -- ^ Type for the rest of the application.-       , acData   :: a-       }-  deriving (Show)--------------------------------------------------------------------------------- * Type checking warnings (aka non-fatal errors)-------------------------------------------------------------------------------- | A non-fatal error is an error which does not prevent us from--- checking the document further and interacting with the user.--data Warning-  = NicifierIssue            DeclarationWarning-  | TerminationIssue         [TerminationError]-  | UnreachableClauses       QName [Range]-  -- ^ `UnreachableClauses f rs` means that the clauses in `f` whose ranges are rs-  --   are unreachable-  | CoverageIssue            QName [(Telescope, [NamedArg DeBruijnPattern])]-  -- ^ `CoverageIssue f pss` means that `pss` are not covered in `f`-  | CoverageNoExactSplit     QName [Clause]-  | NotStrictlyPositive      QName (Seq OccursWhere)-  | UnsolvedMetaVariables    [Range]  -- ^ Do not use directly with 'warning'-  | UnsolvedInteractionMetas [Range]  -- ^ Do not use directly with 'warning'-  | UnsolvedConstraints      Constraints-    -- ^ Do not use directly with 'warning'-  | CantGeneralizeOverSorts [MetaId]-  | AbsurdPatternRequiresNoRHS [NamedArg DeBruijnPattern]-  | OldBuiltin               String String-    -- ^ In `OldBuiltin old new`, the BUILTIN old has been replaced by new-  | EmptyRewritePragma-    -- ^ If the user wrote just @{-\# REWRITE \#-}@.-  | EmptyWhere-    -- ^ An empty @where@ block is dead code.-  | IllformedAsClause String-    -- ^ If the user wrote something other than an unqualified name-    --   in the @as@ clause of an @import@ statement.-    --   The 'String' gives optionally extra explanation.-  | ClashesViaRenaming NameOrModule [C.Name]-    -- ^ If a `renaming' import directive introduces a name or module name clash-    --   in the exported names of a module.-    --   (See issue #4154.)-  | UselessPatternDeclarationForRecord String-    -- ^ The 'pattern' declaration is useless in the presence-    --   of either @coinductive@ or @eta-equality@.-    --   Content of 'String' is "coinductive" or "eta", resp.-  | UselessPublic-    -- ^ If the user opens a module public before the module header.-    --   (See issue #2377.)-  | UselessHiding [C.ImportedName]-    -- ^ Names in `hiding` directive that don't hide anything-    --   imported by a `using` directive.-  | UselessInline            QName-  | WrongInstanceDeclaration-  | InstanceWithExplicitArg  QName-  -- ^ An instance was declared with an implicit argument, which means it-  --   will never actually be considered by instance search.-  | InstanceNoOutputTypeName Doc-  -- ^ The type of an instance argument doesn't end in a named or-  -- variable type, so it will never be considered by instance search.-  | InstanceArgWithExplicitArg Doc-  -- ^ As InstanceWithExplicitArg, but for local bindings rather than-  --   top-level instances.-  | InversionDepthReached    QName-  -- ^ The --inversion-max-depth was reached.-  | NoGuardednessFlag        QName-  -- ^ A coinductive record was declared but neither --guardedness nor-  --   --sized-types is enabled.--  -- Generic warnings for one-off things-  | GenericWarning           Doc-    -- ^ Harmless generic warning (not an error)-  | GenericNonFatalError     Doc-    -- ^ Generic error which doesn't abort proceedings (not a warning)-  | GenericUseless  Range    Doc-    -- ^ Generic warning when code is useless and thus ignored.-    --   'Range' is for dead code highlighting.--  -- Safe flag errors-  | SafeFlagPostulate C.Name-  | SafeFlagPragma [String]                -- ^ Unsafe OPTIONS.-  | SafeFlagNonTerminating-  | SafeFlagTerminating-  | SafeFlagWithoutKFlagPrimEraseEquality-  | WithoutKFlagPrimEraseEquality-  | SafeFlagNoPositivityCheck-  | SafeFlagPolarity-  | SafeFlagNoUniverseCheck-  | SafeFlagNoCoverageCheck-  | SafeFlagInjective-  | SafeFlagEta                            -- ^ ETA pragma is unsafe.-  | ParseWarning             ParseWarning-  | LibraryWarning           LibWarning-  | DeprecationWarning String String String-    -- ^ `DeprecationWarning old new version`:-    --   `old` is deprecated, use `new` instead. This will be an error in Agda `version`.-  | UserWarning Text-    -- ^ User-defined warning (e.g. to mention that a name is deprecated)-  | DuplicateUsing (List1 C.ImportedName)-    -- ^ Duplicate mentions of the same name in @using@ directive(s).-  | FixityInRenamingModule (List1 Range)-    -- ^ Fixity of modules cannot be changed via renaming (since modules have no fixity).-  | ModuleDoesntExport C.QName [C.Name] [C.Name] [C.ImportedName]-    -- ^ Some imported names are not actually exported by the source module.-    --   The second argument is the names that could be exported.-    --   The third  argument is the module names that could be exported.-  | InfectiveImport String ModuleName-    -- ^ Importing a file using an infective option into one which doesn't-  | CoInfectiveImport String ModuleName-    -- ^ Importing a file not using a coinfective option from one which does-  | RewriteNonConfluent Term Term Term Doc-    -- ^ Confluence checker found critical pair and equality checking-    --   resulted in a type error-  | RewriteMaybeNonConfluent Term Term [Doc]-    -- ^ Confluence checker got stuck on computing overlap between two-    --   rewrite rules-  | RewriteAmbiguousRules Term Term Term-    -- ^ The global confluence checker found a term @u@ that reduces-    --   to both @v1@ and @v2@ and there is no rule to resolve the-    --   ambiguity.-  | RewriteMissingRule Term Term Term-    -- ^ The global confluence checker found a term @u@ that reduces-    --   to @v@, but @v@ does not reduce to @rho(u)@.-  | PragmaCompileErased BackendName QName-    -- ^ COMPILE directive for an erased symbol-  | NotInScopeW [C.QName]-    -- ^ Out of scope error we can recover from-  | AsPatternShadowsConstructorOrPatternSynonym Bool-    -- ^ The as-name in an as-pattern may not shadow a constructor (@False@)-    --   or pattern synonym name (@True@),-    --   because this can be confusing to read.-  | RecordFieldWarning RecordFieldWarning-  deriving (Show, Generic)--data RecordFieldWarning-  = DuplicateFieldsWarning [(C.Name, Range)]-      -- ^ Each redundant field comes with a range of associated dead code.-  | TooManyFieldsWarning QName [C.Name] [(C.Name, Range)]-      -- ^ Record type, fields not supplied by user, non-fields but supplied.-      --   The redundant fields come with a range of associated dead code.-  deriving (Show, Data, Generic)--recordFieldWarningToError :: RecordFieldWarning -> TypeError-recordFieldWarningToError = \case-  DuplicateFieldsWarning    xrs -> DuplicateFields    $ map fst xrs-  TooManyFieldsWarning q ys xrs -> TooManyFields q ys $ map fst xrs--warningName :: Warning -> WarningName-warningName = \case-  -- special cases-  NicifierIssue dw             -> declarationWarningName dw-  ParseWarning pw              -> parseWarningName pw-  LibraryWarning lw            -> libraryWarningName lw-  AsPatternShadowsConstructorOrPatternSynonym{} -> AsPatternShadowsConstructorOrPatternSynonym_-  -- scope- and type-checking errors-  AbsurdPatternRequiresNoRHS{} -> AbsurdPatternRequiresNoRHS_-  CantGeneralizeOverSorts{}    -> CantGeneralizeOverSorts_-  CoverageIssue{}              -> CoverageIssue_-  CoverageNoExactSplit{}       -> CoverageNoExactSplit_-  DeprecationWarning{}         -> DeprecationWarning_-  EmptyRewritePragma           -> EmptyRewritePragma_-  EmptyWhere                   -> EmptyWhere_-  IllformedAsClause{}          -> IllformedAsClause_-  WrongInstanceDeclaration{}   -> WrongInstanceDeclaration_-  InstanceWithExplicitArg{}    -> InstanceWithExplicitArg_-  InstanceNoOutputTypeName{}   -> InstanceNoOutputTypeName_-  InstanceArgWithExplicitArg{} -> InstanceArgWithExplicitArg_-  DuplicateUsing{}             -> DuplicateUsing_-  FixityInRenamingModule{}     -> FixityInRenamingModule_-  GenericNonFatalError{}       -> GenericNonFatalError_-  GenericUseless{}             -> GenericUseless_-  GenericWarning{}             -> GenericWarning_-  InversionDepthReached{}      -> InversionDepthReached_-  ModuleDoesntExport{}         -> ModuleDoesntExport_-  NoGuardednessFlag{}          -> NoGuardednessFlag_-  NotInScopeW{}                -> NotInScope_-  NotStrictlyPositive{}        -> NotStrictlyPositive_-  OldBuiltin{}                 -> OldBuiltin_-  SafeFlagNoPositivityCheck    -> SafeFlagNoPositivityCheck_-  SafeFlagNonTerminating       -> SafeFlagNonTerminating_-  SafeFlagNoUniverseCheck      -> SafeFlagNoUniverseCheck_-  SafeFlagPolarity             -> SafeFlagPolarity_-  SafeFlagPostulate{}          -> SafeFlagPostulate_-  SafeFlagPragma{}             -> SafeFlagPragma_-  SafeFlagEta                  -> SafeFlagEta_-  SafeFlagInjective            -> SafeFlagInjective_-  SafeFlagNoCoverageCheck      -> SafeFlagNoCoverageCheck_-  SafeFlagWithoutKFlagPrimEraseEquality -> SafeFlagWithoutKFlagPrimEraseEquality_-  WithoutKFlagPrimEraseEquality -> WithoutKFlagPrimEraseEquality_-  SafeFlagTerminating          -> SafeFlagTerminating_-  TerminationIssue{}           -> TerminationIssue_-  UnreachableClauses{}         -> UnreachableClauses_-  UnsolvedInteractionMetas{}   -> UnsolvedInteractionMetas_-  UnsolvedConstraints{}        -> UnsolvedConstraints_-  UnsolvedMetaVariables{}      -> UnsolvedMetaVariables_-  UselessHiding{}              -> UselessHiding_-  UselessInline{}              -> UselessInline_-  UselessPublic{}              -> UselessPublic_-  UselessPatternDeclarationForRecord{} -> UselessPatternDeclarationForRecord_-  ClashesViaRenaming{}         -> ClashesViaRenaming_-  UserWarning{}                -> UserWarning_-  InfectiveImport{}            -> InfectiveImport_-  CoInfectiveImport{}          -> CoInfectiveImport_-  RewriteNonConfluent{}        -> RewriteNonConfluent_-  RewriteMaybeNonConfluent{}   -> RewriteMaybeNonConfluent_-  RewriteAmbiguousRules{}      -> RewriteAmbiguousRules_-  RewriteMissingRule{}         -> RewriteMissingRule_-  PragmaCompileErased{}        -> PragmaCompileErased_-  -- record field warnings-  RecordFieldWarning w -> case w of-    DuplicateFieldsWarning{}   -> DuplicateFieldsWarning_-    TooManyFieldsWarning{}     -> TooManyFieldsWarning_--data TCWarning-  = TCWarning-    { tcWarningLocation :: CallStack-        -- ^ Location in the internal Agda source code location where the error raised-    , tcWarningRange    :: Range-        -- ^ Range where the warning was raised-    , tcWarning         :: Warning-        -- ^ The warning itself-    , tcWarningPrintedWarning :: Doc-        -- ^ The warning printed in the state and environment where it was raised-    , tcWarningCached :: Bool-        -- ^ Should the warning be affected by caching.-    }-  deriving (Show, Generic)--tcWarningOrigin :: TCWarning -> SrcFile-tcWarningOrigin = rangeFile . tcWarningRange--instance HasRange TCWarning where-  getRange = tcWarningRange---- used for merging lists of warnings-instance Eq TCWarning where-  (==) = (==) `on` tcWarningPrintedWarning-------------------------------------------------------------------------------- * Type checking errors-------------------------------------------------------------------------------- | Information about a call.--data CallInfo = CallInfo-  { callInfoTarget :: QName-    -- ^ Target function name.-  , callInfoRange :: Range-    -- ^ Range of the target function.-  , callInfoCall :: Closure Term-    -- ^ To be formatted representation of the call.-  } deriving (Show, Generic)-    -- no Eq, Ord instances: too expensive! (see issues 851, 852)---- | We only 'show' the name of the callee.-instance Pretty CallInfo where pretty = pretty . callInfoTarget---- | Information about a mutual block which did not pass the--- termination checker.--data TerminationError = TerminationError-  { termErrFunctions :: [QName]-    -- ^ The functions which failed to check. (May not include-    -- automatically generated functions.)-  , termErrCalls :: [CallInfo]-    -- ^ The problematic call sites.-  } deriving (Show, Generic)---- | Error when splitting a pattern variable into possible constructor patterns.-data SplitError-  = NotADatatype        (Closure Type)  -- ^ Neither data type nor record.-  | BlockedType Blocker (Closure Type)  -- ^ Type could not be sufficiently reduced.-  | ErasedDatatype Bool (Closure Type)  -- ^ Data type, but in erased position.-                                        --   If the boolean is 'True',-                                        --   then the reason for the-                                        --   error is that the K rule-                                        --   is turned off.-  | CoinductiveDatatype (Closure Type)  -- ^ Split on codata not allowed.-  -- UNUSED, but keep!-  -- -- | NoRecordConstructor Type  -- ^ record type, but no constructor-  | UnificationStuck-    { cantSplitBlocker  :: Maybe Blocker -- ^ Blocking metavariable (if any)-    , cantSplitConName  :: QName        -- ^ Constructor.-    , cantSplitTel      :: Telescope    -- ^ Context for indices.-    , cantSplitConIdx   :: Args         -- ^ Inferred indices (from type of constructor).-    , cantSplitGivenIdx :: Args         -- ^ Expected indices (from checking pattern).-    , cantSplitFailures :: [UnificationFailure] -- ^ Reason(s) why unification got stuck.-    }-  | CosplitCatchall-      -- ^ Copattern split with a catchall-  | CosplitNoTarget-      -- ^ We do not know the target type of the clause.-  | CosplitNoRecordType (Closure Type)-      -- ^ Target type is not a record type.-  | CannotCreateMissingClause QName (Telescope,[NamedArg DeBruijnPattern]) Doc (Closure (Abs Type))--  | GenericSplitError String-  deriving (Show, Generic)--data NegativeUnification-  = UnifyConflict Telescope Term Term-  | UnifyCycle Telescope Int Term-  deriving (Show, Generic)--data UnificationFailure-  = UnifyIndicesNotVars Telescope Type Term Term Args -- ^ Failed to apply injectivity to constructor of indexed datatype-  | UnifyRecursiveEq Telescope Type Int Term          -- ^ Can't solve equation because variable occurs in (type of) lhs-  | UnifyReflexiveEq Telescope Type Term              -- ^ Can't solve reflexive equation because --without-K is enabled-  | UnifyUnusableModality Telescope Type Int Term Modality  -- ^ Can't solve equation because solution modality is less "usable"-  deriving (Show, Generic)--data UnquoteError-  = BadVisibility String (Arg I.Term)-  | ConInsteadOfDef QName String String-  | DefInsteadOfCon QName String String-  | NonCanonical String I.Term-  | BlockedOnMeta TCState Blocker-  | UnquotePanic String-  deriving (Show, Generic)--data TypeError-        = InternalError String-        | NotImplemented String-        | NotSupported String-        | CompilationError String-        | PropMustBeSingleton-        | DataMustEndInSort Term-{- UNUSED-        | DataTooManyParameters-            -- ^ In @data D xs where@ the number of parameters @xs@ does not fit the-            --   the parameters given in the forward declaraion @data D Gamma : T@.--}-        | ShouldEndInApplicationOfTheDatatype Type-            -- ^ The target of a constructor isn't an application of its-            -- datatype. The 'Type' records what it does target.-        | ShouldBeAppliedToTheDatatypeParameters Term Term-            -- ^ The target of a constructor isn't its datatype applied to-            --   something that isn't the parameters. First term is the correct-            --   target and the second term is the actual target.-        | ShouldBeApplicationOf Type QName-            -- ^ Expected a type to be an application of a particular datatype.-        | ConstructorPatternInWrongDatatype QName QName -- ^ constructor, datatype-        | CantResolveOverloadedConstructorsTargetingSameDatatype QName (List1 QName)-          -- ^ Datatype, constructors.-        | DoesNotConstructAnElementOf QName Type -- ^ constructor, type-        | WrongHidingInLHS-            -- ^ The left hand side of a function definition has a hidden argument-            --   where a non-hidden was expected.-        | WrongHidingInLambda Type-            -- ^ Expected a non-hidden function and found a hidden lambda.-        | WrongHidingInApplication Type-            -- ^ A function is applied to a hidden argument where a non-hidden was expected.-        | WrongNamedArgument (NamedArg A.Expr) [NamedName]-            -- ^ A function is applied to a hidden named argument it does not have.-            -- The list contains names of possible hidden arguments at this point.-        | WrongIrrelevanceInLambda-            -- ^ Wrong user-given relevance annotation in lambda.-        | WrongQuantityInLambda-            -- ^ Wrong user-given quantity annotation in lambda.-        | WrongCohesionInLambda-            -- ^ Wrong user-given cohesion annotation in lambda.-        | QuantityMismatch Quantity Quantity-            -- ^ The given quantity does not correspond to the expected quantity.-        | HidingMismatch Hiding Hiding-            -- ^ The given hiding does not correspond to the expected hiding.-        | RelevanceMismatch Relevance Relevance-            -- ^ The given relevance does not correspond to the expected relevane.-        | UninstantiatedDotPattern A.Expr-        | ForcedConstructorNotInstantiated A.Pattern-        | IllformedProjectionPattern A.Pattern-        | CannotEliminateWithPattern (Maybe Blocker) (NamedArg A.Pattern) Type-        | WrongNumberOfConstructorArguments QName Nat Nat-        | ShouldBeEmpty Type [DeBruijnPattern]-        | ShouldBeASort Type-            -- ^ The given type should have been a sort.-        | ShouldBePi Type-            -- ^ The given type should have been a pi.-        | ShouldBePath Type-        | ShouldBeRecordType Type-        | ShouldBeRecordPattern DeBruijnPattern-        | NotAProjectionPattern (NamedArg A.Pattern)-        | NotAProperTerm-        | InvalidTypeSort Sort-            -- ^ This sort is not a type expression.-        | InvalidType Term-            -- ^ This term is not a type expression.-        | FunctionTypeInSizeUniv Term-            -- ^ This term, a function type constructor, lives in-            --   @SizeUniv@, which is not allowed.-        | SplitOnIrrelevant (Dom Type)-        | SplitOnUnusableCohesion (Dom Type)-        -- UNUSED: -- | SplitOnErased (Dom Type)-        | SplitOnNonVariable Term Type-        | SplitOnNonEtaRecord QName-        | DefinitionIsIrrelevant QName-        | DefinitionIsErased QName-        | VariableIsIrrelevant Name-        | VariableIsErased Name-        | VariableIsOfUnusableCohesion Name Cohesion-        | UnequalLevel Comparison Level Level-        | UnequalTerms Comparison Term Term CompareAs-        | UnequalTypes Comparison Type Type---      | UnequalTelescopes Comparison Telescope Telescope -- UNUSED-        | UnequalRelevance Comparison Term Term-            -- ^ The two function types have different relevance.-        | UnequalQuantity Comparison Term Term-            -- ^ The two function types have different relevance.-        | UnequalCohesion Comparison Term Term-            -- ^ The two function types have different cohesion.-        | UnequalHiding Term Term-            -- ^ The two function types have different hiding.-        | UnequalSorts Sort Sort-        | UnequalBecauseOfUniverseConflict Comparison Term Term-        | NotLeqSort Sort Sort-        | MetaCannotDependOn MetaId Nat-            -- ^ The arguments are the meta variable and the parameter that it wants to depend on.-        | MetaOccursInItself MetaId-        | MetaIrrelevantSolution MetaId Term-        | MetaErasedSolution MetaId Term-        | GenericError String-        | GenericDocError Doc-        | SortOfSplitVarError (Maybe Blocker) Doc-          -- ^ the meta is what we might be blocked on.-        | BuiltinMustBeConstructor String A.Expr-        | NoSuchBuiltinName String-        | DuplicateBuiltinBinding String Term Term-        | NoBindingForBuiltin String-        | NoSuchPrimitiveFunction String-        | DuplicatePrimitiveBinding String QName QName-        | WrongModalityForPrimitive String ArgInfo ArgInfo-        | ShadowedModule C.Name [A.ModuleName]-        | BuiltinInParameterisedModule String-        | IllegalLetInTelescope C.TypedBinding-        | IllegalPatternInTelescope C.Binder-        | NoRHSRequiresAbsurdPattern [NamedArg A.Pattern]-        | TooManyFields QName [C.Name] [C.Name]-          -- ^ Record type, fields not supplied by user, non-fields but supplied.-        | DuplicateFields [C.Name]-        | DuplicateConstructors [C.Name]-        | WithOnFreeVariable A.Expr Term-        | UnexpectedWithPatterns [A.Pattern]-        | WithClausePatternMismatch A.Pattern (NamedArg DeBruijnPattern)-        | FieldOutsideRecord-        | ModuleArityMismatch A.ModuleName Telescope [NamedArg A.Expr]-        | GeneralizeCyclicDependency-        | GeneralizeUnsolvedMeta-    -- Coverage errors--- UNUSED:        | IncompletePatternMatching Term [Elim] -- can only happen if coverage checking is switched off-        | SplitError SplitError-        | ImpossibleConstructor QName NegativeUnification-    -- Positivity errors-        | TooManyPolarities QName Int-    -- Import errors-        | LocalVsImportedModuleClash ModuleName-        | SolvedButOpenHoles-          -- ^ Some interaction points (holes) have not been filled by user.-          --   There are not 'UnsolvedMetas' since unification solved them.-          --   This is an error, since interaction points are never filled-          --   without user interaction.-        | CyclicModuleDependency [C.TopLevelModuleName]-        | FileNotFound C.TopLevelModuleName [AbsolutePath]-        | OverlappingProjects AbsolutePath C.TopLevelModuleName C.TopLevelModuleName-        | AmbiguousTopLevelModuleName C.TopLevelModuleName [AbsolutePath]-        | ModuleNameUnexpected C.TopLevelModuleName C.TopLevelModuleName-          -- ^ Found module name, expected module name.-        | ModuleNameDoesntMatchFileName C.TopLevelModuleName [AbsolutePath]-        | ClashingFileNamesFor ModuleName [AbsolutePath]-        | ModuleDefinedInOtherFile C.TopLevelModuleName AbsolutePath AbsolutePath-          -- ^ Module name, file from which it was loaded, file which-          -- the include path says contains the module.-    -- Scope errors-        | BothWithAndRHS-        | AbstractConstructorNotInScope A.QName-        | NotInScope [C.QName]-        | NoSuchModule C.QName-        | AmbiguousName C.QName (List1 A.QName)-        | AmbiguousModule C.QName (List1 A.ModuleName)-        | ClashingDefinition C.QName A.QName (Maybe NiceDeclaration)-        | ClashingModule A.ModuleName A.ModuleName-        | ClashingImport C.Name A.QName-        | ClashingModuleImport C.Name A.ModuleName-        | PatternShadowsConstructor C.Name A.QName-        | DuplicateImports C.QName [C.ImportedName]-        | InvalidPattern C.Pattern-        | RepeatedVariablesInPattern [C.Name]-        | GeneralizeNotSupportedHere A.QName-        | MultipleFixityDecls [(C.Name, [Fixity'])]-        | MultiplePolarityPragmas [C.Name]-    -- Concrete to Abstract errors-        | NotAModuleExpr C.Expr-            -- ^ The expr was used in the right hand side of an implicit module-            --   definition, but it wasn't of the form @m Delta@.-        | NotAnExpression C.Expr-        | NotAValidLetBinding NiceDeclaration-        | NotValidBeforeField NiceDeclaration-        | NothingAppliedToHiddenArg C.Expr-        | NothingAppliedToInstanceArg C.Expr-    -- Pattern synonym errors-        | BadArgumentsToPatternSynonym A.AmbiguousQName-        | TooFewArgumentsToPatternSynonym A.AmbiguousQName-        | CannotResolveAmbiguousPatternSynonym (List1 (A.QName, A.PatternSynDefn))-        | UnusedVariableInPatternSynonym-    -- Operator errors-        | NoParseForApplication (List2 C.Expr)-        | AmbiguousParseForApplication (List2 C.Expr) (List1 C.Expr)-        | NoParseForLHS LHSOrPatSyn [C.Pattern] C.Pattern-            -- ^ The list contains patterns that failed to be interpreted.-            --   If it is non-empty, the first entry could be printed as error hint.-        | AmbiguousParseForLHS LHSOrPatSyn C.Pattern [C.Pattern]-            -- ^ Pattern and its possible interpretations.-        | OperatorInformation [NotationSection] TypeError-{- UNUSED-        | NoParseForPatternSynonym C.Pattern-        | AmbiguousParseForPatternSynonym C.Pattern [C.Pattern]--}-    -- Usage errors-    -- Instance search errors-        | InstanceNoCandidate Type [(Term, TCErr)]-    -- Reflection errors-        | UnquoteFailed UnquoteError-        | DeBruijnIndexOutOfScope Nat Telescope [Name]-    -- Language option errors-        | NeedOptionCopatterns-        | NeedOptionRewriting-        | NeedOptionProp-        | NeedOptionTwoLevel-    -- Failure associated to warnings-        | NonFatalErrors [TCWarning]-    -- Instance search errors-        | InstanceSearchDepthExhausted Term Type Int-        | TriedToCopyConstrainedPrim QName-          deriving (Show, Generic)---- | Distinguish error message when parsing lhs or pattern synonym, resp.-data LHSOrPatSyn = IsLHS | IsPatSyn-  deriving (Eq, Show, Generic)---- | Type-checking errors.--data TCErr-  = TypeError-    { tcErrLocation :: CallStack-       -- ^ Location in the internal Agda source code where the error was raised-    , tcErrState    :: TCState-        -- ^ The state in which the error was raised.-    , tcErrClosErr  :: Closure TypeError-        -- ^ The environment in which the error as raised plus the error.-    }-  | Exception Range Doc-  | IOException TCState Range E.IOException-    -- ^ The first argument is the state in which the error was-    -- raised.-  | PatternErr Blocker-      -- ^ The exception which is usually caught.-      --   Raised for pattern violations during unification ('assignV')-      --   but also in other situations where we want to backtrack.-      --   Contains an unblocker to control when the computation should-      --   be retried.--instance Show TCErr where-  show (TypeError _ _ e)   = prettyShow (envRange $ clEnv e) ++ ": " ++ show (clValue e)-  show (Exception r d)     = prettyShow r ++ ": " ++ render d-  show (IOException _ r e) = prettyShow r ++ ": " ++ show e-  show PatternErr{}        = "Pattern violation (you shouldn't see this)"--instance HasRange TCErr where-  getRange (TypeError _ _ cl)  = envRange $ clEnv cl-  getRange (Exception r _)     = r-  getRange (IOException s r _) = r-  getRange PatternErr{}        = noRange--instance E.Exception TCErr---------------------------------------------------------------------------------- * Accessing options--------------------------------------------------------------------------------instance MonadIO m => HasOptions (TCMT m) where-  pragmaOptions = useTC stPragmaOptions--  commandLineOptions = do-    p  <- useTC stPragmaOptions-    cl <- stPersistentOptions . stPersistentState <$> getTC-    return $ cl { optPragmaOptions = p }---- HasOptions lifts through monad transformers--- (see default signatures in the HasOptions class).---- Ternary options are annoying to deal with so we provide auxiliary--- definitions using @collapseDefault@.--sizedTypesOption :: HasOptions m => m Bool-sizedTypesOption = collapseDefault . optSizedTypes <$> pragmaOptions--guardednessOption :: HasOptions m => m Bool-guardednessOption = collapseDefault . optGuardedness <$> pragmaOptions--withoutKOption :: HasOptions m => m Bool-withoutKOption = collapseDefault . optWithoutK <$> pragmaOptions--enableCaching :: HasOptions m => m Bool-enableCaching = optCaching <$> pragmaOptions--------------------------------------------------------------------------------- * The reduce monad---------------------------------------------------------------------------------- | Environment of the reduce monad.-data ReduceEnv = ReduceEnv-  { redEnv :: TCEnv    -- ^ Read only access to environment.-  , redSt  :: TCState  -- ^ Read only access to state (signature, metas...).-  }--mapRedEnv :: (TCEnv -> TCEnv) -> ReduceEnv -> ReduceEnv-mapRedEnv f s = s { redEnv = f (redEnv s) }--mapRedSt :: (TCState -> TCState) -> ReduceEnv -> ReduceEnv-mapRedSt f s = s { redSt = f (redSt s) }--mapRedEnvSt :: (TCEnv -> TCEnv) -> (TCState -> TCState) -> ReduceEnv-            -> ReduceEnv-mapRedEnvSt f g (ReduceEnv e s) = ReduceEnv (f e) (g s)---- Lenses-reduceEnv :: Lens' TCEnv ReduceEnv-reduceEnv f s = f (redEnv s) <&> \ e -> s { redEnv = e }--reduceSt :: Lens' TCState ReduceEnv-reduceSt f s = f (redSt s) <&> \ e -> s { redSt = e }--newtype ReduceM a = ReduceM { unReduceM :: ReduceEnv -> a }---  deriving (Functor, Applicative, Monad)--onReduceEnv :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a-onReduceEnv f (ReduceM m) = ReduceM (m . f)--fmapReduce :: (a -> b) -> ReduceM a -> ReduceM b-fmapReduce f (ReduceM m) = ReduceM $ \ e -> f $! m e-{-# INLINE fmapReduce #-}---- Andreas, 2021-05-12, issue #5379:--- It seems more stable to force to evaluate @mf <*> ma@--- from left to right, for the sake of printing--- debug messages in order.-apReduce :: ReduceM (a -> b) -> ReduceM a -> ReduceM b-apReduce (ReduceM f) (ReduceM x) = ReduceM $ \ e ->-  let g = f e-      a = x e-  in  g `pseq` a `pseq` g a-{-# INLINE apReduce #-}---- Andreas, 2021-05-12, issue #5379--- Since the MonadDebug instance of ReduceM is implemented via--- unsafePerformIO, we need to force results that later--- computations do not depend on, otherwise we lose debug messages.-thenReduce :: ReduceM a -> ReduceM b -> ReduceM b-thenReduce (ReduceM x) (ReduceM y) = ReduceM $ \ e -> x e `pseq` y e-{-# INLINE thenReduce #-}---- Andreas, 2021-05-14:--- `seq` does not force evaluation order, the optimizier is allowed to replace--- @---    a `seq` b`--- @--- by:--- @---    b `seq` a `seq` b--- @--- see https://hackage.haskell.org/package/parallel/docs/Control-Parallel.html------ In contrast, `pseq` is only strict in its first argument, so such a permutation--- is forbidden.--- If we want to ensure that debug messages are printed before exceptions are--- propagated, we need to use `pseq`, as in:--- @---    unsafePerformIO (putStrLn "Black hawk is going down...") `pseq` throw HitByRPG--- @-beforeReduce :: ReduceM a -> ReduceM b -> ReduceM a-beforeReduce (ReduceM x) (ReduceM y) = ReduceM $ \ e ->-  let a = x e-  in  a `pseq` y e `pseq` a-{-# INLINE beforeReduce #-}--bindReduce :: ReduceM a -> (a -> ReduceM b) -> ReduceM b-bindReduce (ReduceM m) f = ReduceM $ \ e -> unReduceM (f $! m e) e-{-# INLINE bindReduce #-}--instance Functor ReduceM where-  fmap = fmapReduce--instance Applicative ReduceM where-  pure x = ReduceM (const x)-  (<*>) = apReduce-  (*>)  = thenReduce-  (<*)  = beforeReduce--instance Monad ReduceM where-  return = pure-  (>>=) = bindReduce-  (>>) = (*>)-#if __GLASGOW_HASKELL__ < 808-  fail = Fail.fail-#endif--instance Fail.MonadFail ReduceM where-  fail = error--instance ReadTCState ReduceM where-  getTCState = ReduceM redSt-  locallyTCState l f = onReduceEnv $ mapRedSt $ over l f--runReduceM :: ReduceM a -> TCM a-runReduceM m = TCM $ \ r e -> do-  s <- readIORef r-  E.evaluate $ unReduceM m $ ReduceEnv e s-  -- Andreas, 2021-05-13, issue #5379-  -- This was the following, which is apparently not strict enough-  -- to force all unsafePerformIOs...-  -- runReduceM m = do-  --   e <- askTC-  --   s <- getTC-  --   return $! unReduceM m (ReduceEnv e s)--runReduceF :: (a -> ReduceM b) -> TCM (a -> b)-runReduceF f = do-  e <- askTC-  s <- getTC-  return $ \x -> unReduceM (f x) (ReduceEnv e s)--instance MonadTCEnv ReduceM where-  askTC   = ReduceM redEnv-  localTC = onReduceEnv . mapRedEnv---- Andrea comments (https://github.com/agda/agda/issues/1829#issuecomment-522312084):------   useR forces the result of projecting the lens,---   this usually prevents retaining the whole structure when we only need a field.------ This fixes (or contributes to the fix of) the space leak issue #1829 (caching).-useR :: (ReadTCState m) => Lens' a TCState -> m a-useR l = do-  !x <- (^.l) <$> getTCState-  return x--askR :: ReduceM ReduceEnv-askR = ReduceM ask--localR :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a-localR f = ReduceM . local f . unReduceM--instance HasOptions ReduceM where-  pragmaOptions      = useR stPragmaOptions-  commandLineOptions = do-    p  <- useR stPragmaOptions-    cl <- stPersistentOptions . stPersistentState <$> getTCState-    return $ cl{ optPragmaOptions = p }--class ( Applicative m-      , MonadTCEnv m-      , ReadTCState m-      , HasOptions m-      ) => MonadReduce m where-  liftReduce :: ReduceM a -> m a--  default liftReduce :: (MonadTrans t, MonadReduce n, t n ~ m) => ReduceM a -> m a-  liftReduce = lift . liftReduce--instance MonadReduce ReduceM where-  liftReduce = id--instance MonadReduce m => MonadReduce (ChangeT m)-instance MonadReduce m => MonadReduce (ExceptT err m)-instance MonadReduce m => MonadReduce (IdentityT m)-instance MonadReduce m => MonadReduce (ListT m)-instance MonadReduce m => MonadReduce (MaybeT m)-instance MonadReduce m => MonadReduce (ReaderT r m)-instance MonadReduce m => MonadReduce (StateT w m)-instance (Monoid w, MonadReduce m) => MonadReduce (WriterT w m)-instance MonadReduce m => MonadReduce (BlockT m)-------------------------------------------------------------------------------- * Monad with read-only 'TCEnv'-------------------------------------------------------------------------------- | @MonadTCEnv@ made into its own dedicated service class.---   This allows us to use 'MonadReader' for 'ReaderT' extensions of @TCM@.-class Monad m => MonadTCEnv m where-  askTC   :: m TCEnv-  localTC :: (TCEnv -> TCEnv) -> m a -> m a--  default askTC :: (MonadTrans t, MonadTCEnv n, t n ~ m) => m TCEnv-  askTC = lift askTC--  default localTC-    :: (MonadTransControl t, MonadTCEnv n, t n ~ m)-    =>  (TCEnv -> TCEnv) -> m a -> m a-  localTC = liftThrough . localTC--instance MonadTCEnv m => MonadTCEnv (ChangeT m)-instance MonadTCEnv m => MonadTCEnv (ExceptT err m)-instance MonadTCEnv m => MonadTCEnv (IdentityT m)-instance MonadTCEnv m => MonadTCEnv (MaybeT m)-instance MonadTCEnv m => MonadTCEnv (ReaderT r m)-instance MonadTCEnv m => MonadTCEnv (StateT s m)-instance (Monoid w, MonadTCEnv m) => MonadTCEnv (WriterT w m)--instance MonadTCEnv m => MonadTCEnv (ListT m) where-  localTC = mapListT . localTC--asksTC :: MonadTCEnv m => (TCEnv -> a) -> m a-asksTC f = f <$> askTC--viewTC :: MonadTCEnv m => Lens' a TCEnv -> m a-viewTC l = asksTC (^. l)---- | Modify the lens-indicated part of the @TCEnv@ in a subcomputation.-locallyTC :: MonadTCEnv m => Lens' a TCEnv -> (a -> a) -> m b -> m b-locallyTC l = localTC . over l-------------------------------------------------------------------------------- * Monad with mutable 'TCState'-------------------------------------------------------------------------------- | @MonadTCState@ made into its own dedicated service class.---   This allows us to use 'MonadState' for 'StateT' extensions of @TCM@.-class Monad m => MonadTCState m where-  getTC :: m TCState-  putTC :: TCState -> m ()-  modifyTC :: (TCState -> TCState) -> m ()--  default getTC :: (MonadTrans t, MonadTCState n, t n ~ m) => m TCState-  getTC = lift getTC--  default putTC :: (MonadTrans t, MonadTCState n, t n ~ m) => TCState -> m ()-  putTC = lift . putTC--  default modifyTC :: (MonadTrans t, MonadTCState n, t n ~ m) => (TCState -> TCState) -> m ()-  modifyTC = lift . modifyTC--instance MonadTCState m => MonadTCState (MaybeT m)-instance MonadTCState m => MonadTCState (ListT m)-instance MonadTCState m => MonadTCState (ExceptT err m)-instance MonadTCState m => MonadTCState (ReaderT r m)-instance MonadTCState m => MonadTCState (StateT s m)-instance MonadTCState m => MonadTCState (ChangeT m)-instance MonadTCState m => MonadTCState (IdentityT m)-instance (Monoid w, MonadTCState m) => MonadTCState (WriterT w m)---- ** @TCState@ accessors (no lenses)--getsTC :: ReadTCState m => (TCState -> a) -> m a-getsTC f = f <$> getTCState---- | A variant of 'modifyTC' in which the computation is strict in the--- new state.-modifyTC' :: MonadTCState m => (TCState -> TCState) -> m ()-modifyTC' f = do-  s' <- getTC-  putTC $! f s'---- SEE TC.Monad.State--- -- | Restore the 'TCState' after computation.--- localTCState :: MonadTCState m => m a -> m a--- localTCState = bracket_ getTC putTC---- ** @TCState@ accessors via lenses--useTC :: ReadTCState m => Lens' a TCState -> m a-useTC l = do-  !x <- getsTC (^. l)-  return x--infix 4 `setTCLens`---- | Overwrite the part of the 'TCState' focused on by the lens.-setTCLens :: MonadTCState m => Lens' a TCState -> a -> m ()-setTCLens l = modifyTC . set l---- | Modify the part of the 'TCState' focused on by the lens.-modifyTCLens :: MonadTCState m => Lens' a TCState -> (a -> a) -> m ()-modifyTCLens l = modifyTC . over l---- | Modify a part of the state monadically.-modifyTCLensM :: MonadTCState m => Lens' a TCState -> (a -> m a) -> m ()-modifyTCLensM l f = putTC =<< l f =<< getTC---- | Modify the part of the 'TCState' focused on by the lens, and return some result.-stateTCLens :: MonadTCState m => Lens' a TCState -> (a -> (r , a)) -> m r-stateTCLens l f = stateTCLensM l $ return . f---- | Modify a part of the state monadically, and return some result.-stateTCLensM :: MonadTCState m => Lens' a TCState -> (a -> m (r , a)) -> m r-stateTCLensM l f = do-  s <- getTC-  (result , x) <- f $ s ^. l-  putTC $ set l x s-  return result--------------------------------------------------------------------------------- ** Monad with capability to block a computation------------------------------------------------------------------------------class Monad m => MonadBlock m where--  -- | `patternViolation b` aborts the current computation-  patternViolation :: Blocker -> m a--  default patternViolation :: (MonadTrans t, MonadBlock n, m ~ t n) => Blocker -> m a-  patternViolation = lift . patternViolation--  -- | `catchPatternErr handle m` runs m, handling pattern violations-  --    with `handle` (doesn't roll back the state)-  catchPatternErr :: (Blocker -> m a) -> m a -> m a--newtype BlockT m a = BlockT { unBlockT :: ExceptT Blocker m a }-  deriving ( Functor, Applicative, Monad, MonadTrans -- , MonadTransControl -- requires GHC >= 8.2-           , MonadIO, Fail.MonadFail-           , ReadTCState, HasOptions-           , MonadTCEnv, MonadTCState, MonadTCM-           )--instance Monad m => MonadBlock (BlockT m) where-  patternViolation = BlockT . throwError-  catchPatternErr h f = BlockT $ catchError (unBlockT f) (unBlockT . h)--instance Monad m => MonadBlock (ExceptT TCErr m) where-  patternViolation = throwError . PatternErr-  catchPatternErr h f = catchError f $ \case-    PatternErr b -> h b-    err          -> throwError err--runBlocked :: Monad m => BlockT m a -> m (Either Blocker a)-runBlocked = runExceptT . unBlockT--instance MonadBlock m => MonadBlock (MaybeT m) where-  catchPatternErr h m = MaybeT $ catchPatternErr (runMaybeT . h) $ runMaybeT m--instance MonadBlock m => MonadBlock (ReaderT e m) where-  catchPatternErr h m = ReaderT $ \ e ->-    let run = flip runReaderT e in catchPatternErr (run . h) (run m)-------------------------------------------------------------------------------- * Type checking monad transformer-------------------------------------------------------------------------------- | The type checking monad transformer.--- Adds readonly 'TCEnv' and mutable 'TCState'.-newtype TCMT m a = TCM { unTCM :: IORef TCState -> TCEnv -> m a }---- | Type checking monad.-type TCM = TCMT IO--{-# SPECIALIZE INLINE mapTCMT :: (forall a. IO a -> IO a) -> TCM a -> TCM a #-}-mapTCMT :: (forall a. m a -> n a) -> TCMT m a -> TCMT n a-mapTCMT f (TCM m) = TCM $ \ s e -> f (m s e)--pureTCM :: MonadIO m => (TCState -> TCEnv -> a) -> TCMT m a-pureTCM f = TCM $ \ r e -> do-  s <- liftIO $ readIORef r-  return (f s e)---- One goal of the definitions and pragmas below is to inline the--- monad operations as much as possible. This doesn't seem to have a--- large effect on the performance of the normal executable, but (at--- least on one machine/configuration) it has a massive effect on the--- performance of the profiling executable [1], and reduces the time--- attributed to bind from over 90% to about 25%.------ [1] When compiled with -auto-all and run with -p: roughly 750%--- faster for one example.--returnTCMT :: Applicative m => a -> TCMT m a-returnTCMT = \x -> TCM $ \_ _ -> pure x-{-# INLINE returnTCMT #-}--bindTCMT :: Monad m => TCMT m a -> (a -> TCMT m b) -> TCMT m b-bindTCMT = \(TCM m) k -> TCM $ \r e -> m r e >>= \x -> unTCM (k x) r e-{-# INLINE bindTCMT #-}--thenTCMT :: Applicative m => TCMT m a -> TCMT m b -> TCMT m b-thenTCMT = \(TCM m1) (TCM m2) -> TCM $ \r e -> m1 r e *> m2 r e-{-# INLINE thenTCMT #-}--instance Functor m => Functor (TCMT m) where-  fmap = fmapTCMT--fmapTCMT :: Functor m => (a -> b) -> TCMT m a -> TCMT m b-fmapTCMT = \f (TCM m) -> TCM $ \r e -> fmap f (m r e)-{-# INLINE fmapTCMT #-}--instance Applicative m => Applicative (TCMT m) where-  pure  = returnTCMT-  (<*>) = apTCMT--apTCMT :: Applicative m => TCMT m (a -> b) -> TCMT m a -> TCMT m b-apTCMT = \(TCM mf) (TCM m) -> TCM $ \r e -> mf r e <*> m r e-{-# INLINE apTCMT #-}--instance MonadTrans TCMT where-    lift m = TCM $ \_ _ -> m---- We want a special monad implementation of fail.-#if __GLASGOW_HASKELL__ < 808-instance MonadIO m => Monad (TCMT m) where-#else--- Andreas, 2022-02-02, issue #5659:--- @transformers-0.6@ requires exactly a @Monad@ superclass constraint here--- if we want @instance MonadTrans TCMT@.-instance Monad m => Monad (TCMT m) where-#endif-    return = pure-    (>>=)  = bindTCMT-    (>>)   = (*>)-#if __GLASGOW_HASKELL__ < 808-    fail   = Fail.fail-#endif--instance MonadIO m => Fail.MonadFail (TCMT m) where-  fail = internalError--instance MonadIO m => MonadIO (TCMT m) where-  liftIO m = TCM $ \ s env -> do-    liftIO $ wrap s (envRange env) $ do-      x <- m-      x `seq` return x-    where-      wrap s r m = E.catch m $ \ err -> do-        s <- readIORef s-        E.throwIO $ IOException s r err--instance MonadIO m => MonadTCEnv (TCMT m) where-  askTC             = TCM $ \ _ e -> return e-  localTC f (TCM m) = TCM $ \ s e -> m s (f e)--instance MonadIO m => MonadTCState (TCMT m) where-  getTC   = TCM $ \ r _e -> liftIO (readIORef r)-  putTC s = TCM $ \ r _e -> liftIO (writeIORef r s)-  modifyTC f = putTC . f =<< getTC--instance MonadIO m => ReadTCState (TCMT m) where-  getTCState = getTC-  locallyTCState l f = bracket_ (useTC l <* modifyTCLens l f) (setTCLens l)--instance MonadBlock TCM where-  patternViolation b = throwError (PatternErr b)-  catchPatternErr handle v =-       catchError_ v $ \err ->-       case err of-            -- Not putting s (which should really be the what's already there) makes things go-            -- a lot slower (+20% total time on standard library). How is that possible??-            -- The problem is most likely that there are internal catchErrors which forgets the-            -- state. catchError should preserve the state on pattern violations.-           PatternErr u -> handle u-           _            -> throwError err---instance MonadError TCErr TCM where-  throwError = liftIO . E.throwIO-  catchError m h = TCM $ \ r e -> do  -- now we are in the IO monad-    oldState <- readIORef r-    unTCM m r e `E.catch` \err -> do-      -- Reset the state, but do not forget changes to the persistent-      -- component. Not for pattern violations.-      case err of-        PatternErr{} -> return ()-        _            ->-          liftIO $ do-            newState <- readIORef r-            writeIORef r $ oldState { stPersistentState = stPersistentState newState }-      unTCM (h err) r e---- | Like 'catchError', but resets the state completely before running the handler.---   This means it also loses changes to the 'stPersistentState'.------   The intended use is to catch internal errors during debug printing.---   In debug printing, we are not expecting state changes.-instance CatchImpossible TCM where-  catchImpossibleJust f m h = TCM $ \ r e -> do-    -- save the state-    s <- readIORef r-    catchImpossibleJust f (unTCM m r e) $ \ err -> do-      writeIORef r s-      unTCM (h err) r e--instance MonadIO m => MonadReduce (TCMT m) where-  liftReduce = liftTCM . runReduceM--instance (IsString a, MonadIO m) => IsString (TCMT m a) where-  fromString s = return (fromString s)---- | Strict (non-shortcut) semigroup.------   Note that there might be a lazy alternative, e.g.,---   for TCM All we might want 'Agda.Utils.Monad.and2M' as concatenation,---   to shortcut conjunction in case we already have 'False'.----instance {-# OVERLAPPABLE #-} (MonadIO m, Semigroup a) => Semigroup (TCMT m a) where-  (<>) = liftA2 (<>)---- | Strict (non-shortcut) monoid.-instance {-# OVERLAPPABLE #-} (MonadIO m, Semigroup a, Monoid a) => Monoid (TCMT m a) where-  mempty  = pure mempty-  mappend = (<>)-  mconcat = mconcat <.> sequence--instance {-# OVERLAPPABLE #-} (MonadIO m, Null a) => Null (TCMT m a) where-  empty = return empty-  null  = __IMPOSSIBLE__---- | Preserve the state of the failing computation.-catchError_ :: TCM a -> (TCErr -> TCM a) -> TCM a-catchError_ m h = TCM $ \r e ->-  unTCM m r e-  `E.catch` \err -> unTCM (h err) r e---- | Execute a finalizer even when an exception is thrown.---   Does not catch any errors.---   In case both the regular computation and the finalizer---   throw an exception, the one of the finalizer is propagated.-finally_ :: TCM a -> TCM b -> TCM a-finally_ m f = do-    x <- m `catchError_` \ err -> f >> throwError err-    _ <- f-    return x---- | Embedding a TCM computation.--class ( Applicative tcm, MonadIO tcm-      , MonadTCEnv tcm-      , MonadTCState tcm-      , HasOptions tcm-      ) => MonadTCM tcm where-    liftTCM :: TCM a -> tcm a--    default liftTCM :: (MonadTCM m, MonadTrans t, tcm ~ t m) => TCM a -> tcm a-    liftTCM = lift . liftTCM--{-# RULES "liftTCM/id" liftTCM = id #-}-instance MonadIO m => MonadTCM (TCMT m) where-    liftTCM = mapTCMT liftIO--instance MonadTCM tcm => MonadTCM (ChangeT tcm)-instance MonadTCM tcm => MonadTCM (ExceptT err tcm)-instance MonadTCM tcm => MonadTCM (IdentityT tcm)-instance MonadTCM tcm => MonadTCM (ListT tcm)-instance MonadTCM tcm => MonadTCM (MaybeT tcm)-instance MonadTCM tcm => MonadTCM (ReaderT r tcm)-instance MonadTCM tcm => MonadTCM (StateT s tcm)-instance (Monoid w, MonadTCM tcm) => MonadTCM (WriterT w tcm)---- | We store benchmark statistics in an IORef.---   This enables benchmarking pure computation, see---   "Agda.Benchmarking".-instance MonadBench TCM where-  type BenchPhase TCM = Phase-  getBenchmark = liftIO $ getBenchmark-  putBenchmark = liftIO . putBenchmark-  finally = finally_--instance Null (TCM Doc) where-  empty = return empty-  null = __IMPOSSIBLE__--internalError :: (HasCallStack, MonadTCM tcm) => String -> tcm a-internalError s = withCallerCallStack $ \ loc ->-  liftTCM $ typeError' loc $ InternalError s---- | The constraints needed for 'typeError' and similar.-type MonadTCError m = (MonadTCEnv m, ReadTCState m, MonadError TCErr m)---- | Utility function for 1-arg constructed type errors.--- Note that the @HasCallStack@ constraint is on the *resulting* function.-locatedTypeError :: MonadTCError m => (a -> TypeError) -> (HasCallStack => a -> m b)-locatedTypeError f e = withCallerCallStack (flip typeError' (f e))--genericError :: (HasCallStack, MonadTCError m) => String -> m a-genericError = locatedTypeError GenericError--{-# SPECIALIZE genericDocError :: Doc -> TCM a #-}-genericDocError :: (HasCallStack, MonadTCError m) => Doc -> m a-genericDocError = locatedTypeError GenericDocError--{-# SPECIALIZE typeError' :: CallStack -> TypeError -> TCM a #-}-typeError' :: MonadTCError m => CallStack -> TypeError -> m a-typeError' loc err = throwError =<< typeError'_ loc err--{-# SPECIALIZE typeError :: HasCallStack => TypeError -> TCM a #-}-typeError :: (HasCallStack, MonadTCError m) => TypeError -> m a-typeError err = withCallerCallStack $ \loc -> throwError =<< typeError'_ loc err--{-# SPECIALIZE typeError'_ :: CallStack -> TypeError -> TCM TCErr #-}-typeError'_ :: (MonadTCEnv m, ReadTCState m) => CallStack -> TypeError -> m TCErr-typeError'_ loc err = TypeError loc <$> getTCState <*> buildClosure err--{-# SPECIALIZE typeError_ :: HasCallStack => TypeError -> TCM TCErr #-}-typeError_ :: (HasCallStack, MonadTCEnv m, ReadTCState m) => TypeError -> m TCErr-typeError_ = withCallerCallStack . flip typeError'_---- | Running the type checking monad (most general form).-{-# SPECIALIZE runTCM :: TCEnv -> TCState -> TCM a -> IO (a, TCState) #-}-runTCM :: MonadIO m => TCEnv -> TCState -> TCMT m a -> m (a, TCState)-runTCM e s m = do-  r <- liftIO $ newIORef s-  a <- unTCM m r e-  s <- liftIO $ readIORef r-  return (a, s)---- | Running the type checking monad on toplevel (with initial state).-runTCMTop :: TCM a -> IO (Either TCErr a)-runTCMTop m = (Right <$> runTCMTop' m) `E.catch` (return . Left)--runTCMTop' :: MonadIO m => TCMT m a -> m a-runTCMTop' m = do-  r <- liftIO $ newIORef initState-  unTCM m r initEnv---- | 'runSafeTCM' runs a safe 'TCM' action (a 'TCM' action which---   cannot fail, except that it might raise 'IOException's) in the---   initial environment.--runSafeTCM :: TCM a -> TCState -> IO (a, TCState)-runSafeTCM m st =-  runTCM initEnv st m `E.catch` \(e :: TCErr) -> case e of-    IOException _ _ err -> E.throwIO err-    _                   -> __IMPOSSIBLE__---- | Runs the given computation in a separate thread, with /a copy/ of--- the current state and environment.------ Note that Agda sometimes uses actual, mutable state. If the--- computation given to @forkTCM@ tries to /modify/ this state, then--- bad things can happen, because accesses are not mutually exclusive.--- The @forkTCM@ function has been added mainly to allow the thread to--- /read/ (a snapshot of) the current state in a convenient way.------ Note also that exceptions which are raised in the thread are not--- propagated to the parent, so the thread should not do anything--- important.--forkTCM :: TCM a -> TCM ()-forkTCM m = do-  s <- getTC-  e <- askTC-  liftIO $ void $ C.forkIO $ void $ runTCM e s m-------------------------------------------------------------------------------- * Names for generated definitions-------------------------------------------------------------------------------- | Base name for patterns in telescopes-patternInTeleName :: String-patternInTeleName = ".patternInTele"---- | Base name for extended lambda patterns-extendedLambdaName :: String-extendedLambdaName = ".extendedlambda"---- | Check whether we have an definition from an extended lambda.-isExtendedLambdaName :: A.QName -> Bool-isExtendedLambdaName = (extendedLambdaName `List.isPrefixOf`) . prettyShow . nameConcrete . qnameName---- | Name of absurdLambda definitions.-absurdLambdaName :: String-absurdLambdaName = ".absurdlambda"---- | Check whether we have an definition from an absurd lambda.-isAbsurdLambdaName :: QName -> Bool-isAbsurdLambdaName = (absurdLambdaName ==) . prettyShow . qnameName---- | Base name for generalized variable projections-generalizedFieldName :: String-generalizedFieldName = ".generalizedField-"---- | Check whether we have a generalized variable field-getGeneralizedFieldName :: A.QName -> Maybe String-getGeneralizedFieldName q-  | generalizedFieldName `List.isPrefixOf` strName = Just (drop (length generalizedFieldName) strName)-  | otherwise                                      = Nothing-  where strName = prettyShow $ nameConcrete $ qnameName q-------------------------------------------------------------------------------- * KillRange instances------------------------------------------------------------------------------instance KillRange Signature where-  killRange (Sig secs defs rews) = killRange2 Sig secs defs rews--instance KillRange Sections where-  killRange = fmap killRange--instance KillRange Definitions where-  killRange = fmap killRange--instance KillRange RewriteRuleMap where-  killRange = fmap killRange--instance KillRange Section where-  killRange (Section tel) = killRange1 Section tel--instance KillRange Definition where-  killRange (Defn ai name t pols occs gens gpars displ mut compiled inst copy ma nc inj copat blk lang def) =-    killRange19 Defn ai name t pols occs gens gpars displ mut compiled inst copy ma nc inj copat blk lang def-    -- TODO clarify: Keep the range in the defName field?--instance KillRange NumGeneralizableArgs where-  killRange = id--instance KillRange NLPat where-  killRange (PVar x y) = killRange2 PVar x y-  killRange (PDef x y) = killRange2 PDef x y-  killRange (PLam x y) = killRange2 PLam x y-  killRange (PPi x y)  = killRange2 PPi x y-  killRange (PSort x)  = killRange1 PSort x-  killRange (PBoundVar x y) = killRange2 PBoundVar x y-  killRange (PTerm x)  = killRange1 PTerm x--instance KillRange NLPType where-  killRange (NLPType s a) = killRange2 NLPType s a--instance KillRange NLPSort where-  killRange (PType l) = killRange1 PType l-  killRange (PProp l) = killRange1 PProp l-  killRange s@(PInf f n) = s-  killRange PSizeUniv = PSizeUniv-  killRange PLockUniv = PLockUniv--instance KillRange RewriteRule where-  killRange (RewriteRule q gamma f es rhs t c) =-    killRange6 RewriteRule q gamma f es rhs t c--instance KillRange CompiledRepresentation where-  killRange = id---instance KillRange EtaEquality where-  killRange = id--instance KillRange System where-  killRange (System tel sys) = System (killRange tel) (killRange sys)--instance KillRange ExtLamInfo where-  killRange (ExtLamInfo m b sys) = killRange3 ExtLamInfo m b sys--instance KillRange FunctionFlag where-  killRange = id--instance KillRange CompKit where-  killRange = id--instance KillRange Defn where-  killRange def =-    case def of-      Axiom a -> Axiom a-      DataOrRecSig n -> DataOrRecSig n-      GeneralizableVar -> GeneralizableVar-      AbstractDefn{} -> __IMPOSSIBLE__ -- only returned by 'getConstInfo'!-      Function cls comp ct tt covering inv mut isAbs delayed proj flags term extlam with ->-        killRange14 Function cls comp ct tt covering inv mut isAbs delayed proj flags term extlam with-      Datatype a b c d e f g h       -> killRange7 Datatype a b c d e f g h-      Record a b c d e f g h i j k l -> killRange12 Record a b c d e f g h i j k l-      Constructor a b c d e f g h i j-> killRange10 Constructor a b c d e f g h i j-      Primitive a b c d e            -> killRange5 Primitive a b c d e-      PrimitiveSort a b              -> killRange2 PrimitiveSort a b--instance KillRange MutualId where-  killRange = id--instance KillRange c => KillRange (FunctionInverse' c) where-  killRange NotInjective = NotInjective-  killRange (Inverse m)  = Inverse $ killRangeMap m--instance KillRange TermHead where-  killRange SortHead     = SortHead-  killRange PiHead       = PiHead-  killRange (ConsHead q) = ConsHead $ killRange q-  killRange h@VarHead{}  = h-  killRange UnknownHead  = UnknownHead--instance KillRange Projection where-  killRange (Projection a b c d e) = killRange5 Projection a b c d e--instance KillRange ProjLams where-  killRange = id--instance KillRange a => KillRange (Open a) where-  killRange = fmap killRange--instance KillRange DisplayForm where-  killRange (Display n es dt) = killRange3 Display n es dt--instance KillRange Polarity where-  killRange = id--instance KillRange IsForced where-  killRange = id--instance KillRange DoGeneralize where-  killRange = id--instance KillRange DisplayTerm where-  killRange dt =-    case dt of-      DWithApp dt dts es -> killRange3 DWithApp dt dts es-      DCon q ci dts     -> killRange3 DCon q ci dts-      DDef q dts        -> killRange2 DDef q dts-      DDot v            -> killRange1 DDot v-      DTerm v           -> killRange1 DTerm v--instance KillRange a => KillRange (Closure a) where-  killRange = id-------------------------------------------------------------------------------- NFData instances------------------------------------------------------------------------------instance NFData NumGeneralizableArgs where-  rnf NoGeneralizableArgs       = ()-  rnf (SomeGeneralizableArgs _) = ()--instance NFData TCErr where-  rnf (TypeError a b c)   = rnf a `seq` rnf b `seq` rnf c-  rnf (Exception a b)     = rnf a `seq` rnf b-  rnf (IOException a b c) = rnf a `seq` rnf b `seq` rnf (c == c)-                            -- At the time of writing there is no-                            -- NFData instance for E.IOException.-  rnf (PatternErr a)      = rnf a---- | This instance could be optimised, some things are guaranteed to--- be forced.--instance NFData PreScopeState---- | This instance could be optimised, some things are guaranteed to--- be forced.--instance NFData PostScopeState--instance NFData TCState-instance NFData DisambiguatedName-instance NFData MutualBlock-instance NFData PersistentTCState-instance NFData LoadedFileCache-instance NFData TypeCheckAction-instance NFData ModuleCheckMode-instance NFData ModuleInfo-instance NFData ForeignCode-instance NFData Interface-instance NFData a => NFData (Closure a)-instance NFData ProblemConstraint-instance NFData Constraint-instance NFData Signature-instance NFData Comparison-instance NFData CompareAs-instance NFData a => NFData (Open a)-instance NFData a => NFData (Judgement a)-instance NFData DoGeneralize-instance NFData GeneralizedValue-instance NFData MetaVariable-instance NFData Listener-instance NFData MetaInstantiation-instance NFData Frozen-instance NFData PrincipalArgTypeMetas-instance NFData TypeCheckingProblem-instance NFData RunMetaOccursCheck-instance NFData MetaInfo-instance NFData InteractionPoint-instance NFData InteractionPoints-instance NFData Overapplied-instance NFData t => NFData (IPBoundary' t)-instance NFData IPClause-instance NFData DisplayForm-instance NFData DisplayTerm-instance NFData NLPat-instance NFData NLPType-instance NFData NLPSort-instance NFData RewriteRule-instance NFData Definition-instance NFData Polarity-instance NFData IsForced-instance NFData Projection-instance NFData ProjLams-instance NFData CompilerPragma-instance NFData System-instance NFData ExtLamInfo-instance NFData EtaEquality-instance NFData FunctionFlag-instance NFData CompKit-instance NFData Defn-instance NFData Simplification-instance NFData AllowedReduction-instance NFData ReduceDefs-instance NFData PrimFun-instance NFData c => NFData (FunctionInverse' c)-instance NFData TermHead-instance NFData Call-instance NFData pf => NFData (Builtin pf)-instance NFData HighlightingLevel-instance NFData HighlightingMethod-instance NFData TCEnv-instance NFData UnquoteFlags-instance NFData AbstractMode-instance NFData ExpandHidden-instance NFData CandidateKind-instance NFData Candidate-instance NFData Warning-instance NFData RecordFieldWarning-instance NFData TCWarning-instance NFData CallInfo-instance NFData TerminationError-instance NFData SplitError-instance NFData NegativeUnification-instance NFData UnificationFailure-instance NFData UnquoteError-instance NFData TypeError-instance NFData LHSOrPatSyn+  , module Agda.TypeChecking.Monad.Base.Types+  , module X+  , HasOptions (..)+  , RecordFieldWarning+  , UselessPublicReason(..)+  ) where++import Prelude hiding (null)++import Control.Applicative hiding (empty)+import Control.Arrow                ( (&&&) )+import Control.Concurrent           ( forkIO )+import Control.DeepSeq+import qualified Control.Exception as E++import Control.Monad.Except         ( MonadError(..), ExceptT(..), runExceptT )+import Control.Monad.IO.Class       ( MonadIO(..) )+import Control.Monad.State          ( MonadState(..), modify, StateT(..), runStateT )+import Control.Monad.Reader         ( MonadReader(..), ReaderT(..), runReaderT )+import Control.Monad.Writer         ( WriterT(..), runWriterT )+import Control.Monad.Trans          ( MonadTrans(..), lift )+import Control.Monad.Trans.Control  ( MonadTransControl(..), liftThrough )+import Control.Monad.Trans.Identity ( IdentityT(..), runIdentityT )+import Control.Monad.Trans.Maybe    ( MaybeT(..) )++import Control.Parallel             ( pseq )++import Data.Array (Ix)+import Data.Function (on)+import Data.Word (Word32)+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import qualified Data.List as List+import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as Map -- hiding (singleton, null, empty)+import Data.Sequence (Seq)+import Data.Set (Set, toList, fromList)+import qualified Data.Set as Set -- hiding (singleton, null, empty)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HMap+import qualified Data.HashSet as HashSet+import Data.Hashable+import Data.HashSet (HashSet)+import Data.Semigroup ( Semigroup, (<>)) --, Any(..) )+import Data.Set (Set)+import qualified Data.Set as Set+import Data.String+import Data.Text (Text)+import qualified Data.Text.Lazy as TL++import Data.IORef++import GHC.Generics (Generic)++import System.IO (hFlush, stdout)++import Agda.Benchmarking (Benchmark, Phase)++import {-# SOURCE #-} Agda.Compiler.Treeless.Pretty () -- Instances only+import Agda.Syntax.Common+import Agda.Syntax.Builtin (SomeBuiltin, BuiltinId, PrimitiveId)+import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Definitions+  (NiceDeclaration, DeclarationWarning, declarationWarningName)+import Agda.Syntax.Concrete.Definitions.Errors+  (DeclarationException')+import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Internal as I+import Agda.Syntax.Internal.MetaVars+import Agda.Syntax.Internal.Generic (TermLike(..))+import Agda.Syntax.Parser.Monad (ParseError, ParseWarning, parseWarningName)+import Agda.Syntax.TopLevelModuleName+  (RawTopLevelModuleName, TopLevelModuleName)+import Agda.Syntax.Treeless (Compiled)+import Agda.Syntax.Notation+import Agda.Syntax.Position+import Agda.Syntax.Scope.Base+import Agda.Syntax.Info ( MetaKind(InstanceMeta, UnificationMeta), MetaNameSuggestion, MutualInfo )++import           Agda.TypeChecking.Monad.Base.Types+import qualified Agda.TypeChecking.Monad.Base.Warning as W+import           Agda.TypeChecking.Monad.Base.Warning (RecordFieldWarning, UselessPublicReason(..))+import           Agda.TypeChecking.SizedTypes.Syntax  (HypSizeConstraint)++import Agda.TypeChecking.CompiledClause+import Agda.TypeChecking.Coverage.SplitTree+import Agda.TypeChecking.Positivity.Occurrence+import Agda.TypeChecking.Free.Lazy (Free(freeVars'), underBinder', underBinder)++import Agda.TypeChecking.DiscrimTree.Types++import Agda.Termination.Termination (GuardednessHelps(..))++import Agda.Compiler.Backend.Base (Backend_boot, Backend'_boot)++import Agda.Interaction.Options+import qualified Agda.Interaction.Options.Errors as ErrorName+import Agda.Interaction.Options.Errors as X+  ( CannotQuoteTerm(..)+  , ErasedDatatypeReason(..)+  , NotAValidLetBinding(..)+  , NotAValidLetExpression(..)+  , NotAllowedInDotPatterns(..)+  )+import Agda.Interaction.Options.Warnings+import Agda.Interaction.Response.Base (Response_boot(..))+import Agda.Interaction.Highlighting.Precise+  (HighlightingInfo, NameKind)+import Agda.Interaction.Library+import Agda.Interaction.Library.Base ( ExeName, ExeMap, LibCache, LibErrors )++import Agda.Utils.Benchmark (MonadBench(..))+import Agda.Utils.BiMap (BiMap, HasTag(..))+import qualified Agda.Utils.BiMap as BiMap+import Agda.Utils.Boolean   ( fromBool, toBool )+import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack )+import Agda.Utils.FileId    as X ( FileId, MonadFileId( idFromFile, fileFromId ) )+import Agda.Utils.FileId    ( FileDictBuilder, GetFileId(getFileId), GetIdFile(getIdFile) )+import Agda.Utils.FileName+import Agda.Utils.Functor+import Agda.Utils.Hash+import Agda.Utils.IO        ( CatchIO, catchIO, showIOException )+import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.ListT+import Agda.Utils.List1 (List1, pattern (:|))+import Agda.Utils.List2 (List2, pattern List2)+import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Permutation+import Agda.Syntax.Common.Pretty+import Agda.Utils.SmallSet (SmallSet, SmallSetElement)+import qualified Agda.Utils.SmallSet as SmallSet+import Agda.Utils.Set1 (Set1)+import Agda.Utils.Singleton+import Agda.Utils.Tuple (Pair)+import Agda.Utils.Update++import Agda.Utils.Impossible++---------------------------------------------------------------------------+-- * Type checking state+---------------------------------------------------------------------------++data TCState = TCSt+  { stPersistentState :: !PersistentTCState+    -- ^ State which persists while we build an Agda project (same main file).+  , stPreScopeState   :: !PreScopeState+    -- ^ The state which is frozen after scope checking.+  , stPostScopeState  :: !PostScopeState+    -- ^ The state which is modified after scope checking.+  }+  deriving Generic++class Monad m => ReadTCState m where+  getTCState :: m TCState+  locallyTCState :: Lens' TCState a -> (a -> a) -> m b -> m b++  withTCState :: (TCState -> TCState) -> m a -> m a+  withTCState = locallyTCState id++  default getTCState :: (MonadTrans t, ReadTCState n, t n ~ m) => m TCState+  getTCState = lift getTCState++  default locallyTCState+    :: (MonadTransControl t, ReadTCState n, t n ~ m)+    => Lens' TCState a -> (a -> a) -> m b -> m b+  locallyTCState l = liftThrough . locallyTCState l++instance ReadTCState m => ReadTCState (ListT m) where+  locallyTCState l = mapListT . locallyTCState l++instance ReadTCState m => ReadTCState (ChangeT m)+instance ReadTCState m => ReadTCState (ExceptT err m)+instance ReadTCState m => ReadTCState (IdentityT m)+instance ReadTCState m => ReadTCState (MaybeT m)+instance ReadTCState m => ReadTCState (ReaderT r m)+instance ReadTCState m => ReadTCState (StateT s m)+instance (Monoid w, ReadTCState m) => ReadTCState (WriterT w m)++instance Show TCState where+  show _ = "TCSt{}"++type Backend = Backend_boot Definition TCM+type Backend' opts env menv mod def = Backend'_boot Definition TCM opts env menv mod def++type BackendForeignCode = Map BackendName ForeignCodeStack+type ImportedModules    = Set TopLevelModuleName+type UserWarnings       = Map QName Text++data PreScopeState = PreScopeState+  { stPreTokens             :: !HighlightingInfo+    -- ^ Highlighting info for tokens and Happy parser warnings (but+    -- not for those tokens/warnings for which highlighting exists in+    -- 'stPostSyntaxInfo').+  , stPreImports            :: !Signature  -- XX populated by scope checker+    -- ^ Imported declared identifiers.+    --   Those most not be serialized!+  , stPreImportedModules    :: !ImportedModules+      -- Andreas, 2023-08-05, issue #6750, don't make this a 'HashSet'+      -- because then the order of its @toList@ is undefined,+      -- leading to undefined deserialization order.+    -- ^ The top-level modules imported by the current module.+  , stPreImportedModulesTransitive :: !ImportedModules+      -- ^ The top-level modules transitively imported by the current module.+  , stPreModuleToSourceId   :: !ModuleToSourceId -- imports+  , stPreVisitedModules     :: !VisitedModules   -- imports+      -- ^ Modules loaded so far.+      --   In contrast 'stDecodedModules', contains also modules that are only scope-checked.+  , stPreScope              :: !ScopeInfo+    -- generated by scope checker, current file:+    -- which modules you have, public definitions, current file, maps concrete names to abstract names.+  , stPrePatternSyns        :: !A.PatternSynDefns+    -- ^ Pattern synonyms of the current file.  Serialized.+  , stPrePatternSynImports  :: !A.PatternSynDefns+    -- ^ Imported pattern synonyms.  Must not be serialized!+  , stPreGeneralizedVars    :: !(Strict.Maybe (Set QName))+    -- ^ Collected variables we wish to generalize over; used during scope checking of terms.+    --   If 'Nothing', we are in a position where we do not support generalization,+    --   and do not accept additions to this collection.+  , stPrePragmaOptions      :: !PragmaOptions+    -- ^ Options applying to the current file. @OPTIONS@+    -- pragmas only affect this field.+  , stPreImportedBuiltins   :: !BuiltinThings+  , stPreImportedDisplayForms :: !DisplayForms+    -- ^ Display forms added by someone else to imported identifiers+  , stPreFreshInteractionId :: !InteractionId+  , stPreImportedUserWarnings :: !UserWarnings+    -- ^ Imported @UserWarning@s, not to be stored in the @Interface@+  , stPreLocalUserWarnings    :: !UserWarnings+    -- ^ Locally defined @UserWarning@s, to be stored in the @Interface@+  , stPreWarningOnImport      :: !(Strict.Maybe Text)+    -- ^ Whether the current module should raise a warning when opened+  , stPreImportedPartialDefs :: !(Set QName)+    -- ^ Imported partial definitions, not to be stored in the @Interface@+  , stPreLibCache            :: !LibCache+    -- ^ Cached @.agda-lib@ files.+  , stPreImportedMetaStore :: !RemoteMetaStore+    -- ^ Used for meta-variables from other modules.+  , stPreCopiedNames       :: !(HashMap A.QName A.QName)+    -- ^ Associates a copied name (the key) to its original name (the+    -- value). Computed by the scope checker, used to compute opaque+    -- blocks.+  , stPreNameCopies        :: !(HashMap A.QName (HashSet A.QName))+    -- ^ Associates an original name (the key) to all its copies (the+    -- value). Computed by the scope checker, used to compute opaque+    -- blocks.+  }+  deriving Generic++-- | Name disambiguation for the sake of highlighting.+data DisambiguatedName = DisambiguatedName NameKind A.QName+  deriving Generic+type DisambiguatedNames = IntMap DisambiguatedName++type ConcreteNames = Map Name (List1 C.Name)+type ShadowingNames = Map Name (Set1 RawName)+type UsedNames = Map RawName (Set1 RawName)++data PostScopeState = PostScopeState+  { stPostSyntaxInfo          :: !HighlightingInfo+    -- ^ Highlighting info.+  , stPostDisambiguatedNames  :: !DisambiguatedNames+    -- ^ Disambiguation carried out by the type checker.+    --   Maps position of first name character to disambiguated @'A.QName'@+    --   for each @'A.AmbiguousQName'@ already passed by the type checker.+  , stPostOpenMetaStore       :: !LocalMetaStore+    -- ^ Used for open meta-variables.+  , stPostSolvedMetaStore     :: !LocalMetaStore+    -- ^ Used for local, instantiated meta-variables.+  , stPostInteractionPoints   :: !InteractionPoints -- scope checker first+  , stPostAwakeConstraints    :: !Constraints+  , stPostSleepingConstraints :: !Constraints+  , stPostDirty               :: !Bool -- local+    -- ^ Dirty when a constraint is added, used to prevent pointer update.+    -- Currently unused.+  , stPostOccursCheckDefs     :: !(Set QName) -- local+    -- ^ Definitions to be considered during occurs check.+    --   Initialized to the current mutual block before the check.+    --   During occurs check, we remove definitions from this set+    --   as soon we have checked them.+  , stPostSignature           :: !Signature+    -- ^ Declared identifiers of the current file.+    --   These will be serialized after successful type checking.+  , stPostModuleCheckpoints   :: !(Map ModuleName CheckpointId)+    -- ^ For each module remember the checkpoint corresponding to the orignal+    --   context of the module parameters.+  , stPostImportsDisplayForms :: !DisplayForms+    -- ^ Display forms we add for imported identifiers+  , stPostForeignCode         :: !BackendForeignCode+    -- ^ @{-\# FOREIGN \#-}@ code that should be included in the compiled output.+    -- Does not include code for imported modules.+  , stPostCurrentModule       ::+      !(Maybe (ModuleName, TopLevelModuleName))+    -- ^ The current module is available after it has been type+    -- checked.++  , stPostPendingInstances :: !(Set QName)++  , stPostTemporaryInstances :: !(Set QName)++  , stPostConcreteNames       :: !ConcreteNames+    -- ^ Map keeping track of concrete names assigned to each abstract name+    --   (can be more than one name in case the first one is shadowed)+  , stPostUsedNames           :: !UsedNames+    -- ^ Map keeping track for each name root (= name w/o numeric+    -- suffixes) what names with the same root have been used during a+    -- TC computation. This information is used to build the+    -- @ShadowingNames@ map.+  , stPostShadowingNames      :: !ShadowingNames+    -- ^ Map keeping track for each (abstract) name the list of all+    -- (raw) names that it could maybe be shadowed by.+  , stPostStatistics          :: !Statistics+    -- ^ Counters to collect various statistics about meta variables etc.+    --   Only for current file.+  , stPostTCWarnings          :: !(Set TCWarning)+  , stPostMutualBlocks        :: !MutualBlocks+  , stPostLocalBuiltins       :: !BuiltinThings+  , stPostFreshMetaId         :: !MetaId+  , stPostFreshMutualId       :: !MutualId+  , stPostFreshProblemId      :: !ProblemId+  , stPostFreshCheckpointId   :: !CheckpointId+  , stPostFreshInt            :: !Int+  , stPostFreshNameId         :: !NameId+  , stPostFreshOpaqueId       :: !OpaqueId+  , stPostAreWeCaching        :: !Bool+  , stPostPostponeInstanceSearch :: !Bool+  , stPostConsideringInstance :: !Bool+  , stPostInstantiateBlocking :: !Bool+    -- ^ Should we instantiate away blocking metas?+    --   This can produce ill-typed terms but they are often more readable. See issue #3606.+    --   Best set to True only for calls to pretty*/reify to limit unwanted reductions.+  , stPostLocalPartialDefs    :: !(Set QName)+    -- ^ Local partial definitions, to be stored in the @Interface@+  , stPostOpaqueBlocks        :: Map OpaqueId OpaqueBlock+    -- ^ Associates opaque identifiers to their actual blocks.+  , stPostOpaqueIds           :: Map QName OpaqueId+    -- ^ Associates each opaque QName to the block it was defined in.+  , stPostInstanceHack        :: !Bool+    -- ^ Is this a context where we should always try every possible+    -- instance candidate? Used to support "inert improvement", see+    -- @shouldBlockOverlap@ in InstanceArguments.+  }+  deriving (Generic)++-- | A part of the state that grows monotonically over the whole Agda session.+-- Never reset.+data SessionTCState = SessionTCState+  { stSessionBenchmark :: !Benchmark+      -- ^ Structure to track how much CPU time was spent on which Agda phase.+      --   Needs to be a strict field to avoid space leaks!+  , stSessionBackends  :: [Backend]+      -- ^ Backends with their options.+  , stSessionFileDict  :: !FileDictWithBuiltins+      -- ^ Map file names to unique 'FileId' and back.+      --   Assuming we do not see terribly many different files during one Agda session,+      --   this map needs not be garbage-collected.+      --+      --   Also informs about whether a 'FileId' belongs to one of+      --   Agda's primitive and builtin modules.+  }+  deriving (Generic)++-- | A part of the state which is not reverted when an error is thrown+-- or the state is reset.+data PersistentTCState = PersistentTCSt+  { stPersistentSession :: !SessionTCState+      -- ^ State that persists for the whole Agda session.+      --   Grows monotonically, never sees any deletion.+  , stDecodedModules    :: !DecodedModules+      -- ^ Type-checked modules we visited during our Agda session.+      --   A module gets dropped from this list if its source+      --   or the source of any of its dependencies changed,+      --   or when its identity or the identity of one of its dependencies changed+      --   due to a change of the include paths.+  , stPersistentTopLevelModuleNames ::+      !(BiMap RawTopLevelModuleName ModuleNameHash)+    -- ^ Module name hashes for top-level module names (and vice+    -- versa).+  , stPersistentOptions :: CommandLineOptions+  , stInteractionOutputCallback  :: InteractionOutputCallback+    -- ^ Callback function to call when there is a response+    --   to give to the interactive frontend.+    --   See the documentation of 'InteractionOutputCallback'.+  , stAccumStatistics   :: !Statistics+    -- ^ Should be strict field.+  , stPersistLoadedFileCache :: !(Strict.Maybe LoadedFileCache)+    -- ^ Cached typechecking state from the last loaded file.+    --   Should be @Nothing@ when checking imports.+  }+  deriving Generic++data LoadedFileCache = LoadedFileCache+  { lfcCached  :: !CachedTypeCheckLog+  , lfcCurrent :: !CurrentTypeCheckLog+  }+  deriving Generic++-- | A log of what the type checker does and states after the action is+-- completed.  The cached version is stored first executed action first.+type CachedTypeCheckLog = [(TypeCheckAction, PostScopeState)]++-- | Like 'CachedTypeCheckLog', but storing the log for an ongoing type+-- checking of a module.  Stored in reverse order (last performed action+-- first).+type CurrentTypeCheckLog = [(TypeCheckAction, PostScopeState)]++-- | A complete log for a module will look like this:+--+--   * 'Pragmas'+--+--   * 'EnterSection', entering the main module.+--+--   * 'Decl'\/'EnterSection'\/'LeaveSection', for declarations and nested+--     modules+--+--   * 'LeaveSection', leaving the main module.+--+data TypeCheckAction+  = EnterSection !Erased !ModuleName !A.Telescope+  | LeaveSection !ModuleName+  | Decl !A.Declaration+    -- ^ Never a Section or ScopeDecl+  | Pragmas !PragmaOptions+  deriving (Generic)+++-- | Empty session state.++initFileDict :: AbsolutePath -> FileDictWithBuiltins+initFileDict primLibDir = FileDictWithBuiltins empty empty primLibDir++initSessionState :: AbsolutePath -> SessionTCState+initSessionState primLibDir = SessionTCState+    { stSessionFileDict  = initFileDict primLibDir+    , stSessionBenchmark = empty+    , stSessionBackends  = empty+    }++-- | Empty persistent state.++initPersistentState :: AbsolutePath -> PersistentTCState+initPersistentState = initPersistentStateFromSessionState . initSessionState++initPersistentStateFromSessionState :: SessionTCState -> PersistentTCState+initPersistentStateFromSessionState s = PersistentTCSt+  { stPersistentSession             = s+  , stPersistentOptions             = defaultOptions+  , stPersistentTopLevelModuleNames = empty+  , stDecodedModules                = Map.empty+  , stInteractionOutputCallback     = defaultInteractionOutputCallback+  , stAccumStatistics               = Map.empty+  , stPersistLoadedFileCache        = empty+  }++-- | An initial 'MetaId'.++initialMetaId :: MetaId+initialMetaId = MetaId+  { metaId     = 0+  , metaModule = noModuleNameHash+  }++-- | Empty state of type checker.++initPreScopeState :: PreScopeState+initPreScopeState = PreScopeState+  { stPreTokens               = mempty+  , stPreImports              = emptySignature+  , stPreImportedModules      = empty+  , stPreImportedModulesTransitive = empty+  , stPreModuleToSourceId     = Map.empty+  , stPreVisitedModules       = Map.empty+  , stPreScope                = emptyScopeInfo+  , stPrePatternSyns          = Map.empty+  , stPrePatternSynImports    = Map.empty+  , stPreGeneralizedVars      = mempty+  , stPrePragmaOptions        = defaultInteractionOptions+  , stPreImportedBuiltins     = Map.empty+  , stPreImportedDisplayForms = HMap.empty+  , stPreFreshInteractionId   = 0+  , stPreImportedUserWarnings = Map.empty+  , stPreLocalUserWarnings    = Map.empty+  , stPreWarningOnImport      = empty+  , stPreImportedPartialDefs  = Set.empty+  , stPreLibCache             = empty+  , stPreImportedMetaStore    = HMap.empty+  , stPreCopiedNames          = HMap.empty+  , stPreNameCopies           = HMap.empty+  }++initPostScopeState :: PostScopeState+initPostScopeState = PostScopeState+  { stPostSyntaxInfo             = mempty+  , stPostDisambiguatedNames     = IntMap.empty+  , stPostOpenMetaStore          = Map.empty+  , stPostSolvedMetaStore        = Map.empty+  , stPostInteractionPoints      = empty+  , stPostAwakeConstraints       = []+  , stPostSleepingConstraints    = []+  , stPostDirty                  = False+  , stPostOccursCheckDefs        = Set.empty+  , stPostSignature              = emptySignature+  , stPostModuleCheckpoints      = Map.empty+  , stPostImportsDisplayForms    = HMap.empty+  , stPostCurrentModule          = empty+  , stPostPendingInstances       = Set.empty+  , stPostTemporaryInstances     = Set.empty+  , stPostConcreteNames          = Map.empty+  , stPostUsedNames              = Map.empty+  , stPostShadowingNames         = Map.empty+  , stPostStatistics             = Map.empty+  , stPostTCWarnings             = empty+  , stPostMutualBlocks           = empty+  , stPostLocalBuiltins          = Map.empty+  , stPostFreshMetaId            = initialMetaId+  , stPostFreshMutualId          = 0+  , stPostFreshProblemId         = 1+  , stPostFreshCheckpointId      = 1+  , stPostFreshInt               = 0+  , stPostFreshNameId            = NameId 0 noModuleNameHash+  , stPostFreshOpaqueId          = OpaqueId 0 noModuleNameHash+  , stPostAreWeCaching           = False+  , stPostPostponeInstanceSearch = False+  , stPostConsideringInstance    = False+  , stPostInstantiateBlocking    = False+  , stPostLocalPartialDefs       = Set.empty+  , stPostOpaqueBlocks           = Map.empty+  , stPostOpaqueIds              = Map.empty+  , stPostForeignCode            = Map.empty+  , stPostInstanceHack           = False+  }++initStateIO :: IO TCState+initStateIO = initState <$> getPrimitiveLibDir++initState :: AbsolutePath -> TCState+initState = initStateFromSessionState . initSessionState++initStateFromSessionState :: SessionTCState -> TCState+initStateFromSessionState = initStateFromPersistentState . initPersistentStateFromSessionState++initStateFromPersistentState :: PersistentTCState -> TCState+initStateFromPersistentState s = TCSt+  { stPersistentState = s+  , stPreScopeState   = initPreScopeState+  , stPostScopeState  = initPostScopeState+  }++-- * Lenses for 'TCState'++-- ** Components of 'TCState'++lensPersistentState :: Lens' TCState PersistentTCState+lensPersistentState f s = f (stPersistentState s) <&> \ x -> s { stPersistentState = x }++lensPreScopeState :: Lens' TCState PreScopeState+lensPreScopeState f s = f (stPreScopeState s) <&> \ x -> s { stPreScopeState = x }++lensPostScopeState :: Lens' TCState PostScopeState+lensPostScopeState f s = f (stPostScopeState s) <&> \ x -> s { stPostScopeState = x }++-- ** Components of 'SessionTCState'++lensSessionState :: Lens' TCState SessionTCState+lensSessionState = lensPersistentState . lensPersistentSession++lensBackends :: Lens' SessionTCState [Backend]+lensBackends f s = f (stSessionBackends s) <&> \ x -> s { stSessionBackends = x }++lensBenchmark :: Lens' SessionTCState Benchmark+lensBenchmark f s = f (stSessionBenchmark s) <&> \ x -> s { stSessionBenchmark = x }++lensFileDict :: Lens' SessionTCState FileDictWithBuiltins+lensFileDict f s = f (stSessionFileDict s) <&> \ x -> s { stSessionFileDict = x }++lensFileDictBuilder :: Lens' SessionTCState FileDictBuilder+lensFileDictBuilder = lensFileDict . lensFileDictFileDictBuilder++lensBuiltinModuleIds :: Lens' SessionTCState BuiltinModuleIds+lensBuiltinModuleIds = lensFileDict . lensFileDictBuiltinModuleIds++lensPrimitiveLibDir :: Lens' SessionTCState PrimitiveLibDir+lensPrimitiveLibDir = lensFileDict . lensFileDictPrimitiveLibDir++-- ** Components of 'PersistentTCState'++lensPersistentSession :: Lens' PersistentTCState SessionTCState+lensPersistentSession f s = f (stPersistentSession s) <&> \ x -> s { stPersistentSession = x }++lensLoadedFileCache :: Lens' PersistentTCState (Strict.Maybe LoadedFileCache)+lensLoadedFileCache f s = f (stPersistLoadedFileCache s) <&> \ x -> s { stPersistLoadedFileCache = x }++lensTopLevelModuleNames :: Lens' PersistentTCState (BiMap RawTopLevelModuleName ModuleNameHash)+lensTopLevelModuleNames f s =+  f (stPersistentTopLevelModuleNames s) <&> \ x -> s { stPersistentTopLevelModuleNames = x }++-- ** Components of 'PreScopeState'++lensPreTokens :: Lens' PreScopeState HighlightingInfo+lensPreTokens f s = f (stPreTokens s) <&> \ x -> s { stPreTokens = x }++lensImports :: Lens' PreScopeState Signature+lensImports f s = f (stPreImports s) <&> \ x -> s { stPreImports = x }++lensImportedModules :: Lens' PreScopeState ImportedModules+lensImportedModules f s = f (stPreImportedModules s) <&> \ x -> s { stPreImportedModules = x }++lensImportedModulesTransitive :: Lens' PreScopeState ImportedModules+lensImportedModulesTransitive f s = f (stPreImportedModulesTransitive s) <&> \ x -> s { stPreImportedModulesTransitive = x }++lensModuleToSourceId :: Lens' PreScopeState ModuleToSourceId+lensModuleToSourceId f s = f (stPreModuleToSourceId s ) <&> \ x -> s { stPreModuleToSourceId = x }++lensVisitedModules :: Lens' PreScopeState VisitedModules+lensVisitedModules f s = f (stPreVisitedModules s ) <&> \ x -> s { stPreVisitedModules = x }++lensScope :: Lens' PreScopeState ScopeInfo+lensScope f s = f (stPreScope s ) <&> \ x -> s { stPreScope = x }++lensPatternSyns :: Lens' PreScopeState A.PatternSynDefns+lensPatternSyns f s = f (stPrePatternSyns s ) <&> \ x -> s { stPrePatternSyns = x }++lensPatternSynImports :: Lens' PreScopeState A.PatternSynDefns+lensPatternSynImports f s = f (stPrePatternSynImports s ) <&> \ x -> s { stPrePatternSynImports = x }++lensGeneralizedVars :: Lens' PreScopeState (Strict.Maybe (Set QName))+lensGeneralizedVars f s = f (stPreGeneralizedVars s ) <&> \ x -> s { stPreGeneralizedVars = x }++instance LensPragmaOptions PreScopeState where+  lensPragmaOptions f s = f (stPrePragmaOptions s ) <&> \ x -> s { stPrePragmaOptions = x }++lensImportedBuiltins :: Lens' PreScopeState BuiltinThings+lensImportedBuiltins f s = f (stPreImportedBuiltins s ) <&> \ x -> s { stPreImportedBuiltins = x }++lensFreshInteractionId :: Lens' PreScopeState InteractionId+lensFreshInteractionId f s = f (stPreFreshInteractionId s ) <&> \ x -> s { stPreFreshInteractionId = x }++lensImportedUserWarnings :: Lens' PreScopeState UserWarnings+lensImportedUserWarnings f s = f (stPreImportedUserWarnings s ) <&> \ x -> s { stPreImportedUserWarnings = x }++lensLocalUserWarnings :: Lens' PreScopeState UserWarnings+lensLocalUserWarnings f s = f (stPreLocalUserWarnings s ) <&> \ x -> s { stPreLocalUserWarnings = x }++lensWarningOnImport :: Lens' PreScopeState (Strict.Maybe Text)+lensWarningOnImport f s = f (stPreWarningOnImport s) <&> \ x -> s { stPreWarningOnImport = x }++lensImportedPartialDefs :: Lens' PreScopeState (Set QName)+lensImportedPartialDefs f s = f (stPreImportedPartialDefs s) <&> \ x -> s { stPreImportedPartialDefs = x }++lensLibCache :: Lens' PreScopeState LibCache+lensLibCache f s = f (stPreLibCache s) <&> \ x -> s { stPreLibCache = x }++lensImportedMetaStore :: Lens' PreScopeState RemoteMetaStore+lensImportedMetaStore f s = f (stPreImportedMetaStore s) <&> \x -> s { stPreImportedMetaStore = x }++lensCopiedNames :: Lens' PreScopeState (HashMap QName QName)+lensCopiedNames f s = f (stPreCopiedNames s) <&> \ x -> s { stPreCopiedNames = x }++lensNameCopies :: Lens' PreScopeState (HashMap QName (HashSet QName))+lensNameCopies f s = f (stPreNameCopies s) <&> \ x -> s { stPreNameCopies = x }++-- ** Components of PostScopeState++lensForeignCode :: Lens' PostScopeState BackendForeignCode+lensForeignCode f s = f (stPostForeignCode s ) <&> \ x -> s { stPostForeignCode = x }++lensLocalPartialDefs :: Lens' PostScopeState (Set QName)+lensLocalPartialDefs f s = f (stPostLocalPartialDefs s) <&> \ x -> s { stPostLocalPartialDefs = x }++lensFreshNameId :: Lens' PostScopeState NameId+lensFreshNameId f s = f (stPostFreshNameId s) <&> \ x -> s { stPostFreshNameId = x }++lensFreshOpaqueId :: Lens' PostScopeState OpaqueId+lensFreshOpaqueId f s = f (stPostFreshOpaqueId s) <&> \ x -> s { stPostFreshOpaqueId = x }++lensOpaqueBlocks :: Lens' PostScopeState (Map OpaqueId OpaqueBlock)+lensOpaqueBlocks f s = f (stPostOpaqueBlocks s) <&> \ x -> s { stPostOpaqueBlocks = x }++lensOpaqueIds :: Lens' PostScopeState (Map QName OpaqueId)+lensOpaqueIds f s = f (stPostOpaqueIds s) <&> \ x -> s { stPostOpaqueIds = x }++lensSyntaxInfo :: Lens' PostScopeState HighlightingInfo+lensSyntaxInfo f s = f (stPostSyntaxInfo s) <&> \ x -> s { stPostSyntaxInfo = x }++lensDisambiguatedNames :: Lens' PostScopeState DisambiguatedNames+lensDisambiguatedNames f s = f (stPostDisambiguatedNames s) <&> \ x -> s { stPostDisambiguatedNames = x }++lensOpenMetaStore :: Lens' PostScopeState LocalMetaStore+lensOpenMetaStore f s = f (stPostOpenMetaStore s) <&> \ x -> s { stPostOpenMetaStore = x }++lensSolvedMetaStore :: Lens' PostScopeState LocalMetaStore+lensSolvedMetaStore f s = f (stPostSolvedMetaStore s) <&> \ x -> s { stPostSolvedMetaStore = x }++lensInteractionPoints :: Lens' PostScopeState InteractionPoints+lensInteractionPoints f s = f (stPostInteractionPoints s) <&> \ x -> s { stPostInteractionPoints = x }++lensAwakeConstraints :: Lens' PostScopeState Constraints+lensAwakeConstraints f s = f (stPostAwakeConstraints s) <&> \ x -> s { stPostAwakeConstraints = x }++lensSleepingConstraints :: Lens' PostScopeState Constraints+lensSleepingConstraints f s = f (stPostSleepingConstraints s) <&> \ x -> s { stPostSleepingConstraints = x }++lensDirty :: Lens' PostScopeState Bool+lensDirty f s = f (stPostDirty s) <&> \ x -> s { stPostDirty = x }++lensOccursCheckDefs :: Lens' PostScopeState (Set QName)+lensOccursCheckDefs f s = f (stPostOccursCheckDefs s) <&> \ x -> s { stPostOccursCheckDefs = x }++lensSignature :: Lens' PostScopeState Signature+lensSignature f s = f (stPostSignature s) <&> \ x -> s { stPostSignature = x }++lensModuleCheckpoints :: Lens' PostScopeState (Map ModuleName CheckpointId)+lensModuleCheckpoints f s = f (stPostModuleCheckpoints s) <&> \ x -> s { stPostModuleCheckpoints = x }++lensImportsDisplayForms :: Lens' PostScopeState DisplayForms+lensImportsDisplayForms f s = f (stPostImportsDisplayForms s) <&> \ x -> s { stPostImportsDisplayForms = x }++lensImportedDisplayForms :: Lens' PreScopeState DisplayForms+lensImportedDisplayForms f s = f (stPreImportedDisplayForms s) <&> \ x -> s { stPreImportedDisplayForms = x }++lensTemporaryInstances :: Lens' PostScopeState (Set QName)+lensTemporaryInstances f s = f (stPostTemporaryInstances s) <&> \ x -> s { stPostTemporaryInstances = x }++lensConcreteNames :: Lens' PostScopeState ConcreteNames+lensConcreteNames f s = f (stPostConcreteNames s) <&> \ x -> s { stPostConcreteNames = x }++lensUsedNames :: Lens' PostScopeState UsedNames+lensUsedNames f s = f (stPostUsedNames s) <&> \ x -> s { stPostUsedNames = x }++lensShadowingNames :: Lens' PostScopeState ShadowingNames+lensShadowingNames f s = f (stPostShadowingNames s) <&> \ x -> s { stPostShadowingNames = x }++lensStatistics :: Lens' PostScopeState Statistics+lensStatistics f s = f (stPostStatistics s) <&> \ x -> s { stPostStatistics = x }++lensTCWarnings :: Lens' PostScopeState (Set TCWarning)+lensTCWarnings f s = f (stPostTCWarnings s) <&> \ x -> s { stPostTCWarnings = x }++lensMutualBlocks :: Lens' PostScopeState MutualBlocks+lensMutualBlocks f s = f (stPostMutualBlocks s) <&> \ x -> s { stPostMutualBlocks = x }++lensLocalBuiltins :: Lens' PostScopeState BuiltinThings+lensLocalBuiltins f s = f (stPostLocalBuiltins s) <&> \ x -> s { stPostLocalBuiltins = x }++lensFreshMetaId :: Lens' PostScopeState MetaId+lensFreshMetaId f s = f (stPostFreshMetaId s) <&> \ x -> s { stPostFreshMetaId = x }++lensFreshMutualId :: Lens' PostScopeState MutualId+lensFreshMutualId f s = f (stPostFreshMutualId s) <&> \ x -> s { stPostFreshMutualId = x }++lensFreshProblemId :: Lens' PostScopeState ProblemId+lensFreshProblemId f s = f (stPostFreshProblemId s) <&> \ x -> s { stPostFreshProblemId = x }++lensFreshCheckpointId :: Lens' PostScopeState CheckpointId+lensFreshCheckpointId f s = f (stPostFreshCheckpointId s) <&> \ x -> s { stPostFreshCheckpointId = x }++lensFreshInt :: Lens' PostScopeState Int+lensFreshInt f s = f (stPostFreshInt s) <&> \ x -> s { stPostFreshInt = x }++lensAreWeCaching :: Lens' PostScopeState Bool+lensAreWeCaching f s = f (stPostAreWeCaching s) <&> \x -> s { stPostAreWeCaching = x }++lensPostponeInstanceSearch :: Lens' PostScopeState Bool+lensPostponeInstanceSearch f s = f (stPostPostponeInstanceSearch s) <&> \ x -> s { stPostPostponeInstanceSearch = x }++lensConsideringInstance :: Lens' PostScopeState Bool+lensConsideringInstance f s = f (stPostConsideringInstance s) <&> \ x -> s { stPostConsideringInstance = x }++lensInstantiateBlocking :: Lens' PostScopeState Bool+lensInstantiateBlocking f s = f (stPostInstantiateBlocking s) <&> \ x -> s { stPostInstantiateBlocking = x }++lensInstanceHack :: Lens' PostScopeState Bool+lensInstanceHack f s = f (stPostInstanceHack s) <&> \ x -> s { stPostInstanceHack = x }++-- * @st@-prefixed lenses+------------------------------------------------------------------------++-- ** Session state++stBackends :: Lens' TCState [Backend]+stBackends = lensSessionState . lensBackends++stBenchmark :: Lens' TCState Benchmark+stBenchmark = lensSessionState . lensBenchmark++stFileDict :: Lens' TCState FileDictWithBuiltins+stFileDict = lensSessionState . lensFileDict++stBuiltinModuleIds :: Lens' TCState BuiltinModuleIds+stBuiltinModuleIds = lensSessionState . lensBuiltinModuleIds++stPrimitiveLibDir :: Lens' TCState PrimitiveLibDir+stPrimitiveLibDir = lensSessionState . lensPrimitiveLibDir++-- ** Persistent state++stLoadedFileCache :: Lens' TCState (Maybe LoadedFileCache)+stLoadedFileCache = lensPersistentState . lensLoadedFileCache . Strict.lensMaybeLazy++stTopLevelModuleNames :: Lens' TCState (BiMap RawTopLevelModuleName ModuleNameHash)+stTopLevelModuleNames = lensPersistentState . lensTopLevelModuleNames++-- ** Pre scope state++stTokens :: Lens' TCState HighlightingInfo+stTokens = lensPreScopeState . lensPreTokens++stImports :: Lens' TCState Signature+stImports = lensPreScopeState . lensImports++stImportedModules :: Lens' TCState ImportedModules+stImportedModules = lensPreScopeState . lensImportedModules++stImportedModulesTransitive :: Lens' TCState ImportedModules+stImportedModulesTransitive = lensPreScopeState . lensImportedModulesTransitive++stModuleToSourceId :: Lens' TCState ModuleToSourceId+stModuleToSourceId = lensPreScopeState . lensModuleToSourceId++stModuleToSource :: Lens' TCState ModuleToSource+stModuleToSource = lensProduct stFileDict stModuleToSourceId . lensPairModuleToSource++stVisitedModules :: Lens' TCState VisitedModules+stVisitedModules = lensPreScopeState . lensVisitedModules++stScope :: Lens' TCState ScopeInfo+stScope = lensPreScopeState . lensScope++stPatternSyns :: Lens' TCState A.PatternSynDefns+stPatternSyns = lensPreScopeState . lensPatternSyns++stPatternSynImports :: Lens' TCState A.PatternSynDefns+stPatternSynImports = lensPreScopeState . lensPatternSynImports++stGeneralizedVars :: Lens' TCState (Maybe (Set QName))+stGeneralizedVars = lensPreScopeState . lensGeneralizedVars . Strict.lensMaybeLazy++instance LensPragmaOptions TCState where+  lensPragmaOptions = lensPreScopeState . lensPragmaOptions++stPragmaOptions :: Lens' TCState PragmaOptions+stPragmaOptions = lensPragmaOptions++stImportedBuiltins :: Lens' TCState BuiltinThings+stImportedBuiltins = lensPreScopeState . lensImportedBuiltins++stForeignCode :: Lens' TCState BackendForeignCode+stForeignCode = lensPostScopeState . lensForeignCode++stFreshInteractionId :: Lens' TCState InteractionId+stFreshInteractionId = lensPreScopeState . lensFreshInteractionId++stImportedUserWarnings :: Lens' TCState UserWarnings+stImportedUserWarnings = lensPreScopeState . lensImportedUserWarnings++stLocalUserWarnings :: Lens' TCState UserWarnings+stLocalUserWarnings = lensPreScopeState . lensLocalUserWarnings++getUserWarnings :: ReadTCState m => m UserWarnings+getUserWarnings = do+  iuw <- useR stImportedUserWarnings+  luw <- useR stLocalUserWarnings+  return $ iuw `Map.union` luw++stWarningOnImport :: Lens' TCState (Maybe Text)+stWarningOnImport = lensPreScopeState . lensWarningOnImport . Strict.lensMaybeLazy++stImportedPartialDefs :: Lens' TCState (Set QName)+stImportedPartialDefs = lensPreScopeState . lensImportedPartialDefs++stLibCache :: Lens' TCState LibCache+stLibCache = lensPreScopeState . lensLibCache++stImportedMetaStore :: Lens' TCState RemoteMetaStore+stImportedMetaStore = lensPreScopeState . lensImportedMetaStore++stCopiedNames :: Lens' TCState (HashMap QName QName)+stCopiedNames = lensPreScopeState . lensCopiedNames++stNameCopies :: Lens' TCState (HashMap QName (HashSet QName))+stNameCopies = lensPreScopeState . lensNameCopies++stImportedDisplayForms :: Lens' TCState DisplayForms+stImportedDisplayForms = lensPreScopeState . lensImportedDisplayForms++-- ** Post scope state++stLocalPartialDefs :: Lens' TCState (Set QName)+stLocalPartialDefs = lensPostScopeState . lensLocalPartialDefs++getPartialDefs :: ReadTCState m => m (Set QName)+getPartialDefs = do+  ipd <- useR stImportedPartialDefs+  lpd <- useR stLocalPartialDefs+  return $ ipd `Set.union` lpd++stFreshNameId :: Lens' TCState NameId+stFreshNameId = lensPostScopeState . lensFreshNameId++stFreshOpaqueId :: Lens' TCState OpaqueId+stFreshOpaqueId = lensPostScopeState . lensFreshOpaqueId++stOpaqueBlocks :: Lens' TCState (Map OpaqueId OpaqueBlock)+stOpaqueBlocks = lensPostScopeState . lensOpaqueBlocks++stOpaqueIds :: Lens' TCState (Map QName OpaqueId)+stOpaqueIds = lensPostScopeState . lensOpaqueIds++stInstanceHack :: Lens' TCState Bool+stInstanceHack = lensPostScopeState . lensInstanceHack++stSyntaxInfo :: Lens' TCState HighlightingInfo+stSyntaxInfo = lensPostScopeState . lensSyntaxInfo++stDisambiguatedNames :: Lens' TCState DisambiguatedNames+stDisambiguatedNames = lensPostScopeState . lensDisambiguatedNames++stOpenMetaStore :: Lens' TCState LocalMetaStore+stOpenMetaStore = lensPostScopeState . lensOpenMetaStore++stSolvedMetaStore :: Lens' TCState LocalMetaStore+stSolvedMetaStore = lensPostScopeState . lensSolvedMetaStore++stInteractionPoints :: Lens' TCState InteractionPoints+stInteractionPoints = lensPostScopeState . lensInteractionPoints++stAwakeConstraints :: Lens' TCState Constraints+stAwakeConstraints = lensPostScopeState . lensAwakeConstraints++stSleepingConstraints :: Lens' TCState Constraints+stSleepingConstraints = lensPostScopeState . lensSleepingConstraints++stDirty :: Lens' TCState Bool+stDirty = lensPostScopeState . lensDirty++stOccursCheckDefs :: Lens' TCState (Set QName)+stOccursCheckDefs = lensPostScopeState . lensOccursCheckDefs++stSignature :: Lens' TCState Signature+stSignature = lensPostScopeState . lensSignature++stRewriteRules :: Lens' TCState RewriteRuleMap+stRewriteRules = stSignature . sigRewriteRules++stModuleCheckpoints :: Lens' TCState (Map ModuleName CheckpointId)+stModuleCheckpoints = lensPostScopeState . lensModuleCheckpoints++stImportsDisplayForms :: Lens' TCState DisplayForms+stImportsDisplayForms = lensPostScopeState . lensImportsDisplayForms++-- | Note that the lens is \"strict\".++stCurrentModule ::+  Lens' TCState (Maybe (ModuleName, TopLevelModuleName))+stCurrentModule f s =+  f (stPostCurrentModule (stPostScopeState s)) <&>+  \x -> s {stPostScopeState =+             (stPostScopeState s)+               {stPostCurrentModule = case x of+                  Nothing         -> Nothing+                  Just (!m, !top) -> Just (m, top)}}++-- TODO: turn this into a composition of shallow lenses++-- lensCurrentModule :: Lens' PostScopeState (Maybe (ModuleName, TopLevelModuleName))+-- lensCurrentModule f s = f (stPostCurrentModule s) <&> \ x -> s { stPostCurrentModule = x }++-- -- | Note that the lens is \"strict\".++-- stCurrentModule :: Lens' TCState (Maybe (ModuleName, TopLevelModuleName))+-- stCurrentModule = lensPostScopeState . lensCurrentModule . fmap (fmap \ (!m, !top) -> (m, top))++stInstanceDefs :: Lens' TCState TempInstanceTable+stInstanceDefs f s =+  f ( s ^. stSignature . sigInstances+    , stPostPendingInstances (stPostScopeState s)+    )+  <&> \(t, x) ->+    set (stSignature . sigInstances) t+      (s { stPostScopeState = (stPostScopeState s) { stPostPendingInstances = x }})++stTemporaryInstances :: Lens' TCState (Set QName)+stTemporaryInstances = lensPostScopeState . lensTemporaryInstances++stConcreteNames :: Lens' TCState ConcreteNames+stConcreteNames = lensPostScopeState . lensConcreteNames++stUsedNames :: Lens' TCState UsedNames+stUsedNames = lensPostScopeState . lensUsedNames++stShadowingNames :: Lens' TCState ShadowingNames+stShadowingNames = lensPostScopeState . lensShadowingNames++stStatistics :: Lens' TCState Statistics+stStatistics = lensPostScopeState . lensStatistics++stTCWarnings :: Lens' TCState (Set TCWarning)+stTCWarnings = lensPostScopeState . lensTCWarnings++stMutualBlocks :: Lens' TCState MutualBlocks+stMutualBlocks = lensPostScopeState . lensMutualBlocks++stLocalBuiltins :: Lens' TCState BuiltinThings+stLocalBuiltins = lensPostScopeState . lensLocalBuiltins++stFreshMetaId :: Lens' TCState MetaId+stFreshMetaId = lensPostScopeState . lensFreshMetaId++stFreshMutualId :: Lens' TCState MutualId+stFreshMutualId = lensPostScopeState . lensFreshMutualId++stFreshProblemId :: Lens' TCState ProblemId+stFreshProblemId = lensPostScopeState . lensFreshProblemId++stFreshCheckpointId :: Lens' TCState CheckpointId+stFreshCheckpointId = lensPostScopeState . lensFreshCheckpointId++stFreshInt :: Lens' TCState Int+stFreshInt = lensPostScopeState . lensFreshInt++-- | use @areWeCaching@ from the Caching module instead.+stAreWeCaching :: Lens' TCState Bool+stAreWeCaching = lensPostScopeState . lensAreWeCaching++stPostponeInstanceSearch :: Lens' TCState Bool+stPostponeInstanceSearch = lensPostScopeState . lensPostponeInstanceSearch++stConsideringInstance :: Lens' TCState Bool+stConsideringInstance = lensPostScopeState . lensConsideringInstance++stInstantiateBlocking :: Lens' TCState Bool+stInstantiateBlocking = lensPostScopeState . lensInstantiateBlocking++stInstanceTree :: Lens' TCState (DiscrimTree QName)+stInstanceTree = stSignature . sigInstances . itableTree++stBuiltinThings :: TCState -> BuiltinThings+stBuiltinThings s = Map.unionWith unionBuiltin (s ^. stLocalBuiltins) (s ^. stImportedBuiltins)++-- | Union two 'Builtin's.  Only defined for 'BuiltinRewriteRelations'.+unionBuiltin :: Builtin a -> Builtin a -> Builtin a+unionBuiltin = curry $ \case+  (BuiltinRewriteRelations xs, BuiltinRewriteRelations ys) -> BuiltinRewriteRelations $ xs <> ys+  _ -> __IMPOSSIBLE__+++-- * Fresh things+------------------------------------------------------------------------++class Enum i => HasFresh i where+    freshLens :: Lens' TCState i+    nextFresh' :: i -> i+    nextFresh' = succ++{-# INLINE nextFresh #-}+nextFresh :: HasFresh i => TCState -> (i, TCState)+nextFresh s =+  let !c = s ^. freshLens+      !next = set freshLens (nextFresh' c) s+  in (c, next)++class Monad m => MonadFresh i m where+  fresh :: m i++  default fresh :: (MonadTrans t, MonadFresh i n, t n ~ m) => m i+  fresh = lift fresh++instance MonadFresh i m => MonadFresh i (ExceptT e m)+instance MonadFresh i m => MonadFresh i (MaybeT m)+instance MonadFresh i m => MonadFresh i (ReaderT r m)+instance MonadFresh i m => MonadFresh i (StateT s m)+instance (MonadFresh i m, Monoid w) => MonadFresh i (WriterT w m)+instance MonadFresh i m => MonadFresh i (ListT m)+instance MonadFresh i m => MonadFresh i (IdentityT m)++instance HasFresh i => MonadFresh i TCM where+  fresh = do+        !s <- getTC+        let (!c , !s') = nextFresh s+        putTC s'+        return c+  {-# INLINE fresh #-}++instance HasFresh MetaId where+  freshLens = stFreshMetaId++instance HasFresh MutualId where+  freshLens = stFreshMutualId++instance HasFresh InteractionId where+  freshLens = stFreshInteractionId++instance HasFresh NameId where+  freshLens = stFreshNameId+  -- nextFresh increments the current fresh name by 2 so @NameId@s used+  -- before caching starts do not overlap with the ones used after.+  nextFresh' = succ . succ++instance HasFresh OpaqueId where+  freshLens = stFreshOpaqueId++instance HasFresh Int where+  freshLens = stFreshInt++instance HasFresh ProblemId where+  freshLens = stFreshProblemId++newtype CheckpointId = CheckpointId Int+  deriving (Eq, Ord, Enum, Real, Integral, Num, NFData)++instance Show CheckpointId where+  show (CheckpointId n) = show n++instance Pretty CheckpointId where+  pretty (CheckpointId n) = pretty n++instance HasFresh CheckpointId where+  freshLens = stFreshCheckpointId++freshName :: MonadFresh NameId m => Range -> String -> m Name+freshName r s = do+  i <- fresh+  return $ mkName r i s++freshNoName :: MonadFresh NameId m => Range -> m Name+freshNoName r =+    do  i <- fresh+        return $ makeName i (C.NoName noRange i) r noFixity' False++freshNoName_ :: MonadFresh NameId m => m Name+freshNoName_ = freshNoName noRange++freshRecordName :: MonadFresh NameId m => m Name+freshRecordName = do+  i <- fresh+  return $ makeName i (C.setNotInScope $ C.simpleName "r") noRange noFixity' True++-- | Create a fresh name from @a@.+class FreshName a where+  freshName_ :: MonadFresh NameId m => a -> m Name++instance FreshName (Range, String) where+  freshName_ = uncurry freshName++instance FreshName String where+  freshName_ = freshName noRange++instance FreshName Range where+  freshName_ = freshNoName++instance FreshName () where+  freshName_ () = freshNoName_++instance FreshName Name where+  freshName_ (Name _ con can bs fix rn) = do+    i <- fresh+    pure $ Name i con can bs fix rn++---------------------------------------------------------------------------+-- * Associating concrete names to an abstract name+---------------------------------------------------------------------------++-- | A monad that has read and write access to the stConcreteNames+--   part of the TCState. Basically, this is a synonym for `MonadState+--   ConcreteNames m` (which cannot be used directly because of the+--   limitations of Haskell's typeclass system).+class Monad m => MonadStConcreteNames m where+  runStConcreteNames :: StateT ConcreteNames m a -> m a++  useConcreteNames :: m ConcreteNames+  useConcreteNames = runStConcreteNames get++  modifyConcreteNames :: (ConcreteNames -> ConcreteNames) -> m ()+  modifyConcreteNames = runStConcreteNames . modify++instance MonadStConcreteNames TCM where+  runStConcreteNames m = stateTCLensM stConcreteNames $ runStateT m++-- | The concrete names get lost in case of an exception.+instance MonadStConcreteNames m => MonadStConcreteNames (ExceptT e m) where+  runStConcreteNames m = ExceptT $ runStConcreteNames $ StateT $ \ ns -> do+    runExceptT (runStateT m ns) <&> \case+      Left e         -> (Left e, mempty)+      Right (x, ns') -> (Right x, ns')++instance MonadStConcreteNames m => MonadStConcreteNames (IdentityT m) where+  runStConcreteNames m = IdentityT $ runStConcreteNames $ StateT $ runIdentityT . runStateT m++instance MonadStConcreteNames m => MonadStConcreteNames (MaybeT m) where+  runStConcreteNames m = MaybeT $ runStConcreteNames $ StateT $ \ ns -> do+    runMaybeT (runStateT m ns) <&> \case+      Nothing       -> (Nothing, mempty)+      Just (x, ns') -> (Just x, ns')++instance MonadStConcreteNames m => MonadStConcreteNames (ReaderT r m) where+  runStConcreteNames m = ReaderT $ runStConcreteNames . StateT . flip (runReaderT . runStateT m)++instance MonadStConcreteNames m => MonadStConcreteNames (StateT s m) where+  runStConcreteNames m = StateT $ \s -> runStConcreteNames $ StateT $ \ns -> do+    ((x,ns'),s') <- runStateT (runStateT m ns) s+    return ((x,s'),ns')++instance (MonadStConcreteNames m, Monoid w) => MonadStConcreteNames (WriterT w m) where+  runStConcreteNames m = WriterT $ runStConcreteNames $ StateT $ \ ns -> do+    ((x,ns'),w) <- runWriterT $ runStateT m ns+    return ((x,w),ns')++---------------------------------------------------------------------------+-- * File handling+---------------------------------------------------------------------------++instance GetFileId FileDictWithBuiltins where+  getFileId = getFileId . fileDictBuilder++instance GetIdFile FileDictWithBuiltins where+  getIdFile = getIdFile . fileDictBuilder++-- | Get the file name of a 'SourceFile'.++srcFilePath :: MonadFileId m => SourceFile -> m AbsolutePath+srcFilePath (SourceFile fi) = fileFromId fi++-- | Get make a 'SourceFile' from a file name.+srcFromPath :: MonadFileId m => AbsolutePath -> m SourceFile+srcFromPath p = SourceFile <$> idFromFile p++instance Pretty ModuleToSource where+  pretty (ModuleToSource dict mods) = vcat+    [ hsep [ "-", pretty m, "->", pretty $ getIdFile dict i ]+    | (m, SourceFile i) <- Map.toList mods+    ]++-- | Lookup the path of a top level module name, which must be a known one.++topLevelModuleFilePath :: ModuleToSource -> TopLevelModuleName -> AbsolutePath+topLevelModuleFilePath (ModuleToSource dict m2s) m =+  getIdFile dict $ srcFileId $ Map.findWithDefault __IMPOSSIBLE__ m m2s++---------------------------------------------------------------------------+-- * Interface+---------------------------------------------------------------------------+++-- | Distinguishes between type-checked and scope-checked interfaces+--   when stored in the map of `VisitedModules`.+data ModuleCheckMode+  = ModuleScopeChecked+  | ModuleTypeChecked+  deriving (Eq, Ord, Bounded, Enum, Show, Generic)+++data ModuleInfo = ModuleInfo+  { miInterface  :: Interface+  , miWarnings   :: Set TCWarning+    -- ^ Warnings were encountered when the module was type checked.+    --   These might include warnings not stored in the interface itself,+    --   specifically unsolved interaction metas.+    --   See "Agda.Interaction.Imports"+  , miPrimitive  :: Bool+    -- ^ 'True' if the module is a primitive module, which should always+    -- be importable.+  , miMode       :: ModuleCheckMode+    -- ^ The `ModuleCheckMode` used to create the `Interface`+  }+  deriving Generic++type VisitedModules = Map TopLevelModuleName ModuleInfo+type DecodedModules = Map TopLevelModuleName ModuleInfo++data ForeignCode = ForeignCode Range String+  deriving (Show, Generic)++-- | Foreign code fragments are stored in reversed order to support efficient appending:+--   head points to the latest pragma in module.+newtype ForeignCodeStack = ForeignCodeStack+  { getForeignCodeStack :: [ForeignCode]+  } deriving (Show, Generic, NFData)++data Interface = Interface+  { iSourceHash      :: !Hash+    -- ^ Hash of the source code.+  , iSource          :: TL.Text+    -- ^ The source code. The source code is stored so that the HTML+    -- and LaTeX backends can generate their output without having to+    -- re-read the (possibly out of date) source code.+  , iFileType        :: FileType+    -- ^ Source file type, determined from the file extension+  , iImportedModules :: [(TopLevelModuleName, Hash)]+    -- ^ Imported modules and their hashes.+  , iModuleName      :: ModuleName+    -- ^ Module name of this interface.+  , iTopLevelModuleName :: TopLevelModuleName+    -- ^ The module's top-level module name.+  , iScope           :: Map ModuleName Scope+    -- ^ Scope defined by this module.+    --+    --   Andreas, AIM XX: Too avoid duplicate serialization, this field is+    --   not serialized, so if you deserialize an interface, @iScope@+    --   will be empty.+    --   But 'constructIScope' constructs 'iScope' from 'iInsideScope'.+  , iInsideScope     :: ScopeInfo+    -- ^ Scope after we loaded this interface.+    --   Used in 'Agda.Interaction.BasicOps.AtTopLevel'+    --   and     'Agda.Interaction.CommandLine.interactionLoop'.+  , iSignature       :: Signature+  , iMetaBindings    :: RemoteMetaStore+    -- ^ Instantiations for meta-variables that come from this module.+  , iDisplayForms    :: DisplayForms+    -- ^ Display forms added for imported identifiers.+  , iUserWarnings    :: UserWarnings+    -- ^ User warnings for imported identifiers+  , iImportWarning   :: Maybe Text+    -- ^ Whether this module should raise a warning when imported+  , iBuiltin         :: BuiltinThings' (PrimitiveId, QName)+  , iForeignCode     :: Map BackendName ForeignCodeStack+  , iHighlighting    :: HighlightingInfo+  , iDefaultPragmaOptions :: [OptionsPragma]+    -- ^ Pragma options set in library files.+  , iFilePragmaOptions    :: [OptionsPragma]+    -- ^ Pragma options set in the file.+  , iOptionsUsed     :: PragmaOptions+    -- ^ Options/features used when checking the file (can be different+    --   from options set directly in the file).+  , iPatternSyns     :: A.PatternSynDefns+  , iWarnings        :: Set TCWarning+  , iPartialDefs     :: Set QName+  , iOpaqueBlocks    :: Map OpaqueId OpaqueBlock+  , iOpaqueNames     :: Map QName OpaqueId+  }+  deriving (Show, Generic)++instance Pretty Interface where+  pretty (Interface+            sourceH source fileT importedM moduleN topModN scope insideS+            signature metas display userwarn importwarn builtin+            foreignCode highlighting libPragmaO filePragmaO oUsed+            patternS warnings partialdefs oblocks onames) =++    hang "Interface" 2 $ vcat+      [ "source hash:"         <+> (pretty . show) sourceH+      , "source:"              $$  nest 2 (text $ TL.unpack source)+      , "file type:"           <+> (pretty . show) fileT+      , "imported modules:"    <+> (pretty . show) importedM+      , "module name:"         <+> pretty moduleN+      , "top-level module name:" <+> pretty topModN+      , "scope:"               <+> (pretty . show) scope+      , "inside scope:"        <+> (pretty . show) insideS+      , "signature:"           <+> (pretty . show) signature+      , "meta-variables:"      <+> (pretty . show) metas+      , "display:"             <+> (pretty . show) display+      , "user warnings:"       <+> (pretty . show) userwarn+      , "import warning:"      <+> (pretty . show) importwarn+      , "builtin:"             <+> (pretty . show) builtin+      , "Foreign code:"        <+> (pretty . show) foreignCode+      , "highlighting:"        <+> (pretty . show) highlighting+      , "library pragma options:" <+> (pretty . show) libPragmaO+      , "file pragma options:" <+> (pretty . show) filePragmaO+      , "options used:"        <+> (pretty . show) oUsed+      , "pattern syns:"        <+> (pretty . show) patternS+      , "warnings:"            <+> (pretty . show) warnings+      , "partial definitions:" <+> (pretty . show) partialdefs+      , "opaque blocks:"       <+> pretty oblocks+      , "opaque names"         <+> pretty onames+      ]++-- | Combines the source hash and the (full) hashes of the imported modules.+iFullHash :: Interface -> Hash+iFullHash i = combineHashes $ iSourceHash i : List.map snd (iImportedModules i)++-- | A lens for the 'iSignature' field of the 'Interface' type.++intSignature :: Lens' Interface Signature+intSignature f i = f (iSignature i) <&> \s -> i { iSignature = s }++---------------------------------------------------------------------------+-- ** Closure+---------------------------------------------------------------------------++data Closure a = Closure+  { clSignature        :: Signature+  , clEnv              :: TCEnv+  , clScope            :: ScopeInfo+  , clModuleCheckpoints :: Map ModuleName CheckpointId+  , clValue            :: a+  }+    deriving (Functor, Foldable, Generic)++instance Show a => Show (Closure a) where+  show cl = "Closure { clValue = " ++ show (clValue cl) ++ " }"++instance HasRange a => HasRange (Closure a) where+  getRange = getRange . clValue++class LensClosure b a | b -> a where+  lensClosure :: Lens' b (Closure a)++instance LensClosure (Closure a) a where+  lensClosure = id++instance LensTCEnv (Closure a) where+  lensTCEnv f cl = (f $! clEnv cl) <&> \ env -> cl { clEnv = env }++{-# SPECIALIZE buildClosure :: a -> TCM (Closure a)  #-}+buildClosure :: (MonadTCEnv m, ReadTCState m) => a -> m (Closure a)+buildClosure x = do+    env   <- askTC+    sig   <- useR stSignature+    scope <- useR stScope+    cps   <- useR stModuleCheckpoints+    return $ Closure sig env scope cps x++---------------------------------------------------------------------------+-- ** Constraints+---------------------------------------------------------------------------++type Constraints = [ProblemConstraint]++data ProblemConstraint = PConstr+  { constraintProblems  :: Set ProblemId+  , constraintUnblocker :: Blocker+  , theConstraint       :: Closure Constraint+  }+  deriving (Show, Generic)++instance HasRange ProblemConstraint where+  getRange = getRange . theConstraint++-- | Why are we performing a modality check?+data WhyCheckModality+  = ConstructorType+  -- ^ Because --without-K is enabled, so the types of data constructors+  -- must be usable at the context's modality.+  | IndexedClause+  -- ^ Because --without-K is enabled, so the result type of clauses+  -- must be usable at the context's modality.+  | IndexedClauseArg Name Name+  -- ^ Because --without-K is enabled, so any argument (second name)+  -- which mentions a dotted argument (first name) must have a type+  -- which is usable at the context's modality.+  | GeneratedClause+  -- ^ Because we double-check the --cubical-compatible clauses. This is+  -- an internal error!+  deriving (Show, Generic)++data Constraint+  = ValueCmp Comparison CompareAs Term Term+  | ValueCmpOnFace Comparison Term Type Term Term+  | ElimCmp [Polarity] [IsForced] Type Term [Elim] [Elim]+  | SortCmp Comparison Sort Sort+  | LevelCmp Comparison Level Level+--  | ShortCut MetaId Term Type+--    -- ^ A delayed instantiation.  Replaces @ValueCmp@ in 'postponeTypeCheckingProblem'.+  | HasBiggerSort Sort+  | HasPTSRule (Dom Type) (Abs Sort)+  | CheckDataSort QName Sort+    -- ^ Check that the sort 'Sort' of data type 'QName' admits data/record types.+    -- E.g., sorts @IUniv@, @SizeUniv@ etc. do not admit such constructions.+    -- See 'Agda.TypeChecking.Rules.Data.checkDataSort'.+  | CheckMetaInst MetaId+  | CheckType Type+  | UnBlock MetaId+    -- ^ Meta created for a term blocked by a postponed type checking problem or unsolved+    --   constraints. The 'MetaInstantiation' for the meta (when unsolved) is either 'BlockedConst'+    --   or 'PostponedTypeCheckingProblem'.+  | IsEmpty Range Type+    -- ^ The range is the one of the absurd pattern.+  | CheckSizeLtSat Term+    -- ^ Check that the 'Term' is either not a SIZELT or a non-empty SIZELT.+  | FindInstance Range MetaId (Maybe [Candidate])+    -- ^ the second argument is the instance argument and the third one is dhe list of candidates+    --   (or Nothing if we haven’t determined the list of candidates yet)+  | ResolveInstanceHead QName+    -- ^ Resolve the head symbol of the type that the given instance targets+  | CheckFunDef A.DefInfo QName [A.Clause] TCErr+    -- ^ Last argument is the error causing us to postpone.+  | UnquoteTactic Term Term Type   -- ^ First argument is computation and the others are hole and goal type+  | CheckLockedVars Term Type (Arg Term) Type     -- ^ @CheckLockedVars t ty lk lk_ty@ with @t : ty@, @lk : lk_ty@ and @t lk@ well-typed.+  | UsableAtModality WhyCheckModality (Maybe Sort) Modality Term+    -- ^ Is the term usable at the given modality?+    -- This check should run if the @Sort@ is @Nothing@ or @isFibrant@.+  deriving (Show, Generic)++-- It's important to have a proper range for constraints that can remain unsolved+-- without a corresponding unsolved to point to the location of the constraint.+instance HasRange Constraint where+  getRange (IsEmpty r t)         = r+  getRange (FindInstance r _ _)  = r+  getRange ValueCmp{}            = noRange+  getRange ElimCmp{}             = noRange+  getRange SortCmp{}             = noRange+  getRange LevelCmp{}            = noRange+  getRange UnBlock{}             = noRange+  getRange ValueCmpOnFace{}      = noRange+  getRange HasBiggerSort{}       = noRange+  getRange HasPTSRule{}          = noRange+  getRange CheckDataSort{}       = noRange+  getRange CheckMetaInst{}       = noRange+  getRange CheckType{}           = noRange+  getRange CheckSizeLtSat{}      = noRange+  getRange CheckFunDef{}         = noRange+  getRange ResolveInstanceHead{} = noRange+  getRange UnquoteTactic{}       = noRange+  getRange CheckLockedVars{}     = noRange+  getRange UsableAtModality{}    = noRange++instance Free Constraint where+  freeVars' c =+    case c of+      ValueCmp _ t u v      -> freeVars' (t, (u, v))+      ValueCmpOnFace _ p t u v -> freeVars' (p, (t, (u, v)))+      ElimCmp _ _ t u es es'  -> freeVars' ((t, u), (es, es'))+      SortCmp _ s s'        -> freeVars' (s, s')+      LevelCmp _ l l'       -> freeVars' (l, l')+      UnBlock _             -> mempty+      IsEmpty _ t           -> freeVars' t+      CheckSizeLtSat u      -> freeVars' u+      FindInstance _ _ cs   -> freeVars' cs+      ResolveInstanceHead q -> mempty+      CheckFunDef{}         -> mempty+      HasBiggerSort s       -> freeVars' s+      HasPTSRule a s        -> freeVars' (a , s)+      CheckLockedVars a b c d -> freeVars' ((a,b),(c,d))+      UnquoteTactic t h g   -> freeVars' (t, (h, g))+      CheckDataSort _ s     -> freeVars' s+      CheckMetaInst m       -> mempty+      CheckType t           -> freeVars' t+      UsableAtModality _ ms mod t -> freeVars' (ms, t)++instance TermLike Constraint where+  foldTerm f = \case+      ValueCmp _ t u v       -> foldTerm f (t, u, v)+      ValueCmpOnFace _ p t u v -> foldTerm f (p, t, u, v)+      ElimCmp _ _ t u es es' -> foldTerm f (t, u, es, es')+      LevelCmp _ l l'        -> foldTerm f (Level l, Level l')  -- Note wrapping as term, to ensure f gets to act on l and l'+      IsEmpty _ t            -> foldTerm f t+      CheckSizeLtSat u       -> foldTerm f u+      UnquoteTactic t h g    -> foldTerm f (t, h, g)+      SortCmp _ s1 s2        -> foldTerm f (Sort s1, Sort s2)   -- Same as LevelCmp case+      UnBlock _              -> mempty+      CheckLockedVars a b c d -> foldTerm f (a, b, c, d)+      FindInstance _ _ _     -> mempty+      ResolveInstanceHead q  -> mempty+      CheckFunDef{}          -> mempty+      HasBiggerSort s        -> foldTerm f s+      HasPTSRule a s         -> foldTerm f (a, Sort <$> s)+      CheckDataSort _ s      -> foldTerm f s+      CheckMetaInst m        -> mempty+      CheckType t            -> foldTerm f t+      UsableAtModality _ ms m t   -> foldTerm f (Sort <$> ms, t)++  traverseTermM f c = __IMPOSSIBLE__ -- Not yet implemented++instance AllMetas Constraint++instance Pretty Comparison where+  pretty CmpEq  = "="+  pretty CmpLeq = "=<"++-- | An extension of 'Comparison' to @>=@.+data CompareDirection = DirEq | DirLeq | DirGeq+  deriving (Eq, Show)++instance Pretty CompareDirection where+  pretty = text . \case+    DirEq  -> "="+    DirLeq -> "=<"+    DirGeq -> ">="++-- | Embed 'Comparison' into 'CompareDirection'.+fromCmp :: Comparison -> CompareDirection+fromCmp CmpEq  = DirEq+fromCmp CmpLeq = DirLeq++-- | Flip the direction of comparison.+flipCmp :: CompareDirection -> CompareDirection+flipCmp DirEq  = DirEq+flipCmp DirLeq = DirGeq+flipCmp DirGeq = DirLeq++-- | Turn a 'Comparison' function into a 'CompareDirection' function.+--+--   Property: @dirToCmp f (fromCmp cmp) = f cmp@+dirToCmp :: (Comparison -> a -> a -> c) -> CompareDirection -> a -> a -> c+dirToCmp cont DirEq  = cont CmpEq+dirToCmp cont DirLeq = cont CmpLeq+dirToCmp cont DirGeq = flip $ cont CmpLeq++-- | We can either compare two terms at a given type, or compare two+--   types without knowing (or caring about) their sorts.+data CompareAs+  = AsTermsOf Type -- ^ @Type@ should not be @Size@.+                   --   But currently, we do not rely on this invariant.+  | AsSizes        -- ^ Replaces @AsTermsOf Size@.+  | AsTypes+  deriving (Show, Generic)++instance Free CompareAs where+  freeVars' (AsTermsOf a) = freeVars' a+  freeVars' AsSizes       = mempty+  freeVars' AsTypes       = mempty++instance TermLike CompareAs where+  foldTerm f (AsTermsOf a) = foldTerm f a+  foldTerm f AsSizes       = mempty+  foldTerm f AsTypes       = mempty++  traverseTermM f = \case+    AsTermsOf a -> AsTermsOf <$> traverseTermM f a+    AsSizes     -> return AsSizes+    AsTypes     -> return AsTypes++instance AllMetas CompareAs++instance Pretty CompareAs where+  pretty (AsTermsOf a) = ":" <+> pretty a+  pretty AsSizes       = ":" <+> text "Size"+  pretty AsTypes       = empty++---------------------------------------------------------------------------+-- * Open things+---------------------------------------------------------------------------++-- | A thing tagged with the context it came from. Also keeps the substitution from previous+--   checkpoints. This lets us handle the case when an open thing was created in a context that we+--   have since exited. Remember which module it's from to make sure we don't get confused by+--   checkpoints from other files.+data Open a = OpenThing { openThingCheckpoint    :: CheckpointId+                        , openThingCheckpointMap :: Map CheckpointId Substitution+                        , openThingModule        :: ModuleNameHash+                        , openThing              :: a }+    deriving (Show, Functor, Foldable, Traversable, Generic)++instance Decoration Open where+  traverseF f (OpenThing cp env m x) = OpenThing cp env m <$> f x++instance Pretty a => Pretty (Open a) where+  prettyPrec p (OpenThing cp env _ x) = mparens (p > 9) $+    "OpenThing" <+> pretty cp <+> pretty (Map.toList env) <?> prettyPrec 10 x++---------------------------------------------------------------------------+-- * Judgements+--+-- Used exclusively for typing of meta variables.+---------------------------------------------------------------------------++-- | Parametrized since it is used without MetaId when creating a new meta.+data Judgement a+  = HasType+    { jMetaId     :: a+    , jComparison :: Comparison -- ^ are we checking (@CmpLeq@) or inferring (@CmpEq@) the type?+    , jMetaType   :: Type+    }+  | IsSort+    { jMetaId   :: a+    , jMetaType :: Type -- Andreas, 2011-04-26: type needed for higher-order sort metas+    }+  deriving (Show, Generic)++instance Pretty a => Pretty (Judgement a) where+    pretty (HasType a cmp t) = hsep [ pretty a, ":"    , pretty t ]+    pretty (IsSort  a t)     = hsep [ pretty a, ":sort", pretty t ]++-----------------------------------------------------------------------------+-- ** Generalizable variables+-----------------------------------------------------------------------------++data DoGeneralize+  = YesGeneralizeVar  -- ^ Generalize because it is a generalizable variable.+  | YesGeneralizeMeta -- ^ Generalize because it is a metavariable and+                      --   we're currently checking the type of a generalizable variable+                      --   (this should get the default modality).+  | NoGeneralize      -- ^ Don't generalize.+  deriving (Eq, Ord, Show, Generic)++-- | The value of a generalizable variable. This is created to be a+--   generalizable meta before checking the type to be generalized.+data GeneralizedValue = GeneralizedValue+  { genvalCheckpoint :: CheckpointId+  , genvalTerm       :: Term+  , genvalType       :: Type+  } deriving (Show, Generic)++---------------------------------------------------------------------------+-- ** Meta variables+---------------------------------------------------------------------------++-- | Information about local meta-variables.++data MetaVariable =+        MetaVar { mvInfo          :: MetaInfo+                , mvPriority      :: MetaPriority -- ^ some metavariables are more eager to be instantiated+                , mvPermutation   :: Permutation+                  -- ^ a metavariable doesn't have to depend on all variables+                  --   in the context, this "permutation" will throw away the+                  --   ones it does not depend on+                , mvJudgement     :: Judgement MetaId+                , mvInstantiation :: MetaInstantiation+                , mvListeners     :: Set Listener -- ^ meta variables scheduled for eta-expansion but blocked by this one+                , mvFrozen        :: Frozen -- ^ are we past the point where we can instantiate this meta variable?+                , mvTwin          :: Maybe MetaId+                  -- ^ @Just m@ means that this meta-variable will be+                  -- equated to @m@ when the latter is unblocked. See+                  -- 'Agda.TypeChecking.MetaVars.blockTermOnProblem'.+                }+  deriving Generic++data Listener = EtaExpand MetaId+              | CheckConstraint Nat ProblemConstraint+  deriving Generic++instance Eq Listener where+  EtaExpand       x   == EtaExpand       y   = x == y+  CheckConstraint x _ == CheckConstraint y _ = x == y+  _ == _ = False++instance Ord Listener where+  EtaExpand       x   `compare` EtaExpand       y   = x `compare` y+  CheckConstraint x _ `compare` CheckConstraint y _ = x `compare` y+  EtaExpand{} `compare` CheckConstraint{} = LT+  CheckConstraint{} `compare` EtaExpand{} = GT++-- | Frozen meta variable cannot be instantiated by unification.+--   This serves to prevent the completion of a definition by its use+--   outside of the current block.+--   (See issues 118, 288, 399).+data Frozen+  = Frozen        -- ^ Do not instantiate.+  | Instantiable+    deriving (Eq, Show, Generic)++-- | Solution status of meta.+data MetaInstantiation+  = InstV Instantiation -- ^ Solved by 'Instantiation'.+  | OpenMeta MetaKind   -- ^ Unsolved (open to solutions).+  | BlockedConst Term   -- ^ Solved, but solution blocked by unsolved constraints.+  | PostponedTypeCheckingProblem (Closure TypeCheckingProblem)+      -- ^ Meta stands for value of the expression that is still to be type checked.+  deriving Generic++-- | Meta-variable instantiations.++data Instantiation = Instantiation+  { instTel :: [Arg String]+    -- ^ The solution is abstracted over these free variables.+  , instBody :: Term+    -- ^ The body of the solution.+  }+  deriving (Show, Generic)++-- | Information about remote meta-variables.+--+-- Remote meta-variables are meta-variables originating in other+-- modules. These meta-variables are always instantiated. We do not+-- retain all the information about a local meta-variable when+-- creating an interface:+--+-- * The 'mvPriority' field is not needed, because the meta-variable+--   cannot be instantiated.+-- * The 'mvFrozen' field is not needed, because there is no point in+--   freezing instantiated meta-variables.+-- * The 'mvListeners' field is not needed, because no meta-variable+--   should be listening to this one.+-- * The 'mvTwin' field is not needed, because the meta-variable has+--   already been instantiated.+-- * The 'mvPermutation' is currently removed, but could be retained+--   if it turns out to be useful for something.+-- * The only part of the 'mvInfo' field that is kept is the+--   'miModality' field. The 'miMetaOccursCheck' and 'miGeneralizable'+--   fields are omitted, because the meta-variable has already been+--   instantiated. The 'Range' that is part of the 'miClosRange' field+--   and the 'miNameSuggestion' field are omitted because instantiated+--   meta-variables are typically not presented to users. Finally the+--   'Closure' part of the 'miClosRange' field is omitted because it+--   can be large (at least if we ignore potential sharing).++data RemoteMetaVariable = RemoteMetaVariable+  { rmvInstantiation :: Instantiation+  , rmvModality      :: Modality+  , rmvJudgement     :: Judgement MetaId+  }+  deriving (Show, Generic)++-- | Solving a 'CheckArgs' constraint may or may not check the target type. If+--   it did, it returns a handle to any unsolved constraints.+data CheckedTarget = CheckedTarget (Maybe ProblemId)+                   | NotCheckedTarget++data PrincipalArgTypeMetas = PrincipalArgTypeMetas+  { patmMetas     :: Args -- ^ metas created for hidden and instance arguments+                          --   in the principal argument's type+  , patmRemainder :: Type -- ^ principal argument's type, stripped of hidden and+                          --   instance arguments+  }+  deriving Generic++data TypeCheckingProblem+  = CheckExpr Comparison A.Expr Type+  | CheckArgs Comparison ExpandHidden A.Expr [NamedArg A.Expr] Type Type (ArgsCheckState CheckedTarget -> TCM Term)+  | CheckProjAppToKnownPrincipalArg Comparison A.Expr ProjOrigin (List1 QName) A.Expr A.Args Type Int Term Type PrincipalArgTypeMetas+  | CheckLambda Comparison (Arg (List1 (WithHiding Name), Maybe Type)) A.Expr Type+    -- ^ @(λ (xs : t₀) → e) : t@+    --   This is not an instance of 'CheckExpr' as the domain type+    --   has already been checked.+    --   For example, when checking+    --     @(λ (x y : Fin _) → e) : (x : Fin n) → ?@+    --   we want to postpone @(λ (y : Fin n) → e) : ?@ where @Fin n@+    --   is a 'Type' rather than an 'A.Expr'.+  | DisambiguateConstructor ConstructorDisambiguationData (ConHead -> TCM Term)+    -- ^ A stuck constructor disambiguation with the bits to retry it on and the success continuation.+  | DoQuoteTerm Comparison Term Type -- ^ Quote the given term and check type against `Term`+  deriving Generic++-- | Information we have constructored in the middle of disambiguating a constructor.+data ConstructorDisambiguationData = ConstructorDisambiguationData+  -- bcd for blocked constructor disambiguation+  { bcdConName    :: QName+      -- ^ One of the eligible ambiguous names (for error messages).+  , bcdCandidates :: List1 (QName, Type, ConHead)+      -- ^ The possible candidates for disambiguation+  , bcdArguments  :: A.Args+      -- ^ The arguments given to the constructor.+  , bcdType       :: Type+      -- ^ The type of the constructor application+  } deriving Generic++instance Pretty MetaInstantiation where+  pretty = \case+    OpenMeta UnificationMeta                 -> "Open"+    OpenMeta InstanceMeta                    -> "OpenInstance"+    PostponedTypeCheckingProblem{}           -> "PostponedTypeCheckingProblem (...)"+    BlockedConst t                           -> hsep [ "BlockedConst", parens (pretty t) ]+    InstV Instantiation{ instTel, instBody } -> hsep [ "InstV", pretty instTel, parens (pretty instBody) ]++-- | Meta variable priority:+--   When we have an equation between meta-variables, which one+--   should be instantiated?+--+--   Higher value means higher priority to be instantiated.+newtype MetaPriority = MetaPriority Int+    deriving (Eq, Ord, Show, NFData)++data RunMetaOccursCheck+  = RunMetaOccursCheck+  | DontRunMetaOccursCheck+  deriving (Eq, Ord, Show, Generic)++-- | @MetaInfo@ is cloned from one meta to the next during pruning.+data MetaInfo = MetaInfo+  { miClosRange       :: Closure Range -- TODO: Not so nice. But we want both to have the environment of the meta (Closure) and its range.+  , miModality        :: Modality           -- ^ Instantiable with irrelevant/erased solution?+  , miMetaOccursCheck :: RunMetaOccursCheck -- ^ Run the extended occurs check that goes in definitions?+  , miNameSuggestion  :: MetaNameSuggestion+    -- ^ Used for printing.+    --   @Just x@ if meta-variable comes from omitted argument with name @x@.+  , miGeneralizable   :: Arg DoGeneralize+    -- ^ Should this meta be generalized if unsolved? If so, at what ArgInfo?+  }+  deriving Generic++instance LensModality MetaInfo where+  getModality = miModality+  setModality mod mi = mi { miModality = mod }+  mapModality f mi = mi { miModality = f $ miModality mi }++instance LensQuantity MetaInfo where+  getQuantity   = getQuantity . getModality+  mapQuantity f = mapModality (mapQuantity f)++instance LensRelevance MetaInfo where+  mapRelevance f = mapModality (mapRelevance f)++instance LensModalPolarity MetaInfo where+  getModalPolarity   = getModalPolarity . getModality+  mapModalPolarity f = mapModality (mapModalPolarity f)++-- | Append an 'ArgName' to a 'MetaNameSuggestion', for computing the+-- name suggestions of eta-expansion metas. If the 'MetaNameSuggestion'+-- is empty or an underscore, the field name is taken as the suggestion.+suffixNameSuggestion :: MetaNameSuggestion -> ArgName -> MetaNameSuggestion+suffixNameSuggestion "_"    field = field+suffixNameSuggestion ""     field = field+suffixNameSuggestion record field = record ++ "." ++ field++instance Pretty NamedMeta where+  pretty (NamedMeta "" x) = pretty x+  pretty (NamedMeta "_" x) = pretty x+  pretty (NamedMeta s  x) = text $ "_" ++ s ++ prettyShow x++-- | Used for meta-variables from the current module.++type LocalMetaStore = Map MetaId MetaVariable++{-# SPECIALIZE Map.insert :: MetaId -> v -> Map MetaId v -> Map MetaId v #-}+{-# SPECIALIZE Map.lookup :: MetaId -> Map MetaId v -> Maybe v #-}++-- | Used for meta-variables from other modules (and in 'Interface's).++type RemoteMetaStore = HashMap MetaId RemoteMetaVariable++instance HasRange MetaInfo where+  getRange = clValue . miClosRange++instance HasRange MetaVariable where+    getRange m = getRange $ getMetaInfo m++instance SetRange MetaInfo where+  setRange r m = m { miClosRange = (miClosRange m) { clValue = r }}++instance SetRange MetaVariable where+  setRange r m = m { mvInfo = setRange r (mvInfo m) }++instance LensModality MetaVariable where+  getModality = getModality . mvInfo+  setModality mod mv = mv { mvInfo = setModality mod $ mvInfo mv }+  mapModality f mv = mv { mvInfo = mapModality f $ mvInfo mv }++instance LensRelevance MetaVariable where+  setRelevance mod mv = mv { mvInfo = setRelevance mod $ mvInfo mv }++instance LensQuantity MetaVariable where+  getQuantity   = getQuantity . getModality+  mapQuantity f = mapModality (mapQuantity f)++instance LensModality RemoteMetaVariable where+  getModality      = rmvModality+  mapModality f mv = mv { rmvModality = f $ rmvModality mv }++instance LensRelevance RemoteMetaVariable where+  mapRelevance f = mapModality (mapRelevance f)++instance LensQuantity RemoteMetaVariable where+  mapQuantity f = mapModality (mapQuantity f)++instance LensModalPolarity RemoteMetaVariable where+  mapModalPolarity f = mapModality (mapModalPolarity f)++normalMetaPriority :: MetaPriority+normalMetaPriority = MetaPriority 0++lowMetaPriority :: MetaPriority+lowMetaPriority = MetaPriority (-10)++highMetaPriority :: MetaPriority+highMetaPriority = MetaPriority 10++getMetaInfo :: MetaVariable -> Closure Range+getMetaInfo = miClosRange . mvInfo++getMetaScope :: MetaVariable -> ScopeInfo+getMetaScope m = clScope $ getMetaInfo m++getMetaEnv :: MetaVariable -> TCEnv+getMetaEnv m = clEnv $ getMetaInfo m++getMetaSig :: MetaVariable -> Signature+getMetaSig m = clSignature $ getMetaInfo m++-- Lenses++metaFrozen :: Lens' MetaVariable Frozen+metaFrozen f mv = f (mvFrozen mv) <&> \ x -> mv { mvFrozen = x }++_mvInfo :: Lens' MetaVariable MetaInfo+_mvInfo f mv = (f $! mvInfo mv) <&> \ mi -> mv { mvInfo = mi }++-- Lenses onto Closure Range++instance LensClosure MetaInfo Range where+  lensClosure f mi = (f $! miClosRange mi) <&> \ cl -> mi { miClosRange = cl }++instance LensClosure MetaVariable Range where+  lensClosure = _mvInfo . lensClosure++-- Lenses onto IsAbstract++instance LensIsAbstract TCEnv where+  lensIsAbstract f env =+     -- Andreas, 2019-08-19+     -- Using $! to prevent space leaks like #1829.+     -- This can crash when trying to get IsAbstract from IgnoreAbstractMode.+    (f $! fromMaybe __IMPOSSIBLE__ (aModeToDef $ envAbstractMode env))+    <&> \ a -> env { envAbstractMode = aDefToMode a }++instance LensIsAbstract (Closure a) where+  lensIsAbstract = lensTCEnv . lensIsAbstract++instance LensIsAbstract MetaInfo where+  lensIsAbstract = lensClosure . lensIsAbstract++instance LensIsOpaque TCEnv where+  lensIsOpaque f env =+    (f $! case envCurrentOpaqueId env of { Just x -> OpaqueDef x ; Nothing -> TransparentDef })+    <&> \case { OpaqueDef x    -> env { envCurrentOpaqueId = Just x }+              ; TransparentDef -> env { envCurrentOpaqueId = Nothing }+              }++---------------------------------------------------------------------------+-- ** Interaction meta variables+---------------------------------------------------------------------------++-- | Interaction points are created by the scope checker who sets the range.+--   The meta variable is created by the type checker and then hooked up to the+--   interaction point.+data InteractionPoint = InteractionPoint+  { ipRange    :: Range        -- ^ The position of the interaction point.+  , ipMeta     :: Maybe MetaId -- ^ The meta variable, if any, holding the type etc.+  , ipSolved   :: Bool         -- ^ Has this interaction point already been solved?+  , ipClause   :: IPClause+    -- ^ The clause of the interaction point (if any).+    --   Used for case splitting.+  , ipBoundary :: IPBoundary+  }+  deriving Generic++instance Eq InteractionPoint where (==) = (==) `on` ipMeta++instance HasTag InteractionPoint where+  type Tag InteractionPoint = MetaId+  tag = ipMeta++-- | Data structure managing the interaction points.+--+--   We never remove interaction points from this map, only set their+--   'ipSolved' to @True@.  (Issue #2368)+type InteractionPoints = BiMap InteractionId InteractionPoint++-- | Flag to indicate whether the meta is overapplied in the+--   constraint.  A meta is overapplied if it has more arguments than+--   the size of the telescope in its creation environment+--   (as stored in MetaInfo).+data Overapplied = Overapplied | NotOverapplied+  deriving (Eq, Show, Generic)++newtype IPBoundary' t = IPBoundary+  { getBoundary :: Map (IntMap Bool) t+  }+  deriving (Show, Functor, Foldable, Traversable, Generic)++type IPBoundary = IPBoundary' Term++-- | Which clause is an interaction point located in?+data IPClause = IPClause+  { ipcQName    :: QName              -- ^ The name of the function.+  , ipcClauseNo :: Int                -- ^ The number of the clause of this function.+  , ipcType     :: Type               -- ^ The type of the function+  , ipcWithSub  :: Maybe Substitution -- ^ Module parameter substitution+  , ipcClause   :: A.SpineClause      -- ^ The original AST clause.+  , ipcClosure  :: Closure ()         -- ^ Environment for rechecking the clause.+  }+  | IPNoClause -- ^ The interaction point is not in the rhs of a clause.+  deriving (Generic)++instance Eq IPClause where+  IPNoClause           == IPNoClause             = True+  IPClause x i _ _ _ _ == IPClause x' i' _ _ _ _ = x == x' && i == i'+  _                    == _                      = False++---------------------------------------------------------------------------+-- ** Signature+---------------------------------------------------------------------------++data Signature = Sig+      { _sigSections     :: Sections+      , _sigDefinitions  :: Definitions+      , _sigRewriteRules :: RewriteRuleMap  -- ^ The rewrite rules defined in this file.+      , _sigInstances    :: InstanceTable+      }+  deriving (Show, Generic)++instance Null Signature where+  empty = Sig empty empty empty empty+  null (Sig a b c d) = null a && null b && null c && null d++sigSections :: Lens' Signature Sections+sigSections f s =+  f (_sigSections s) <&>+  \x -> s {_sigSections = x}++sigDefinitions :: Lens' Signature Definitions+sigDefinitions f s =+  f (_sigDefinitions s) <&>+  \x -> s {_sigDefinitions = x}++sigInstances :: Lens' Signature InstanceTable+sigInstances f s = f (_sigInstances s) <&> \x -> s {_sigInstances = x}++sigRewriteRules :: Lens' Signature RewriteRuleMap+sigRewriteRules f s =+  f (_sigRewriteRules s) <&>+  \x -> s {_sigRewriteRules = x}++type Sections    = Map ModuleName Section+type Definitions = HashMap QName Definition+type RewriteRuleMap = HashMap QName RewriteRules+type DisplayForms = HashMap QName [LocalDisplayForm]++-- 2023-21-30, András: see issue 6927+#if __GLASGOW_HASKELL__ >= 900+{-# SPECIALIZE HMap.insert :: QName -> v -> HashMap QName v -> HashMap QName v #-}+#endif+{-# SPECIALIZE HMap.lookup :: QName -> HashMap QName v -> Maybe v #-}++newtype Section = Section { _secTelescope :: Telescope }+  deriving (Show, NFData)++instance Pretty Section where+  pretty = pretty . _secTelescope++secTelescope :: Lens' Section Telescope+secTelescope f s =+  f (_secTelescope s) <&>+  \x -> s {_secTelescope = x}++emptySignature :: Signature+emptySignature = Sig Map.empty HMap.empty HMap.empty mempty++-- | A @DisplayForm@ is in essence a rewrite rule @q ts --> dt@ for a defined symbol (could be a+--   constructor as well) @q@. The right hand side is a 'DisplayTerm' which is used to 'reify' to a+--   more readable 'Abstract.Syntax'.+--+--   The patterns @ts@ are just terms, but the first @dfPatternVars@ variables are pattern variables+--   that matches any term.+data DisplayForm = Display+  { dfPatternVars :: Nat+    -- ^ Number @n@ of pattern variables in 'dfPats'.+  , dfPats :: Elims+    -- ^ Left hand side patterns, the @n@ first free variables are pattern variables,+    --   any variables above @n@ are fixed and only match that particular variable. This+    --   happens when you have display forms inside parameterised modules that match on the module+    --   parameters. The 'ArgInfo' is ignored in these patterns.+  , dfRHS :: DisplayTerm+    -- ^ Right hand side.+  }+  deriving (Show, Generic)++type LocalDisplayForm = Open DisplayForm++-- | A structured presentation of a 'Term' for reification into+--   'Abstract.Syntax'.+data DisplayTerm+  = DWithApp DisplayTerm (List1 DisplayTerm) Elims+    -- ^ @(f vs | ws) es@.+    --   The first 'DisplayTerm' is the parent function @f@ with its args @vs@.+    --   The list of 'DisplayTerm's are the with expressions @ws@.+    --   The 'Elims' are additional arguments @es@+    --   (possible in case the with-application is of function type)+    --   or projections (if it is of record type).+  | DCon ConHead ConInfo [Arg DisplayTerm]+    -- ^ @c vs@.+  | DDef QName [Elim' DisplayTerm]+    -- ^ @d vs@.+  | DDot' Term Elims+    -- ^ @.(v es)@.  See 'DTerm''.+  | DTerm' Term Elims+    -- ^ @v es@.+    --   This is a frozen elimination that is not always safe to run,+    --   because display forms may be ill-typed.+    --   (See issue #6476.)+  deriving (Show, Generic)++pattern DDot :: Term -> DisplayTerm+pattern DDot v = DDot' v []++pattern DTerm :: Term -> DisplayTerm+pattern DTerm v = DTerm' v []++instance Free DisplayForm where+  freeVars' (Display n ps t) = underBinder (freeVars' ps) `mappend` underBinder' n (freeVars' t)++instance Free DisplayTerm where+  freeVars' (DWithApp t ws es) = freeVars' (t, (ws, es))+  freeVars' (DCon _ _ vs)      = freeVars' vs+  freeVars' (DDef _ es)        = freeVars' es+  freeVars' (DDot' v es)       = freeVars' (v, es)+  freeVars' (DTerm' v es)      = freeVars' (v, es)++instance Pretty DisplayTerm where+  prettyPrec p v =+    case v of+      DTerm v           -> prettyPrec p v+      DTerm' v es       -> prettyPrec 9 v `pApp` es+      DDot v            -> "." <> prettyPrec 10 v+      DDot' v es        -> "." <> parens (prettyPrec 9 v `pAp` es)+      DDef f es        -> pretty f `pApp` es+      DCon c _ vs      -> pretty (conName c) `pApp` map Apply vs+      DWithApp h ws es ->+        mparens (p > 0)+          (sep [ pretty h+               , nest 2 $ fsep $ fmap (\ w -> "|" <+> pretty w) ws+               ])+        `pApp` es+    where+      pApp :: Pretty el => Doc -> [el] -> Doc+      pApp d els = mparens (not (null els) && p > 9) $ pAp d els+      pAp :: Pretty el => Doc -> [el] -> Doc+      pAp d els = sep [d, nest 2 $ fsep (map (prettyPrec 10) els)]++instance Pretty DisplayForm where+  prettyPrec p (Display fv lhs rhs) = mparens (p > 9) $+    "Display" <?> fsep [ pshow fv, prettyPrec 10 lhs, prettyPrec 10 rhs ]++-- | By default, we have no display form.+defaultDisplayForm :: QName -> [LocalDisplayForm]+defaultDisplayForm c = []++-- | Non-linear (non-constructor) first-order pattern.+data NLPat+  = PVar !Int [Arg Int]+    -- ^ Matches anything (modulo non-linearity) that only contains bound+    --   variables that occur in the given arguments.+  | PDef QName PElims+    -- ^ Matches @f es@+  | PLam ArgInfo (Abs NLPat)+    -- ^ Matches @λ x → t@+  | PPi (Dom NLPType) (Abs NLPType)+    -- ^ Matches @(x : A) → B@+  | PSort NLPSort+    -- ^ Matches a sort of the given shape.+  | PBoundVar {-# UNPACK #-} !Int PElims+    -- ^ Matches @x es@ where x is a lambda-bound variable+  | PTerm Term+    -- ^ Matches the term modulo β (ideally βη).+  deriving (Show, Generic)+type PElims = [Elim' NLPat]++type instance TypeOf NLPat = Type+type instance TypeOf [Elim' NLPat] = (Type, Elims -> Term)++instance TermLike NLPat where+  traverseTermM f = \case+    p@PVar{}       -> return p+    PDef d ps      -> PDef d <$> traverseTermM f ps+    PLam i p       -> PLam i <$> traverseTermM f p+    PPi a b        -> PPi <$> traverseTermM f a <*> traverseTermM f b+    PSort s        -> PSort <$> traverseTermM f s+    PBoundVar i ps -> PBoundVar i <$> traverseTermM f ps+    PTerm t        -> PTerm <$> f t++  foldTerm f t = case t of+    PVar{}         -> mempty+    PDef d ps      -> foldTerm f ps+    PLam i p       -> foldTerm f p+    PPi a b        -> foldTerm f (a, b)+    PSort s        -> foldTerm f s+    PBoundVar i ps -> foldTerm f ps+    PTerm t        -> foldTerm f t++instance AllMetas NLPat++data NLPType = NLPType+  { nlpTypeSort :: NLPSort+  , nlpTypeUnEl :: NLPat+  } deriving (Show, Generic)++instance TermLike NLPType where+  traverseTermM f (NLPType s t) = NLPType <$> traverseTermM f s <*> traverseTermM f t++  foldTerm f (NLPType s t) = foldTerm f (s, t)++instance AllMetas NLPType++data NLPSort+  = PUniv Univ NLPat+  | PInf Univ Integer+  | PSizeUniv+  | PLockUniv+  | PLevelUniv+  | PIntervalUniv+  deriving (Show, Generic)++pattern PType, PProp, PSSet :: NLPat -> NLPSort+pattern PType p = PUniv UType p+pattern PProp p = PUniv UProp p+pattern PSSet p = PUniv USSet p++{-# COMPLETE+  PType, PSSet, PProp, PInf,+  PSizeUniv, PLockUniv, PLevelUniv, PIntervalUniv #-}++instance TermLike NLPSort where+  traverseTermM f = \case+    PUniv u p         -> PUniv u <$> traverseTermM f p+    s@PInf{}          -> return s+    s@PSizeUniv{}     -> return s+    s@PLockUniv{}     -> return s+    s@PLevelUniv{}    -> return s+    s@PIntervalUniv{} -> return s++  foldTerm f t = case t of+    PUniv _ p         -> foldTerm f p+    s@PInf{}          -> mempty+    s@PSizeUniv{}     -> mempty+    s@PLockUniv{}     -> mempty+    s@PLevelUniv{}    -> mempty+    s@PIntervalUniv{} -> mempty++instance AllMetas NLPSort++type RewriteRules = [RewriteRule]++-- | Rewrite rules can be added independently from function clauses.+data RewriteRule = RewriteRule+  { rewName    :: QName      -- ^ Name of rewrite rule @q : Γ → f ps ≡ rhs@+                             --   where @≡@ is the rewrite relation.+  , rewContext :: Telescope  -- ^ @Γ@.+  , rewHead    :: QName      -- ^ @f@.+  , rewPats    :: PElims     -- ^ @Γ ⊢ f ps : t@.+  , rewRHS     :: Term       -- ^ @Γ ⊢ rhs : t@.+  , rewType    :: Type       -- ^ @Γ ⊢ t@.+  , rewFromClause :: Bool    -- ^ Was this rewrite rule created from a clause in the definition of the function?+  , rewTopModule  :: TopLevelModuleName+      -- ^ In which file is this rewrite rule defined?+      --   This information is used to eliminate rewrite rules that happen to be in 'stImports'+      --   but are not actually transitively imported.++      --   See issue #4343 (Andreas, 2025-06-05).+  }+    deriving (Show, Generic)++-- | Information about an @instance@ definition.+data InstanceInfo = InstanceInfo+  { instanceClass   :: QName       -- ^ Name of the "class" this is an instance for+  , instanceOverlap :: OverlapMode -- ^ Does this instance have a specified overlap mode?+  }+    deriving (Show, Generic)++data Definition = Defn+  { defArgInfo        :: ArgInfo -- ^ Hiding should not be used.+  , defName           :: QName   -- ^ The canonical name, used e.g. in compilation.+  , defType           :: Type    -- ^ Type of the lifted definition.+  , defPolarity       :: [Polarity]+    -- ^ Variance information on arguments of the definition.+    --   Does not include info for dropped parameters to+    --   projection(-like) functions and constructors.+  , defArgOccurrences :: [Occurrence]+    -- ^ Positivity information on arguments of the definition.+    --   Does not include info for dropped parameters to+    --   projection(-like) functions and constructors.++    --   Sometimes Agda looks up 'Occurrence's in these lists based on+    --   their position, so one might consider replacing the list+    --   with, say, an 'IntMap'. However, presumably these lists tend+    --   to be short, in which case 'IntMap's could be slower than+    --   lists. For instance, at one point the longest list+    --   encountered for the standard library (in serialised+    --   interfaces) had length 27. Distribution:+    --+    --   Length, number of lists+    --   -----------------------+    --+    --    0, 2444+    --    1,  721+    --    2,  433+    --    3,  668+    --    4,  602+    --    5,  624+    --    6,  626+    --    7,  484+    --    8,  375+    --    9,  264+    --   10,  305+    --   11,  188+    --   12,  171+    --   13,  108+    --   14,   84+    --   15,   80+    --   16,   38+    --   17,   23+    --   18,   16+    --   19,    8+    --   20,    7+    --   21,    5+    --   22,    2+    --   23,    3+    --   27,    1+  , defGeneralizedParams :: [Maybe Name]+    -- ^ Gives the name of the (bound variable) parameter for named generalized+    --   parameters. This is needed to bring it into scope when type checking+    --   the data/record definition corresponding to a type with generalized+    --   parameters.+  , defDisplay        :: [LocalDisplayForm]+  , defMutual         :: MutualId+  , defCompiledRep    :: CompiledRepresentation+  , defInstance       :: Maybe InstanceInfo+    -- ^ @Just q@ when this definition is an instance.+  , defCopy           :: Bool+    -- ^ Has this function been created by a module+                         -- instantiation?+  , defMatchable      :: Set QName+    -- ^ The set of symbols with rewrite rules that match against this symbol+  , defNoCompilation  :: Bool+    -- ^ should compilers skip this? Used for e.g. cubical's comp+  , defInjective      :: Bool+    -- ^ Should the def be treated as injective by the pattern matching unifier?+  , defCopatternLHS   :: Bool+    -- ^ Is this a function defined by copatterns?+  , defBlocked        :: Blocked_+    -- ^ What blocking tag to use when we cannot reduce this def?+    --   Used when checking a function definition is blocked on a meta+    --   in the type.+  , defLanguage       :: !Language+    -- ^ The language used for the definition.+  , theDef            :: Defn+  }+    deriving (Show, Generic)++instance LensArgInfo Definition where+  getArgInfo = defArgInfo+  mapArgInfo f def = def { defArgInfo = f $ defArgInfo def }++instance LensModality  Definition where+instance LensQuantity  Definition where+instance LensRelevance Definition where+instance LensModalPolarity Definition where++data NumGeneralizableArgs+  = NoGeneralizableArgs+  | SomeGeneralizableArgs !Int+    -- ^ When lambda-lifting new args are generalizable if+    --   'SomeGeneralizableArgs', also when the number is zero.+  deriving Show++lensTheDef :: Lens' Definition Defn+lensTheDef f d = f (theDef d) <&> \ df -> d { theDef = df }++-- | Create a definition with sensible defaults.+defaultDefn ::+  ArgInfo -> QName -> Type -> Language -> Defn -> Definition+defaultDefn info x t lang def = Defn+  { defArgInfo        = info+  , defName           = x+  , defType           = t+  , defPolarity       = []+  , defArgOccurrences = []+  , defGeneralizedParams = []+  , defDisplay        = defaultDisplayForm x+  , defMutual         = 0+  , defCompiledRep    = noCompiledRep+  , defInstance       = Nothing+  , defCopy           = False+  , defMatchable      = Set.empty+  , defNoCompilation  = False+  , defInjective      = False+  , defCopatternLHS   = False+  , defBlocked        = NotBlocked ReallyNotBlocked ()+  , defLanguage       = lang+  , theDef            = def+  }++instance Pretty Polarity where+  pretty = text . \case+    Covariant     -> "+"+    Contravariant -> "-"+    Invariant     -> "*"+    Nonvariant    -> "_"++-- | Information about whether an argument is forced by the type of a function.+data IsForced+  = Forced+  | NotForced+  deriving (Show, Eq, Generic)++-- | The backends are responsible for parsing their own pragmas.+data CompilerPragma = CompilerPragma Range String+  deriving (Show, Eq, Generic)++instance HasRange CompilerPragma where+  getRange (CompilerPragma r _) = r++jsBackendName, ghcBackendName :: BackendName+jsBackendName  = "JS"+ghcBackendName = "GHC"++type CompiledRepresentation = Map BackendName [CompilerPragma]++noCompiledRep :: CompiledRepresentation+noCompiledRep = Map.empty++-- A face represented as a list of equality constraints.+-- (r,False) ↦ (r = i0)+-- (r,True ) ↦ (r = i1)+type Face = [(Term,Bool)]++-- | An alternative representation of partial elements in a telescope:+--   Γ ⊢ λ Δ. [φ₁ u₁, ... , φₙ uₙ] : Δ → PartialP (∨_ᵢ φᵢ) T+--   see cubicaltt paper (however we do not store the type T).+data System = System+  { systemTel :: Telescope+    -- ^ the telescope Δ, binding vars for the clauses, Γ ⊢ Δ+  , systemClauses :: [(Face,Term)]+    -- ^ a system [φ₁ u₁, ... , φₙ uₙ] where Γ, Δ ⊢ φᵢ and Γ, Δ, φᵢ ⊢ uᵢ+  } deriving (Show, Generic)++-- | Additional information for extended lambdas.+data ExtLamInfo = ExtLamInfo+  { extLamModule    :: ModuleName+    -- ^ For complicated reasons the scope checker decides the QName of a+    --   pattern lambda, and thus its module. We really need to decide the+    --   module during type checking though, since if the lambda appears in a+    --   refined context the module picked by the scope checker has very much+    --   the wrong parameters.+  , extLamAbsurd :: Bool+    -- ^ Was this definition created from an absurd lambda @λ ()@?+  , extLamSys :: !(Strict.Maybe System)+  } deriving (Show, Generic)++modifySystem :: (System -> System) -> ExtLamInfo -> ExtLamInfo+modifySystem f e = let !e' = e { extLamSys = f <$> extLamSys e } in e'++-- | Additional information for projection 'Function's.+data Projection = Projection+  { projProper    :: Maybe QName+    -- ^ @Nothing@ if only projection-like, @Just r@ if record projection.+    --   The @r@ is the name of the record type projected from.+    --   This field is updated by module application.+  , projOrig      :: QName+    -- ^ The original projection name+    --   (current name could be from module application).+  , projFromType  :: Arg QName+    -- ^ Type projected from. Original record type if @projProper = Just{}@.+    --   Also stores @ArgInfo@ of the principal argument.+    --   This field is unchanged by module application.+  , projIndex     :: Int+    -- ^ Index of the record argument.+    --   Start counting with 1, because 0 means that+    --   it is already applied to the record value.+    --   This can happen in module instantiation, but+    --   then either the record value is @var 0@, or @funProjection == Left _@.+  , projLams :: ProjLams+    -- ^ Term @t@ to be be applied to record parameters and record value.+    --   The parameters will be dropped.+    --   In case of a proper projection, a postfix projection application+    --   will be created: @t = \ pars r -> r .p@+    --   (Invariant: the number of abstractions equals 'projIndex'.)+    --   In case of a projection-like function, just the function symbol+    --   is returned as 'Def':  @t = \ pars -> f@.+  } deriving (Show, Generic)++-- | Abstractions to build projection function (dropping parameters).+newtype ProjLams = ProjLams { getProjLams :: [Arg ArgName] }+  deriving (Show, Null, Generic)++-- | Building the projection function (which drops the parameters).+projDropPars :: Projection -> ProjOrigin -> Term+-- Proper projections:+projDropPars (Projection Just{} d _ _ lams) o =+  case initLast $ getProjLams lams of+    Nothing -> Def d []+    Just (pars, Arg i y) ->+      let core = Lam i $ Abs y $ Var 0 [Proj o d] in+      List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) core pars+-- Projection-like functions:+projDropPars (Projection Nothing d _ _ lams) o =+  List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) (Def d []) $+    initWithDefault __IMPOSSIBLE__ $ getProjLams lams++-- | The info of the principal (record) argument.+projArgInfo :: Projection -> ArgInfo+projArgInfo (Projection _ _ _ _ lams) =+  maybe __IMPOSSIBLE__ getArgInfo $ lastMaybe $ getProjLams lams++-- | Should a record type admit eta-equality?+data EtaEquality+  = Specified { theEtaEquality :: !HasEta }  -- ^ User specifed 'eta-equality' or 'no-eta-equality'.+  | Inferred  { theEtaEquality :: !HasEta }  -- ^ Positivity checker inferred whether eta is safe.+  deriving (Show, Eq, Generic)++instance PatternMatchingAllowed EtaEquality where+  patternMatchingAllowed = patternMatchingAllowed . theEtaEquality++instance CopatternMatchingAllowed EtaEquality where+  copatternMatchingAllowed = copatternMatchingAllowed . theEtaEquality++-- | Make sure we do not overwrite a user specification.+setEtaEquality :: EtaEquality -> HasEta -> EtaEquality+setEtaEquality e@Specified{} _ = e+setEtaEquality _ b = Inferred b++data FunctionFlag+  = FunStatic  -- ^ Should calls to this function be normalised at compile-time?+  | FunInline  -- ^ Should calls to this function be inlined by the compiler?+  | FunMacro   -- ^ Is this function a macro?+  | FunFirstOrder+      -- ^ Is this function @INJECTIVE_FOR_INFERENCE@?+      -- Indicates whether the first-order shortcut should be applied to the definition.+  | FunErasure+      -- ^ Was @--erasure@ in effect when the function was defined?+      -- (This can affect the type of a projection.)+  | FunAbstract+      -- ^ Is the function abstract?+  | FunProj+      -- ^ Is this function a descendant of a field (typically, a projection)?+  deriving (Eq, Ord, Enum, Show, Generic, Ix, Bounded)++instance SmallSetElement FunctionFlag+instance KillRange (SmallSet FunctionFlag) where killRange = id++data CompKit = CompKit+  { nameOfHComp :: Maybe QName+  , nameOfTransp :: Maybe QName+  }+  deriving (Eq, Ord, Show, Generic)++emptyCompKit :: CompKit+emptyCompKit = CompKit Nothing Nothing++defaultAxiom :: Defn+defaultAxiom = Axiom False++constTranspAxiom :: Defn+constTranspAxiom = Axiom True++data Defn+  = AxiomDefn AxiomData+      -- ^ Postulate.+  | DataOrRecSigDefn DataOrRecSigData+      -- ^ Data or record type signature that doesn't yet have a definition.+  | GeneralizableVar+      -- ^ Generalizable variable (introduced in @variable@ block).+      NumGeneralizableArgs+        -- ^ For a generalized variable, shows how many arguments should be generalised.+  | AbstractDefn Defn+      -- ^ Returned by 'getConstInfo' if definition is abstract.+  | FunctionDefn FunctionData+  | DatatypeDefn DatatypeData+  | RecordDefn RecordData+  | ConstructorDefn ConstructorData+  | PrimitiveDefn PrimitiveData+      -- ^ Primitive or builtin functions.+  | PrimitiveSortDefn PrimitiveSortData+    deriving (Show, Generic)++{-# COMPLETE+  Axiom, DataOrRecSig, GeneralizableVar, AbstractDefn,+  Function, Datatype, Record, Constructor, Primitive, PrimitiveSort #-}++data AxiomData = AxiomData+  { _axiomConstTransp :: Bool+    -- ^ Can transp for this postulate be constant?+    --   Set to @True@ for bultins like String.+  } deriving (Show, Generic)++pattern Axiom :: Bool -> Defn+pattern Axiom{ axiomConstTransp } = AxiomDefn (AxiomData axiomConstTransp)++data DataOrRecSigData = DataOrRecSigData+  { _datarecPars :: Int+  } deriving (Show, Generic)++pattern DataOrRecSig :: Int -> Defn+pattern DataOrRecSig{ datarecPars } = DataOrRecSigDefn (DataOrRecSigData datarecPars)++-- | Indicates the reason behind a function having not been marked+-- projection-like.+data ProjectionLikenessMissing+  = MaybeProjection+    -- ^ Projection-likeness analysis has not run on this function yet.+    -- It may do so in the future.+  | NeverProjection+    -- ^ The user has requested that this function be not be marked+    -- projection-like. The analysis may already have run on this+    -- function, but the results have been discarded, and it will not be+    -- run again.+  deriving (Show, Generic, Enum, Bounded)++data FunctionData = FunctionData+  { _funClauses        :: [Clause]+  , _funCompiled       :: Maybe CompiledClauses+      -- ^ 'Nothing' while function is still type-checked.+      --   @Just cc@ after type and coverage checking and+      --   translation to case trees.+  , _funSplitTree      :: Maybe SplitTree+      -- ^ The split tree constructed by the coverage+      --   checker. Needed to re-compile the clauses after+      --   forcing translation.+  , _funTreeless       :: Maybe Compiled+      -- ^ Intermediate representation for compiler backends.+  , _funCovering       :: [Clause]+      -- ^ Covering clauses computed by coverage checking.+      --   Erased by (IApply) confluence checking(?)+  , _funInv            :: FunctionInverse+  , _funMutual         :: Maybe [QName]+      -- ^ Mutually recursive functions, @data@s and @record@s.+      --   Does include this function.+      --   Empty list if not recursive.+      --   @Nothing@ if not yet computed (by positivity checker).+  , _funProjection     :: Either ProjectionLikenessMissing Projection+      -- ^ Is it a record projection?+      --   If yes, then return the name of the record type and index of+      --   the record argument.  Start counting with 1, because 0 means that+      --   it is already applied to the record. (Can happen in module+      --   instantiation.) This information is used in the termination+      --   checker.+  , _funFlags          :: SmallSet FunctionFlag+      -- ^ Various boolean flags pertaining to the function definition, see 'FunctionFlag'.+  , _funTerminates     :: Maybe Bool+      -- ^ Has this function been termination checked?  Did it pass?+  , _funExtLam         :: Maybe ExtLamInfo+      -- ^ Is this function generated from an extended lambda?+      --   If yes, then return the number of hidden and non-hidden lambda-lifted arguments.+  , _funWith           :: Maybe QName+      -- ^ Is this a generated with-function?+      --   If yes, then what's the name of the parent function?+  , _funIsKanOp        :: Maybe QName+      -- ^ Is this a helper for one of the Kan operations (transp,+      -- hcomp) on data types/records? If so, for which data type?+  , _funOpaque         :: IsOpaque+      -- ^ Is this function opaque? If so, and we're not in an opaque+      -- block that includes this function('s name), it will be treated+      -- abstractly.+  } deriving (Show, Generic)++pattern Function+  :: [Clause]+  -> Maybe CompiledClauses+  -> Maybe SplitTree+  -> Maybe Compiled+  -> [Clause]+  -> FunctionInverse+  -> Maybe [QName]+  -> Either ProjectionLikenessMissing Projection+  -> SmallSet FunctionFlag+  -> Maybe Bool+  -> Maybe ExtLamInfo+  -> Maybe QName+  -> Maybe QName+  -> IsOpaque+  -> Defn+pattern Function+  { funClauses+  , funCompiled+  , funSplitTree+  , funTreeless+  , funCovering+  , funInv+  , funMutual+  , funProjection+  , funFlags+  , funTerminates+  , funExtLam+  , funWith+  , funIsKanOp+  , funOpaque+  } = FunctionDefn (FunctionData+    funClauses+    funCompiled+    funSplitTree+    funTreeless+    funCovering+    funInv+    funMutual+    funProjection+    funFlags+    funTerminates+    funExtLam+    funWith+    funIsKanOp+    funOpaque+  )++data DatatypeData = DatatypeData+  { _dataPars           :: Nat+      -- ^ Number of parameters.+  , _dataIxs            :: Nat+      -- ^ Number of indices.+  , _dataClause         :: Maybe Clause+      -- ^ This might be in an instantiated module.+  , _dataCons           :: [QName]+      -- ^ Constructor names, ordered according to the order of their definition.+  , _dataSort           :: Sort+  , _dataMutual         :: Maybe [QName]+      -- ^ Mutually recursive functions, @data@s and @record@s.+      --   Does include this data type.+      --   Empty if not recursive.+      --   @Nothing@ if not yet computed (by positivity checker).+  , _dataAbstr          :: IsAbstract+  , _dataPathCons       :: [QName]+      -- ^ Path constructor names (subset of @dataCons@).+  , _dataTranspIx       :: Maybe QName+      -- ^ If indexed datatype, name of the "index transport" function.+  , _dataTransp         :: Maybe QName+      -- ^ Transport function, should be available for all datatypes in supported sorts.+  } deriving (Show, Generic)++pattern Datatype+  :: Nat+  -> Nat+  -> (Maybe Clause)+  -> [QName]+  -> Sort+  -> Maybe [QName]+  -> IsAbstract+  -> [QName]+  -> Maybe QName+  -> Maybe QName+  -> Defn++pattern Datatype+  { dataPars+  , dataIxs+  , dataClause+  , dataCons+  , dataSort+  , dataMutual+  , dataAbstr+  , dataPathCons+  , dataTranspIx+  , dataTransp+  } = DatatypeDefn (DatatypeData+    dataPars+    dataIxs+    dataClause+    dataCons+    dataSort+    dataMutual+    dataAbstr+    dataPathCons+    dataTranspIx+    dataTransp+  )++data RecordData = RecordData+  { _recPars           :: Nat+      -- ^ Number of parameters.+  , _recClause         :: Maybe Clause+      -- ^ Was this record type created by a module application?+      --   If yes, the clause is its definition (linking back to the original record type).+  , _recConHead        :: ConHead+      -- ^ Constructor name and fields.+  , _recNamedCon       :: Bool+      -- ^ Does this record have a @constructor@?+  , _recFields         :: [Dom QName]+      -- ^ The record field names.+  , _recTel            :: Telescope+      -- ^ The record field telescope. (Includes record parameters.)+      --   Note: @TelV recTel _ == telView' recConType@.+      --   Thus, @recTel@ is redundant.+  , _recMutual         :: Maybe [QName]+      -- ^ Mutually recursive functions, @data@s and @record@s.+      --   Does include this record.+      --   Empty if not recursive.+      --   @Nothing@ if not yet computed (by positivity checker).+  , _recEtaEquality'    :: EtaEquality+      -- ^ Eta-expand at this record type?+      --   @False@ for unguarded recursive records and coinductive records+      --   unless the user specifies otherwise.+  , _recPatternMatching :: PatternOrCopattern+      -- ^ In case eta-equality is off, do we allow pattern matching on the+      --   constructor or construction by copattern matching?+      --   Having both loses subject reduction, see issue #4560.+      --   After positivity checking, this field is obsolete, part of 'EtaEquality'.+  , _recInduction      :: Maybe Induction+      -- ^ 'Inductive' or 'CoInductive'?  Matters only for recursive records.+      --   'Nothing' means that the user did not specify it, which is an error+      --   for recursive records.+  , _recTerminates     :: Maybe Bool+      -- ^ 'Just True' means that unfolding of the recursive record terminates,+      --   'Just False' means that we have no evidence for termination,+      --   and 'Nothing' means we have not run the termination checker yet.+  , _recAbstr          :: IsAbstract+  , _recComp           :: CompKit+  } deriving (Show, Generic)++pattern Record+  :: Nat+  -> Maybe Clause+  -> ConHead+  -> Bool+  -> [Dom QName]+  -> Telescope+  -> Maybe [QName]+  -> EtaEquality+  -> PatternOrCopattern+  -> Maybe Induction+  -> Maybe Bool+  -> IsAbstract+  -> CompKit+  -> Defn++pattern Record+  { recPars+  , recClause+  , recConHead+  , recNamedCon+  , recFields+  , recTel+  , recMutual+  , recEtaEquality'+  , recPatternMatching+  , recInduction+  , recTerminates+  , recAbstr+  , recComp+  } = RecordDefn (RecordData+    recPars+    recClause+    recConHead+    recNamedCon+    recFields+    recTel+    recMutual+    recEtaEquality'+    recPatternMatching+    recInduction+    recTerminates+    recAbstr+    recComp+  )++data ConstructorData = ConstructorData+  { _conPars   :: Int+      -- ^ Number of parameters.+  , _conArity  :: Int+      -- ^ Number of arguments (excluding parameters).+  , _conSrcCon :: ConHead+      -- ^ Name of (original) constructor and fields. (This might be in a module instance.)+  , _conData   :: QName+      -- ^ Name of datatype or record type.+  , _conAbstr  :: IsAbstract+  , _conComp   :: CompKit+      -- ^ Cubical composition.+  , _conProj   :: Maybe [QName]+      -- ^ Projections. 'Nothing' if not yet computed.+  , _conForced :: [IsForced]+      -- ^ Which arguments are forced (i.e. determined by the type of the constructor)?+      --   Either this list is empty (if the forcing analysis isn't run), or its length is @conArity@.+  , _conErased :: Maybe [Bool]+      -- ^ Which arguments are erased at runtime (computed during compilation to treeless)?+      --   'True' means erased, 'False' means retained.+      --   'Nothing' if no erasure analysis has been performed yet.+      --   The length of the list is @conArity@.+  , _conErasure :: !Bool+      -- ^ Was @--erasure@ in effect when the constructor was defined?+      --   (This can affect the constructor's type.)+  , _conInline :: !Bool+      -- ^ Shall we translate the constructor on the root of the rhs into copattern matching on the lhs?+      --   Activated by INLINE pragma.+  } deriving (Show, Generic)++pattern Constructor+  :: Int+  -> Int+  -> ConHead+  -> QName+  -> IsAbstract+  -> CompKit+  -> Maybe [QName]+  -> [IsForced]+  -> Maybe [Bool]+  -> Bool+  -> Bool+  -> Defn+pattern Constructor+  { conPars+  , conArity+  , conSrcCon+  , conData+  , conAbstr+  , conComp+  , conProj+  , conForced+  , conErased+  , conErasure+  , conInline+  } = ConstructorDefn (ConstructorData+    conPars+    conArity+    conSrcCon+    conData+    conAbstr+    conComp+    conProj+    conForced+    conErased+    conErasure+    conInline+  )++data PrimitiveData = PrimitiveData+  { _primAbstr    :: IsAbstract+  , _primName     :: PrimitiveId+  , _primClauses  :: [Clause]+      -- ^ 'null' for primitive functions, @not null@ for builtin functions.+  , _primInv      :: FunctionInverse+      -- ^ Builtin functions can have inverses. For instance, natural number addition.+  , _primCompiled :: Maybe CompiledClauses+      -- ^ 'Nothing' for primitive functions,+      --   @'Just' something@ for builtin functions.+  , _primOpaque   :: IsOpaque+      -- ^ Primitives can also live in opaque blocks.+  } deriving (Show, Generic)++pattern Primitive+  :: IsAbstract+  -> PrimitiveId+  -> [Clause]+  -> FunctionInverse+  -> Maybe CompiledClauses+  -> IsOpaque+  -> Defn+pattern Primitive+  { primAbstr+  , primName+  , primClauses+  , primInv+  , primCompiled+  , primOpaque+  } = PrimitiveDefn (PrimitiveData+    primAbstr+    primName+    primClauses+    primInv+    primCompiled+    primOpaque+  )++data PrimitiveSortData = PrimitiveSortData+  { _primSortName :: BuiltinSort+  , _primSortSort :: Sort+  } deriving (Show, Generic)++pattern PrimitiveSort+  :: BuiltinSort+  -> Sort+  -> Defn+pattern PrimitiveSort+  { primSortName+  , primSortSort+  } = PrimitiveSortDefn (PrimitiveSortData+    primSortName+    primSortSort+  )++-- TODO: lenses for all Defn variants++lensFunction :: Lens' Defn FunctionData+lensFunction f = \case+  FunctionDefn d -> FunctionDefn <$> f d+  _ -> __IMPOSSIBLE__++lensConstructor :: Lens' Defn ConstructorData+lensConstructor f = \case+  ConstructorDefn d -> ConstructorDefn <$> f d+  _ -> __IMPOSSIBLE__++lensRecord :: Lens' Defn RecordData+lensRecord f = \case+  RecordDefn d -> RecordDefn <$> f d+  _ -> __IMPOSSIBLE__++-- Lenses for Record++lensRecTel :: Lens' RecordData Telescope+lensRecTel f r =+  f (_recTel r) <&> \ tel -> r { _recTel = tel }++lensRecEta :: Lens' RecordData EtaEquality+lensRecEta f r =+  f (_recEtaEquality' r) <&> \ eta -> r { _recEtaEquality' = eta }++-- Pretty printing definitions++instance Pretty Definition where+  pretty Defn{..} =+    "Defn {" <?> vcat+      [ "defArgInfo        =" <?> pshow defArgInfo+      , "defName           =" <?> pretty defName+      , "defType           =" <?> pretty defType+      , "defPolarity       =" <?> pshow defPolarity+      , "defArgOccurrences =" <?> pshow defArgOccurrences+      , "defGeneralizedParams =" <?> pshow defGeneralizedParams+      , "defDisplay        =" <?> pretty defDisplay+      , "defMutual         =" <?> pshow defMutual+      , "defCompiledRep    =" <?> pshow defCompiledRep+      , "defInstance       =" <?> pshow defInstance+      , "defCopy           =" <?> pshow defCopy+      , "defMatchable      =" <?> pshow (Set.toList defMatchable)+      , "defInjective      =" <?> pshow defInjective+      , "defCopatternLHS   =" <?> pshow defCopatternLHS+      , "theDef            =" <?> pretty theDef ] <+> "}"++instance Pretty Defn where+  pretty = \case+    AxiomDefn _         -> "Axiom"+    DataOrRecSigDefn d  -> pretty d+    GeneralizableVar _  -> "GeneralizableVar"+    AbstractDefn def    -> "AbstractDefn" <?> parens (pretty def)+    FunctionDefn d      -> pretty d+    DatatypeDefn d      -> pretty d+    RecordDefn d        -> pretty d+    ConstructorDefn d   -> pretty d+    PrimitiveDefn d     -> pretty d+    PrimitiveSortDefn d -> pretty d++instance Pretty DataOrRecSigData where+  pretty (DataOrRecSigData n) = "DataOrRecSig" <+> pretty n++instance Pretty ProjectionLikenessMissing where+  pretty MaybeProjection = "MaybeProjection"+  pretty NeverProjection = "NeverProjection"++instance Pretty FunctionData where+  pretty (FunctionData+      funClauses+      funCompiled+      funSplitTree+      funTreeless+      _funCovering+      funInv+      funMutual+      funProjection+      funFlags+      funTerminates+      _funExtLam+      funWith+      funIsKanOp+      funOpaque+    ) =+    "Function {" <?> vcat+      [ "funClauses      =" <?> vcat (map pretty funClauses)+      , "funCompiled     =" <?> pretty funCompiled+      , "funSplitTree    =" <?> pretty funSplitTree+      , "funTreeless     =" <?> pretty funTreeless+      , "funInv          =" <?> pretty funInv+      , "funMutual       =" <?> pshow funMutual+      , "funProjection   =" <?> pretty funProjection+      , "funFlags        =" <?> pshow funFlags+      , "funTerminates   =" <?> pshow funTerminates+      , "funWith         =" <?> pretty funWith+      , "funIsKanOp      =" <?> pretty funIsKanOp+      , "funOpaque       =" <?> pshow funOpaque+      ] <?> "}"++instance Pretty DatatypeData where+  pretty (DatatypeData+      dataPars+      dataIxs+      dataClause+      dataCons+      dataSort+      dataMutual+      _dataAbstr+      _dataPathCons+      _dataTranspIx+      _dataTransp+    ) =+    "Datatype {" <?> vcat+      [ "dataPars       =" <?> pshow dataPars+      , "dataIxs        =" <?> pshow dataIxs+      , "dataClause     =" <?> pretty dataClause+      , "dataCons       =" <?> pshow dataCons+      , "dataSort       =" <?> pretty dataSort+      , "dataMutual     =" <?> pshow dataMutual+      , "dataAbstr      =" <?> pshow dataAbstr+      ] <?> "}"++instance Pretty RecordData where+  pretty (RecordData+      recPars+      recClause+      recConHead+      recNamedCon+      recFields+      recTel+      recMutual+      recEtaEquality'+      _recPatternMatching+      recInduction+      _recTerminates+      recAbstr+      _recComp+    ) =+    "Record {" <?> vcat+      [ "recPars         =" <?> pshow recPars+      , "recClause       =" <?> pretty recClause+      , "recConHead      =" <?> pretty recConHead+      , "recNamedCon     =" <?> pretty recNamedCon+      , "recFields       =" <?> pretty recFields+      , "recTel          =" <?> pretty recTel+      , "recMutual       =" <?> pshow recMutual+      , "recEtaEquality' =" <?> pshow recEtaEquality'+      , "recInduction    =" <?> pshow recInduction+      , "recAbstr        =" <?> pshow recAbstr+      ] <?> "}"++instance Pretty ConstructorData where+  pretty (ConstructorData+      conPars+      conArity+      conSrcCon+      conData+      conAbstr+      _conComp+      _conProj+      _conForced+      conErased+      conErasure+      conInline+    ) =+    "Constructor {" <?> vcat+      [ "conPars    =" <?> pshow conPars+      , "conArity   =" <?> pshow conArity+      , "conSrcCon  =" <?> pretty conSrcCon+      , "conData    =" <?> pretty conData+      , "conAbstr   =" <?> pshow conAbstr+      , "conErased  =" <?> pshow conErased+      , "conErasure =" <?> pshow conErasure+      , "conInline  =" <?> pshow conInline+      ] <?> "}"++instance Pretty PrimitiveData where+  pretty (PrimitiveData+      primAbstr+      primName+      primClauses+      _primInv+      primCompiled+      primOpaque+      ) =+    "Primitive {" <?> vcat+      [ "primAbstr    =" <?> pshow primAbstr+      , "primName     =" <?> pshow primName+      , "primClauses  =" <?> pshow primClauses+      , "primCompiled =" <?> pshow primCompiled+      , "primOpaque   =" <?> pshow primOpaque+      ] <?> "}"++instance Pretty PrimitiveSortData where+  pretty (PrimitiveSortData primSortName primSortSort) =+    "PrimitiveSort {" <?> vcat+      [ "primSortName =" <?> pshow primSortName+      , "primSortSort =" <?> pshow primSortSort+      ] <?> "}"++instance Pretty Projection where+  pretty Projection{..} =+    "Projection {" <?> vcat+      [ "projProper   =" <?> pretty projProper+      , "projOrig     =" <?> pretty projOrig+      , "projFromType =" <?> pretty projFromType+      , "projIndex    =" <?> pshow projIndex+      , "projLams     =" <?> pretty projLams+      ]++instance Pretty c => Pretty (FunctionInverse' c) where+  pretty NotInjective = "NotInjective"+  pretty (Inverse inv) = "Inverse" <?>+    vcat [ pretty h <+> "->" <?> pretty cs+         | (h, cs) <- Map.toList inv ]++instance Pretty ProjLams where+  pretty (ProjLams args) = pretty args++-- | Is the record type recursive?+recRecursive :: Defn -> Bool+recRecursive (RecordDefn d) = recRecursive_ d+recRecursive _ = __IMPOSSIBLE__++recRecursive_ :: RecordData -> Bool+recRecursive_ RecordData{ _recMutual = Just qs } = not $ null qs+recRecursive_ _ = __IMPOSSIBLE__++recEtaEquality :: Defn -> HasEta+recEtaEquality = theEtaEquality . recEtaEquality'++_recEtaEquality :: RecordData -> HasEta+_recEtaEquality = theEtaEquality . _recEtaEquality'++-- | A template for creating 'Function' definitions, with sensible+-- defaults.+emptyFunctionData :: HasOptions m => m FunctionData+emptyFunctionData = emptyFunctionData_ . optErasure <$> pragmaOptions++emptyFunctionData_ :: Bool -> FunctionData+emptyFunctionData_ erasure = FunctionData+    { _funClauses     = []+    , _funCompiled    = Nothing+    , _funSplitTree   = Nothing+    , _funTreeless    = Nothing+    , _funInv         = NotInjective+    , _funMutual      = Nothing+    , _funProjection  = Left MaybeProjection+    , _funFlags       = SmallSet.fromList [ FunErasure | erasure ]+    , _funTerminates  = Nothing+    , _funExtLam      = Nothing+    , _funWith        = Nothing+    , _funCovering    = []+    , _funIsKanOp     = Nothing+    , _funOpaque      = TransparentDef+    }++emptyFunction :: HasOptions m => m Defn+emptyFunction = FunctionDefn <$> emptyFunctionData++emptyFunction_ :: Bool -> Defn+emptyFunction_ = FunctionDefn . emptyFunctionData_++funFlag_ :: FunctionFlag -> Lens' FunctionData Bool+funFlag_ flag f def@FunctionData{ _funFlags = flags } =+  f (SmallSet.member flag flags) <&>+  \ b -> def{ _funFlags = (if b then SmallSet.insert else SmallSet.delete) flag flags }++funFlag :: FunctionFlag -> Lens' Defn Bool+funFlag flag f = \case+  FunctionDefn d -> FunctionDefn <$> funFlag_ flag f d+  def            -> f False $> def++funStatic, funInline, funMacro :: Lens' Defn Bool+funStatic       = funFlag FunStatic+funInline       = funFlag FunInline+funMacro        = funFlag FunMacro++funMacro_ :: Lens' FunctionData Bool+funMacro_ = funFlag_ FunMacro++-- | Toggle the 'FunFirstOrder' flag.+funFirstOrder :: Lens' Defn Bool+funFirstOrder = funFlag FunFirstOrder++-- | Toggle the 'FunErasure' flag.+funErasure :: Lens' Defn Bool+funErasure = funFlag FunErasure++-- | Toggle the 'FunAbstract' flag.+funAbstract :: Lens' Defn Bool+funAbstract = funFlag FunAbstract++-- | Toggle the 'FunAbstract' flag.+funAbstr :: Lens' Defn IsAbstract+funAbstr = funAbstract . iso fromBool toBool++-- | Toggle the 'FunAbstract' flag.+funAbstract_ :: Lens' FunctionData Bool+funAbstract_ = funFlag_ FunAbstract++-- | Toggle the 'FunAbstract' flag.+funAbstr_ :: Lens' FunctionData IsAbstract+funAbstr_ = funAbstract_ . iso fromBool toBool++-- | Toggle the 'FunProj' flag.+funProj :: Lens' Defn Bool+funProj = funFlag FunProj++-- | Toggle the 'FunProj' flag.+funProj_ :: Lens' FunctionData Bool+funProj_ = funFlag_ FunProj++isMacro :: Defn -> Bool+isMacro = (^. funMacro)++-- | Checking whether we are dealing with a function yet to be defined.+isEmptyFunction :: Defn -> Bool+isEmptyFunction def =+  case def of+    Function { funClauses = [] } -> True+    _ -> False++isExtendedLambda :: Defn -> Bool+isExtendedLambda def =+  case def of+    Function { funExtLam = Just{} } -> True+    _ -> False++isWithFunction :: Defn -> Bool+isWithFunction def =+  case def of+    Function { funWith = Just{} } -> True+    _ -> False++isCopatternLHS :: [Clause] -> Bool+isCopatternLHS = List.any (List.any (isJust . A.isProjP) . namedClausePats)++recCon :: Defn -> QName+recCon Record{ recConHead } = conName recConHead+recCon _ = __IMPOSSIBLE__++defIsRecord :: Defn -> Bool+defIsRecord Record{} = True+defIsRecord _        = False++defIsDataOrRecord :: Defn -> Bool+defIsDataOrRecord Record{}   = True+defIsDataOrRecord Datatype{} = True+defIsDataOrRecord _          = False++defConstructors :: Defn -> [QName]+defConstructors Datatype{dataCons = cs} = cs+defConstructors Record{recConHead = c} = [conName c]+defConstructors _ = __IMPOSSIBLE__++newtype Fields = Fields [(C.Name, Type)]+  deriving Null++-- | Did we encounter a simplifying reduction?+--   In terms of CIC, that would be a iota-reduction.+--   In terms of Agda, this is a constructor or literal+--   pattern that matched.+--   Just beta-reduction (substitution) or delta-reduction+--   (unfolding of definitions) does not count as simplifying?++data Simplification = YesSimplification | NoSimplification+  deriving (Eq, Show, Generic)++instance Null Simplification where+  empty = NoSimplification+  null  = (== NoSimplification)++instance Semigroup Simplification where+  YesSimplification <> _ = YesSimplification+  NoSimplification  <> s = s++instance Monoid Simplification where+  mempty = NoSimplification+  mappend = (<>)++data Reduced no yes+  = NoReduction no+  | YesReduction Simplification yes+  deriving Functor++redReturn :: a -> ReduceM (Reduced a' a)+redReturn = return . YesReduction YesSimplification++-- | Conceptually: @redBind m f k = either (return . Left . f) k =<< m@++redBind :: ReduceM (Reduced a a') -> (a -> ReduceM b) ->+           (a' -> ReduceM (Reduced b b')) -> ReduceM (Reduced b b')+redBind ma f k = do+  r <- ma+  case r of+    NoReduction x    -> NoReduction <$> f x+    YesReduction _ y -> k y++-- | Three cases: 1. not reduced, 2. reduced, but blocked, 3. reduced, not blocked.+data IsReduced+  = NotReduced+  | Reduced    (Blocked ())++data MaybeReduced a = MaybeRed+  { isReduced     :: IsReduced+  , ignoreReduced :: a+  }+  deriving (Functor)++instance IsProjElim e => IsProjElim (MaybeReduced e) where+  isProjElim = isProjElim . ignoreReduced++type MaybeReducedArgs = [MaybeReduced (Arg Term)]+type MaybeReducedElims = [MaybeReduced Elim]++notReduced :: a -> MaybeReduced a+notReduced x = MaybeRed NotReduced x++reduced :: Blocked (Arg Term) -> MaybeReduced (Arg Term)+reduced b = MaybeRed (Reduced $ () <$ b) $ ignoreBlocking b++-- | Controlling 'reduce'.+data AllowedReduction+  = ProjectionReductions     -- ^ (Projection and) projection-like functions may be reduced.+  | InlineReductions         -- ^ Functions marked INLINE may be reduced.+  | CopatternReductions      -- ^ Copattern definitions may be reduced.+  | FunctionReductions       -- ^ Non-recursive functions and primitives may be reduced.+  | RecursiveReductions      -- ^ Even recursive functions may be reduced.+  | LevelReductions          -- ^ Reduce @'Level'@ terms.+  | TypeLevelReductions      -- ^ Allow @allReductions@ in types, even+                             --   if not allowed at term level (used+                             --   by confluence checker)+  | UnconfirmedReductions    -- ^ Functions whose termination has not (yet) been confirmed.+  | NonTerminatingReductions -- ^ Functions that have failed termination checking.+  deriving (Show, Eq, Ord, Enum, Bounded, Ix, Generic)++instance SmallSet.SmallSetElement AllowedReduction++type AllowedReductions = SmallSet AllowedReduction++-- | Not quite all reductions (skip non-terminating reductions)+allReductions :: AllowedReductions+allReductions = SmallSet.delete NonTerminatingReductions reallyAllReductions++reallyAllReductions :: AllowedReductions+reallyAllReductions = SmallSet.total++data ReduceDefs+  = OnlyReduceDefs (Set QName)+  | DontReduceDefs (Set QName)+  deriving Generic++reduceAllDefs :: ReduceDefs+reduceAllDefs = DontReduceDefs empty++locallyReduceDefs :: MonadTCEnv m => ReduceDefs -> m a -> m a+locallyReduceDefs = locallyTC eReduceDefs . const++locallyReduceAllDefs :: MonadTCEnv m => m a -> m a+locallyReduceAllDefs = locallyReduceDefs reduceAllDefs++shouldReduceDef :: (MonadTCEnv m) => QName -> m Bool+shouldReduceDef f = asksTC envReduceDefs <&> \case+  OnlyReduceDefs defs -> f `Set.member` defs+  DontReduceDefs defs -> not $ f `Set.member` defs++toReduceDefs :: (Bool, [QName]) -> ReduceDefs+toReduceDefs (True,  ns) = OnlyReduceDefs (Data.Set.fromList ns)+toReduceDefs (False, ns) = DontReduceDefs (Data.Set.fromList ns)++fromReduceDefs :: ReduceDefs -> (Bool, [QName])+fromReduceDefs (OnlyReduceDefs ns) = (True,  toList ns)+fromReduceDefs (DontReduceDefs ns) = (False, toList ns)++locallyReconstructed :: MonadTCEnv m => m a -> m a+locallyReconstructed = locallyTC eReconstructed . const $ True++isReconstructed :: (MonadTCEnv m) => m Bool+isReconstructed = asksTC envReconstructed++-- | Primitives++data PrimitiveImpl = PrimImpl Type PrimFun++data PrimFun = PrimFun+  { primFunName           :: QName+  , primFunArity          :: Arity+  , primFunArgOccurrences :: [Occurrence]+    -- ^ See 'defArgOccurrences'.+  , primFunImplementation :: [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term)+  }+  deriving Generic++primFun :: QName -> Arity -> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun+primFun q ar imp = PrimFun q ar [] (\args _ -> imp args)++defClauses :: Definition -> [Clause]+defClauses Defn{theDef = Function{funClauses = cs}}        = cs+defClauses Defn{theDef = Primitive{primClauses = cs}}      = cs+defClauses Defn{theDef = Datatype{dataClause = Just c}}    = [c]+defClauses Defn{theDef = Record{recClause = Just c}}       = [c]+defClauses _                                               = []++defCompiled :: Definition -> Maybe CompiledClauses+defCompiled Defn{theDef = Function {funCompiled  = mcc}} = mcc+defCompiled Defn{theDef = Primitive{primCompiled = mcc}} = mcc+defCompiled _ = Nothing++defParameters :: Definition -> Maybe Nat+defParameters Defn{theDef = Datatype{dataPars = n}} = Just n+defParameters Defn{theDef = Record  {recPars  = n}} = Just n+defParameters _                                     = Nothing++defInverse :: Definition -> FunctionInverse+defInverse Defn{theDef = Function { funInv  = inv }} = inv+defInverse Defn{theDef = Primitive{ primInv = inv }} = inv+defInverse _                                         = NotInjective++defCompilerPragmas :: BackendName -> Definition -> [CompilerPragma]+defCompilerPragmas b = reverse . fromMaybe [] . Map.lookup b . defCompiledRep+  -- reversed because we add new pragmas to the front of the list++-- | Has the definition failed the termination checker?+defNonterminating :: Definition -> Bool+defNonterminating Defn{theDef = Function{funTerminates = Just False}} = True+defNonterminating _                                                   = False++-- | Has the definition not termination checked or did the check fail?+defTerminationUnconfirmed :: Definition -> Bool+defTerminationUnconfirmed Defn{theDef = Function{funTerminates = Just True}} = False+defTerminationUnconfirmed Defn{theDef = Function{funTerminates = _        }} = True+defTerminationUnconfirmed _ = False++defAbstract :: Definition -> IsAbstract+defAbstract def = case theDef def of+    AxiomDefn _         -> ConcreteDef+    DataOrRecSigDefn _  -> ConcreteDef+    GeneralizableVar _  -> ConcreteDef+    AbstractDefn _      -> AbstractDef+    FunctionDefn d      -> d ^. funAbstr_+    DatatypeDefn d      -> _dataAbstr d+    RecordDefn d        -> _recAbstr d+    ConstructorDefn d   -> _conAbstr d+    PrimitiveDefn d     -> _primAbstr d+    PrimitiveSortDefn _ -> ConcreteDef++defOpaque :: Definition -> IsOpaque+defOpaque d = case theDef d of+    -- These two can be opaque:+    Function{funOpaque=o}     -> o+    Primitive{primOpaque=o}   -> o++    -- Doesn't matter whether or not it's opaque:+    Axiom{}                   -> TransparentDef+    -- Concreteness is orthogonal to opacity:+    AbstractDefn{}            -> TransparentDef++    -- None of these are supported in opaque blocks:+    DataOrRecSig{}            -> TransparentDef+    GeneralizableVar{}        -> TransparentDef+    Datatype{}                -> TransparentDef+    Record{}                  -> TransparentDef+    Constructor{}             -> TransparentDef+    PrimitiveSort{}           -> TransparentDef++defForced :: Definition -> [IsForced]+defForced d = case theDef d of+    Constructor{conForced = fs} -> fs+    Axiom{}                     -> []+    DataOrRecSig{}              -> []+    GeneralizableVar{}          -> []+    AbstractDefn{}              -> []+    Function{}                  -> []+    Datatype{}                  -> []+    Record{}                    -> []+    Primitive{}                 -> []+    PrimitiveSort{}             -> []++---------------------------------------------------------------------------+-- ** Injectivity+---------------------------------------------------------------------------++type FunctionInverse = FunctionInverse' Clause+type InversionMap c = Map TermHead [c]++data FunctionInverse' c+  = NotInjective+  | Inverse (InversionMap c)+  deriving (Show, Functor, Generic)++data TermHead = SortHead+              | PiHead+              | ConsHead QName+              | VarHead Nat+              | UnknownHead+  deriving (Eq, Ord, Show, Generic)++instance Pretty TermHead where+  pretty = \ case+    SortHead    -> "SortHead"+    PiHead      -> "PiHead"+    ConsHead q  -> "ConsHead" <+> pretty q+    VarHead i   -> text ("VarHead " ++ show i)+    UnknownHead -> "UnknownHead"++---------------------------------------------------------------------------+-- ** Mutual blocks+---------------------------------------------------------------------------++newtype MutualId = MutualId Word32+  deriving (Eq, Ord, Show, Num, Enum, NFData)++instance Pretty MutualId where+  pretty (MutualId i) = pretty i++-- | Map 'MutualId' to 'MutualBlock'.+type MutualBlocks = IntMap MutualBlock++-- | A mutual block of names in the signature.+data MutualBlock = MutualBlock+  { mutualInfo  :: MutualInfo+    -- ^ The original info of the mutual block.+  , mutualNames :: Set QName+  } deriving (Show, Eq, Generic)++instance Null MutualBlock where+  empty = MutualBlock empty empty++---------------------------------------------------------------------------+-- ** Statistics+---------------------------------------------------------------------------++type Statistics = Map String Integer++---------------------------------------------------------------------------+-- ** Trace+---------------------------------------------------------------------------++data Call+  = CheckClause Type A.SpineClause+  | CheckLHS A.SpineLHS+  | CheckPattern A.Pattern Telescope Type+  | CheckPatternLinearityType C.Name+  | CheckPatternLinearityValue C.Name+  | CheckLetBinding A.LetBinding+  | InferExpr A.Expr+  | CheckExprCall Comparison A.Expr Type+  | CheckDotPattern A.Expr Term+  | CheckProjection Range QName Type+  | IsTypeCall Comparison A.Expr Sort+  | IsType_ A.Expr+  | InferVar Name+  | InferDef QName+  | CheckArguments A.Expr [NamedArg A.Expr] Type (Maybe Type)+  | CheckMetaSolution Range MetaId Type Term+  | CheckTargetType Range Type Type+  | CheckDataDef Range QName [A.LamBinding] [A.Constructor]+  | CheckRecDef Range QName [A.LamBinding] [A.Constructor]+  | CheckConstructor QName Telescope Sort A.Constructor+  | CheckConArgFitsIn QName Bool Type Sort+  | CheckFunDefCall Range QName [A.Clause] Bool+    -- ^ Highlight (interactively) if and only if the boolean is 'True'.+  | CheckPragma Range A.Pragma+  | CheckPrimitive Range QName A.Expr+  | CheckIsEmpty Range Type+  | CheckConfluence QName QName+  | CheckModuleParameters ModuleName A.Telescope+  | CheckWithFunctionType Type+  | CheckSectionApplication Range Erased ModuleName A.ModuleApplication+  | CheckNamedWhere ModuleName+  -- | Checking a clause for confluence with endpoint reductions. Always+  -- @φ ⊢ f vs = rhs@ for now, but we store the simplifications of+    -- @f vs[φ]@ and @rhs[φ]@.+  | CheckIApplyConfluence+      Range  -- ^ Clause range+      QName  -- ^ Function name+      Term   -- ^ (As-is) Function applied to the patterns in this clause+      Term   -- ^ (Simplified) Function applied to the patterns in this clause+      Term   -- ^ (Simplified) clause RHS+      Type   -- ^ (Simplified) clause type+  | ScopeCheckExpr C.Expr+  | ScopeCheckDeclaration NiceDeclaration+  | ScopeCheckLHS C.QName C.Pattern+  | NoHighlighting+  | ModuleContents  -- ^ Interaction command: show module contents.+  | SetRange Range  -- ^ used by 'setCurrentRange'+  deriving Generic++instance Pretty Call where+    pretty CheckClause{}             = "CheckClause"+    pretty CheckLHS{}                = "CheckLHS"+    pretty CheckPattern{}            = "CheckPattern"+    pretty CheckPatternLinearityType{}  = "CheckPatternLinearityType"+    pretty CheckPatternLinearityValue{} = "CheckPatternLinearityValue"+    pretty InferExpr{}               = "InferExpr"+    pretty CheckExprCall{}           = "CheckExprCall"+    pretty CheckLetBinding{}         = "CheckLetBinding"+    pretty CheckProjection{}         = "CheckProjection"+    pretty IsTypeCall{}              = "IsTypeCall"+    pretty IsType_{}                 = "IsType_"+    pretty InferVar{}                = "InferVar"+    pretty InferDef{}                = "InferDef"+    pretty CheckArguments{}          = "CheckArguments"+    pretty CheckMetaSolution{}       = "CheckMetaSolution"+    pretty CheckTargetType{}         = "CheckTargetType"+    pretty CheckDataDef{}            = "CheckDataDef"+    pretty CheckRecDef{}             = "CheckRecDef"+    pretty CheckConstructor{}        = "CheckConstructor"+    pretty CheckConArgFitsIn{}       = "CheckConArgFitsIn"+    pretty CheckFunDefCall{}         = "CheckFunDefCall"+    pretty CheckPragma{}             = "CheckPragma"+    pretty CheckPrimitive{}          = "CheckPrimitive"+    pretty CheckModuleParameters{}   = "CheckModuleParameters"+    pretty CheckWithFunctionType{}   = "CheckWithFunctionType"+    pretty CheckNamedWhere{}         = "CheckNamedWhere"+    pretty ScopeCheckExpr{}          = "ScopeCheckExpr"+    pretty ScopeCheckDeclaration{}   = "ScopeCheckDeclaration"+    pretty ScopeCheckLHS{}           = "ScopeCheckLHS"+    pretty CheckDotPattern{}         = "CheckDotPattern"+    pretty SetRange{}                = "SetRange"+    pretty CheckSectionApplication{} = "CheckSectionApplication"+    pretty CheckIsEmpty{}            = "CheckIsEmpty"+    pretty CheckConfluence{}         = "CheckConfluence"+    pretty NoHighlighting{}          = "NoHighlighting"+    pretty ModuleContents{}          = "ModuleContents"+    pretty CheckIApplyConfluence{}   = "ModuleContents"++instance HasRange Call where+    getRange (CheckClause _ c)                   = getRange c+    getRange (CheckLHS lhs)                      = getRange lhs+    getRange (CheckPattern p _ _)                = getRange p+    getRange (CheckPatternLinearityType x)       = getRange x+    getRange (CheckPatternLinearityValue x)      = getRange x+    getRange (InferExpr e)                       = getRange e+    getRange (CheckExprCall _ e _)               = getRange e+    getRange (CheckLetBinding b)                 = getRange b+    getRange (CheckProjection r _ _)             = r+    getRange (IsTypeCall cmp e s)                = getRange e+    getRange (IsType_ e)                         = getRange e+    getRange (InferVar x)                        = getRange x+    getRange (InferDef f)                        = getRange f+    getRange (CheckArguments fun _ _ _)          = getRange fun+    getRange (CheckMetaSolution r _ _ _)         = r+    getRange (CheckTargetType r _ _)             = r+    getRange (CheckDataDef i _ _ _)              = getRange i+    getRange (CheckRecDef i _ _ _)               = getRange i+    getRange (CheckConstructor _ _ _ c)          = getRange c+    getRange (CheckConArgFitsIn c _ _ _)         = getRange c+    getRange (CheckFunDefCall i _ _ _)           = getRange i+    getRange (CheckPragma r _)                   = r+    getRange (CheckPrimitive i _ _)              = getRange i+    getRange (CheckModuleParameters _ tel)       = getRange tel+    getRange CheckWithFunctionType{}             = noRange+    getRange (CheckNamedWhere m)                 = getRange m+    getRange (ScopeCheckExpr e)                  = getRange e+    getRange (ScopeCheckDeclaration d)           = getRange d+    getRange (ScopeCheckLHS _ p)                 = getRange p+    getRange (CheckDotPattern e _)               = getRange e+    getRange (SetRange r)                        = r+    getRange (CheckSectionApplication r _ _ _)   = r+    getRange (CheckIsEmpty r _)                  = r+    getRange (CheckConfluence rule1 rule2)       = max (getRange rule1) (getRange rule2)+    getRange NoHighlighting                      = noRange+    getRange ModuleContents                      = noRange+    getRange (CheckIApplyConfluence e _ _ _ _ _) = getRange e++---------------------------------------------------------------------------+-- ** Instance table+---------------------------------------------------------------------------++-- | Records information about the instances in the signature. Does not+-- deal with local instances.+data InstanceTable = InstanceTable+  { _itableTree   :: DiscrimTree QName+    -- ^ The actual discrimination tree for looking up instances with++  , _itableCounts :: Map QName Int+    -- ^ For profiling, we store the number of instances on a per-class+    -- basis. This lets us compare the result from the discrimination+    -- tree with all the instances in scope, thus informing us how many+    -- validity checks were skipped.+  }+  deriving (Show, Generic)++instance Semigroup InstanceTable where+  InstanceTable t i <> InstanceTable t' i' = InstanceTable+    { _itableTree   = t <> t'+    , _itableCounts = Map.unionWith (+) i i'+    }++instance Monoid InstanceTable where+  mempty = InstanceTable mempty mempty++instance Null InstanceTable where+  empty = mempty+  null (InstanceTable a b) = null a && null b++itableTree :: Lens' InstanceTable (DiscrimTree QName)+itableTree f s = f (_itableTree s) <&> \x -> s { _itableTree = x }++itableCounts :: Lens' InstanceTable (Map QName Int)+itableCounts f s = f (_itableCounts s) <&> \x -> s { _itableCounts = x }++-- | When typechecking something of the following form:+--+--     instance+--       x : _+--       x = y+--+--   it's not yet known where to add @x@, so we add it to a list of+--   unresolved instances and we'll deal with it later.+type TempInstanceTable = (InstanceTable , Set QName)++---------------------------------------------------------------------------+-- ** Builtin things+---------------------------------------------------------------------------++data BuiltinSort+  = SortUniv Univ+  | SortOmega Univ+  | SortIntervalUniv+  | SortLevelUniv+  deriving (Show, Eq, Generic)++pattern SortProp, SortSet, SortStrictSet, SortPropOmega, SortSetOmega, SortStrictSetOmega :: BuiltinSort+pattern SortProp           = SortUniv  UProp+pattern SortSet            = SortUniv  UType+pattern SortStrictSet      = SortUniv  USSet+pattern SortPropOmega      = SortOmega UProp+pattern SortSetOmega       = SortOmega UType+pattern SortStrictSetOmega = SortOmega USSet++{-# COMPLETE+  SortProp, SortSet, SortStrictSet,+  SortPropOmega, SortSetOmega, SortStrictSetOmega,+  SortIntervalUniv, SortLevelUniv #-}++data BuiltinDescriptor+  = BuiltinData (TCM Type) [BuiltinId]+  | BuiltinDataCons (TCM Type)+  | BuiltinPrim PrimitiveId (Term -> TCM ())+  | BuiltinSort BuiltinSort+  | BuiltinPostulate Relevance (TCM Type)+  | BuiltinUnknown (Maybe (TCM Type)) (Term -> Type -> TCM ())+    -- ^ Builtin of any kind.+    --   Type can be checked (@Just t@) or inferred (@Nothing@).+    --   The second argument is the hook for the verification function.++data BuiltinInfo =+   BuiltinInfo { builtinName :: BuiltinId+               , builtinDesc :: BuiltinDescriptor }++type BuiltinThings = BuiltinThings' PrimFun+type BuiltinThings' pf = Map SomeBuiltin (Builtin pf)++data Builtin pf+        = Builtin Term+        | Prim pf+        | BuiltinRewriteRelations (Set QName)+            -- ^ @BUILTIN REWRITE@.  We can have several rewrite relations.+    deriving (Show, Functor, Foldable, Traversable, Generic)++---------------------------------------------------------------------------+-- * Highlighting levels+---------------------------------------------------------------------------++-- | @ifTopLevelAndHighlightingLevelIs l b m@ runs @m@ when we're+-- type-checking the top-level module (or before we've started doing+-- this) and either the highlighting level is /at least/ @l@ or @b@ is+-- 'True'.++ifTopLevelAndHighlightingLevelIsOr ::+  MonadTCEnv tcm => HighlightingLevel -> Bool -> tcm () -> tcm ()+ifTopLevelAndHighlightingLevelIsOr l b m = do+  e <- askTC+  when (envHighlightingLevel e >= l || b) $+    case (envImportPath e) of+      -- Below the main module.+      (_:_:_) -> pure ()+      -- In or before the top-level module.+      _ -> m++-- | @ifTopLevelAndHighlightingLevelIs l m@ runs @m@ when we're+-- type-checking the top-level module (or before we've started doing+-- this) and the highlighting level is /at least/ @l@.++ifTopLevelAndHighlightingLevelIs ::+  MonadTCEnv tcm => HighlightingLevel -> tcm () -> tcm ()+ifTopLevelAndHighlightingLevelIs l =+  ifTopLevelAndHighlightingLevelIsOr l False++---------------------------------------------------------------------------+-- * Type checking environment+---------------------------------------------------------------------------++data TCEnv =+    TCEnv { envContext             :: Context+          , envLetBindings         :: LetBindings+          , envCurrentModule       :: ModuleName+          , envCurrentPath         :: Maybe FileId+            -- ^ The path to the file that is currently being+            -- type-checked.  'Nothing' if we do not have a file+            -- (like in interactive mode see @CommandLine@).+          , envAnonymousModules    :: [(ModuleName, Nat)] -- ^ anonymous modules and their number of free variables+          , envImportPath          :: [TopLevelModuleName]+            -- ^ The module stack with the entry being the top-level module as+            --   Agda chases modules. It will be empty if there is no main+            --   module, will have a single entry for the top level module, or+            --   more when descending past the main module. This is used to+            --   detect import cycles and in some cases highlighting behavior.+            --   The level of a given module is not necessarily the same as the+            --   length, in the module dependency graph, of the shortest path+            --   from the top-level module; it depends on in which order Agda+            --   chooses to chase dependencies.+          , envMutualBlock         :: Maybe MutualId -- ^ the current (if any) mutual block+          , envTerminationCheck    :: TerminationCheck ()  -- ^ are we inside the scope of a termination pragma+          , envCoverageCheck       :: CoverageCheck        -- ^ are we inside the scope of a coverage pragma+          , envMakeCase            :: Bool                 -- ^ are we inside a make-case (if so, ignore forcing analysis in unifier)+          , envSolvingConstraints  :: Bool+                -- ^ Are we currently in the process of solving active constraints?+          , envCheckingWhere       :: C.WhereClause_+                -- ^ Have we stepped into the where-declarations of a clause?+                --   Everything under a @where@ will be checked with this flag on.+          , envWorkingOnTypes      :: Bool+                -- ^ Are we working on types? Turned on by 'workOnTypes'.+          , envAssignMetas         :: Bool+            -- ^ Are we allowed to assign metas?+          , envActiveProblems      :: Set ProblemId+          , envUnquoteProblem      :: Maybe ProblemId+            -- ^ If inside a `runUnquoteM` call, stores the top-level problem id assigned to the+            --   invokation. We use this to decide which instance constraints originate from the+            --   current call and which come from the outside, for the purpose of a+            --   `solveInstanceConstraints` inside `noConstraints` only failing for local instance+            --   constraints.+          , envAbstractMode        :: AbstractMode+                -- ^ When checking the typesignature of a public definition+                --   or the body of a non-abstract definition this is true.+                --   To prevent information about abstract things leaking+                --   outside the module.+          , envRelevance           :: Relevance+                -- ^ Are we checking an irrelevant argument? (=@Irrelevant@)+                -- Then top-level irrelevant declarations are enabled.+                -- Other value: @Relevant@, then only relevant decls. are available.+          , envQuantity            :: Quantity+                -- ^ Are we checking a runtime-irrelevant thing? (='Quantity0')+                -- Then runtime-irrelevant things are usable.+          , envHardCompileTimeMode :: Bool+                -- ^ Is the \"hard\" compile-time mode enabled? In+                -- this mode the quantity component of the environment+                -- is always zero, and every new definition is treated+                -- as erased.+          , envSplitOnStrict       :: Bool+                -- ^ Are we currently case-splitting on a strict+                --   datatype (i.e. in SSet)? If yes, the+                --   pattern-matching unifier will solve reflexive+                --   equations even --without-K.+          , envDisplayFormsEnabled :: Bool+                -- ^ Sometimes we want to disable display forms.+          , envFoldLetBindings :: Bool+                -- ^ Fold let-bindings when printing terms (default: True)+          , envRange :: Range+          , envHighlightingRange :: Range+                -- ^ Interactive highlighting uses this range rather+                --   than 'envRange'.+          , envClause :: IPClause+                -- ^ What is the current clause we are type-checking?+                --   Will be recorded in interaction points in this clause.+          , envCall  :: Maybe (Closure Call)+                -- ^ what we're doing at the moment+          , envHighlightingLevel  :: HighlightingLevel+                -- ^ Set to 'None' when imported modules are+                --   type-checked.+          , envHighlightingMethod :: HighlightingMethod+          , envExpandLast :: ExpandHidden+                -- ^ When type-checking an alias f=e, we do not want+                -- to insert hidden arguments in the end, because+                -- these will become unsolved metas.+          , envAppDef :: Maybe QName+                -- ^ We are reducing an application of this function.+                -- (For tracking of incomplete matches.)+          , envSimplification :: Simplification+                -- ^ Did we encounter a simplification (proper match)+                --   during the current reduction process?+          , envAllowedReductions :: AllowedReductions+          , envReduceDefs :: ReduceDefs+          , envReconstructed :: Bool+          , envInjectivityDepth :: Int+                -- ^ Injectivity can cause non-termination for unsolvable contraints+                --   (#431, #3067). Keep a limit on the nesting depth of injectivity+                --   uses.+          , envCompareBlocked :: Bool+                -- ^ When @True@, the conversion checker will consider+                --   all term constructors as injective, including+                --   blocked function applications and metas. Warning:+                --   this should only be used when not assigning any+                --   metas (e.g. when @envAssignMetas@ is @False@ or+                --   when running @pureEqualTerms@) or else we get+                --   non-unique meta solutions.+          , envPrintDomainFreePi :: Bool+                -- ^ When @True@, types will be omitted from printed pi types if they+                --   can be inferred.+          , envPrintMetasBare :: Bool+                -- ^ When @True@, throw away meta numbers and meta elims.+                --   This is used for reifying terms for feeding into the+                --   user's source code, e.g., for the interaction tactics @solveAll@.+          , envInsideDotPattern :: Bool+                -- ^ Used by the scope checker to make sure that certain forms+                --   of expressions are not used inside dot patterns: extended+                --   lambdas and let-expressions.+          , envUnquoteFlags :: UnquoteFlags+          , envInstanceDepth :: !Int+              -- ^ Until we get a termination checker for instance search (#1743) we+              --   limit the search depth to ensure termination.+          , envIsDebugPrinting :: Bool+          , envPrintingPatternLambdas :: [QName]+                -- ^ #3004: pattern lambdas with copatterns may refer to themselves. We+                --   don't have a good story for what to do in this case, but at least+                --   printing shouldn't loop. Here we keep track of which pattern lambdas+                --   we are currently in the process of printing.+          , envCallByNeed :: Bool+                -- ^ Use call-by-need evaluation for reductions.+          , envCurrentCheckpoint :: CheckpointId+                -- ^ Checkpoints track the evolution of the context as we go+                -- under binders or refine it by pattern matching.+          , envCheckpoints :: Map CheckpointId Substitution+                -- ^ Keeps the substitution from each previous checkpoint to+                --   the current context.+          , envGeneralizeMetas :: DoGeneralize+                -- ^ Should new metas generalized over.+          , envGeneralizedVars :: Map QName GeneralizedValue+                -- ^ Values for used generalizable variables.+          , envActiveBackendName :: Maybe BackendName+                -- ^ Is some backend active at the moment, and if yes, which?+                --   NB: we only store the 'BackendName' here, otherwise+                --   @instance Data TCEnv@ is not derivable.+                --   The actual backend can be obtained from the name via 'stBackends'.+          , envConflComputingOverlap :: Bool+                -- ^ Are we currently computing the overlap between+                --   two rewrite rules for the purpose of confluence checking?+          , envCurrentlyElaborating :: Bool+                -- ^ Are we currently in the process of executing an+                --   elaborate-and-give interactive command?+          , envSyntacticEqualityFuel :: !(Strict.Maybe Int)+                -- ^ If this counter is 'Strict.Nothing', then+                -- syntactic equality checking is unrestricted. If it+                -- is zero, then syntactic equality checking is not+                -- run at all. If it is a positive number, then+                -- syntactic equality checking is allowed to run, but+                -- the counter is decreased in the failure+                -- continuation of+                -- 'Agda.TypeChecking.SyntacticEquality.checkSyntacticEquality'.+          , envCurrentOpaqueId :: !(Maybe OpaqueId)+                -- ^ Unique identifier of the opaque block we are+                -- currently under, if any. Used by the scope checker+                -- (to associate definitions to blocks), and by the type+                -- checker (for unfolding control).+          , envTermCheckReducing :: Bool+                -- ^ Are we currently trying to reduce away function calls using+                --   non-recursive clauses during termination checking?+          }+    deriving (Generic)++initEnv :: TCEnv+initEnv = TCEnv { envContext             = []+                , envLetBindings         = Map.empty+                , envCurrentModule       = noModuleName+                , envCurrentPath         = Nothing+                , envAnonymousModules    = []+                , envImportPath          = []+                , envMutualBlock         = Nothing+                , envTerminationCheck    = TerminationCheck+                , envCoverageCheck       = YesCoverageCheck+                , envMakeCase            = False+                , envSolvingConstraints  = False+                , envCheckingWhere       = C.NoWhere_+                , envActiveProblems      = Set.empty+                , envUnquoteProblem      = Nothing+                , envWorkingOnTypes      = False+                , envAssignMetas         = True+                , envAbstractMode        = ConcreteMode+  -- Andreas, 2013-02-21:  This was 'AbstractMode' until now.+  -- However, top-level checks for mutual blocks, such as+  -- constructor-headedness, should not be able to look into+  -- abstract definitions unless abstract themselves.+  -- (See also discussion on issue 796.)+  -- The initial mode should be 'ConcreteMode', ensuring you+  -- can only look into abstract things in an abstract+  -- definition (which sets 'AbstractMode').+                , envRelevance              = unitRelevance+                , envQuantity               = unitQuantity+                , envHardCompileTimeMode    = False+                , envSplitOnStrict          = False+                , envDisplayFormsEnabled    = True+                , envFoldLetBindings        = True+                , envRange                  = noRange+                , envHighlightingRange      = noRange+                , envClause                 = IPNoClause+                , envCall                   = Nothing+                , envHighlightingLevel      = None+                , envHighlightingMethod     = Indirect+                , envExpandLast             = ExpandLast+                , envAppDef                 = Nothing+                , envSimplification         = NoSimplification+                , envAllowedReductions      = allReductions+                , envReduceDefs             = reduceAllDefs+                , envReconstructed          = False+                , envInjectivityDepth       = 0+                , envCompareBlocked         = False+                , envPrintDomainFreePi      = False+                , envPrintMetasBare         = False+                , envInsideDotPattern       = False+                , envUnquoteFlags           = defaultUnquoteFlags+                , envInstanceDepth          = 0+                , envIsDebugPrinting        = False+                , envPrintingPatternLambdas = []+                , envCallByNeed             = True+                , envCurrentCheckpoint      = 0+                , envCheckpoints            = Map.singleton 0 IdS+                , envGeneralizeMetas        = NoGeneralize+                , envGeneralizedVars        = Map.empty+                , envActiveBackendName      = Nothing+                , envConflComputingOverlap  = False+                , envCurrentlyElaborating   = False+                , envSyntacticEqualityFuel  = Strict.Nothing+                , envCurrentOpaqueId        = Nothing+                , envTermCheckReducing      = False+                }++class LensTCEnv a where+  lensTCEnv :: Lens' a TCEnv++instance LensTCEnv TCEnv where+  lensTCEnv = id++data UnquoteFlags = UnquoteFlags+  { _unquoteNormalise :: Bool }+  deriving Generic++defaultUnquoteFlags :: UnquoteFlags+defaultUnquoteFlags = UnquoteFlags+  { _unquoteNormalise = False }++unquoteNormalise :: Lens' UnquoteFlags Bool+unquoteNormalise f e = f (_unquoteNormalise e) <&> \ x -> e { _unquoteNormalise = x }++eUnquoteNormalise :: Lens' TCEnv Bool+eUnquoteNormalise = eUnquoteFlags . unquoteNormalise++-- * e-prefixed lenses+------------------------------------------------------------------------++eContext :: Lens' TCEnv Context+eContext f e = f (envContext e) <&> \ x -> e { envContext = x }++eLetBindings :: Lens' TCEnv LetBindings+eLetBindings f e = f (envLetBindings e) <&> \ x -> e { envLetBindings = x }++eCurrentModule :: Lens' TCEnv ModuleName+eCurrentModule f e = f (envCurrentModule e) <&> \ x -> e { envCurrentModule = x }++eCurrentPath :: Lens' TCEnv (Maybe FileId)+eCurrentPath f e = f (envCurrentPath e) <&> \ x -> e { envCurrentPath = x }++eAnonymousModules :: Lens' TCEnv [(ModuleName, Nat)]+eAnonymousModules f e = f (envAnonymousModules e) <&> \ x -> e { envAnonymousModules = x }++eImportPath :: Lens' TCEnv [TopLevelModuleName]+eImportPath f e = f (envImportPath e) <&> \ x -> e { envImportPath = x }++eMutualBlock :: Lens' TCEnv (Maybe MutualId)+eMutualBlock f e = f (envMutualBlock e) <&> \ x -> e { envMutualBlock = x }++eTerminationCheck :: Lens' TCEnv (TerminationCheck ())+eTerminationCheck f e = f (envTerminationCheck e) <&> \ x -> e { envTerminationCheck = x }++eCoverageCheck :: Lens' TCEnv CoverageCheck+eCoverageCheck f e = f (envCoverageCheck e) <&> \ x -> e { envCoverageCheck = x }++eMakeCase :: Lens' TCEnv Bool+eMakeCase f e = f (envMakeCase e) <&> \ x -> e { envMakeCase = x }++eSolvingConstraints :: Lens' TCEnv Bool+eSolvingConstraints f e = f (envSolvingConstraints e) <&> \ x -> e { envSolvingConstraints = x }++eCheckingWhere :: Lens' TCEnv C.WhereClause_+eCheckingWhere f e = f (envCheckingWhere e) <&> \ x -> e { envCheckingWhere = x }++eWorkingOnTypes :: Lens' TCEnv Bool+eWorkingOnTypes f e = f (envWorkingOnTypes e) <&> \ x -> e { envWorkingOnTypes = x }++eAssignMetas :: Lens' TCEnv Bool+eAssignMetas f e = f (envAssignMetas e) <&> \ x -> e { envAssignMetas = x }++eActiveProblems :: Lens' TCEnv (Set ProblemId)+eActiveProblems f e = f (envActiveProblems e) <&> \ x -> e { envActiveProblems = x }++eAbstractMode :: Lens' TCEnv AbstractMode+eAbstractMode f e = f (envAbstractMode e) <&> \ x -> e { envAbstractMode = x }++eRelevance :: Lens' TCEnv Relevance+eRelevance f e = f (envRelevance e) <&> \x -> e { envRelevance = x }++-- | Note that this lens does not satisfy all lens laws: If hard+-- compile-time mode is enabled, then quantities other than zero are+-- replaced by '__IMPOSSIBLE__'.++eQuantity :: Lens' TCEnv Quantity+eQuantity f e =+  if envHardCompileTimeMode e+  then f (check (envQuantity e)) <&>+       \x -> e { envQuantity = check x }+  else f (envQuantity e) <&> \x -> e { envQuantity = x }+  where+  check q+    | hasQuantity0 q = q+    | otherwise      = __IMPOSSIBLE__++eHardCompileTimeMode :: Lens' TCEnv Bool+eHardCompileTimeMode f e = f (envHardCompileTimeMode e) <&> \x -> e { envHardCompileTimeMode = x }++eSplitOnStrict :: Lens' TCEnv Bool+eSplitOnStrict f e = f (envSplitOnStrict e) <&> \ x -> e { envSplitOnStrict = x }++eDisplayFormsEnabled :: Lens' TCEnv Bool+eDisplayFormsEnabled f e = f (envDisplayFormsEnabled e) <&> \ x -> e { envDisplayFormsEnabled = x }++eFoldLetBindings :: Lens' TCEnv Bool+eFoldLetBindings f e = f (envFoldLetBindings e) <&> \ x -> e { envFoldLetBindings = x }++eRange :: Lens' TCEnv Range+eRange f e = f (envRange e) <&> \ x -> e { envRange = x }++eHighlightingRange :: Lens' TCEnv Range+eHighlightingRange f e = f (envHighlightingRange e) <&> \ x -> e { envHighlightingRange = x }++eCall :: Lens' TCEnv (Maybe (Closure Call))+eCall f e = f (envCall e) <&> \ x -> e { envCall = x }++eHighlightingLevel :: Lens' TCEnv HighlightingLevel+eHighlightingLevel f e = f (envHighlightingLevel e) <&> \ x -> e { envHighlightingLevel = x }++eHighlightingMethod :: Lens' TCEnv HighlightingMethod+eHighlightingMethod f e = f (envHighlightingMethod e) <&> \ x -> e { envHighlightingMethod = x }++eExpandLast :: Lens' TCEnv ExpandHidden+eExpandLast f e = f (envExpandLast e) <&> \ x -> e { envExpandLast = x }++eExpandLastBool :: Lens' TCEnv Bool+eExpandLastBool f e = f (isExpandLast $ envExpandLast e) <&> \ x -> e { envExpandLast = toExpandLast x }++eAppDef :: Lens' TCEnv (Maybe QName)+eAppDef f e = f (envAppDef e) <&> \ x -> e { envAppDef = x }++eSimplification :: Lens' TCEnv Simplification+eSimplification f e = f (envSimplification e) <&> \ x -> e { envSimplification = x }++eAllowedReductions :: Lens' TCEnv AllowedReductions+eAllowedReductions f e = f (envAllowedReductions e) <&> \ x -> e { envAllowedReductions = x }++eReduceDefs :: Lens' TCEnv ReduceDefs+eReduceDefs f e = f (envReduceDefs e) <&> \ x -> e { envReduceDefs = x }++eReduceDefsPair :: Lens' TCEnv (Bool, [QName])+eReduceDefsPair f e = f (fromReduceDefs $ envReduceDefs e) <&> \ x -> e { envReduceDefs = toReduceDefs x }++eReconstructed :: Lens' TCEnv Bool+eReconstructed f e = f (envReconstructed e) <&> \ x -> e { envReconstructed = x }++eInjectivityDepth :: Lens' TCEnv Int+eInjectivityDepth f e = f (envInjectivityDepth e) <&> \ x -> e { envInjectivityDepth = x }++eCompareBlocked :: Lens' TCEnv Bool+eCompareBlocked f e = f (envCompareBlocked e) <&> \ x -> e { envCompareBlocked = x }++ePrintDomainFreePi :: Lens' TCEnv Bool+ePrintDomainFreePi f e = f (envPrintDomainFreePi e) <&> \ x -> e { envPrintDomainFreePi = x }++ePrintMetasBare :: Lens' TCEnv Bool+ePrintMetasBare f e = f (envPrintMetasBare e) <&> \ x -> e { envPrintMetasBare = x }++eInsideDotPattern :: Lens' TCEnv Bool+eInsideDotPattern f e = f (envInsideDotPattern e) <&> \ x -> e { envInsideDotPattern = x }++eUnquoteFlags :: Lens' TCEnv UnquoteFlags+eUnquoteFlags f e = f (envUnquoteFlags e) <&> \ x -> e { envUnquoteFlags = x }++eInstanceDepth :: Lens' TCEnv Int+eInstanceDepth f e = f (envInstanceDepth e) <&> \ x -> e { envInstanceDepth = x }++eIsDebugPrinting :: Lens' TCEnv Bool+eIsDebugPrinting f e = f (envIsDebugPrinting e) <&> \ x -> e { envIsDebugPrinting = x }++ePrintingPatternLambdas :: Lens' TCEnv [QName]+ePrintingPatternLambdas f e = f (envPrintingPatternLambdas e) <&> \ x -> e { envPrintingPatternLambdas = x }++eCallByNeed :: Lens' TCEnv Bool+eCallByNeed f e = f (envCallByNeed e) <&> \ x -> e { envCallByNeed = x }++eCurrentCheckpoint :: Lens' TCEnv CheckpointId+eCurrentCheckpoint f e = f (envCurrentCheckpoint e) <&> \ x -> e { envCurrentCheckpoint = x }++eCheckpoints :: Lens' TCEnv (Map CheckpointId Substitution)+eCheckpoints f e = f (envCheckpoints e) <&> \ x -> e { envCheckpoints = x }++eGeneralizeMetas :: Lens' TCEnv DoGeneralize+eGeneralizeMetas f e = f (envGeneralizeMetas e) <&> \ x -> e { envGeneralizeMetas = x }++eGeneralizedVars :: Lens' TCEnv (Map QName GeneralizedValue)+eGeneralizedVars f e = f (envGeneralizedVars e) <&> \ x -> e { envGeneralizedVars = x }++eActiveBackendName :: Lens' TCEnv (Maybe BackendName)+eActiveBackendName f e = f (envActiveBackendName e) <&> \ x -> e { envActiveBackendName = x }++eConflComputingOverlap :: Lens' TCEnv Bool+eConflComputingOverlap f e = f (envConflComputingOverlap e) <&> \ x -> e { envConflComputingOverlap = x }++eCurrentlyElaborating :: Lens' TCEnv Bool+eCurrentlyElaborating f e = f (envCurrentlyElaborating e) <&> \ x -> e { envCurrentlyElaborating = x }++{-# SPECIALISE currentModality :: TCM Modality #-}+-- | The current modality.+--   Note that the returned cohesion component is always 'unitCohesion'.+currentModality :: MonadTCEnv m => m Modality+currentModality = do+  r <- viewTC eRelevance+  q <- viewTC eQuantity+  return Modality+    { modRelevance = r+    , modPolarity  = defaultPolarity+    , modQuantity  = q+    , modCohesion  = unitCohesion+    }++---------------------------------------------------------------------------+-- ** Let bindings+---------------------------------------------------------------------------++type LetBindings = Map Name (Open LetBinding)++data LetBinding = LetBinding { letOrigin :: Origin+                             , letTerm   :: Term+                             , letType   :: Dom Type+                             }+  deriving (Show, Generic)++onLetBindingType :: (Dom Type -> Dom Type) -> LetBinding -> LetBinding+onLetBindingType f b = b { letType = f $ letType b }++---------------------------------------------------------------------------+-- ** Abstract mode+---------------------------------------------------------------------------++data AbstractMode+  = AbstractMode        -- ^ Abstract things in the current module can be accessed.+  | ConcreteMode        -- ^ No abstract things can be accessed.+  | IgnoreAbstractMode  -- ^ All abstract things can be accessed.+  deriving (Show, Eq, Generic)++aDefToMode :: IsAbstract -> AbstractMode+aDefToMode AbstractDef = AbstractMode+aDefToMode ConcreteDef = ConcreteMode++aModeToDef :: AbstractMode -> Maybe IsAbstract+aModeToDef AbstractMode = Just AbstractDef+aModeToDef ConcreteMode = Just ConcreteDef+aModeToDef _ = Nothing++---------------------------------------------------------------------------+-- ** Opaque blocks+---------------------------------------------------------------------------++-- | A block of opaque definitions.+data OpaqueBlock = OpaqueBlock+  { opaqueId        :: {-# UNPACK #-} !OpaqueId+    -- ^ Unique identifier for this block.+  , opaqueUnfolding :: HashSet QName+    -- ^ Set of names we are allowed to unfold. After scope-checking,+    -- this set should be transitively closed.+  , opaqueDecls     :: HashSet QName+    -- ^ Declarations contained in this abstract block.+  , opaqueParent    :: Maybe OpaqueId+    -- ^ Pointer to an enclosing opaque block, if one exists.+  , opaqueRange     :: Range+    -- ^ Where is this opaque block?+  } deriving (Show, Generic)++instance Pretty OpaqueBlock where+  pretty (OpaqueBlock _ uf ds p _) = vcat+    $ [ "opaque (extends " <> pretty p <> ") {"+      , nest 2 "unfolds"+      ]+    ++ [ nest 4 (pretty n <> ",") | n <- List.sort $ HashSet.toList uf ]+         -- Andreas, 2023-08-10, https://github.com/agda/agda/pull/6628#discussion_r1285078454+         -- The HashSet.toList is non-deterministic, order may depend on version of @hashable@.+         -- Thus, we sort the list, so that the output isn't dependent on the specific build.+    ++ [ nest 2 "declares" ]+    ++ [ nest 4 (pretty n <+> ": _") | n <- List.sort $ HashSet.toList ds ]+    ++ [ "}" ]++instance Eq OpaqueBlock where+  xs == ys = opaqueId xs == opaqueId ys++instance Hashable OpaqueBlock where+  hashWithSalt s = hashWithSalt s . opaqueId++---------------------------------------------------------------------------+-- ** Insertion of implicit arguments+---------------------------------------------------------------------------++data ExpandHidden+  = ExpandLast      -- ^ Add implicit arguments in the end until type is no longer hidden 'Pi'.+  | DontExpandLast  -- ^ Do not append implicit arguments.+  | ReallyDontExpandLast -- ^ Makes 'doExpandLast' have no effect. Used to avoid implicit insertion of arguments to metavariables.+  deriving (Eq, Generic)++isExpandLast :: ExpandHidden -> Bool+isExpandLast ExpandLast           = True+isExpandLast DontExpandLast       = False+isExpandLast ReallyDontExpandLast = False++isDontExpandLast :: ExpandHidden -> Bool+isDontExpandLast = not . isExpandLast++toExpandLast :: Bool -> ExpandHidden+toExpandLast True  = ExpandLast+toExpandLast False = DontExpandLast++data CandidateKind+  = LocalCandidate+  | GlobalCandidate QName+  deriving (Show, Generic)++-- | A candidate solution for an instance meta is a term with its type.+--   It may be the case that the candidate is not fully applied yet or+--   of the wrong type, hence the need for the type.+data Candidate  = Candidate+  { candidateKind    :: CandidateKind+  , candidateTerm    :: Term+  , candidateType    :: Type+  , candidateOverlap :: OverlapMode+  }+  deriving (Show, Generic)++instance Free Candidate where+  freeVars' (Candidate _ t u _) = freeVars' (t, u)++instance HasOverlapMode Candidate where+  lensOverlapMode f x = f (candidateOverlap x) <&> \m -> x{ candidateOverlap = m }++---------------------------------------------------------------------------+-- ** Checking arguments+---------------------------------------------------------------------------++data CheckedArg = CheckedArg+  { caElim        :: Elim+      -- ^ Checked and inserted argument.+  , caRange       :: Maybe Range+      -- ^ Range of checked argument, where present.+      --   E.g. inserted implicits have no correponding abstract syntax.+  , caConstraint  :: Maybe (Abs Constraint)+      -- ^ Head constraint before applying the argument.+  }+  deriving Show++data ArgsCheckState a = ACState+  { acCheckedArgs :: [CheckedArg]+      -- ^ Checked and inserted arguments so far.+  , acFun         :: A.Expr+      -- ^ The function applied to the already checked arguments.+  , acType        :: Type+      -- ^ Type of the function (for checking the remaining arguments).+  , acData        :: a+  }+  deriving Show++---------------------------------------------------------------------------+-- * Type checking warnings (aka non-fatal errors)+---------------------------------------------------------------------------++-- | A non-fatal error is an error which does not prevent us from+-- checking the document further and interacting with the user.++data Warning+  = NicifierIssue            DeclarationWarning+  | TerminationIssue         (List1 TerminationError)+  | UnreachableClauses       QName (List1 Range)+  -- ^ @UnreachableClauses f rs@ means that the clauses in @f@ whose ranges are @rs@+  --   are unreachable.+  | CoverageIssue            QName (List1 (Telescope, [NamedArg DeBruijnPattern]))+  -- ^ `CoverageIssue f pss` means that `pss` are not covered in `f`+  | CoverageNoExactSplit     QName (List1 Clause)+  | InlineNoExactSplit       QName Clause+    -- ^ 'Clause' was turned into copattern matching clause(s) by an @{-# INLINE constructor #-}@+    --   and thus is not a definitional equality any more.+  | NotStrictlyPositive      QName (Seq OccursWhere)+  | ConstructorDoesNotFitInData DataOrRecord_ QName Sort Sort TCErr+      -- ^ Checking whether constructor 'QName' 'Sort' fits into @data@ 'Sort'+      --   produced 'TCErr'.+  | CoinductiveEtaRecord QName+      -- ^ A record type declared as both @coinductive@ and having @eta-equality@.++  | UnsolvedMetaVariables    (Set1 Range)  -- ^ Do not use directly with 'warning'+  | UnsolvedInteractionMetas (Set1 Range)  -- ^ Do not use directly with 'warning'+  | UnsolvedConstraints      (List1 ProblemConstraint)  -- no instance Ord ProblemConstraint+    -- ^ Do not use directly with 'warning'+  | InteractionMetaBoundaries (Set1 Range)+    -- ^ Do not use directly with 'warning'++  | CantGeneralizeOverSorts (Set1 MetaId)+  | AbsurdPatternRequiresAbsentRHS+  | OldBuiltin               BuiltinId BuiltinId+    -- ^ In `OldBuiltin old new`, the BUILTIN old has been replaced by new.+  | BuiltinDeclaresIdentifier BuiltinId+    -- ^ The builtin declares a new identifier, so it should not be in scope.+  | DuplicateRecordDirective C.RecordDirective+    -- ^ The given record directive is conflicting with a prior one in the same record declaration.+  | EmptyRewritePragma+    -- ^ If the user wrote just @{-\# REWRITE \#-}@.+  | EmptyWhere+    -- ^ An empty @where@ block is dead code.+  -- TODO: linearity+  -- -- | FixingQuantity String Quantity Quantity+  -- --   -- ^ Auto-correcting quantity pertaining to 'String' /from/ /to/.+  | FixingRelevance String Relevance Relevance+    -- ^ Auto-correcting relevance pertaining to 'String' /from/ /to/.+  | FixingCohesion String Cohesion Cohesion+    -- ^ Auto-correcting cohesion pertaining to 'String' /from/ /to/.+  | FixingPolarity String PolarityModality PolarityModality+    -- ^ Auto-correcting polarity pertaining to 'String' /from/ /to/.+  | IllformedAsClause String+    -- ^ If the user wrote something other than an unqualified name+    --   in the @as@ clause of an @import@ statement.+    --   The 'String' gives optionally extra explanation.+  | InvalidCharacterLiteral Char+    -- ^ A character literal Agda does not support, e.g. surrogate code points.+  | ClashesViaRenaming NameOrModule (Set1 C.Name)+    -- ^ If a `renaming' import directive introduces a name or module name clash+    --   in the exported names of a module.+    --   (See issue #4154.)+  | UselessPatternDeclarationForRecord String+    -- ^ The 'pattern' declaration is useless in the presence+    --   of either @coinductive@ or @eta-equality@.+    --   Content of 'String' is "coinductive" or "eta", resp.+  | UselessPragma Range Doc+    -- ^ Warning when pragma is useless and thus ignored.+    --   'Range' is for dead code highlighting.+  | UselessPublic UselessPublicReason+    -- ^ If the user opens a module public before the module header.+    --   (See issue #2377.)+  | UselessHiding (List1 C.ImportedName)+    -- ^ Names in `hiding` directive that don't hide anything+    --   imported by a `using` directive.+  | UselessInline            QName+  | UselessTactic+    -- ^ A tactic attribute applied to a non-hidden (visible or instance) argument.+  | WrongInstanceDeclaration+  | InstanceWithExplicitArg  QName+  -- ^ An instance was declared with an implicit argument, which means it+  --   will never actually be considered by instance search.+  | InstanceNoOutputTypeName Doc+  -- ^ The type of an instance argument doesn't end in a named or+  -- variable type, so it will never be considered by instance search.+  | InstanceArgWithExplicitArg Doc+  -- ^ As InstanceWithExplicitArg, but for local bindings rather than+  --   top-level instances.+  | InversionDepthReached    QName+  -- ^ The --inversion-max-depth was reached.++  -- Safe flag errors+  | SafeFlagPostulate QName+  | SafeFlagPragma (Set String)+      -- ^ Unsafe OPTIONS.+  | SafeFlagWithoutKFlagPrimEraseEquality+  | WithoutKFlagPrimEraseEquality+  | ConflictingPragmaOptions String String+    -- ^ `ConflictingPragmaOptions a b`:+    --   Inconsistent options `--a` and `--no-b`, since `--a` implies `--b`. Ignoring `--no-b`.+  | OptionWarning            OptionWarning+  | ParseWarning             ParseWarning+  | LibraryWarning           LibWarning+  | DeprecationWarning String String String+    -- ^ `DeprecationWarning old new version`:+    --   `old` is deprecated, use `new` instead. This will be an error in Agda `version`.+  | UserWarning Text+    -- ^ User-defined warning (e.g. to mention that a name is deprecated)+  | DuplicateUsing (List1 C.ImportedName)+    -- ^ Duplicate mentions of the same name in @using@ directive(s).+  | FixityInRenamingModule (List1 Range)+    -- ^ Fixity of modules cannot be changed via renaming (since modules have no fixity).+  | ModuleDoesntExport C.QName [C.Name] [C.Name] (List1 C.ImportedName)+    -- ^ Some imported names are not actually exported by the source module.+    --   The second argument is the names that could be exported.+    --   The third  argument is the module names that could be exported.+  | InfectiveImport Doc+    -- ^ Importing a file using an infective option into one which doesn't+  | CoInfectiveImport Doc+    -- ^ Importing a file not using a coinfective option from one which does+  | ConfluenceCheckingIncompleteBecauseOfMeta QName+    -- ^ Confluence checking incomplete because the definition of the 'QName'+    --   contains unsolved metavariables.+  | ConfluenceForCubicalNotSupported+    -- ^ Confluence checking with @--cubical@ might be incomplete.+  | NotARewriteRule C.QName IsAmbiguous+    -- ^ 'IllegalRewriteRule' detected during scope checking.+  | IllegalRewriteRule QName IllegalRewriteRuleReason+  | RewriteNonConfluent Term Term Term Doc+    -- ^ Confluence checker found critical pair and equality checking+    --   resulted in a type error+  | RewriteMaybeNonConfluent Term Term [Doc]+    -- ^ Confluence checker got stuck on computing overlap between two+    --   rewrite rules+  | RewriteAmbiguousRules Term Term Term+    -- ^ The global confluence checker found a term @u@ that reduces+    --   to both @v1@ and @v2@ and there is no rule to resolve the+    --   ambiguity.+  | RewriteMissingRule Term Term Term+    -- ^ The global confluence checker found a term @u@ that reduces+    --   to @v@, but @v@ does not reduce to @rho(u)@.+  | PragmaCompileErased BackendName QName+    -- ^ COMPILE directive for an erased symbol.+  | PragmaCompileList+    -- ^ @COMPILE GHC@ pragma for lists; ignored.+  | PragmaCompileMaybe+    -- ^ @COMPILE GHC@ pragma for @MAYBE@; ignored.+  | PragmaCompileUnparsable String+    -- ^ @COMPILE GHC@ pragma 'String' not parsable; ignored.+  | PragmaCompileWrong QName String+    -- ^ Wrong @COMPILE GHC@ given for 'QName'; explanation is in 'String'.+  | PragmaCompileWrongName C.QName IsAmbiguous+    -- ^ @COMPILE@ pragma with name 'C.QName' that is not an unambiguous constructor or definition.+  | PragmaExpectsDefinedSymbol String C.QName+    -- ^ Pragma 'String' with name 'C.QName' that is not an 'A.Def'.+  | PragmaExpectsUnambiguousConstructorOrFunction String C.QName IsAmbiguous+    -- ^ Pragma 'String' with name 'C.QName' that is not an unambiguous constructor or definition.+    --   General form of 'PragmaCompileWrongName' and 'NotARewriteRule'.+  | PragmaExpectsUnambiguousProjectionOrFunction String C.QName IsAmbiguous+    -- ^ Pragma 'String' with name 'C.QName' that is not an unambiguous projection or function.+  | NoMain TopLevelModuleName+    -- ^ Compiler run on module that does not have a @main@ function.+  | NotInScopeW C.QName+    -- ^ Out of scope error we can recover from.+  | UnsupportedIndexedMatch Doc+    -- ^ Was not able to compute a full equivalence when splitting.+  | AsPatternShadowsConstructorOrPatternSynonym ConstructorOrPatternSynonym+    -- ^ The as-name in an as-pattern may not shadow a constructor+    --   or pattern synonym name,+    --   because this can be confusing to read.+  | PatternShadowsConstructor C.Name A.QName+    -- ^ A pattern variable has the name of a constructor+    --   (data constructor or matchable record constructor).+  | PlentyInHardCompileTimeMode QωOrigin+    -- ^ Explicit use of @@ω@ or @@plenty@ in hard compile-time mode.+  | RecordFieldWarning RecordFieldWarning++  -- Opaque+  | MissingTypeSignatureForOpaque QName IsOpaque+    -- ^ An @abstract@ or @opaque@ definition lacks a type signature.+  | NotAffectedByOpaque+  | UnfoldingWrongName C.QName+      -- ^ Name in @unfolding@ clause does not resolve to unambiguous defined name.+  | UnfoldTransparentName QName+  | UselessOpaque++  -- Recoverable scope-checking errors+  | HiddenNotInArgumentPosition C.Expr+  | InstanceNotInArgumentPosition C.Expr+  | MacroInLetBindings+  | AbstractInLetBindings++  -- Display form warnings+  | InvalidDisplayForm QName String+      -- ^ DISPLAY form for 'QName' is invalid because 'String'.+  | UnusedVariablesInDisplayForm (List1 A.Name)+      -- ^ The given names are bound in the lhs of the display form+      --   but not used on the rhs.+      --   This can indicate a user misunderstanding of display forms.++  -- Type checker warnings+  | TooManyArgumentsToSort QName (List1 (NamedArg A.Expr))+      -- ^ Extra arguments to sort (will be ignored).+  | RewritesNothing+      -- ^ A @rewrite@ expression that does not fire.+  | WithClauseProjectionFixityMismatch+    { withClausePattern          :: NamedArg A.Pattern+    , withClauseProjectionOrigin :: ProjOrigin+    , parentPattern              :: NamedArg DeBruijnPattern+    , parentProjectionOrigin     :: ProjOrigin+    }+    -- ^ The with-clause uses projection in a different fixity style+    --   than the parent clause.++  -- Polarity warnings+  | TooManyPolarities QName PragmaPolarities+    -- ^ Too many polarities given in POLARITY pragma for 'QName'.+    --   'PragmaPolarities' contains the (likely) excessive polarities.+  | TopLevelPolarity QName PolarityModality+    -- ^ Definition with non-default polarity annotation.++  -- Cubical+  | FaceConstraintCannotBeHidden ArgInfo+    -- ^ Face constraint patterns @(i = 0)@ must be visible arguments.+  | FaceConstraintCannotBeNamed NamedName+    -- ^ Face constraint patterns @(i = 0)@ must be unnamed arguments.++  -- Not source code related+  | CustomBackendWarning String Doc+    -- ^ Used for backend-specific warnings. The string is the backend name.+  deriving (Show, Generic)++recordFieldWarningToError :: RecordFieldWarning -> TypeError+recordFieldWarningToError = \case+  W.DuplicateFields    xrs -> DuplicateFields    $ fmap fst xrs+  W.TooManyFields q ys xrs -> TooManyFields q ys $ fmap fst xrs++warningName :: Warning -> WarningName+warningName = \case+  -- special cases+  NicifierIssue dw             -> declarationWarningName dw+  OptionWarning ow             -> optionWarningName ow+  ParseWarning pw              -> parseWarningName pw+  LibraryWarning lw            -> libraryWarningName lw+  -- scope- and type-checking errors+  AsPatternShadowsConstructorOrPatternSynonym{} -> AsPatternShadowsConstructorOrPatternSynonym_+  PatternShadowsConstructor{}  -> PatternShadowsConstructor_+  AbsurdPatternRequiresAbsentRHS{} -> AbsurdPatternRequiresAbsentRHS_+  CantGeneralizeOverSorts{}    -> CantGeneralizeOverSorts_+  CoverageIssue{}              -> CoverageIssue_+  CoverageNoExactSplit{}       -> CoverageNoExactSplit_+  InlineNoExactSplit{}         -> InlineNoExactSplit_+  DeprecationWarning{}         -> DeprecationWarning_+  DuplicateRecordDirective{}   -> DuplicateRecordDirective_+  EmptyRewritePragma           -> EmptyRewritePragma_+  EmptyWhere                   -> EmptyWhere_+  -- TODO: linearity+  -- FixingQuantity{}             -> FixingQuantity_+  FixingRelevance{}            -> FixingRelevance_+  FixingCohesion{}             -> FixingCohesion_+  FixingPolarity{}             -> FixingPolarity_+  IllformedAsClause{}          -> IllformedAsClause_+  WrongInstanceDeclaration{}   -> WrongInstanceDeclaration_+  InstanceWithExplicitArg{}    -> InstanceWithExplicitArg_+  InstanceNoOutputTypeName{}   -> InstanceNoOutputTypeName_+  InstanceArgWithExplicitArg{} -> InstanceArgWithExplicitArg_+  DuplicateUsing{}             -> DuplicateUsing_+  FixityInRenamingModule{}     -> FixityInRenamingModule_+  InvalidCharacterLiteral{}    -> InvalidCharacterLiteral_+  UselessPragma{}              -> UselessPragma_+  InversionDepthReached{}      -> InversionDepthReached_+  InteractionMetaBoundaries{}  -> InteractionMetaBoundaries_{}+  ModuleDoesntExport{}         -> ModuleDoesntExport_+  NotInScopeW{}                -> NotInScope_+  NotStrictlyPositive{}        -> NotStrictlyPositive_+  ConstructorDoesNotFitInData{}-> ConstructorDoesNotFitInData_+  CoinductiveEtaRecord{}       -> CoinductiveEtaRecord_+  UnsupportedIndexedMatch{}    -> UnsupportedIndexedMatch_+  OldBuiltin{}                 -> OldBuiltin_+  BuiltinDeclaresIdentifier{}  -> BuiltinDeclaresIdentifier_+  SafeFlagPostulate{}          -> SafeFlagPostulate_+  SafeFlagPragma{}             -> SafeFlagPragma_+  SafeFlagWithoutKFlagPrimEraseEquality -> SafeFlagWithoutKFlagPrimEraseEquality_+  ConflictingPragmaOptions{}   -> ConflictingPragmaOptions_+  WithoutKFlagPrimEraseEquality -> WithoutKFlagPrimEraseEquality_+  TerminationIssue{}           -> TerminationIssue_+  UnreachableClauses{}         -> UnreachableClauses_+  UnsolvedInteractionMetas{}   -> UnsolvedInteractionMetas_+  UnsolvedConstraints{}        -> UnsolvedConstraints_+  UnsolvedMetaVariables{}      -> UnsolvedMetaVariables_+  UselessHiding{}              -> UselessHiding_+  UselessInline{}              -> UselessInline_+  UselessPublic{}              -> UselessPublic_+  UselessPatternDeclarationForRecord{} -> UselessPatternDeclarationForRecord_+  UselessTactic{}              -> UselessTactic_+  ClashesViaRenaming{}         -> ClashesViaRenaming_+  UserWarning{}                -> UserWarning_+  InfectiveImport{}            -> InfectiveImport_+  CoInfectiveImport{}          -> CoInfectiveImport_+  ConfluenceCheckingIncompleteBecauseOfMeta{} -> ConfluenceCheckingIncompleteBecauseOfMeta_+  ConfluenceForCubicalNotSupported{}          -> ConfluenceForCubicalNotSupported_+  IllegalRewriteRule _ reason  -> illegalRewriteWarningName reason+  NotARewriteRule{}            -> NotARewriteRule_+  RewriteNonConfluent{}        -> RewriteNonConfluent_+  RewriteMaybeNonConfluent{}   -> RewriteMaybeNonConfluent_+  RewriteAmbiguousRules{}      -> RewriteAmbiguousRules_+  RewriteMissingRule{}         -> RewriteMissingRule_+  PragmaCompileErased{}        -> PragmaCompileErased_+  PragmaCompileList{}          -> PragmaCompileList_+  PragmaCompileMaybe{}         -> PragmaCompileMaybe_+  PragmaCompileUnparsable{}    -> PragmaCompileUnparsable_+  PragmaCompileWrong{}         -> PragmaCompileWrong_+  PragmaCompileWrongName{}     -> PragmaCompileWrongName_+  PragmaExpectsDefinedSymbol{} -> PragmaExpectsDefinedSymbol_+  PragmaExpectsUnambiguousConstructorOrFunction{} ->+    PragmaExpectsUnambiguousConstructorOrFunction_+  PragmaExpectsUnambiguousProjectionOrFunction{} ->+    PragmaExpectsUnambiguousProjectionOrFunction_+  NoMain{}                     -> NoMain_+  PlentyInHardCompileTimeMode{}+                               -> PlentyInHardCompileTimeMode_+  -- record field warnings+  RecordFieldWarning w -> case w of+    W.DuplicateFields{}   -> DuplicateFields_+    W.TooManyFields{}     -> TooManyFields_++  -- opaque warnings+  MissingTypeSignatureForOpaque{} -> MissingTypeSignatureForOpaque_+  NotAffectedByOpaque{}   -> NotAffectedByOpaque_+  UselessOpaque{}         -> UselessOpaque_+  UnfoldingWrongName{}    -> UnfoldingWrongName_+  UnfoldTransparentName{} -> UnfoldTransparentName_++  -- Recoverable scope-checking errors+  HiddenNotInArgumentPosition{}   -> HiddenNotInArgumentPosition_+  InstanceNotInArgumentPosition{} -> InstanceNotInArgumentPosition_+  MacroInLetBindings{}            -> MacroInLetBindings_+  AbstractInLetBindings{}         -> AbstractInLetBindings_++  -- Display forms+  InvalidDisplayForm{}                 -> InvalidDisplayForm_+  UnusedVariablesInDisplayForm{}       -> UnusedVariablesInDisplayForm_++  -- Type checking+  TooManyArgumentsToSort{}             -> TooManyArgumentsToSort_+  RewritesNothing{}                    -> RewritesNothing_+  WithClauseProjectionFixityMismatch{} -> WithClauseProjectionFixityMismatch_++  -- Polarities+  TooManyPolarities{}                  -> TooManyPolarities_+  TopLevelPolarity{}                   -> TopLevelPolarity_++  -- Cubical+  FaceConstraintCannotBeHidden{} -> FaceConstraintCannotBeHidden_+  FaceConstraintCannotBeNamed{}  -> FaceConstraintCannotBeNamed_++  -- Backend warnings+  CustomBackendWarning{} -> CustomBackendWarning_++illegalRewriteWarningName :: IllegalRewriteRuleReason -> WarningName+illegalRewriteWarningName = \case+  LHSNotDefinitionOrConstructor{}      -> RewriteLHSNotDefinitionOrConstructor_+  VariablesNotBoundByLHS{}             -> RewriteVariablesNotBoundByLHS_+  VariablesBoundMoreThanOnce{}         -> RewriteVariablesBoundMoreThanOnce_+  LHSReduces{}                         -> RewriteLHSReduces_+  HeadSymbolIsProjectionLikeFunction{} -> RewriteHeadSymbolIsProjectionLikeFunction_+  HeadSymbolIsTypeConstructor{}        -> RewriteHeadSymbolIsTypeConstructor_+  HeadSymbolContainsMetas{}            -> RewriteHeadSymbolContainsMetas_+  ConstructorParametersNotGeneral{}    -> RewriteConstructorParametersNotGeneral_+  ContainsUnsolvedMetaVariables{}      -> RewriteContainsUnsolvedMetaVariables_+  BlockedOnProblems{}                  -> RewriteBlockedOnProblems_+  RequiresDefinitions{}                -> RewriteRequiresDefinitions_+  DoesNotTargetRewriteRelation         -> RewriteDoesNotTargetRewriteRelation_+  BeforeFunctionDefinition             -> RewriteBeforeFunctionDefinition_+  BeforeMutualFunctionDefinition{}     -> RewriteBeforeMutualFunctionDefinition_+  DuplicateRewriteRule                 -> DuplicateRewriteRule_++-- | Should warnings of that type be serialized?+--+-- Only when changes in the source code can silence or influence the warning.+--+isSourceCodeWarning :: WarningName -> Bool+isSourceCodeWarning = \case+  WarningProblem_ -> False+  _ -> True++data TCWarning+  = TCWarning+    { tcWarningLocation :: CallStack+        -- ^ Location in the internal Agda source code location where the error raised+    , tcWarningRange    :: Range+        -- ^ Range where the warning was raised+    , tcWarning         :: Warning+        -- ^ The warning itself+    , tcWarningDoc      :: Doc+        -- ^ The warning printed in the state and environment where it was raised+    , tcWarningString   :: String+        -- ^ Caches @render tcWarningDoc@ for the sake of an 'Ord' instance.+    , tcWarningCached :: Bool+        -- ^ Should the warning be affected by caching.+    }+  deriving (Show, Generic)++tcWarningOrigin :: TCWarning -> SrcFile+tcWarningOrigin = rangeFile . tcWarningRange++instance HasRange TCWarning where+  getRange = tcWarningRange++instance Eq TCWarning where+  (==) = (==) `on` tcWarningRange &&& tcWarningString++instance Ord TCWarning where+  compare = compare `on` tcWarningRange &&& tcWarningString++---------------------------------------------------------------------------+-- * Type checking errors+---------------------------------------------------------------------------++-- | Information about a call.++data CallInfo = CallInfo+  { callInfoTarget :: QName+    -- ^ Target function name.  (Contains its range.)+  , callInfoCall :: Closure Term+    -- ^ To be formatted representation of the call.+  } deriving (Show, Generic)+    -- no Eq, Ord instances: too expensive! (see issues 851, 852)++instance HasRange CallInfo where+  getRange = getRange . callInfoTarget++-- | We only 'show' the name of the callee.+instance Pretty CallInfo where pretty = pretty . callInfoTarget++-- | Information about a mutual block which did not pass the+-- termination checker.++data TerminationError = TerminationError+  { termErrFunctions :: [QName]+    -- ^ The functions which failed to check. (May not include+    -- automatically generated functions.)+  , termErrCalls :: [CallInfo]+    -- ^ The problematic call sites.+  , termErrGuardednessHelps :: GuardednessHelps+    -- ^ Is the termination error resolved by activating @--guardedness@?+  } deriving (Show, Generic)++-- | Error when splitting a pattern variable into possible constructor patterns.+data SplitError+  = NotADatatype        (Closure Type)  -- ^ Neither data type nor record.+  | BlockedType Blocker (Closure Type)  -- ^ Type could not be sufficiently reduced.+  | ErasedDatatype ErasedDatatypeReason (Closure Type)+                                        -- ^ Data type, but in erased position.+  | CoinductiveDatatype (Closure Type)  -- ^ Split on codata not allowed.+  -- UNUSED, but keep!+  -- -- | NoRecordConstructor Type  -- ^ record type, but no constructor+  | UnificationStuck+    { cantSplitBlocker  :: Maybe Blocker -- ^ Blocking metavariable (if any)+    , cantSplitConName  :: QName        -- ^ Constructor.+    , cantSplitTel      :: Telescope    -- ^ Context for indices.+    , cantSplitConIdx   :: Args         -- ^ Inferred indices (from type of constructor).+    , cantSplitGivenIdx :: Args         -- ^ Expected indices (from checking pattern).+    , cantSplitFailures :: [UnificationFailure] -- ^ Reason(s) why unification got stuck.+    }+  | CosplitCatchall+      -- ^ Copattern split with a catchall+  | CosplitNoTarget+      -- ^ We do not know the target type of the clause.+  | CosplitNoRecordType (Closure Type)+      -- ^ Target type is not a record type.+  | CannotCreateMissingClause QName (Telescope,[NamedArg DeBruijnPattern]) Doc (Closure (Abs Type))++  | GenericSplitError String+  deriving (Show, Generic)++data NegativeUnification+  = UnifyConflict Telescope Term Term+  | UnifyCycle Telescope Int Term+  deriving (Show, Generic)++data UnificationFailure+  = UnifyIndicesNotVars Telescope Type Term Term Args -- ^ Failed to apply injectivity to constructor of indexed datatype+  | UnifyRecursiveEq Telescope Type Int Term          -- ^ Can't solve equation because variable occurs in (type of) lhs+  | UnifyReflexiveEq Telescope Type Term              -- ^ Can't solve reflexive equation because --without-K is enabled+  | UnifyUnusableModality Telescope Type Int Term Modality  -- ^ Can't solve equation because solution modality is less "usable"+  deriving (Show, Generic)++data UnquoteError+  = BlockedOnMeta TCState Blocker+  | CannotDeclareHiddenFunction QName+      -- ^ Attempt to @unquoteDecl@ with 'Hiding' other than 'NotHidden'.+  | CommitAfterDef+  | ConInsteadOfDef QName String String+  | DefineDataNotData QName+  | DefInsteadOfCon QName String String+  | MissingDeclaration QName+  | MissingDefinition QName+  | NakedUnquote+  | NonCanonical String I.Term+  | PatLamWithoutClauses I.Term+  | StaleMeta TopLevelModuleName MetaId+      -- ^ Attempt to unquote a serialized meta.+  | TooManyParameters Nat A.Expr+      -- ^ Attempt to shave of 'Nat' many parameters from function type 'A.Expr'.+  | UnboundName QName+  deriving (Show, Generic)++-- | Error when trying to call an external executable during reflection.+data ExecError+  = ExeNotTrusted ExeName ExeMap+      -- ^ The given executable is not listed as trusted.+  | ExeNotFound ExeName FilePath+      -- ^ The given executable could not be found under the given path.+  | ExeNotExecutable ExeName FilePath+      -- ^ The given file path does not have executable permissions.+  deriving (Show, Generic)++data TypeError+        = InternalError String+        | NotImplemented String+        | NotSupported String+        | CompilationError String+        | SyntaxError String+             -- ^ Essential syntax error thrown after successful parsing.+             --   Description in 'String'.+        | OptionError OptionError+             -- ^ Error thrown by the option parser.+        | NicifierError DeclarationException'+             -- ^ Error thrown in the nicifier phase 'Agda.Syntax.Concrete.Definitions'.+        | DoNotationError String+             -- ^ Error during unsugaring some @do@ notation.+             --   Error message in 'String'.+        | IdiomBracketError String+             -- ^ Error during (operator) parsing and interpreting the contents of idiom brackets.+             --   Error message in 'String'.+        | NoKnownRecordWithSuchFields [C.Name]+            -- ^ The user has given a record expression with the given fields,+            --   but no record type known to type inference has all these fields.+            --   The list can be empty.+        | ShouldEndInApplicationOfTheDatatype Type+            -- ^ The target of a constructor isn't an application of its+            -- datatype. The 'Type' records what it does target.+        | ConstructorPatternInWrongDatatype QName QName -- ^ constructor, datatype+        | CantResolveOverloadedConstructorsTargetingSameDatatype QName (List1 QName)+          -- ^ Datatype, constructors.+        | ConstructorDoesNotTargetGivenType QName Type -- ^ constructor, type+        | InvalidDottedExpression+            -- ^ @.e@ in non-argument position.+        | LiteralTooBig+            -- ^ An integer literal that would be too costly to expand to unary.+        | NegativeLiteralInPattern+            -- ^ Negative literals are not supported in patterns.+        | WrongHidingInLHS+            -- ^ The left hand side of a function definition has a hidden argument+            --   where a non-hidden was expected.+        | WrongHidingInLambda Type+            -- ^ Expected a non-hidden function and found a hidden lambda.+        | WrongHidingInApplication Type+            -- ^ A function is applied to a hidden argument where a non-hidden was expected.+        | WrongHidingInProjection QName+        | IllegalHidingInPostfixProjection (NamedArg C.Expr)+        | WrongNamedArgument (NamedArg A.Expr) (List1 NamedName)+            -- ^ A function is applied to a hidden named argument it does not have.+            -- The list contains names of possible hidden arguments at this point.+        | WrongAnnotationInLambda+            -- ^ Wrong user-given (lock/tick) annotation in lambda.+        | WrongIrrelevanceInLambda+            -- ^ Wrong user-given relevance annotation in lambda.+        | WrongQuantityInLambda+            -- ^ Wrong user-given quantity annotation in lambda.+        | WrongCohesionInLambda+            -- ^ Wrong user-given cohesion annotation in lambda.+        | WrongPolarityInLambda+            -- ^ Wrong user-given polarity annotation in lambda.+        | QuantityMismatch Quantity Quantity+            -- ^ The given quantity does not correspond to the expected quantity.+        | HidingMismatch Hiding Hiding+            -- ^ The given hiding does not correspond to the expected hiding.+        | RelevanceMismatch Relevance Relevance+            -- ^ The given relevance does not correspond to the expected relevance.+        | ForcedConstructorNotInstantiated A.Pattern+        | IllformedProjectionPatternAbstract A.Pattern+        | IllformedProjectionPatternConcrete C.Pattern+        | CannotEliminateWithPattern (Maybe Blocker) (NamedArg A.Pattern) Type+        | CannotEliminateWithProjection (Arg Type) Bool QName+        | WrongNumberOfConstructorArguments QName Nat Nat+        | ShouldBeEmpty Type [DeBruijnPattern]+            -- ^ Type should be empty. The list gives possible patterns that match, but can be empty.+        | ShouldBeASort Type+            -- ^ The given type should have been a sort.+        | ShouldBePi Type+            -- ^ The given type should have been a pi.+        | ShouldBePath Type+        | ShouldBeRecordType Type+        | ShouldBeRecordPattern DeBruijnPattern+        | CannotApply A.Expr Type+            -- ^ The given expression is used as a function+            --   but its type is not a function type.+        | InvalidTypeSort Sort+            -- ^ This sort is not a type expression.+        | SplitOnCoinductive+        | SplitOnIrrelevant (Dom Type)+        | SplitOnUnusableCohesion (Dom Type)+        | SplitOnUnusablePolarity (Dom Type)+        -- UNUSED: -- | SplitOnErased (Dom Type)+        | SplitOnNonVariable Term Type+        | SplitOnNonEtaRecord QName+        | SplitOnAbstract QName+        | SplitOnUnchecked QName+        | SplitOnPartial (Dom Type)+        | SplitInProp DataOrRecordE+        | DefinitionIsIrrelevant QName+        | DefinitionIsErased QName+        | ProjectionIsIrrelevant QName+        | VariableIsIrrelevant Name+        | VariableIsErased Name+        | VariableIsOfUnusableCohesion Name Cohesion+        | LambdaIsErased+        | RecordIsErased+        | InvalidModalTelescopeUse Term Modality Modality Definition+        | VariableIsOfUnusablePolarity Name PolarityModality+        | UnequalLevel Comparison Level Level+        | UnequalTerms Comparison Term Term CompareAs+        | UnequalRelevance Comparison Term Term+            -- ^ The two function types have different relevance.+        | UnequalQuantity Comparison Term Term+            -- ^ The two function types have different relevance.+        | UnequalCohesion Comparison Term Term+            -- ^ The two function types have different cohesion.+        | UnequalPolarity Comparison Term Term+            -- ^ The two function types have different polarity.+        | UnequalFiniteness Comparison Term Term+            -- ^ One of the function types has a finite domain (i.e. is a @Partia@l@) and the other isonot.+        | UnequalHiding Term Term+            -- ^ The two function types have different hiding.+        | UnequalSorts Sort Sort+        | NotLeqSort Sort Sort+        | MetaCannotDependOn MetaId Term Nat+            -- ^ The arguments are the meta variable, the proposed solution,+            --   and the parameter that it wants to depend on.+        | MetaIrrelevantSolution MetaId Term+            -- ^ When solving @'MetaId' ... := 'Term'@,+            --   part of the 'Term' is invalid as it was created in an irrelevant context.+        | MetaErasedSolution MetaId Term+            -- ^ When solving @'MetaId' ... := 'Term'@,+            --   part of the 'Term' is invalid as it was created in an erased context.+        | GenericError String+        | GenericDocError Doc+        | SortOfSplitVarError (Maybe Blocker) Doc+          -- ^ the meta is what we might be blocked on.+        | WrongSharpArity A.QName+        | BuiltinMustBeConstructor BuiltinId A.Expr+        | BuiltinMustBeData BuiltinId Int+        | BuiltinMustBeDef BuiltinId+        | BuiltinMustBeFunction BuiltinId+        | BuiltinMustBePostulate BuiltinId+        | NoSuchBuiltinName String+        | InvalidBuiltin String+        | DuplicateBuiltinBinding BuiltinId Term Term+        | NoBindingForBuiltin BuiltinId+        | NoBindingForPrimitive PrimitiveId+        | NoSuchPrimitiveFunction String+        | DuplicatePrimitiveBinding PrimitiveId QName QName+        | WrongArgInfoForPrimitive PrimitiveId ArgInfo ArgInfo+        | ShadowedModule C.Name (List1 A.ModuleName)+        | BuiltinInParameterisedModule BuiltinId+        | IllegalDeclarationInDataDefinition (List1 C.Declaration)+            -- ^ The declaration list comes from a single 'C.NiceDeclaration'.+        | IllegalLetInTelescope C.TypedBinding+        | IllegalPatternInTelescope C.Binder+        | AbsentRHSRequiresAbsurdPattern+        | TooManyFields QName [C.Name] (List1 C.Name)+          -- ^ Record type, fields not supplied by user, possibly non-fields but supplied.+        | DuplicateFields (List1 C.Name)+        | DuplicateConstructors (List1 C.Name)+        | DuplicateOverlapPragma QName OverlapMode OverlapMode+        | WithOnFreeVariable A.Expr Term+        | UnexpectedWithPatterns (List1 A.Pattern)+        | WithClausePatternMismatch A.Pattern (NamedArg DeBruijnPattern)+        | IllTypedPatternAfterWithAbstraction A.Pattern+        | TooFewPatternsInWithClause+        | TooManyPatternsInWithClause+        | PathAbstractionFailed (Abs Type)+        | FieldOutsideRecord+        | ModuleArityMismatch A.ModuleName Telescope (Either (List1 (NamedArg A.Expr)) Args)+        | GeneralizeCyclicDependency+        | ReferencesFutureVariables Term (List1 Int) (Arg Term) Int+          -- ^ The first term references the given list of variables,+          -- which are in "the future" with respect to the given lock+          -- (and its leftmost variable)+        | DoesNotMentionTicks Term Type (Arg Term)+          -- ^ Arguments: later term, its type, lock term. The lock term+          -- does not mention any @lock variables.+        | MismatchedProjectionsError QName QName+        | AttributeKindNotEnabled String String String+        | InvalidProjectionParameter (NamedArg A.Expr)+        | TacticAttributeNotAllowed+        | CannotRewriteByNonEquation Type+        | MacroResultTypeMismatch Type+        | NamedWhereModuleInRefinedContext [Term] [String]+            -- ^ The lists should have the same length.+            --   TODO: enforce this by construction.+        | ComatchingDisabledForRecord QName+        | IncorrectTypeForRewriteRelation Term IncorrectTypeForRewriteRelationReason+    -- Cubical errors+        | CannotGenerateHCompClause Type+            -- ^ Cannot generate @hcomp@ clause because type is not fibrant.+        | CannotGenerateTransportClause QName (Closure (Abs Type))+            -- ^ Cannot generate transport clause because type is not fibrant.+        | CubicalNotErasure QName+            -- ^ Name was defined for @--cubical@+            --   and for use in @--erased-cubical@ the option @--erasure@ is needed.+        | CubicalPrimitiveNotFullyApplied QName+        | ExpectedIntervalLiteral A.Expr+            -- ^ Expected an interval literal (0 or 1) but found 'A.Expr'.+        | FaceConstraintDisjunction+        | FaceConstraintUnsatisfiable+        | PatternInPathLambda+            -- ^ Attempt to pattern match in an abstraction of interval type.+        | PatternInSystem+            -- ^ Attempt to pattern or copattern match in a system.+    -- Data errors+        | UnexpectedParameter A.LamBinding+        | NoParameterOfName ArgName+        | UnexpectedModalityAnnotationInParameter A.LamBinding+        | ExpectedBindingForParameter (Dom Type) (Abs Type)+        | UnexpectedTypeSignatureForParameter (List1 (NamedArg A.Binder))+        | SortDoesNotAdmitDataDefinitions QName Sort+        | SortCannotDependOnItsIndex QName Type+    -- Modality errors+        | UnusableAtModality WhyCheckModality Modality Term+    -- Coverage errors+-- UNUSED:        | IncompletePatternMatching Term [Elim] -- can only happen if coverage checking is switched off+        | SplitError SplitError+        | ImpossibleConstructor QName NegativeUnification+    -- Positivity and polarity errors+        | DatatypeIndexPolarity+            -- ^ An index of a data type has a polarity different from 'Mixed'.+        | RecursiveRecordNeedsInductivity QName+            -- ^ A record type inferred as recursive needs a manual declaration+            --   whether it should be inductively or coinductively.++    -- Sized type errors+        | CannotSolveSizeConstraints (List1 (ProblemConstraint, HypSizeConstraint)) Doc+            -- ^ The list of constraints is given redundantly as pairs of+            --   'ProblemConstraint' (original constraint) and+            --   'HypSizeConstraint' (form with size assumptions in context spelled out).+            --   The 'Doc' is some extra reason for why solving failed.+        | ContradictorySizeConstraint (ProblemConstraint, HypSizeConstraint)+        | EmptyTypeOfSizes Term+            -- ^ This type, representing a type of sizes, might be empty.+        | FunctionTypeInSizeUniv Term+            -- ^ This term, a function type constructor, lives in+            --   @SizeUniv@, which is not allowed.+        | PostulatedSizeInModule+    -- Import errors+        | LibraryError LibErrors+            -- ^ Collected errors when processing the @.agda-lib@ file.+        | LibTooFarDown TopLevelModuleName AgdaLibFile+            -- ^ The @.agda-lib@ file for the given module is not on the right level.+        | SolvedButOpenHoles+          -- ^ Some interaction points (holes) have not been filled by user.+          --   There are not 'UnsolvedMetas' since unification solved them.+          --   This is an error, since interaction points are never filled+          --   without user interaction.+        | CyclicModuleDependency (List2 TopLevelModuleName)+            -- ^ The cycle starts and ends with the same module.+        | FileNotFound TopLevelModuleName [AbsolutePath]+            -- ^ The list can be empty.+        | OverlappingProjects AbsolutePath TopLevelModuleName TopLevelModuleName+        | AmbiguousTopLevelModuleName TopLevelModuleName (List2 AbsolutePath)+            -- ^ The given module has at least 2 file locations.+        | ModuleNameUnexpected TopLevelModuleName TopLevelModuleName+          -- ^ Found module name, expected module name.+        | ModuleNameDoesntMatchFileName TopLevelModuleName [AbsolutePath]+            -- ^ The list can be empty.+        | ModuleDefinedInOtherFile TopLevelModuleName AbsolutePath AbsolutePath+          -- ^ Module name, file from which it was loaded, file which+          -- the include path says contains the module.+        | InvalidFileName AbsolutePath InvalidFileNameReason+          -- ^ The file name does not correspond to a module name.+        | ModuleNameHashCollision RawTopLevelModuleName (Maybe RawTopLevelModuleName)+    -- Scope errors+        | BothWithAndRHS+        | AbstractConstructorNotInScope A.QName+        | CopatternHeadNotProjection C.QName+        | NotAllowedInDotPatterns NotAllowedInDotPatterns+        | NotInScope C.QName+        | NoSuchModule C.QName+        | AmbiguousName C.QName AmbiguousNameReason+        | AmbiguousModule C.QName (List1 A.ModuleName)+        | AmbiguousField C.Name (List2 A.ModuleName)+        | AmbiguousConstructor QName (List2 QName)+            -- ^ The list contains all interpretations of the name.+        | ClashingDefinition C.QName A.QName (Maybe NiceDeclaration)+        | ClashingModule A.ModuleName A.ModuleName+        | DefinitionInDifferentModule A.QName+            -- ^ The given data/record definition rests in a different module than its signature.+        | DuplicateImports C.QName (List1 C.ImportedName)+        | InvalidPattern C.Pattern+        | InvalidPun ConstructorOrPatternSynonym C.QName+            -- ^ Expected the identifier to be a variable, not a constructor or pattern synonym.+        | RepeatedNamesInImportDirective (List1 (List2 C.ImportedName))+            -- ^ Some names are bound several times by an @import@/@open@ directive.+        | RepeatedVariablesInPattern (List1 C.Name)+        | GeneralizeNotSupportedHere A.QName+        | GeneralizedVarInLetOpenedModule A.QName+        | MultipleFixityDecls (List1 (C.Name, Pair Fixity'))+        | MultiplePolarityPragmas (List1 C.Name)+        | ExplicitPolarityVsPragma QName+        | ConstructorNameOfNonRecord ResolvedName+    -- Concrete to Abstract errors+        | CannotQuote CannotQuote+        | CannotQuoteTerm CannotQuoteTerm+        | DeclarationsAfterTopLevelModule+        | IllegalDeclarationBeforeTopLevelModule+        | MissingTypeSignature MissingTypeSignatureInfo+        | NotAnExpression C.Expr+        | NotAValidLetBinding (Maybe NotAValidLetBinding)+        | NotAValidLetExpression NotAValidLetExpression+        | NotValidBeforeField NiceDeclaration+        | PrivateRecordField+        | QualifiedLocalModule+    -- Pattern synonym errors+        | AsPatternInPatternSynonym+        | DotPatternInPatternSynonym+        | BadArgumentsToPatternSynonym A.AmbiguousQName+        | TooFewArgumentsToPatternSynonym A.AmbiguousQName+        | CannotResolveAmbiguousPatternSynonym (List1 (A.QName, A.PatternSynDefn))+        | IllegalInstanceVariableInPatternSynonym C.Name+            -- ^ This variable is bound in the lhs of the pattern synonym in instance position,+            --   but not on the rhs.+            --   This is forbidden because expansion of pattern synonyms would not be faithful+            --   to availability of instances in instance search.+        | PatternSynonymArgumentShadows ConstructorOrPatternSynonym C.Name (List1 AbstractName)+            -- ^ A variable to be bound in the pattern synonym resolved on the rhs as name of+            --   a constructor or a pattern synonym.+            --   The resolvents are given in the list.+        | UnusedVariableInPatternSynonym C.Name+            -- ^ This variable is only bound on the lhs of the pattern synonym, not on the rhs.+        | UnboundVariablesInPatternSynonym (List1 A.Name)+            -- ^ These variables are only bound on the rhs of the pattern synonym, not on the lhs.+    -- Operator errors+        | NoParseForApplication (List2 C.Expr)+        | AmbiguousParseForApplication (List2 C.Expr) (List1 C.Expr)+        | NoParseForLHS LHSOrPatSyn [C.Pattern] C.Pattern+            -- ^ The list contains patterns that failed to be interpreted.+            --   If it is non-empty, the first entry could be printed as error hint.+        | AmbiguousParseForLHS LHSOrPatSyn C.Pattern (List2 C.Pattern)+            -- ^ Pattern and its possible interpretations.+        | AmbiguousProjection QName (List1 QName)+            -- ^ The list contains alternative interpretations of the name.+        | AmbiguousOverloadedProjection (List1 QName) Doc+        | OperatorInformation [NotationSection] TypeError+            -- ^ The list of notations can be empty.+{- UNUSED+        | NoParseForPatternSynonym C.Pattern+        | AmbiguousParseForPatternSynonym C.Pattern [C.Pattern]+-}+    -- Usage errors+    -- Instance search errors+        | InstanceNoCandidate Type [(Term, TCErr)]+            -- ^ The list can be empty.+    -- Reflection errors+        | ExecError ExecError+        | UnquoteFailed UnquoteError+        | DeBruijnIndexOutOfScope Nat Telescope [Name]+            -- ^ The list can be empty.+    -- Language option errors+        | NeedOptionAllowExec+        | NeedOptionCopatterns+        | NeedOptionCubical Cubical String+            -- ^ Flavor of cubical needed for the given reason.+        | NeedOptionPatternMatching+        | NeedOptionProp+        | NeedOptionRewriting+        | NeedOptionSizedTypes String+            -- ^ Need @--sized-types@ for the given reason.+        | NeedOptionTwoLevel+        | NeedOptionUniversePolymorphism+    -- Failure associated to warnings+        | NonFatalErrors (Set1 TCWarning)+    -- Instance search errors+        | InstanceSearchDepthExhausted Term Type Int+        | TriedToCopyConstrainedPrim QName+        | InvalidInstanceHeadType Type WhyInvalidInstanceType+    -- Interaction errors+        | InteractionError InteractionError+    -- Backend errors+        | BackendDoesNotSupportOnlyScopeChecking BackendName+            -- ^ The given backend does not support @--only-scope-checking@.+        | CubicalCompilationNotSupported Cubical+            -- ^ NYI: Compilation of files using the given flavor of 'Cubical'.+        | CustomBackendError BackendName Doc+            -- ^ Used for backend-specific errors. The string is the backend name.+        | GHCBackendError GHCBackendError+            -- ^ Errors raised by the GHC backend.+        | JSBackendError JSBackendError+            -- ^ Errors raised by the JS backend.+        | UnknownBackend BackendName (Set BackendName)+            -- ^ Unknown backend requested, known ones are in the 'Set'.+          deriving (Show, Generic)++-- | Reason for why the instance type is invalid.+data WhyInvalidInstanceType+  = ImproperInstHead+    -- ^ The type isn't headed by a local, a definition, or a postulate+    -- (e.g. it's a universe)+  | ImproperInstTele+    -- ^ The type we're looking for has a visible argument+  deriving (Show, Generic)++-- | Errors raised in @--interaction@ mode.+data InteractionError+  = CannotGive A.Expr+      -- ^ Failure of the 'give' interactive tactic.+  | CannotRefine String+      -- ^ Failure of the 'refine' interactive tactic.+  | CaseSplitError Doc+      -- ^ Failure of the 'makeCase' interactive tactic.+  | ExpectedIdentifier C.Expr+      -- ^ Expected the given expression to be an identifier.+  | ExpectedApplication+      -- ^ Expected an argument of the form @f e1 e2 .. en@.+  | NoActionForInteractionPoint InteractionId+      -- ^ Interaction point has not been reached during type checking.+  | NoSuchInteractionPoint InteractionId+      -- ^ 'InteractionId' does not resolve to an 'InteractionPoint'.+  | UnexpectedWhere+      -- ^ @where@ not allowed in hole.+  deriving (Show, Generic)++-- | Errors raised by the GHC backend.+data GHCBackendError+  = ConstructorCountMismatch QName [QName] [String]+      -- ^ The number of Haskell constructors ('String' list) does not match+      --   the number of constructors of the given data type.+  | NotAHaskellType Term WhyNotAHaskellType+      -- ^ GHC backend fails to represent given Agda type in Haskell.+  | WrongTypeOfMain QName Type+      -- ^ The type of @main@ should be @IO _@ ('QName') but is instead 'Type'.+  deriving (Show, Generic)++-- | Errors raised by the JS backend.+data JSBackendError+  = BadCompilePragma+  deriving (Show, Generic)++-- | Extra information for 'MissingTypeSignature' error.+data MissingTypeSignatureInfo+  = MissingDataSignature     C.Name+      -- ^ The @data@ definition for 'C.Name' lacks a data signature.+  | MissingRecordSignature   C.Name+      -- ^ The @record@ definition for 'C.Name' lacks a record signature.+  | MissingFunctionSignature C.LHS+      -- ^ The function lhs misses a type signature.+  deriving (Show, Generic)++-- | Extra information for 'NotAHaskellType' error.+data WhyNotAHaskellType+  = NoPragmaFor QName+  | WrongPragmaFor Range QName+  | BadLambda Term+  | BadMeta Term+  | BadDontCare Term+  | NotCompiled QName+  deriving (Show, Generic)++-- | Extra information for 'InvalidFileName' error.+data InvalidFileNameReason+  = DoesNotCorrespondToValidModuleName+  | RootNameModuleNotAQualifiedModuleName Text+  deriving (Show, Generic)++type DataOrRecordE = DataOrRecord' InductionAndEta++data InductionAndEta = InductionAndEta+  { recordInduction   :: Maybe Induction+  , recordEtaEquality :: EtaEquality+  } deriving (Show, Generic)++-- Reason, why rewrite rule is invalid+data IllegalRewriteRuleReason+  = LHSNotDefinitionOrConstructor+  | VariablesNotBoundByLHS IntSet+  | VariablesBoundMoreThanOnce IntSet+  | LHSReduces Term Term+  | HeadSymbolIsProjectionLikeFunction QName+  | HeadSymbolIsTypeConstructor QName+  | HeadSymbolContainsMetas QName+  | ConstructorParametersNotGeneral ConHead Args+  | ContainsUnsolvedMetaVariables (Set1 MetaId)+  | BlockedOnProblems (Set1 ProblemId)+  | RequiresDefinitions (Set1 QName)+  | DoesNotTargetRewriteRelation+  | BeforeFunctionDefinition+  | BeforeMutualFunctionDefinition QName+  | DuplicateRewriteRule+    deriving (Show, Generic)++-- | Boolean flag whether a name is ambiguous.+data IsAmbiguous+  = YesAmbiguous AmbiguousQName+  | NotAmbiguous+  deriving (Show, Generic)++-- Reason, why type for rewrite rule is incorrect+data IncorrectTypeForRewriteRelationReason+  = ShouldAcceptAtLeastTwoArguments+  | FinalTwoArgumentsNotVisible+  | TypeDoesNotEndInSort Type Telescope+    deriving (Show, Generic)++-- | Extra information for error 'CannotQuote'.+data CannotQuote+  = CannotQuoteAmbiguous (List2 A.QName)+      -- ^ @quote@ is applied to an ambiguous name.+  | CannotQuoteExpression A.Expr+      -- ^ @quote@ is applied to an expression that is not an unambiguous defined name.+  | CannotQuoteHidden+      -- ^ @quote@ is applied to a non-visible argument.+  | CannotQuoteNothing+      -- ^ @quote@ is unapplied.+  | CannotQuotePattern (NamedArg C.Pattern)+      -- ^ @quote@ is applied to a pattern that is not an unambiguous defined name.+    deriving (Show, Generic)++-- | Distinguish error message when parsing lhs or pattern synonym, resp.+data LHSOrPatSyn = IsLHS | IsPatSyn+  deriving (Eq, Show, Generic, Bounded, Enum)++-- | Type-checking errors.++data TCErr+  = TypeError+    { tcErrLocation :: CallStack+       -- ^ Location in the internal Agda source code where the error was raised+    , tcErrState    :: TCState+        -- ^ The state in which the error was raised.+    , tcErrClosErr  :: Closure TypeError+        -- ^ The environment in which the error as raised plus the error.+    }+  | ParserError ParseError+      -- ^ Error raised by the Happy parser.+  | GenericException String+      -- ^ Unspecific error without 'Range'.+  | IOException (Maybe TCState) Range E.IOException+      -- ^ The first argument is the state in which the error was raised.+  | PatternErr Blocker+      -- ^ The exception which is usually caught.+      --   Raised for pattern violations during unification ('assignV')+      --   but also in other situations where we want to backtrack.+      --   Contains an unblocker to control when the computation should+      --   be retried.++instance Show TCErr where+  show = \case+    TypeError _ _ e      -> prettyShow (envRange $ clEnv e) ++ ": " ++ show (clValue e)+    ParserError e        -> prettyShow e+    GenericException msg -> msg+    IOException _ r e    -> prettyShow r ++ ": " ++ showIOException e+    PatternErr{}         -> "Pattern violation (you shouldn't see this)"++instance HasRange TCErr where+  getRange (TypeError _ _ cl)  = envRange $ clEnv cl+  getRange (ParserError e)     = getRange e+  getRange GenericException{}  = noRange+  getRange (IOException _ r _) = r+  getRange PatternErr{}        = noRange++instance E.Exception TCErr++-- | Assorted warnings and errors to be displayed to the user+data WarningsAndNonFatalErrors = WarningsAndNonFatalErrors+  { tcWarnings     :: Set TCWarning+  , nonFatalErrors :: Set TCWarning+  }++instance Null WarningsAndNonFatalErrors where+  null (WarningsAndNonFatalErrors ws errs) = null ws && null errs+  empty = WarningsAndNonFatalErrors empty empty++-----------------------------------------------------------------------------+-- * Accessing options+-----------------------------------------------------------------------------++instance MonadIO m => HasOptions (TCMT m) where+  pragmaOptions = useTC stPragmaOptions+  {-# INLINE pragmaOptions #-}++  commandLineOptions = do+    p  <- useTC stPragmaOptions+    cl <- stPersistentOptions . stPersistentState <$> getTC+    return $ cl { optPragmaOptions = p }+  {-# SPECIALIZE commandLineOptions :: TCM CommandLineOptions #-}++-- HasOptions lifts through monad transformers+-- (see default signatures in the HasOptions class).++sizedTypesOption :: HasOptions m => m Bool+sizedTypesOption = optSizedTypes <$> pragmaOptions+{-# INLINE sizedTypesOption #-}++guardednessOption :: HasOptions m => m Bool+guardednessOption = optGuardedness <$> pragmaOptions+{-# INLINE guardednessOption #-}++withoutKOption :: HasOptions m => m Bool+withoutKOption = optWithoutK <$> pragmaOptions+{-# INLINE withoutKOption #-}++cubicalOption :: HasOptions m => m (Maybe Cubical)+cubicalOption = optCubical <$> pragmaOptions+{-# INLINE cubicalOption #-}++cubicalCompatibleOption :: HasOptions m => m Bool+cubicalCompatibleOption = optCubicalCompatible <$> pragmaOptions+{-# INLINE cubicalCompatibleOption #-}++enableCaching :: HasOptions m => m Bool+enableCaching = optCaching <$> pragmaOptions+{-# INLINE enableCaching #-}++-----------------------------------------------------------------------------+-- * The reduce monad+-----------------------------------------------------------------------------++-- | Environment of the reduce monad.+data ReduceEnv = ReduceEnv+  { redEnv  :: TCEnv    -- ^ Read only access to environment.+  , redSt   :: TCState  -- ^ Read only access to state (signature, metas...).+  , redPred :: Maybe (MetaId -> ReduceM Bool)+    -- ^ An optional predicate that is used by 'instantiate'' and+    -- 'instantiateFull'': meta-variables are only instantiated if+    -- they satisfy this predicate.+  }++mapRedEnv :: (TCEnv -> TCEnv) -> ReduceEnv -> ReduceEnv+mapRedEnv f s = s { redEnv = f (redEnv s) }+{-# INLINE mapRedEnv #-}++mapRedSt :: (TCState -> TCState) -> ReduceEnv -> ReduceEnv+mapRedSt f s = s { redSt = f (redSt s) }+{-# INLINE mapRedSt #-}++mapRedEnvSt :: (TCEnv -> TCEnv) -> (TCState -> TCState) -> ReduceEnv+            -> ReduceEnv+mapRedEnvSt f g (ReduceEnv e s p) = ReduceEnv (f e) (g s) p+{-# INLINE mapRedEnvSt #-}++-- Lenses+reduceEnv :: Lens' ReduceEnv TCEnv+reduceEnv f s = f (redEnv s) <&> \ e -> s { redEnv = e }+{-# INLINE reduceEnv #-}++reduceSt :: Lens' ReduceEnv TCState+reduceSt f s = f (redSt s) <&> \ e -> s { redSt = e }+{-# INLINE reduceSt #-}++newtype ReduceM a = ReduceM { unReduceM :: ReduceEnv -> a }+--  deriving (Functor, Applicative, Monad)++unKleisli :: (a -> ReduceM b) -> ReduceM (a -> b)+unKleisli f = ReduceM $ \ env x -> unReduceM (f x) env++onReduceEnv :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a+onReduceEnv f (ReduceM m) = ReduceM (m . f)+{-# INLINE onReduceEnv #-}++fmapReduce :: (a -> b) -> ReduceM a -> ReduceM b+fmapReduce f (ReduceM m) = ReduceM $ \ e -> f $! m e+{-# INLINE fmapReduce #-}++-- Andreas, 2021-05-12, issue #5379:+-- It seems more stable to force to evaluate @mf <*> ma@+-- from left to right, for the sake of printing+-- debug messages in order.+apReduce :: ReduceM (a -> b) -> ReduceM a -> ReduceM b+apReduce (ReduceM f) (ReduceM x) = ReduceM $ \ e ->+  let g = f e+      a = x e+  in  g `pseq` a `pseq` g a+{-# INLINE apReduce #-}+++-- Andreas, 2021-05-12, issue #5379+-- Since the MonadDebug instance of ReduceM is implemented via+-- unsafePerformIO, we need to force results that later+-- computations do not depend on, otherwise we lose debug messages.+thenReduce :: ReduceM a -> ReduceM b -> ReduceM b+thenReduce (ReduceM x) (ReduceM y) = ReduceM $ \ e -> x e `pseq` y e+{-# INLINE thenReduce #-}+++-- Andreas, 2021-05-14:+-- `seq` does not force evaluation order, the optimizier is allowed to replace+-- @+--    a `seq` b`+-- @+-- by:+-- @+--    b `seq` a `seq` b+-- @+-- see https://hackage.haskell.org/package/parallel/docs/Control-Parallel.html+--+-- In contrast, `pseq` is only strict in its first argument, so such a permutation+-- is forbidden.+-- If we want to ensure that debug messages are printed before exceptions are+-- propagated, we need to use `pseq`, as in:+-- @+--    unsafePerformIO (putStrLn "Black hawk is going down...") `pseq` throw HitByRPG+-- @+beforeReduce :: ReduceM a -> ReduceM b -> ReduceM a+beforeReduce (ReduceM x) (ReduceM y) = ReduceM $ \ e ->+  let a = x e+  in  a `pseq` y e `pseq` a+{-# INLINE beforeReduce #-}++bindReduce :: ReduceM a -> (a -> ReduceM b) -> ReduceM b+bindReduce (ReduceM m) f = ReduceM $ \ e -> unReduceM (f $! m e) e+{-# INLINE bindReduce #-}++instance Functor ReduceM where+  fmap = fmapReduce++instance Applicative ReduceM where+  pure x = ReduceM (const x)+  (<*>) = apReduce+  (*>)  = thenReduce+  (<*)  = beforeReduce++instance Monad ReduceM where+  return = pure+  (>>=) = bindReduce+  (>>) = (*>)++instance MonadFail ReduceM where+  fail = error++instance ReadTCState ReduceM where+  getTCState = ReduceM redSt+  locallyTCState l f = onReduceEnv $ mapRedSt $ over l f++runReduceM :: ReduceM a -> TCM a+runReduceM m = TCM $ \ r e -> do+  s <- readIORef r+  E.evaluate $ unReduceM m $ ReduceEnv e s Nothing+  -- Andreas, 2021-05-13, issue #5379+  -- This was the following, which is apparently not strict enough+  -- to force all unsafePerformIOs...+  -- runReduceM m = do+  --   e <- askTC+  --   s <- getTC+  --   return $! unReduceM m (ReduceEnv e s)++instance MonadTCEnv ReduceM where+  askTC   = ReduceM redEnv+  localTC = onReduceEnv . mapRedEnv++-- Andrea comments (https://github.com/agda/agda/issues/1829#issuecomment-522312084):+--+--   useR forces the result of projecting the lens,+--   this usually prevents retaining the whole structure when we only need a field.+--+-- This fixes (or contributes to the fix of) the space leak issue #1829 (caching).+useR :: (ReadTCState m) => Lens' TCState a -> m a+useR l = do+  !x <- getTCState <&> (^. l)+  return x+{-# INLINE useR #-}++askR :: ReduceM ReduceEnv+askR = ReduceM ask+{-# INLINE askR #-}++localR :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a+localR f = ReduceM . local f . unReduceM+{-# INLINE localR #-}++instance HasOptions ReduceM where+  pragmaOptions      = useR stPragmaOptions+  commandLineOptions = do+    p  <- useR stPragmaOptions+    cl <- stPersistentOptions . stPersistentState <$> getTCState+    return $ cl{ optPragmaOptions = p }++class ( Applicative m+      , MonadTCEnv m+      , ReadTCState m+      , HasOptions m+      ) => MonadReduce m where+  liftReduce :: ReduceM a -> m a++  default liftReduce :: (MonadTrans t, MonadReduce n, t n ~ m) => ReduceM a -> m a+  liftReduce = lift . liftReduce++instance MonadReduce ReduceM where+  liftReduce = id++instance MonadReduce m => MonadReduce (ChangeT m)+instance MonadReduce m => MonadReduce (ExceptT err m)+instance MonadReduce m => MonadReduce (IdentityT m)+instance MonadReduce m => MonadReduce (ListT m)+instance MonadReduce m => MonadReduce (MaybeT m)+instance MonadReduce m => MonadReduce (ReaderT r m)+instance MonadReduce m => MonadReduce (StateT w m)+instance (Monoid w, MonadReduce m) => MonadReduce (WriterT w m)+instance MonadReduce m => MonadReduce (BlockT m)++---------------------------------------------------------------------------+-- * Monad with read-only 'TCEnv'+---------------------------------------------------------------------------++-- | @MonadTCEnv@ made into its own dedicated service class.+--   This allows us to use 'MonadReader' for 'ReaderT' extensions of @TCM@.+class Monad m => MonadTCEnv m where+  askTC   :: m TCEnv+  localTC :: (TCEnv -> TCEnv) -> m a -> m a++  default askTC :: (MonadTrans t, MonadTCEnv n, t n ~ m) => m TCEnv+  askTC = lift askTC++  default localTC+    :: (MonadTransControl t, MonadTCEnv n, t n ~ m)+    =>  (TCEnv -> TCEnv) -> m a -> m a+  localTC = liftThrough . localTC++instance MonadTCEnv m => MonadTCEnv (ChangeT m)+instance MonadTCEnv m => MonadTCEnv (ExceptT err m)+instance MonadTCEnv m => MonadTCEnv (IdentityT m)+instance MonadTCEnv m => MonadTCEnv (MaybeT m)+instance MonadTCEnv m => MonadTCEnv (ReaderT r m)+instance MonadTCEnv m => MonadTCEnv (StateT s m)+instance (Monoid w, MonadTCEnv m) => MonadTCEnv (WriterT w m)++instance MonadTCEnv m => MonadTCEnv (ListT m) where+  localTC = mapListT . localTC++{-# INLINE asksTC #-}+asksTC :: MonadTCEnv m => (TCEnv -> a) -> m a+asksTC f = f <$> askTC++{-# INLINE viewTC #-}+viewTC :: MonadTCEnv m => Lens' TCEnv a -> m a+viewTC l = asksTC (^. l)++{-# INLINE locallyTC #-}+-- | Modify the lens-indicated part of the @TCEnv@ in a subcomputation.+locallyTC :: MonadTCEnv m => Lens' TCEnv a -> (a -> a) -> m b -> m b+locallyTC l = localTC . over l++---------------------------------------------------------------------------+-- * Monad with mutable 'TCState'+---------------------------------------------------------------------------++-- | @MonadTCState@ made into its own dedicated service class.+--   This allows us to use 'MonadState' for 'StateT' extensions of @TCM@.+class Monad m => MonadTCState m where+  getTC :: m TCState+  putTC :: TCState -> m ()+  modifyTC :: (TCState -> TCState) -> m ()++  default getTC :: (MonadTrans t, MonadTCState n, t n ~ m) => m TCState+  getTC = lift getTC++  default putTC :: (MonadTrans t, MonadTCState n, t n ~ m) => TCState -> m ()+  putTC = lift . putTC++  default modifyTC :: (MonadTrans t, MonadTCState n, t n ~ m) => (TCState -> TCState) -> m ()+  modifyTC = lift . modifyTC++instance MonadTCState m => MonadTCState (MaybeT m)+instance MonadTCState m => MonadTCState (ListT m)+instance MonadTCState m => MonadTCState (ExceptT err m)+instance MonadTCState m => MonadTCState (ReaderT r m)+instance MonadTCState m => MonadTCState (StateT s m)+instance MonadTCState m => MonadTCState (ChangeT m)+instance MonadTCState m => MonadTCState (IdentityT m)+instance (Monoid w, MonadTCState m) => MonadTCState (WriterT w m)++{-# INLINE getsTC #-}+-- ** @TCState@ accessors (no lenses)+getsTC :: ReadTCState m => (TCState -> a) -> m a+getsTC f = f <$> getTCState++{-# INLINE modifyTC' #-}+-- | A variant of 'modifyTC' in which the computation is strict in the+-- new state.+modifyTC' :: MonadTCState m => (TCState -> TCState) -> m ()+modifyTC' f = do+  s' <- getTC+  putTC $! f s'++-- SEE TC.Monad.State+-- -- | Restore the 'TCState' after computation.+-- localTCState :: MonadTCState m => m a -> m a+-- localTCState = bracket_ getTC putTC++-- ** @TCState@ accessors via lenses++{-# INLINE useTC #-}+useTC :: ReadTCState m => Lens' TCState a -> m a+useTC l = do+  !x <- getsTC (^. l)+  return x++infix 4 `setTCLens`++{-# INLINE setTCLens #-}+-- | Overwrite the part of the 'TCState' focused on by the lens.+setTCLens :: MonadTCState m => Lens' TCState a -> a -> m ()+setTCLens l = modifyTC . set l++{-# INLINE setTCLens' #-}+-- | Overwrite the part of the 'TCState' focused on by the lens+-- (strictly).+setTCLens' :: MonadTCState m => Lens' TCState a -> a -> m ()+setTCLens' l = modifyTC' . set l++{-# INLINE modifyTCLens #-}+-- | Modify the part of the 'TCState' focused on by the lens.+modifyTCLens :: MonadTCState m => Lens' TCState a -> (a -> a) -> m ()+modifyTCLens l = modifyTC . over l++{-# INLINE modifyTCLens' #-}+-- | Modify the part of the 'TCState' focused on by the lens+-- (strictly).+modifyTCLens' :: MonadTCState m => Lens' TCState a -> (a -> a) -> m ()+modifyTCLens' l = modifyTC' . over l++{-# INLINE modifyTCLensM #-}+-- | Modify a part of the state monadically.+--+--   This is an instance of 'Agda.Utils.Lens.%=='.+modifyTCLensM :: (MonadTCState m, ReadTCState m) => Lens' TCState a -> (a -> m a) -> m ()+modifyTCLensM l f = useTC l >>= f >>= setTCLens l+  -- Note:+  -- The implementation @getTC >>= l f >>= putTC@ loses state changes+  -- contained in @f@, see https://github.com/agda/agda/pull/7470#discussion_r1747232483++{-# INLINE stateTCLens #-}+-- | Modify the part of the 'TCState' focused on by the lens, and return some result.+stateTCLens :: (MonadTCState m, ReadTCState m) => Lens' TCState a -> (a -> (r , a)) -> m r+stateTCLens l f = stateTCLensM l $ return . f++{-# INLINE stateTCLensM #-}+-- | Modify a part of the state monadically, and return some result.+--+--   This is an instance of 'Agda.Utils.Lens.%%='.+stateTCLensM :: (MonadTCState m, ReadTCState m) => Lens' TCState a -> (a -> m (r , a)) -> m r+stateTCLensM l f = do+  a <- useTC l+  (result , a') <- f a+  result <$ setTCLens l a'+++---------------------------------------------------------------------------+-- ** Monad with capability to block a computation+---------------------------------------------------------------------------++class Monad m => MonadBlock m where++  -- | `patternViolation b` aborts the current computation+  patternViolation :: Blocker -> m a++  default patternViolation :: (MonadTrans t, MonadBlock n, m ~ t n) => Blocker -> m a+  patternViolation = lift . patternViolation++  -- | `catchPatternErr handle m` runs m, handling pattern violations+  --    with `handle` (doesn't roll back the state)+  catchPatternErr :: (Blocker -> m a) -> m a -> m a++newtype BlockT m a = BlockT { unBlockT :: ExceptT Blocker m a }+  deriving ( Functor, Applicative, Monad, MonadTrans -- , MonadTransControl -- requires GHC >= 8.2+           , MonadIO, MonadFail+           , ReadTCState, HasOptions+           , MonadTCEnv, MonadTCState, MonadTCM+           )++instance Monad m => MonadBlock (BlockT m) where+  patternViolation = BlockT . throwError+  catchPatternErr h f = BlockT $ catchError (unBlockT f) (unBlockT . h)++instance Monad m => MonadBlock (ExceptT TCErr m) where+  patternViolation = throwError . PatternErr+  catchPatternErr h f = catchError f $ \case+    PatternErr b -> h b+    err          -> throwError err++runBlocked :: Monad m => BlockT m a -> m (Either Blocker a)+runBlocked = runExceptT . unBlockT+{-# INLINE runBlocked #-}++instance MonadBlock m => MonadBlock (MaybeT m) where+  catchPatternErr h m = MaybeT $ catchPatternErr (runMaybeT . h) $ runMaybeT m++instance MonadBlock m => MonadBlock (ReaderT e m) where+  catchPatternErr h m = ReaderT $ \ e ->+    let run = flip runReaderT e in catchPatternErr (run . h) (run m)++---------------------------------------------------------------------------+-- * Type checking monad transformer+---------------------------------------------------------------------------++-- | The type checking monad transformer.+-- Adds readonly 'TCEnv' and mutable 'TCState'.+newtype TCMT m a = TCM { unTCM :: IORef TCState -> TCEnv -> m a }++-- | Type checking monad.+type TCM = TCMT IO++{-# SPECIALIZE INLINE mapTCMT :: (forall a. IO a -> IO a) -> TCM a -> TCM a #-}+mapTCMT :: (forall a. m a -> n a) -> TCMT m a -> TCMT n a+mapTCMT f (TCM m) = TCM $ \ s e -> f (m s e)++pureTCM :: MonadIO m => (TCState -> TCEnv -> a) -> TCMT m a+pureTCM f = TCM $ \ r e -> do+  s <- liftIO $ readIORef r+  return (f s e)+{-# INLINE pureTCM #-}++-- One goal of the definitions and pragmas below is to inline the+-- monad operations as much as possible. This doesn't seem to have a+-- large effect on the performance of the normal executable, but (at+-- least on one machine/configuration) it has a massive effect on the+-- performance of the profiling executable [1], and reduces the time+-- attributed to bind from over 90% to about 25%.+--+-- [1] When compiled with -auto-all and run with -p: roughly 750%+-- faster for one example.++returnTCMT :: Applicative m => a -> TCMT m a+returnTCMT = \x -> TCM $ \_ _ -> pure x+{-# INLINE returnTCMT #-}++bindTCMT :: Monad m => TCMT m a -> (a -> TCMT m b) -> TCMT m b+bindTCMT = \(TCM m) k -> TCM $ \r e -> m r e >>= \x -> unTCM (k x) r e+{-# INLINE bindTCMT #-}++thenTCMT :: Applicative m => TCMT m a -> TCMT m b -> TCMT m b+thenTCMT = \(TCM m1) (TCM m2) -> TCM $ \r e -> m1 r e *> m2 r e+{-# INLINE thenTCMT #-}++instance Functor m => Functor (TCMT m) where+  fmap = fmapTCMT; {-# INLINE fmap #-}++fmapTCMT :: Functor m => (a -> b) -> TCMT m a -> TCMT m b+fmapTCMT = \f (TCM m) -> TCM $ \r e -> fmap f (m r e)+{-# INLINE fmapTCMT #-}++instance Applicative m => Applicative (TCMT m) where+  pure  = returnTCMT; {-# INLINE pure #-}+  (<*>) = apTCMT; {-# INLINE (<*>) #-}++apTCMT :: Applicative m => TCMT m (a -> b) -> TCMT m a -> TCMT m b+apTCMT = \(TCM mf) (TCM m) -> TCM $ \r e -> mf r e <*> m r e+{-# INLINE apTCMT #-}++instance MonadTrans TCMT where+    lift m = TCM $ \_ _ -> m; {-# INLINE lift #-}++-- We want a special monad implementation of fail.+-- Andreas, 2022-02-02, issue #5659:+-- @transformers-0.6@ requires exactly a @Monad@ superclass constraint here+-- if we want @instance MonadTrans TCMT@.+instance Monad m => Monad (TCMT m) where+    return = pure; {-# INLINE return #-}+    (>>=)  = bindTCMT; {-# INLINE (>>=) #-}+    (>>)   = (*>); {-# INLINE (>>) #-}++instance (CatchIO m, MonadIO m) => MonadFail (TCMT m) where+  fail = internalError++instance MonadIO m => MonadIO (TCMT m) where+  liftIO m = TCM $ \ s env -> do+    liftIO $ wrap s (envRange env) $ do+      x <- m+      x `seq` return x+    where+      wrap s r m = E.catch m $ \ err -> do+        s <- readIORef s+        E.throwIO $ IOException (Just s) r err++instance MonadIO m => MonadTCEnv (TCMT m) where+  askTC             = TCM $ \ _ e -> return e; {-# INLINE askTC #-}+  localTC f (TCM m) = TCM $ \ s e -> m s (f e); {-# INLINE localTC #-}++instance MonadIO m => MonadTCState (TCMT m) where+  getTC   = TCM $ \ r _e -> liftIO (readIORef r); {-# INLINE getTC #-}+  putTC s = TCM $ \ r _e -> liftIO (writeIORef r s); {-# INLINE putTC #-}+  modifyTC f = putTC . f =<< getTC; {-# INLINE modifyTC #-}++instance MonadIO m => ReadTCState (TCMT m) where+  getTCState = getTC; {-# INLINE getTCState #-}+  locallyTCState l f = bracket_ (useTC l <* modifyTCLens l f) (setTCLens l); {-# INLINE locallyTCState #-}++instance MonadBlock TCM where+  patternViolation b = throwError (PatternErr b)+  catchPatternErr handle v =+       catchError_ v $ \err ->+       case err of+            -- Not putting s (which should really be the what's already there) makes things go+            -- a lot slower (+20% total time on standard library). How is that possible??+            -- The problem is most likely that there are internal catchErrors which forgets the+            -- state. catchError should preserve the state on pattern violations.+           PatternErr u -> handle u+           _            -> throwError err++instance (CatchIO m, MonadIO m) => MonadError TCErr (TCMT m) where+  throwError = liftIO . E.throwIO+  catchError m h = TCM $ \ r e -> do  -- now we are in the monad m+    oldState <- liftIO $ readIORef r+    unTCM m r e `catchIO` \err -> do+      -- Reset the state, but do not forget changes to the persistent+      -- component. Not for pattern violations.+      case err of+        PatternErr{} -> return ()+        _            ->+          liftIO $ do+            newState <- readIORef r+            writeIORef r $ oldState { stPersistentState = stPersistentState newState }+      unTCM (h err) r e++-- | Like 'catchError', but resets the state completely before running the handler.+--   This means it also loses changes to the 'stPersistentState'.+--+--   The intended use is to catch internal errors during debug printing.+--   In debug printing, we are not expecting state changes.+instance CatchImpossible TCM where+  catchImpossibleJust f m h = TCM $ \ r e -> do+    -- save the state+    s <- readIORef r+    catchImpossibleJust f (unTCM m r e) $ \ err -> do+      writeIORef r s+      unTCM (h err) r e++instance MonadIO m => MonadReduce (TCMT m) where+  liftReduce = liftTCM . runReduceM; {-# INLINE liftReduce #-}++instance (IsString a, MonadIO m) => IsString (TCMT m a) where+  fromString s = return (fromString s)++-- | Strict (non-shortcut) semigroup.+--+--   Note that there might be a lazy alternative, e.g.,+--   for TCM All we might want 'Agda.Utils.Monad.and2M' as concatenation,+--   to shortcut conjunction in case we already have 'False'.+--+instance {-# OVERLAPPABLE #-} (MonadIO m, Semigroup a) => Semigroup (TCMT m a) where+  (<>) = liftA2 (<>)++-- | Strict (non-shortcut) monoid.+instance {-# OVERLAPPABLE #-} (MonadIO m, Semigroup a, Monoid a) => Monoid (TCMT m a) where+  mempty  = pure mempty+  mappend = (<>)+  mconcat = mconcat <.> sequence++instance {-# OVERLAPPABLE #-} (MonadIO m, Null a) => Null (TCMT m a) where+  empty = return empty+  null  = __IMPOSSIBLE__++-- | Preserve the state of the failing computation.+catchError_ :: TCM a -> (TCErr -> TCM a) -> TCM a+catchError_ m h = TCM $ \r e ->+  unTCM m r e+  `E.catch` \err -> unTCM (h err) r e++-- | Execute a finalizer even when an exception is thrown.+--   Does not catch any errors.+--   In case both the regular computation and the finalizer+--   throw an exception, the one of the finalizer is propagated.+finally_ :: TCM a -> TCM b -> TCM a+finally_ m f = do+    x <- m `catchError_` \ err -> f >> throwError err+    _ <- f+    return x++-- | Embedding a TCM computation.++class ( Applicative tcm, MonadIO tcm+      , MonadTCEnv tcm+      , MonadTCState tcm+      , HasOptions tcm+      ) => MonadTCM tcm where+    liftTCM :: TCM a -> tcm a++    default liftTCM :: (MonadTCM m, MonadTrans t, tcm ~ t m) => TCM a -> tcm a+    liftTCM = lift . liftTCM+    {-# INLINE liftTCM #-}++{-# RULES "liftTCM/id" liftTCM = id #-}+instance MonadIO m => MonadTCM (TCMT m) where+    liftTCM = mapTCMT liftIO+    {-# INLINE liftTCM #-}++instance MonadTCM tcm => MonadTCM (ChangeT tcm)+instance MonadTCM tcm => MonadTCM (ExceptT err tcm)+instance MonadTCM tcm => MonadTCM (IdentityT tcm)+instance MonadTCM tcm => MonadTCM (ListT tcm)+instance MonadTCM tcm => MonadTCM (MaybeT tcm)+instance MonadTCM tcm => MonadTCM (ReaderT r tcm)+instance MonadTCM tcm => MonadTCM (StateT s tcm)+instance (Monoid w, MonadTCM tcm) => MonadTCM (WriterT w tcm)++-- | We store benchmark statistics in an IORef.+--   This enables benchmarking pure computation, see+--   "Agda.Benchmarking".+instance MonadBench TCM where+  type BenchPhase TCM = Phase+  getBenchmark = liftIO $ getBenchmark+  putBenchmark = liftIO . putBenchmark+  finally = finally_++instance Null (TCM Doc) where+  empty = return empty+  null = __IMPOSSIBLE__++internalError :: (HasCallStack, MonadTCError m) => String -> m a+internalError s = withCallerCallStack $ \ loc ->+  typeError' loc $ InternalError s++-- | The constraints needed for 'typeError' and similar.+type MonadTCError m = (MonadTCEnv m, ReadTCState m, MonadError TCErr m)++-- | Utility function for 1-arg constructed type errors.+-- Note that the @HasCallStack@ constraint is on the *resulting* function.+locatedTypeError :: MonadTCError m => (a -> TypeError) -> (HasCallStack => a -> m b)+locatedTypeError f e = withCallerCallStack (flip typeError' (f e))++genericError :: (HasCallStack, MonadTCError m) => String -> m a+genericError = locatedTypeError GenericError++{-# SPECIALIZE genericDocError :: Doc -> TCM a #-}+genericDocError :: (HasCallStack, MonadTCError m) => Doc -> m a+genericDocError = locatedTypeError GenericDocError++{-# SPECIALIZE typeError' :: CallStack -> TypeError -> TCM a #-}+typeError' :: MonadTCError m => CallStack -> TypeError -> m a+typeError' loc err = throwError =<< typeError'_ loc err++{-# SPECIALIZE typeError :: HasCallStack => TypeError -> TCM a #-}+typeError :: (HasCallStack, MonadTCError m) => TypeError -> m a+typeError err = withCallerCallStack $ \loc -> throwError =<< typeError'_ loc err++{-# SPECIALIZE typeError'_ :: CallStack -> TypeError -> TCM TCErr #-}+typeError'_ :: (MonadTCEnv m, ReadTCState m) => CallStack -> TypeError -> m TCErr+typeError'_ loc err = TypeError loc <$> getTCState <*> buildClosure err++{-# SPECIALIZE typeError_ :: HasCallStack => TypeError -> TCM TCErr #-}+typeError_ :: (HasCallStack, MonadTCEnv m, ReadTCState m) => TypeError -> m TCErr+typeError_ = withCallerCallStack . flip typeError'_++interactionError :: (HasCallStack, MonadTCError m) => InteractionError -> m a+interactionError = locatedTypeError InteractionError++syntaxError :: (HasCallStack, MonadTCError m) => String -> m a+syntaxError = locatedTypeError SyntaxError++unquoteError :: (HasCallStack, MonadTCError m) => UnquoteError -> m a+unquoteError = locatedTypeError UnquoteFailed++execError :: (HasCallStack, MonadTCError m) => ExecError -> m a+execError = locatedTypeError ExecError++-- | Running the type checking monad (most general form).+{-# SPECIALIZE runTCM :: TCEnv -> TCState -> TCM a -> IO (a, TCState) #-}+runTCM :: MonadIO m => TCEnv -> TCState -> TCMT m a -> m (a, TCState)+runTCM e s m = do+  r <- liftIO $ newIORef s+  a <- unTCM m r e+  s <- liftIO $ readIORef r+  return (a, s)++-- | Running the type checking monad on toplevel (with initial state).+runTCMTop :: TCM a -> IO (Either TCErr a)+runTCMTop m = (Right <$> runTCMTop' m) `E.catch` (return . Left)++runTCMTop' :: MonadIO m => TCMT m a -> m a+runTCMTop' m = do+  r <- liftIO $ newIORef =<< initStateIO+  unTCM m r initEnv++-- | 'runSafeTCM' runs a safe 'TCM' action (a 'TCM' action which+--   cannot fail, except that it might raise 'IOException's) in the+--   initial environment.++runSafeTCM :: TCM a -> TCState -> IO (a, TCState)+runSafeTCM m st =+  runTCM initEnv st m `E.catch` \(e :: TCErr) -> case e of+    IOException _ _ err -> E.throwIO err+    _                   -> __IMPOSSIBLE__++-- | Runs the given computation in a separate thread, with /a copy/ of+-- the current state and environment.+--+-- Note that Agda sometimes uses actual, mutable state. If the+-- computation given to @forkTCM@ tries to /modify/ this state, then+-- bad things can happen, because accesses are not mutually exclusive.+-- The @forkTCM@ function has been added mainly to allow the thread to+-- /read/ (a snapshot of) the current state in a convenient way.+--+-- Note also that exceptions which are raised in the thread are not+-- propagated to the parent, so the thread should not do anything+-- important.++forkTCM :: TCM () -> TCM ()+forkTCM m = do+  s <- getTC+  e <- askTC+  liftIO $ void $ forkIO $ void $ runTCM e s m++---------------------------------------------------------------------------+-- * Interaction Callback+---------------------------------------------------------------------------++-- | Callback fuction to call when there is a response+--   to give to the interactive frontend.+--+--   Note that the response is given in pieces and incrementally,+--   so the user can have timely response even during long computations.+--+--   Typical 'InteractionOutputCallback' functions:+--+--    * Convert the response into a 'String' representation and+--      print it on standard output+--      (suitable for inter-process communication).+--+--    * Put the response into a mutable variable stored in the+--      closure of the 'InteractionOutputCallback' function.+--      (suitable for intra-process communication).++type InteractionOutputCallback = Response_boot TCErr TCWarning WarningsAndNonFatalErrors -> TCM ()++-- | The default 'InteractionOutputCallback' function prints certain+-- things to stdout (other things generate internal errors).++defaultInteractionOutputCallback :: InteractionOutputCallback+defaultInteractionOutputCallback = \case+  Resp_HighlightingInfo {}  -> __IMPOSSIBLE__+  Resp_Status {}            -> __IMPOSSIBLE__+  Resp_JumpToError {}       -> __IMPOSSIBLE__+  Resp_InteractionPoints {} -> __IMPOSSIBLE__+  Resp_GiveAction {}        -> __IMPOSSIBLE__+  Resp_MakeCase {}          -> __IMPOSSIBLE__+  Resp_SolveAll {}          -> __IMPOSSIBLE__+  Resp_Mimer {}             -> __IMPOSSIBLE__+  Resp_DisplayInfo {}       -> __IMPOSSIBLE__+  Resp_RunningInfo _ s      -> liftIO $ do+                                 putStr s+                                 hFlush stdout+  Resp_ClearRunningInfo {}  -> __IMPOSSIBLE__+  Resp_ClearHighlighting {} -> __IMPOSSIBLE__+  Resp_DoneAborting {}      -> __IMPOSSIBLE__+  Resp_DoneExiting {}       -> __IMPOSSIBLE__++---------------------------------------------------------------------------+-- * Names for generated definitions+---------------------------------------------------------------------------++-- | Base name for patterns in telescopes+patternInTeleName :: String+patternInTeleName = ".patternInTele"++-- | Base name for extended lambda patterns+extendedLambdaName :: String+extendedLambdaName = ".extendedlambda"++-- | Check whether we have an definition from an extended lambda.+isExtendedLambdaName :: A.QName -> Bool+isExtendedLambdaName = (extendedLambdaName `List.isPrefixOf`) . prettyShow . nameConcrete . qnameName++-- | Name of absurdLambda definitions.+absurdLambdaName :: String+absurdLambdaName = ".absurdlambda"++-- | Check whether we have an definition from an absurd lambda.+isAbsurdLambdaName :: QName -> Bool+isAbsurdLambdaName = (absurdLambdaName ==) . prettyShow . qnameName++-- | Base name for generalized variable projections+generalizedFieldName :: String+generalizedFieldName = ".generalizedField-"++-- | Check whether we have a generalized variable field+getGeneralizedFieldName :: A.QName -> Maybe String+getGeneralizedFieldName = List.stripPrefix generalizedFieldName . prettyShow . nameConcrete . qnameName++---------------------------------------------------------------------------+-- * KillRange instances+---------------------------------------------------------------------------++instance KillRange Signature where+  killRange (Sig secs defs rews inst) = killRangeN Sig secs defs rews inst++instance KillRange InstanceTable where+  killRange (InstanceTable tree count) = killRangeN InstanceTable tree count++instance KillRange Sections where+  killRange = fmap killRange++instance KillRange Definitions where+  killRange = fmap killRange++instance KillRange RewriteRuleMap where+  killRange = fmap killRange++instance KillRange Section where+  killRange (Section tel) = killRangeN Section tel++instance KillRange InstanceInfo where+  killRange :: KillRangeT InstanceInfo+  killRange (InstanceInfo a b) = killRangeN InstanceInfo a b++instance KillRange Definition where+  killRange (Defn ai name t pols occs gpars displ mut compiled inst copy ma nc inj copat blk lang def) =+    killRangeN Defn ai name t pols occs gpars displ mut compiled inst copy ma nc inj copat blk lang def+    -- TODO clarify: Keep the range in the defName field?++instance KillRange NumGeneralizableArgs where+  killRange = id++instance KillRange NLPat where+  killRange (PVar x y) = killRangeN PVar x y+  killRange (PDef x y) = killRangeN PDef x y+  killRange (PLam x y) = killRangeN PLam x y+  killRange (PPi x y)  = killRangeN PPi x y+  killRange (PSort x)  = killRangeN PSort x+  killRange (PBoundVar x y) = killRangeN PBoundVar x y+  killRange (PTerm x)  = killRangeN PTerm x++instance KillRange NLPType where+  killRange (NLPType s a) = killRangeN NLPType s a++instance KillRange NLPSort where+  killRange (PUniv u l) = killRangeN (PUniv u) l+  killRange s@(PInf f n) = s+  killRange PSizeUniv = PSizeUniv+  killRange PLockUniv = PLockUniv+  killRange PLevelUniv = PLevelUniv+  killRange PIntervalUniv = PIntervalUniv++instance KillRange RewriteRule where+  killRange (RewriteRule q gamma f es rhs t c top) =+    killRangeN RewriteRule q gamma f es rhs t c top++instance KillRange CompiledRepresentation where+  killRange = id+++instance KillRange EtaEquality where+  killRange = id++instance KillRange System where+  killRange (System tel sys) = System (killRange tel) (killRange sys)++instance KillRange ExtLamInfo where+  killRange (ExtLamInfo m b sys) = killRangeN ExtLamInfo m b sys++instance KillRange FunctionFlag where+  killRange = id++instance KillRange CompKit where+  killRange = id++instance KillRange ProjectionLikenessMissing where+  killRange = id++instance KillRange BuiltinSort where+  killRange = id++instance KillRange Defn where+  killRange def =+    case def of+      Axiom a -> Axiom a+      DataOrRecSig n -> DataOrRecSig n+      GeneralizableVar a -> GeneralizableVar a+      AbstractDefn{} -> __IMPOSSIBLE__ -- only returned by 'getConstInfo'!+      Function a b c d e f g h i j k l m n ->+        killRangeN Function a b c d e f g h i j k l m n+      Datatype a b c d e f g h i j   -> killRangeN Datatype a b c d e f g h i j+      Record a b c d e f g h i j k l m -> killRangeN Record a b c d e f g h i j k l m+      Constructor a b c d e f g h i j k -> killRangeN Constructor a b c d e f g h i j k+      Primitive a b c d e f          -> killRangeN Primitive a b c d e f+      PrimitiveSort a b              -> killRangeN PrimitiveSort a b++instance KillRange MutualId where+  killRange = id++instance KillRange c => KillRange (FunctionInverse' c) where+  killRange NotInjective = NotInjective+  killRange (Inverse m)  = Inverse $ killRangeMap m++instance KillRange TermHead where+  killRange SortHead     = SortHead+  killRange PiHead       = PiHead+  killRange (ConsHead q) = ConsHead $ killRange q+  killRange h@VarHead{}  = h+  killRange UnknownHead  = UnknownHead++instance KillRange Projection where+  killRange (Projection a b c d e) = killRangeN Projection a b c d e++instance KillRange ProjLams where+  killRange = id++instance KillRange a => KillRange (Open a) where+  killRange = fmap killRange++instance KillRange DisplayForm where+  killRange (Display n es dt) = killRangeN Display n es dt++instance KillRange Polarity where+  killRange = id++instance KillRange IsForced where+  killRange = id++instance KillRange DoGeneralize where+  killRange = id++instance KillRange DisplayTerm where+  killRange dt =+    case dt of+      DWithApp dt dts es -> killRangeN DWithApp dt dts es+      DCon q ci dts      -> killRangeN DCon q ci dts+      DDef q dts         -> killRangeN DDef q dts+      DDot' v es         -> killRangeN DDot' v es+      DTerm' v es        -> killRangeN DTerm' v es++instance KillRange a => KillRange (Closure a) where+  killRange = id++---------------------------------------------------------------------------+-- NFData instances+---------------------------------------------------------------------------++instance NFData NumGeneralizableArgs where+  rnf NoGeneralizableArgs       = ()+  rnf (SomeGeneralizableArgs _) = ()++instance NFData TCErr where+  rnf (TypeError a b c)   = rnf a `seq` rnf b `seq` rnf c+  rnf (ParserError a)     = rnf a+  rnf (GenericException a)= rnf a+  rnf (IOException a b c) = rnf a `seq` rnf b `seq` rnf (c == c)+                            -- At the time of writing there is no+                            -- NFData instance for E.IOException.+  rnf (PatternErr a)      = rnf a++-- | This instance could be optimised, some things are guaranteed to+-- be forced.++instance NFData PreScopeState++-- | This instance could be optimised, some things are guaranteed to+-- be forced.++instance NFData PostScopeState++instance NFData TCState+instance NFData DisambiguatedName+instance NFData MutualBlock+instance NFData OpaqueBlock+instance NFData (BiMap RawTopLevelModuleName ModuleNameHash)+instance NFData PersistentTCState+instance NFData SessionTCState+instance NFData LoadedFileCache+instance NFData TypeCheckAction+instance NFData ModuleCheckMode+instance NFData ModuleInfo+instance NFData ForeignCode+instance NFData Interface+instance NFData a => NFData (Closure a)+instance NFData ProblemConstraint+instance NFData WhyCheckModality+instance NFData Constraint+instance NFData Signature+instance NFData InstanceTable+instance NFData Comparison+instance NFData CompareAs+instance NFData a => NFData (Open a)+instance NFData a => NFData (Judgement a)+instance NFData DoGeneralize+instance NFData GeneralizedValue+instance NFData MetaVariable+instance NFData Listener+instance NFData MetaInstantiation+instance NFData Instantiation+instance NFData RemoteMetaVariable+instance NFData Frozen+instance NFData PrincipalArgTypeMetas+instance NFData TypeCheckingProblem+instance NFData RunMetaOccursCheck+instance NFData MetaInfo+instance NFData InteractionPoint+instance NFData InteractionPoints+instance NFData Overapplied+instance NFData t => NFData (IPBoundary' t)+instance NFData IPClause+instance NFData DisplayForm+instance NFData DisplayTerm+instance NFData NLPat+instance NFData NLPType+instance NFData NLPSort+instance NFData RewriteRule+instance NFData InstanceInfo+instance NFData Definition+instance NFData Polarity+instance NFData IsForced+instance NFData Projection+instance NFData ProjLams+instance NFData CompilerPragma+instance NFData System+instance NFData ExtLamInfo+instance NFData EtaEquality+instance NFData FunctionFlag+instance NFData CompKit+instance NFData AxiomData+instance NFData DataOrRecSigData+instance NFData ProjectionLikenessMissing+instance NFData FunctionData+instance NFData DatatypeData+instance NFData RecordData+instance NFData ConstructorData+instance NFData PrimitiveData+instance NFData PrimitiveSortData+instance NFData Defn+instance NFData Simplification+instance NFData AllowedReduction+instance NFData ReduceDefs+instance NFData PrimFun+instance NFData c => NFData (FunctionInverse' c)+instance NFData TermHead+instance NFData Call+instance NFData BuiltinSort+instance NFData pf => NFData (Builtin pf)+instance NFData HighlightingLevel+instance NFData HighlightingMethod+instance NFData TCEnv+instance NFData LetBinding+instance NFData UnquoteFlags+instance NFData AbstractMode+instance NFData ExpandHidden+instance NFData CandidateKind+instance NFData Candidate+instance NFData Warning+instance NFData RecordFieldWarning+instance NFData TCWarning+instance NFData CallInfo+instance NFData TerminationError+instance NFData SplitError+instance NFData NegativeUnification+instance NFData UnificationFailure+instance NFData UnquoteError+instance NFData TypeError+instance NFData WhyInvalidInstanceType+instance NFData InvalidFileNameReason+instance NFData LHSOrPatSyn+instance NFData InductionAndEta+instance NFData IllegalRewriteRuleReason+instance NFData IncorrectTypeForRewriteRelationReason+instance NFData GHCBackendError+instance NFData JSBackendError+instance NFData MissingTypeSignatureInfo+instance NFData WhyNotAHaskellType+instance NFData InteractionError+instance NFData IsAmbiguous+instance NFData CannotQuote+instance NFData ExecError+instance NFData ConstructorDisambiguationData
− src/full/Agda/TypeChecking/Monad/Base.hs-boot 
@@ -1,51 +0,0 @@-{-# LANGUAGE CPP #-}--module Agda.TypeChecking.Monad.Base where--import Control.Monad.IO.Class (MonadIO)-import Data.IORef (IORef)-import Data.Map (Map)--import Agda.Syntax.Common (Nat)-import Agda.Syntax.Concrete.Name (TopLevelModuleName)-import Agda.Utils.FileName (AbsolutePath)--data Warning--data TCErr-data TCWarning-data NamedMeta-data HighlightingMethod-instance Show HighlightingMethod-instance Read HighlightingMethod--data HighlightingLevel-instance Show HighlightingLevel-instance Read HighlightingLevel---data TCEnv-data TCState-newtype TCMT m a = TCM { unTCM :: IORef TCState -> TCEnv -> m a }--instance Applicative m => Applicative (TCMT m)-instance Functor m => Functor (TCMT m)-instance MonadIO m => MonadIO (TCMT m)--#if __GLASGOW_HASKELL__ < 808-instance MonadIO m => Monad (TCMT m) where-#else--- Andreas, 2022-02-02, issue #5659:--- @transformers-0.6@ requires exactly a @Monad@ superclass constraint here--- if we want @instance MonadTrans TCMT@.-instance Monad m => Monad (TCMT m) where-#endif--type TCM = TCMT IO--type ModuleToSource = Map TopLevelModuleName AbsolutePath--type BackendName = String--data Comparison-data Polarity
+ src/full/Agda/TypeChecking/Monad/Base/Types.hs view
@@ -0,0 +1,204 @@+-- | Data structures for the type checker.+--+-- Part of "Agda.TypeChecking.Monad.Base", extracted to avoid import cycles.++module Agda.TypeChecking.Monad.Base.Types+  ( module Agda.TypeChecking.Monad.Base.Types+  , module X+  )+where++import Prelude hiding (null)++import Control.DeepSeq                ( NFData )+import Data.EnumMap                   ( EnumMap )+import Data.Functor                   ( (<&>) )+import Data.Map                       ( Map )+import GHC.Generics                   ( Generic )++import Agda.Syntax.Common+  ( LensArgInfo(..), LensCohesion, LensHiding, LensModality, LensOrigin, LensQuantity, LensRelevance, LensModalPolarity )++import Agda.Syntax.Info               ( MetaNameSuggestion )+import Agda.Syntax.Internal           ( Dom, MetaId, Name, Type )+import Agda.Syntax.TopLevelModuleName as X ( TopLevelModuleName )++import Agda.Utils.FileId              as X ( FileId, FileDictBuilder )+import Agda.Utils.FileName            as X ( AbsolutePath )+import Agda.Utils.Lens                ( Lens', (&&&), iso )+import Agda.Utils.Null                ( Null(..) )+++---------------------------------------------------------------------------+-- * Context+---------------------------------------------------------------------------++-- | The @Context@ is a stack of 'ContextEntry's.+type Context = [ContextEntry]++data ContextEntry+  = CtxVar+    { ceName :: Name+    , ceType :: Dom Type+    }+  -- N.B. 2024-11-29 there might be CtxLet in the future.+  deriving (Show, Generic)++instance LensArgInfo ContextEntry where+  getArgInfo (CtxVar _ a) = getArgInfo a+  mapArgInfo f (CtxVar x a) = CtxVar x $ mapArgInfo f a++instance LensModality  ContextEntry+instance LensRelevance ContextEntry+instance LensCohesion  ContextEntry+instance LensOrigin    ContextEntry+instance LensQuantity  ContextEntry+instance LensHiding    ContextEntry+instance LensModalPolarity ContextEntry++---------------------------------------------------------------------------+-- * Conversion+---------------------------------------------------------------------------++data Comparison = CmpEq | CmpLeq+  deriving (Eq, Show, Generic)++-- | Polarity for equality and subtype checking.+data Polarity+  = Covariant      -- ^ monotone+  | Contravariant  -- ^ antitone+  | Invariant      -- ^ no information (mixed variance)+  | Nonvariant     -- ^ constant+  deriving (Show, Eq, Generic)++---------------------------------------------------------------------------+-- * Cubical+---------------------------------------------------------------------------++-- | Datatype representing a single boundary condition:+--   x_0 = u_0, ... ,x_n = u_n ⊢ t = ?n es+data IPFace' t = IPFace'+  { faceEqns :: [(t, t)]+  , faceRHS  :: t+  }++---------------------------------------------------------------------------+-- * Highlighting+---------------------------------------------------------------------------++-- | How much highlighting should be sent to the user interface?++data HighlightingLevel+  = None+  | NonInteractive+  | Interactive+    -- ^ This includes both non-interactive highlighting and+    -- interactive highlighting of the expression that is currently+    -- being type-checked.+    deriving (Eq, Ord, Show, Read, Generic)++-- | How should highlighting be sent to the user interface?++data HighlightingMethod+  = Direct+    -- ^ Via stdout.+  | Indirect+    -- ^ Both via files and via stdout.+    deriving (Eq, Show, Read, Generic)++---------------------------------------------------------------------------+-- * Managing file names+---------------------------------------------------------------------------++-- | Discern Agda's primitive modules from other file modules.+--   @IsPrimitiveModule `implies` IsBuiltinModuleWithSafePostulate `implies` isBuiltinModule.++--   Keep constructors in this order!+data IsBuiltinModule+  = IsPrimitiveModule+      -- ^ Very magical module, e.g. @Agda.Primitive@.+  | IsBuiltinModuleWithSafePostulates+      -- ^ Safe module, e.g. @Agda.Builtin.Equality@.+  | IsBuiltinModule+      -- ^ Any builtin module.+  deriving (Eq, Ord, Show, Generic)++-- | Collection of 'FileId's of primitive modules.++type BuiltinModuleIds = EnumMap FileId IsBuiltinModule++-- | Translation between 'AbsolutePath' and 'FileId' that also knows about Agda's builtin modules.++data FileDictWithBuiltins = FileDictWithBuiltins+  { fileDictBuilder  :: !FileDictBuilder+      -- ^ (Building a) translation between 'AbsolutePath' and 'FileId'.+  , builtinModuleIds :: !BuiltinModuleIds+      -- ^ For the known 'FileId's, remember whether they refer to Agda's builtin modules.+  , primitiveLibDir  :: !PrimitiveLibDir+      -- ^ The absolute path to the directory with the builtin modules.+      --   Needs to be set upon initialization.+  }+  deriving Generic++type PrimitiveLibDir = AbsolutePath++-- | 'SourceFile's must exist and be registered in our file dictionary.++newtype SourceFile = SourceFile { srcFileId :: FileId }+  deriving (Eq, Ord, Show, Generic)++-- | Maps top-level module names to the corresponding source file ids.++type ModuleToSourceId = Map TopLevelModuleName SourceFile++data ModuleToSource = ModuleToSource+  { fileDict         :: !FileDictWithBuiltins+  , moduleToSourceId :: !ModuleToSourceId+  }++-- ** Lenses++lensFileDictFileDictBuilder :: Lens' FileDictWithBuiltins FileDictBuilder+lensFileDictFileDictBuilder f s = f (fileDictBuilder s) <&> \ x -> s { fileDictBuilder = x }++lensFileDictBuiltinModuleIds :: Lens' FileDictWithBuiltins BuiltinModuleIds+lensFileDictBuiltinModuleIds f s = f (builtinModuleIds s) <&> \ x -> s { builtinModuleIds = x }++lensFileDictPrimitiveLibDir :: Lens' FileDictWithBuiltins PrimitiveLibDir+lensFileDictPrimitiveLibDir f s = f (primitiveLibDir s) <&> \ x -> s { primitiveLibDir = x }++lensPairModuleToSource :: Lens' (FileDictWithBuiltins, ModuleToSourceId) ModuleToSource+lensPairModuleToSource = iso (uncurry ModuleToSource) (fileDict &&& moduleToSourceId)++---------------------------------------------------------------------------+-- * Meta variables+---------------------------------------------------------------------------++-- | For printing, we couple a meta with its name suggestion.+data NamedMeta = NamedMeta+  { nmSuggestion :: MetaNameSuggestion+  , nmid         :: MetaId+  }++++-- Feel free to move more types from Agda.TypeChecking.Monad.Base here when needed...++-- Null instances++-- Andreas, 2024-11-10: Let's not have these instances because there is no default primLibDir:+--+-- instance Null FileDictWithBuiltins where+--   empty = FileDictWithBuiltins empty empty __IMPOSSIBLE__+--   null (FileDictWithBuiltins a b _primLibDir) = null a && null b+--+-- instance Null ModuleToSource where+--   empty = ModuleToSource empty empty+--   null (ModuleToSource dict m2s) = null dict && null m2s++-- NFData instances++instance NFData ContextEntry+instance NFData FileDictWithBuiltins+instance NFData SourceFile+instance NFData IsBuiltinModule
+ src/full/Agda/TypeChecking/Monad/Base/Warning.hs view
@@ -0,0 +1,29 @@+-- | Types related to warnings raised by Agda.++module Agda.TypeChecking.Monad.Base.Warning where++import           Control.DeepSeq            (NFData)+import           GHC.Generics               (Generic)++import           Agda.Syntax.Abstract.Name+import           Agda.Syntax.Position       (Range)+import qualified Agda.Syntax.Concrete.Name  as C++import           Agda.Utils.List1           (List1)++data RecordFieldWarning+  = DuplicateFields (List1 (C.Name, Range))+      -- ^ Each redundant field comes with a range of associated dead code.+  | TooManyFields QName [C.Name] (List1 (C.Name, Range))+      -- ^ Record type, fields not supplied by user, non-fields but supplied.+      --   The redundant fields come with a range of associated dead code.+  deriving (Show, Generic)++data UselessPublicReason+  = UselessPublicPreamble+  | UselessPublicLet+  | UselessPublicNoOpen+  | UselessPublicAnonymousModule+  deriving (Show, Generic, Enum, Bounded)++instance NFData UselessPublicReason
src/full/Agda/TypeChecking/Monad/Benchmark.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Measure CPU time for individual phases of the Agda pipeline.  module Agda.TypeChecking.Monad.Benchmark@@ -21,27 +23,10 @@ import qualified Agda.Utils.Benchmark as B  import Agda.Utils.Monad-import Agda.Utils.Pretty (prettyShow)--benchmarkKey :: String-benchmarkKey = "profile"--benchmarkLevel :: Int-benchmarkLevel = 7--benchmarkModulesKey :: String-benchmarkModulesKey = "profile.modules"--benchmarkModulesLevel :: Int-benchmarkModulesLevel = 10--benchmarkDefsKey :: String-benchmarkDefsKey = "profile.definitions"--benchmarkDefsLevel :: Int-benchmarkDefsLevel = 10+import Agda.Syntax.Common.Pretty (prettyShow)+import qualified Agda.Utils.ProfileOptions as Profile --- | When verbosity is set or changes, we need to turn benchmarking on or off.+-- | When profile options are set or changed, we need to turn benchmarking on or off. updateBenchmarkingStatus :: TCM () -- {-# SPECIALIZE updateBenchmarkingStatus :: TCM () #-} -- updateBenchmarkingStatus :: (HasOptions m, MonadBench a m) => m ()@@ -51,20 +36,14 @@ -- | Check whether benchmarking is activated. {-# SPECIALIZE benchmarking :: TCM (B.BenchmarkOn Phase) #-} benchmarking :: MonadTCM tcm => tcm (B.BenchmarkOn Phase)-benchmarking = liftTCM $ do-  -- Ulf, 2016-12-13: Using verbosity levels to control the type of-  -- benchmarking isn't ideal, but let's stick with it for now.-  internal <- hasVerbosity benchmarkKey benchmarkLevel-  defs     <- hasVerbosity benchmarkDefsKey benchmarkDefsLevel-  modules  <- hasVerbosity benchmarkModulesKey benchmarkModulesLevel-  return $ case (internal, defs, modules) of-    (True, _, _) -> B.BenchmarkSome isInternalAccount-    (_, True, _) -> B.BenchmarkSome isDefAccount-    (_, _, True) -> B.BenchmarkSome isModuleAccount-    _            -> B.BenchmarkOff+benchmarking = liftTCM $+  ifM (hasProfileOption Profile.Internal)    (pure $ B.BenchmarkSome isInternalAccount) $+  ifM (hasProfileOption Profile.Definitions) (pure $ B.BenchmarkSome isDefAccount) $+  ifM (hasProfileOption Profile.Modules)     (pure $ B.BenchmarkSome isModuleAccount) $+  pure B.BenchmarkOff  -- | Prints the accumulated benchmark results. Does nothing if--- profiling is not activated at level 2.+--   no benchmark profiling is enabled. print :: MonadTCM tcm => tcm () print = liftTCM $ whenM (B.isBenchmarkOn [] <$> benchmarking) $ do   b <- B.getBenchmark@@ -76,9 +55,8 @@   -- Ulf, 2020-03-04: Using benchmarkLevel here means that it only prints if internal benchmarking   -- is turned on, effectively making module/definition benchmarking impossible (since internal   -- takes precedence). It needs to be > 1 to avoid triggering #2602 though. Also use-  -- displayDebugMessage instead of reportSLn to avoid requiring -v profile:2 in addition to the-  -- specific profile levels.-  displayDebugMessage benchmarkKey 2 $ prettyShow b+  -- displayDebugMessage instead of reportSLn to avoid requiring -v profile:2.+  displayDebugMessage "profile" 2 $ prettyShow b  -- -- | Bill a computation to a specific account. -- {-# SPECIALIZE billTo :: Account -> TCM a -> TCM a #-}
src/full/Agda/TypeChecking/Monad/Builtin.hs view
@@ -4,19 +4,17 @@   , module Agda.Syntax.Builtin  -- The names are defined here.   ) where -import qualified Control.Monad.Fail as Fail--import Control.Monad                ( liftM2, void )-import Control.Monad.Except+import Control.Monad.Except         ( MonadError(..), ExceptT ) import Control.Monad.IO.Class       ( MonadIO(..) )-import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Trans.Identity (IdentityT)+import Control.Monad.Reader         ( ReaderT )+import Control.Monad.State          ( StateT )+import Control.Monad.Trans.Identity ( IdentityT ) import Control.Monad.Trans.Maybe-import Control.Monad.Writer+import Control.Monad.Writer         ( WriterT ) -import qualified Data.Map as Map import Data.Function ( on )+import qualified Data.Map as Map+import Data.Set (Set)  import Agda.Syntax.Common import Agda.Syntax.Position@@ -27,22 +25,27 @@ -- import Agda.TypeChecking.Functions  -- LEADS TO IMPORT CYCLE import Agda.TypeChecking.Substitute +import Agda.Utils.Functor+import Agda.Utils.Lens import Agda.Utils.ListT import Agda.Utils.Monad import Agda.Utils.Maybe+import Agda.Utils.Singleton import Agda.Utils.Tuple+import Agda.Utils.Update  import Agda.Utils.Impossible  class ( Functor m       , Applicative m-      , Fail.MonadFail m+      , Monad m       ) => HasBuiltins m where-  getBuiltinThing :: String -> m (Maybe (Builtin PrimFun))+  getBuiltinThing :: SomeBuiltin -> m (Maybe (Builtin PrimFun)) -  default getBuiltinThing :: (MonadTrans t, HasBuiltins n, t n ~ m) => String -> m (Maybe (Builtin PrimFun))+  default getBuiltinThing :: (MonadTrans t, HasBuiltins n, t n ~ m) => SomeBuiltin -> m (Maybe (Builtin PrimFun))   getBuiltinThing = lift . getBuiltinThing +instance HasBuiltins m => HasBuiltins (ChangeT m) instance HasBuiltins m => HasBuiltins (ExceptT e m) instance HasBuiltins m => HasBuiltins (IdentityT m) instance HasBuiltins m => HasBuiltins (ListT m)@@ -54,9 +57,34 @@ deriving instance HasBuiltins m => HasBuiltins (BlockT m)  instance MonadIO m => HasBuiltins (TCMT m) where-  getBuiltinThing b = liftM2 mplus (Map.lookup b <$> useTC stLocalBuiltins)-                      (Map.lookup b <$> useTC stImportedBuiltins)+  getBuiltinThing b =+    liftM2 (unionMaybeWith unionBuiltin)+      (Map.lookup b <$> useTC stLocalBuiltins)+      (Map.lookup b <$> useTC stImportedBuiltins)+{-# SPECIALIZE getBuiltinThing :: SomeBuiltin -> TCM (Maybe (Builtin PrimFun)) #-} ++-- | The trivial implementation of 'HasBuiltins', using a constant 'TCState'.+--+-- This may be used instead of 'TCMT'/'ReduceM' where builtins must be accessed+-- in a pure context.+newtype BuiltinAccess a = BuiltinAccess { unBuiltinAccess :: TCState -> a }+  deriving (Functor, Applicative, Monad)++instance MonadFail BuiltinAccess where+  fail msg = BuiltinAccess $ \_ -> error msg++instance HasBuiltins BuiltinAccess where+  getBuiltinThing b = BuiltinAccess $ \state ->+    unionMaybeWith unionBuiltin+      (Map.lookup b $ state ^. stLocalBuiltins)+      (Map.lookup b $ state ^. stImportedBuiltins)++-- | Run a 'BuiltinAccess' monad.+runBuiltinAccess :: TCState -> BuiltinAccess a -> a+runBuiltinAccess s m = unBuiltinAccess m s++ -- If Agda is changed so that the type of a literal can belong to an -- inductive family (with at least one index), then the implementation -- of split' in Agda.TypeChecking.Coverage should be changed.@@ -78,68 +106,121 @@   where     el t = El (mkType 0) t -setBuiltinThings :: BuiltinThings PrimFun -> TCM ()+setBuiltinThings :: BuiltinThings -> TCM () setBuiltinThings b = stLocalBuiltins `setTCLens` b -bindBuiltinName :: String -> Term -> TCM ()+bindBuiltinName :: BuiltinId -> Term -> TCM () bindBuiltinName b x = do-  builtin <- getBuiltinThing b+  builtin <- getBuiltinThing b'   case builtin of     Just (Builtin y) -> typeError $ DuplicateBuiltinBinding b y x-    Just (Prim _)    -> typeError $ NoSuchBuiltinName b-    Nothing          -> stLocalBuiltins `modifyTCLens` Map.insert b (Builtin x)+    Just Prim{}      -> typeError $ __IMPOSSIBLE__+    Just BuiltinRewriteRelations{} -> __IMPOSSIBLE__+    Nothing          -> stLocalBuiltins `modifyTCLens` Map.insert b' (Builtin x)+  where b' = BuiltinName b -bindPrimitive :: String -> PrimFun -> TCM ()+bindPrimitive :: PrimitiveId -> PrimFun -> TCM () bindPrimitive b pf = do-  builtin <- getBuiltinThing b+  builtin <- getBuiltinThing b'   case builtin of-    Just (Builtin _) -> typeError $ NoSuchPrimitiveFunction b+    Just (Builtin _) -> typeError $ NoSuchPrimitiveFunction (getBuiltinId b)     Just (Prim x)    -> typeError $ (DuplicatePrimitiveBinding b `on` primFunName) x pf-    Nothing          -> stLocalBuiltins `modifyTCLens` Map.insert b (Prim pf)+    Just BuiltinRewriteRelations{} -> __IMPOSSIBLE__+    Nothing          -> stLocalBuiltins `modifyTCLens` Map.insert b' (Prim pf)+  where b' = PrimitiveName b -getBuiltin :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)-           => String -> m Term+-- | Add one (more) relation symbol to the rewrite relations.+bindBuiltinRewriteRelation :: QName -> TCM ()+bindBuiltinRewriteRelation x =+  stLocalBuiltins `modifyTCLens`+    Map.insertWith unionBuiltin (BuiltinName builtinRewrite) (BuiltinRewriteRelations $ singleton x)++-- | Get the currently registered rewrite relation symbols.+getBuiltinRewriteRelations :: (HasBuiltins m, MonadTCError m) => m (Set QName)+getBuiltinRewriteRelations =+  fromMaybeM (typeError $ NoBindingForBuiltin builtinRewrite) getBuiltinRewriteRelations'++-- | Get the currently registered rewrite relation symbols, if any.+getBuiltinRewriteRelations' :: HasBuiltins m => m (Maybe (Set QName))+getBuiltinRewriteRelations' = fmap rels <$> getBuiltinThing (BuiltinName builtinRewrite)+  where+  rels = \case+    BuiltinRewriteRelations xs -> xs+    Prim{}    -> __IMPOSSIBLE__+    Builtin{} -> __IMPOSSIBLE__++{-# INLINABLE getBuiltinName_ #-}+getBuiltinName_ :: (HasBuiltins m, MonadTCError m)+  => BuiltinId -> m QName+getBuiltinName_ x =+  fromMaybeM (typeError $ NoBindingForBuiltin x) $ getBuiltinName' x++-- {-# INLINABLE getBuiltinName' #-}+-- -- | Returns 'Nothing' if built-in is not bound or bound to a 'Prim' or anything other than a 'Def'.+-- getBuiltinName' :: HasBuiltins m => BuiltinId -> m (Maybe Term)+-- getBuiltinName' x = (getBuiltinName =<<) <$> getBuiltin' x+--   where+--     getBuiltinName = \case+--       Def f [] -> Just f+--       _        -> Nothing++{-# INLINABLE getBuiltin #-}+getBuiltin :: (HasBuiltins m, MonadTCError m)+           => BuiltinId -> m Term getBuiltin x =   fromMaybeM (typeError $ NoBindingForBuiltin x) $ getBuiltin' x -getBuiltin' :: HasBuiltins m => String -> m (Maybe Term)-getBuiltin' x = do-    builtin <- getBuiltinThing x-    case builtin of-        Just (Builtin t) -> return $ Just $ killRange t-        _                -> return Nothing+{-# INLINABLE getBuiltin' #-}+-- | Returns 'Nothing' if built-in is not bound or bound to a 'Prim'.+getBuiltin' :: HasBuiltins m => BuiltinId -> m (Maybe Term)+getBuiltin' x = (getBuiltin =<<) <$> getBuiltinThing (BuiltinName x)+  where+    getBuiltin = \case+      Builtin t                 -> Just $ killRange t+      Prim{}                    -> Nothing+      BuiltinRewriteRelations{} -> __IMPOSSIBLE__ -getPrimitive' :: HasBuiltins m => String -> m (Maybe PrimFun)-getPrimitive' x = (getPrim =<<) <$> getBuiltinThing x+{-# INLINABLE getPrimitive' #-}+-- | Returns 'Nothing' if primitive is not bound or bound to a 'Builtin'.+getPrimitive' :: HasBuiltins m => PrimitiveId -> m (Maybe PrimFun)+getPrimitive' x = (getPrim =<<) <$> getBuiltinThing (PrimitiveName x)   where-    getPrim (Prim pf) = return pf-    getPrim _         = Nothing+    getPrim = \case+      Prim pf                   -> return pf+      Builtin{}                 -> Nothing+      BuiltinRewriteRelations{} -> __IMPOSSIBLE__ +{-# INLINABLE getPrimitive #-} getPrimitive :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)-             => String -> m PrimFun+             => PrimitiveId -> m PrimFun getPrimitive x =-  fromMaybeM (typeError $ NoSuchPrimitiveFunction x) $ getPrimitive' x+  fromMaybeM (typeError . NoSuchPrimitiveFunction $ getBuiltinId x) $ getPrimitive' x  getPrimitiveTerm :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)-                 => String -> m Term+                 => PrimitiveId -> m Term getPrimitiveTerm x = (`Def` []) . primFunName <$> getPrimitive x -getPrimitiveTerm' :: HasBuiltins m => String -> m (Maybe Term)++getPrimitiveTerm' :: HasBuiltins m => PrimitiveId -> m (Maybe Term) getPrimitiveTerm' x = fmap (`Def` []) <$> getPrimitiveName' x -getTerm' :: HasBuiltins m => String -> m (Maybe Term)-getTerm' x = mplus <$> getBuiltin' x <*> getPrimitiveTerm' x+getTerm' :: (HasBuiltins m, IsBuiltin a) => a -> m (Maybe Term)+getTerm' = go . someBuiltin where+  go (BuiltinName x)   = getBuiltin' x+  go (PrimitiveName x) = getPrimitiveTerm' x -getName' :: HasBuiltins m => String -> m (Maybe QName)-getName' x = mplus <$> getBuiltinName' x <*> getPrimitiveName' x+getName' :: (HasBuiltins m, IsBuiltin a) => a -> m (Maybe QName)+getName' = go . someBuiltin where+  go (BuiltinName x)   = getBuiltinName' x+  go (PrimitiveName x) = getPrimitiveName' x  -- | @getTerm use name@ looks up @name@ as a primitive or builtin, and -- throws an error otherwise. -- The @use@ argument describes how the name is used for the sake of -- the error message.-getTerm :: (HasBuiltins m) => String -> String -> m Term+getTerm :: (HasBuiltins m, IsBuiltin a) => String -> a -> m Term getTerm use name = flip fromMaybeM (getTerm' name) $-  return $! throwImpossible (ImpMissingDefinitions [name] use)+  return $! throwImpossible (ImpMissingDefinitions [getBuiltinId name] use)   -- | Rewrite a literal to constructor form if possible.@@ -149,6 +230,8 @@       pSuc  = fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSuc   constructorForm' pZero pSuc v +{-# INLINABLE constructorForm' #-}+{-# SPECIALIZE constructorForm' :: TCM Term -> TCM Term -> Term -> TCM Term #-} constructorForm' :: Applicative m => m Term -> m Term -> Term -> m Term constructorForm' pZero pSuc v =   case v of@@ -166,12 +249,11 @@     primFloat, primChar, primString, primUnit, primUnitUnit, primBool, primTrue, primFalse,     primSigma,     primList, primNil, primCons, primIO, primNat, primSuc, primZero, primMaybe, primNothing, primJust,-    primPath, primPathP, primInterval, primIZero, primIOne, primPartial, primPartialP,+    primPath, primPathP, primIntervalUniv, primInterval, primIZero, primIOne, primPartial, primPartialP,     primIMin, primIMax, primINeg,     primIsOne, primItIsOne, primIsOne1, primIsOne2, primIsOneEmpty,     primSub, primSubIn, primSubOut,     primTrans, primHComp,-    primId, primConId, primIdElim,     primEquiv, primEquivFun, primEquivProof,     primTranspProof,     primGlue, prim_glue, prim_unglue,@@ -184,16 +266,16 @@     primSizeUniv, primSize, primSizeLt, primSizeSuc, primSizeInf, primSizeMax,     primInf, primSharp, primFlat,     primEquality, primRefl,-    primRewrite, -- Name of rewrite relation     primLevel, primLevelZero, primLevelSuc, primLevelMax,     primLockUniv,-    primSet, primProp, primSetOmega, primStrictSet, primSSetOmega,+    primLevelUniv,+    primProp, primSet, primStrictSet, primPropOmega, primSetOmega, primSSetOmega,     primFromNat, primFromNeg, primFromString,     -- builtins for reflection:     primQName, primArgInfo, primArgArgInfo, primArg, primArgArg, primAbs, primAbsAbs, primAgdaTerm, primAgdaTermVar,     primAgdaTermLam, primAgdaTermExtLam, primAgdaTermDef, primAgdaTermCon, primAgdaTermPi,     primAgdaTermSort, primAgdaTermLit, primAgdaTermUnsupported, primAgdaTermMeta,-    primAgdaErrorPart, primAgdaErrorPartString, primAgdaErrorPartTerm, primAgdaErrorPartName,+    primAgdaErrorPart, primAgdaErrorPartString, primAgdaErrorPartTerm, primAgdaErrorPartPatt, primAgdaErrorPartName,     primHiding, primHidden, primInstance, primVisible,     primRelevance, primRelevant, primIrrelevant,     primQuantity, primQuantity0, primQuantityω,@@ -210,19 +292,29 @@     primAgdaPatLit, primAgdaPatProj,     primAgdaPatAbsurd,     primAgdaMeta,+    primAgdaBlocker, primAgdaBlockerAny, primAgdaBlockerAll, primAgdaBlockerMeta,     primAgdaTCM, primAgdaTCMReturn, primAgdaTCMBind, primAgdaTCMUnify,     primAgdaTCMTypeError, primAgdaTCMInferType, primAgdaTCMCheckType,     primAgdaTCMNormalise, primAgdaTCMReduce,     primAgdaTCMCatchError, primAgdaTCMGetContext, primAgdaTCMExtendContext, primAgdaTCMInContext,-    primAgdaTCMFreshName, primAgdaTCMDeclareDef, primAgdaTCMDeclarePostulate, primAgdaTCMDefineFun,+    primAgdaTCMFreshName, primAgdaTCMDeclareDef, primAgdaTCMDeclarePostulate, primAgdaTCMDeclareData, primAgdaTCMDefineData, primAgdaTCMDefineFun,     primAgdaTCMGetType, primAgdaTCMGetDefinition,     primAgdaTCMQuoteTerm, primAgdaTCMUnquoteTerm, primAgdaTCMQuoteOmegaTerm,-    primAgdaTCMBlockOnMeta, primAgdaTCMCommit, primAgdaTCMIsMacro,-    primAgdaTCMWithNormalisation, primAgdaTCMDebugPrint, primAgdaTCMWithReconsParams,-    primAgdaTCMOnlyReduceDefs, primAgdaTCMDontReduceDefs,+    primAgdaTCMCommit, primAgdaTCMIsMacro, primAgdaTCMBlock,+    primAgdaTCMFormatErrorParts, primAgdaTCMDebugPrint,+    primAgdaTCMWithNormalisation, primAgdaTCMWithReconstructed,+    primAgdaTCMWithExpandLast, primAgdaTCMWithReduceDefs,+    primAgdaTCMAskNormalisation, primAgdaTCMAskReconstructed,+    primAgdaTCMAskExpandLast, primAgdaTCMAskReduceDefs,     primAgdaTCMNoConstraints,+    primAgdaTCMWorkOnTypes,     primAgdaTCMRunSpeculative,-    primAgdaTCMExec+    primAgdaTCMExec,+    primAgdaTCMCheckFromString,+    primAgdaTCMGetInstances,+    primAgdaTCMSolveInstances,+    primAgdaTCMPragmaForeign,+    primAgdaTCMPragmaCompile     :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term  primInteger                           = getBuiltin builtinInteger@@ -244,19 +336,17 @@ primNothing                           = getBuiltin builtinNothing primJust                              = getBuiltin builtinJust primIO                                = getBuiltin builtinIO-primId                                = getBuiltin builtinId-primConId                             = getBuiltin builtinConId-primIdElim                            = getPrimitiveTerm builtinIdElim primPath                              = getBuiltin builtinPath primPathP                             = getBuiltin builtinPathP+primIntervalUniv                      = getBuiltin builtinIntervalUniv primInterval                          = getBuiltin builtinInterval primIZero                             = getBuiltin builtinIZero primIOne                              = getBuiltin builtinIOne primIMin                              = getPrimitiveTerm builtinIMin primIMax                              = getPrimitiveTerm builtinIMax primINeg                              = getPrimitiveTerm builtinINeg-primPartial                           = getPrimitiveTerm "primPartial"-primPartialP                          = getPrimitiveTerm "primPartialP"+primPartial                           = getPrimitiveTerm PrimPartial+primPartialP                          = getPrimitiveTerm PrimPartialP primIsOne                             = getBuiltin builtinIsOne primItIsOne                           = getBuiltin builtinItIsOne primTrans                             = getPrimitiveTerm builtinTrans@@ -299,17 +389,18 @@ primFlat                              = getBuiltin builtinFlat primEquality                          = getBuiltin builtinEquality primRefl                              = getBuiltin builtinRefl-primRewrite                           = getBuiltin builtinRewrite primLevel                             = getBuiltin builtinLevel primLevelZero                         = getBuiltin builtinLevelZero primLevelSuc                          = getBuiltin builtinLevelSuc primLevelMax                          = getBuiltin builtinLevelMax-primSet                               = getBuiltin builtinSet primProp                              = getBuiltin builtinProp+primSet                               = getBuiltin builtinSet+primStrictSet                         = getBuiltin builtinStrictSet+primPropOmega                         = getBuiltin builtinPropOmega primSetOmega                          = getBuiltin builtinSetOmega-primLockUniv                          = getPrimitiveTerm builtinLockUniv primSSetOmega                         = getBuiltin builtinSSetOmega-primStrictSet                         = getBuiltin builtinStrictSet+primLockUniv                          = getPrimitiveTerm builtinLockUniv+primLevelUniv                         = getBuiltin builtinLevelUniv primFromNat                           = getBuiltin builtinFromNat primFromNeg                           = getBuiltin builtinFromNeg primFromString                        = getBuiltin builtinFromString@@ -340,6 +431,10 @@ primPrecUnrelated                     = getBuiltin builtinPrecUnrelated primFixity                            = getBuiltin builtinFixity primFixityFixity                      = getBuiltin builtinFixityFixity+primAgdaBlocker                       = getBuiltin builtinAgdaBlocker+primAgdaBlockerAny                    = getBuiltin builtinAgdaBlockerAny+primAgdaBlockerAll                    = getBuiltin builtinAgdaBlockerAll+primAgdaBlockerMeta                   = getBuiltin builtinAgdaBlockerMeta primArgInfo                           = getBuiltin builtinArgInfo primArgArgInfo                        = getBuiltin builtinArgArgInfo primAgdaSortSet                       = getBuiltin builtinAgdaSortSet@@ -362,6 +457,7 @@ primAgdaErrorPart                     = getBuiltin builtinAgdaErrorPart primAgdaErrorPartString               = getBuiltin builtinAgdaErrorPartString primAgdaErrorPartTerm                 = getBuiltin builtinAgdaErrorPartTerm+primAgdaErrorPartPatt                 = getBuiltin builtinAgdaErrorPartPatt primAgdaErrorPartName                 = getBuiltin builtinAgdaErrorPartName primAgdaLiteral                       = getBuiltin builtinAgdaLiteral primAgdaLitNat                        = getBuiltin builtinAgdaLitNat@@ -405,23 +501,36 @@ primAgdaTCMFreshName                  = getBuiltin builtinAgdaTCMFreshName primAgdaTCMDeclareDef                 = getBuiltin builtinAgdaTCMDeclareDef primAgdaTCMDeclarePostulate           = getBuiltin builtinAgdaTCMDeclarePostulate+primAgdaTCMDeclareData                = getBuiltin builtinAgdaTCMDeclareData+primAgdaTCMDefineData                 = getBuiltin builtinAgdaTCMDefineData primAgdaTCMDefineFun                  = getBuiltin builtinAgdaTCMDefineFun primAgdaTCMGetType                    = getBuiltin builtinAgdaTCMGetType primAgdaTCMGetDefinition              = getBuiltin builtinAgdaTCMGetDefinition primAgdaTCMQuoteTerm                  = getBuiltin builtinAgdaTCMQuoteTerm primAgdaTCMQuoteOmegaTerm             = getBuiltin builtinAgdaTCMQuoteOmegaTerm primAgdaTCMUnquoteTerm                = getBuiltin builtinAgdaTCMUnquoteTerm-primAgdaTCMBlockOnMeta                = getBuiltin builtinAgdaTCMBlockOnMeta+primAgdaTCMBlock                      = getBuiltin builtinAgdaTCMBlock primAgdaTCMCommit                     = getBuiltin builtinAgdaTCMCommit primAgdaTCMIsMacro                    = getBuiltin builtinAgdaTCMIsMacro primAgdaTCMWithNormalisation          = getBuiltin builtinAgdaTCMWithNormalisation-primAgdaTCMWithReconsParams           = getBuiltin builtinAgdaTCMWithReconsParams+primAgdaTCMWithReconstructed          = getBuiltin builtinAgdaTCMWithReconstructed+primAgdaTCMWithExpandLast             = getBuiltin builtinAgdaTCMWithExpandLast+primAgdaTCMWithReduceDefs             = getBuiltin builtinAgdaTCMWithReduceDefs+primAgdaTCMAskNormalisation           = getBuiltin builtinAgdaTCMAskNormalisation+primAgdaTCMAskReconstructed           = getBuiltin builtinAgdaTCMAskReconstructed+primAgdaTCMAskExpandLast              = getBuiltin builtinAgdaTCMAskExpandLast+primAgdaTCMAskReduceDefs              = getBuiltin builtinAgdaTCMAskReduceDefs+primAgdaTCMFormatErrorParts           = getBuiltin builtinAgdaTCMFormatErrorParts primAgdaTCMDebugPrint                 = getBuiltin builtinAgdaTCMDebugPrint-primAgdaTCMOnlyReduceDefs             = getBuiltin builtinAgdaTCMOnlyReduceDefs-primAgdaTCMDontReduceDefs             = getBuiltin builtinAgdaTCMDontReduceDefs primAgdaTCMNoConstraints              = getBuiltin builtinAgdaTCMNoConstraints+primAgdaTCMWorkOnTypes                = getBuiltin builtinAgdaTCMWorkOnTypes primAgdaTCMRunSpeculative             = getBuiltin builtinAgdaTCMRunSpeculative primAgdaTCMExec                       = getBuiltin builtinAgdaTCMExec+primAgdaTCMCheckFromString            = getBuiltin builtinAgdaTCMCheckFromString+primAgdaTCMGetInstances               = getBuiltin builtinAgdaTCMGetInstances+primAgdaTCMSolveInstances             = getBuiltin builtinAgdaTCMSolveInstances+primAgdaTCMPragmaForeign              = getBuiltin builtinAgdaTCMPragmaForeign+primAgdaTCMPragmaCompile              = getBuiltin builtinAgdaTCMPragmaCompile  -- | The coinductive primitives. @@ -435,9 +544,9 @@  coinductionKit' :: TCM CoinductionKit coinductionKit' = do-  Def inf   _ <- primInf-  Def sharp _ <- primSharp-  Def flat  _ <- primFlat+  inf   <- getBuiltinName_ builtinInf+  sharp <- getBuiltinName_ builtinSharp+  flat  <- getBuiltinName_ builtinFlat   return $ CoinductionKit     { nameOfInf   = inf     , nameOfSharp = sharp@@ -450,28 +559,57 @@ -- | Sort primitives.  data SortKit = SortKit-  { nameOfSet      :: QName-  , nameOfProp     :: QName-  , nameOfSSet     :: QName-  , nameOfSetOmega :: IsFibrant -> QName+  { nameOfUniv   :: UnivSize -> Univ -> QName+  , isNameOfUniv :: QName -> Maybe (UnivSize, Univ)   } -sortKit :: HasBuiltins m => m SortKit+mkSortKit :: QName -> QName -> QName -> QName -> QName -> QName -> SortKit+mkSortKit prop set sset propomega setomega ssetomega = SortKit+  { nameOfUniv = curry $ \case+      (USmall , UProp) -> prop+      (USmall , UType) -> set+      (USmall , USSet) -> sset+      (ULarge , UProp) -> propomega+      (ULarge , UType) -> setomega+      (ULarge , USSet) -> ssetomega+  , isNameOfUniv = \ x -> if+      | x == prop      -> Just (USmall , UProp)+      | x == set       -> Just (USmall , UType)+      | x == sset      -> Just (USmall , USSet)+      | x == propomega -> Just (ULarge , UProp)+      | x == setomega  -> Just (ULarge , UType)+      | x == ssetomega -> Just (ULarge , USSet)+      | otherwise -> Nothing+  }++-- | Compute a 'SortKit' in an environment that supports failures.+--+-- When 'optLoadPrimitives' is set to 'False', 'sortKit' is a fallible operation,+-- so for the uses of 'sortKit' in fallible contexts (e.g. 'TCM'),+-- we report a type error rather than exploding.+sortKit :: (HasBuiltins m, MonadTCError m, HasOptions m) => m SortKit sortKit = do-  Def set      _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSet-  Def prop     _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinProp-  Def setomega _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSetOmega-  Def sset     _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinStrictSet-  Def ssetomega _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSSetOmega-  return $ SortKit-    { nameOfSet      = set-    , nameOfProp     = prop-    , nameOfSSet     = sset-    , nameOfSetOmega = \case-        IsFibrant -> setomega-        IsStrict  -> ssetomega-    }+  prop      <- getBuiltinName_ builtinProp+  set       <- getBuiltinName_ builtinSet+  sset      <- getBuiltinName_ builtinStrictSet+  propomega <- getBuiltinName_ builtinPropOmega+  setomega  <- getBuiltinName_ builtinSetOmega+  ssetomega <- getBuiltinName_ builtinSSetOmega+  return $ mkSortKit prop set sset propomega setomega ssetomega +-- | Compute a 'SortKit' in contexts that do not support failure (e.g.+-- 'Reify'). This should only be used when we are sure that the+-- primitive sorts have been bound, i.e. because it is "after" type+-- checking.+infallibleSortKit :: HasBuiltins m => m SortKit+infallibleSortKit = do+  prop      <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinProp+  set       <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSet+  sset      <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinStrictSet+  propomega <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinPropOmega+  setomega  <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSetOmega+  ssetomega <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSSetOmega+  return $ mkSortKit prop set sset propomega setomega ssetomega  ------------------------------------------------------------------------ -- * Path equality@@ -488,20 +626,27 @@             (_, Var 0 [Proj _ l]) -> l             (_, t)          -> __IMPOSSIBLE__ -getBuiltinName', getPrimitiveName' :: HasBuiltins m => String -> m (Maybe QName)+getBuiltinName' :: HasBuiltins m => BuiltinId -> m (Maybe QName) getBuiltinName' n = fmap getPrimName <$> getBuiltin' n++getPrimitiveName' :: HasBuiltins m => PrimitiveId -> m (Maybe QName) getPrimitiveName' n = fmap primFunName <$> getPrimitive' n -isPrimitive :: HasBuiltins m => String -> QName -> m Bool+isPrimitive :: HasBuiltins m => PrimitiveId -> QName -> m Bool isPrimitive n q = (Just q ==) <$> getPrimitiveName' n +intervalSort :: Sort+intervalSort = IntervalUniv++{-# SPECIALIZE intervalView' :: TCM (Term -> IntervalView) #-}+{-# INLINABLE intervalView' #-} intervalView' :: HasBuiltins m => m (Term -> IntervalView) intervalView' = do   iz <- getBuiltinName' builtinIZero   io <- getBuiltinName' builtinIOne-  imax <- getPrimitiveName' "primIMax"-  imin <- getPrimitiveName' "primIMin"-  ineg <- getPrimitiveName' "primINeg"+  imax <- getPrimitiveName' builtinIMax+  imin <- getPrimitiveName' builtinIMin+  ineg <- getPrimitiveName' builtinINeg   return $ \ t ->     case t of       Def q es ->@@ -514,6 +659,7 @@                  | Just (conName q) == io -> IOne       _ -> OTerm t +{-# INLINE intervalView #-} intervalView :: HasBuiltins m => Term -> m IntervalView intervalView t = do   f <- intervalView'@@ -524,13 +670,14 @@   f <- intervalUnview'   return (f t) +{-# SPECIALIZE intervalUnview' :: TCM (IntervalView -> Term) #-} intervalUnview' :: HasBuiltins m => m (IntervalView -> Term) intervalUnview' = do   iz <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinIZero -- should it be a type error instead?   io <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinIOne-  imin <- (`Def` []) . fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' "primIMin"-  imax <- (`Def` []) . fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' "primIMax"-  ineg <- (`Def` []) . fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' "primINeg"+  imin <- (`Def` []) . fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' builtinIMin+  imax <- (`Def` []) . fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' builtinIMax+  ineg <- (`Def` []) . fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' builtinINeg   return $ \ v -> case v of              IZero -> iz              IOne  -> io@@ -548,11 +695,13 @@ -- --   Precondition: type is reduced. +{-# INLINE pathView #-} pathView :: HasBuiltins m => Type -> m PathView pathView t0 = do   view <- pathView'   return $ view t0 +{-# SPECIALIZE pathView' :: TCM (Type -> PathView)  #-} pathView' :: HasBuiltins m => m (Type -> PathView) pathView' = do  mpath  <- getBuiltinName' builtinPath@@ -566,18 +715,6 @@       | Just path' == mpathp, Just path <- mpathp -> PathType s path level typ lhs rhs     _ -> OType t0 --- | Non dependent Path-idViewAsPath :: HasBuiltins m => Type -> m PathView-idViewAsPath t0@(El s t) = do-  mid <- fmap getPrimName <$> getBuiltin' builtinId-  mpath <- fmap getPrimName <$> getBuiltin' builtinPath-  case mid of-   Just path | isJust mpath -> case t of-    Def path' [ Apply level , Apply typ , Apply lhs , Apply rhs ]-      | path' == path -> return $ PathType s (fromJust mpath) level typ lhs rhs-    _ -> return $ OType t0-   _ -> return $ OType t0- boldPathView :: Type -> PathView boldPathView t0@(El s t) = do   case t of@@ -600,7 +737,6 @@  -- | Get the name of the equality type. primEqualityName :: TCM QName--- primEqualityName = getDef =<< primEquality  -- LEADS TO IMPORT CYCLE primEqualityName = do   eq <- primEquality   -- Andreas, 2014-05-17 moved this here from TC.Rules.Def@@ -622,8 +758,11 @@ -- --   Precondition: type is reduced. -equalityView :: Type -> TCM EqualityView-equalityView t0@(El s t) = do+equalityView ::+     Range  -- ^ Range of the @rewrite@ expression, if any.+  -> Type   -- ^ Identity type?+  -> TCM EqualityView+equalityView r t0@(El s t) = do   equality <- primEqualityName   case t of     Def equality' es | equality' == equality -> do@@ -631,24 +770,30 @@       let n = length vs       unless (n >= 3) __IMPOSSIBLE__       let (pars, [ typ , lhs, rhs ]) = splitAt (n-3) vs-      return $ EqualityType s equality pars typ lhs rhs+      return $ EqualityType r s equality pars typ lhs rhs     _ -> return $ OtherType t0  -- | Revert the 'EqualityView'. -- --   Postcondition: type is reduced. -equalityUnview :: EqualityView -> Type-equalityUnview (OtherType t) = t-equalityUnview (IdiomType t) = t-equalityUnview (EqualityType s equality l t lhs rhs) =-  El s $ Def equality $ map Apply (l ++ [t, lhs, rhs])+class EqualityUnview a where+  equalityUnview :: a -> Type +instance EqualityUnview EqualityView where+  equalityUnview = \case+    OtherType t -> t+    IdiomType t -> t+    EqualityViewType eqt -> equalityUnview eqt++instance EqualityUnview EqualityTypeData where+  equalityUnview (EqualityTypeData _r s equality l t lhs rhs) =+    El s $ Def equality $ map Apply (l ++ [t, lhs, rhs])+ -- | Primitives with typechecking constrants.-constrainedPrims :: [String]+constrainedPrims :: [PrimitiveId] constrainedPrims =-  [ builtinConId-  , builtinPOr+  [ builtinPOr   , builtinComp   , builtinHComp   , builtinTrans@@ -656,7 +801,7 @@   , builtin_glueU   ] -getNameOfConstrained :: HasBuiltins m => String -> m (Maybe QName)+getNameOfConstrained :: HasBuiltins m => PrimitiveId -> m (Maybe QName) getNameOfConstrained s = do   unless (s `elem` constrainedPrims) __IMPOSSIBLE__   getName' s
src/full/Agda/TypeChecking/Monad/Builtin.hs-boot view
@@ -7,16 +7,15 @@ import Control.Monad.Trans.Identity ( IdentityT ) import Control.Monad.Trans          ( MonadTrans, lift ) -import qualified Control.Monad.Fail as Fail- import Agda.TypeChecking.Monad.Base (TCMT, Builtin, PrimFun)+import Agda.Syntax.Builtin (SomeBuiltin)  class ( Functor m       , Applicative m-      , Fail.MonadFail m+      , Monad m       ) => HasBuiltins m where-  getBuiltinThing :: String -> m (Maybe (Builtin PrimFun))-  default getBuiltinThing :: (MonadTrans t, HasBuiltins n, t n ~ m) => String -> m (Maybe (Builtin PrimFun))+  getBuiltinThing :: SomeBuiltin -> m (Maybe (Builtin PrimFun))+  default getBuiltinThing :: (MonadTrans t, HasBuiltins n, t n ~ m) => SomeBuiltin -> m (Maybe (Builtin PrimFun))   getBuiltinThing = lift . getBuiltinThing  instance HasBuiltins m => HasBuiltins (IdentityT m)
src/full/Agda/TypeChecking/Monad/Caching.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Monad.Caching   ( -- * Log reading/writing operations@@ -16,6 +17,8 @@   , restorePostScopeState   ) where +import qualified Data.Set as Set+ import Agda.Syntax.Common  import Agda.Interaction.Options@@ -36,15 +39,18 @@ cachingStarts = do     NameId _ m <- useTC stFreshNameId     stFreshNameId `setTCLens` NameId 1 m+    stFreshOpaqueId `setTCLens` OpaqueId 1 m     stAreWeCaching `setTCLens` True     validateCache m -- fixes issue #4835     where       validateCache m = (localCache readFromCachedLog) >>= \case         Just (_ , s) -> do-          let NameId _ m' = stPostFreshNameId s-          when (m' /= m) cleanCachedLog-        _ -> do-          return ()+          let+            NameId _ m' = stPostFreshNameId s+            OpaqueId _ m'' = stPostFreshOpaqueId s+            stale = or [ m' /= m, m'' /= m ]+          when stale cleanCachedLog+        _ -> return ()  areWeCaching :: (ReadTCState m) => m Bool areWeCaching = useR stAreWeCaching@@ -63,10 +69,12 @@ restorePostScopeState pss = do   reportSLn "cache" 10 $ "restorePostScopeState"   modifyTC $ \s ->-    let ipoints = s^.stInteractionPoints-        ws = s^.stTCWarnings+    let ipoints = s ^. stInteractionPoints+        ws = s ^. stTCWarnings         pss' = pss{stPostInteractionPoints = stPostInteractionPoints pss `mergeIPMap` ipoints                   ,stPostTCWarnings = stPostTCWarnings pss `mergeWarnings` ws+                  ,stPostOpaqueBlocks = s ^. stOpaqueBlocks+                  ,stPostOpaqueIds = s ^. stOpaqueIds                   }     in  s{stPostScopeState = pss'}   where@@ -74,8 +82,8 @@     -- see #1338 on why we need to use the new ranges.     mergeIP li si = li { ipRange = ipRange si } -    mergeWarnings loading current = [ w | w <- current, not $ tcWarningCached w ]-                                 ++ [ w | w <- loading,       tcWarningCached w ]+    mergeWarnings loading current = Set.filter (not . tcWarningCached) current+                        `Set.union` Set.filter (      tcWarningCached) loading  {-# SPECIALIZE modifyCache :: (Maybe LoadedFileCache -> Maybe LoadedFileCache) -> TCM () #-} modifyCache
src/full/Agda/TypeChecking/Monad/Closure.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.Monad.Closure where  import Control.Monad@@ -8,7 +10,8 @@  import Agda.Utils.Lens -enterClosure :: (MonadTCEnv m, ReadTCState m, LensClosure a c)+{-# INLINE enterClosure #-}+enterClosure :: (MonadTCEnv m, ReadTCState m, LensClosure c a)              => c -> (a -> m b) -> m b enterClosure c k | Closure _sig env scope cps x <- c ^. lensClosure = do   isDbg <- viewTC eIsDebugPrinting@@ -17,8 +20,10 @@     $ withEnv env{ envIsDebugPrinting = isDbg }     $ k x +{-# INLINE withClosure  #-} withClosure :: (MonadTCEnv m, ReadTCState m) => Closure a -> (a -> m b) -> m (Closure b) withClosure cl k = enterClosure cl $ k >=> buildClosure +{-# INLINE mapClosure  #-} mapClosure :: (MonadTCEnv m, ReadTCState m) => (a -> m b) -> Closure a -> m (Closure b) mapClosure = flip withClosure
src/full/Agda/TypeChecking/Monad/Constraints.hs view
@@ -11,6 +11,7 @@ import qualified Data.Set as Set import Data.Semigroup ((<>)) +import Agda.Interaction.Options.Base import Agda.Syntax.Internal import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Closure@@ -34,10 +35,22 @@   return x  isProblemSolved :: (MonadTCEnv m, ReadTCState m) => ProblemId -> m Bool-isProblemSolved pid =+isProblemSolved = isProblemSolved' False++isProblemCompletelySolved :: (MonadTCEnv m, ReadTCState m) => ProblemId -> m Bool+isProblemCompletelySolved = isProblemSolved' True++isProblemSolved' :: (MonadTCEnv m, ReadTCState m) => Bool -> ProblemId -> m Bool+isProblemSolved' completely pid =   and2M (not . Set.member pid <$> asksTC envActiveProblems)-        (not . any (Set.member pid . constraintProblems) <$> getAllConstraints)+        (not . any belongsToUs <$> getAllConstraints)+  where+    belongsToUs c+      | Set.notMember pid (constraintProblems c)         = False+      | isBlockingConstraint (clValue $ theConstraint c) = True+      | otherwise                                        = completely -- Ignore non-blocking unless `completely` +{-# SPECIALIZE getConstraintsForProblem :: ProblemId -> TCM Constraints #-} getConstraintsForProblem :: ReadTCState m => ProblemId -> m Constraints getConstraintsForProblem pid = List.filter (Set.member pid . constraintProblems) <$> getAllConstraints @@ -106,7 +119,7 @@ getAllConstraints :: ReadTCState m => m Constraints getAllConstraints = do   s <- getTCState-  return $ s^.stAwakeConstraints ++ s^.stSleepingConstraints+  return $ s ^. stAwakeConstraints ++ s ^. stSleepingConstraints  withConstraint :: MonadConstraint m => (Constraint -> m a) -> ProblemConstraint -> m a withConstraint f (PConstr pids _ c) = do@@ -170,16 +183,6 @@   modifySleepingConstraints = lift . modifySleepingConstraints   wakeConstraints = lift . wakeConstraints -addAndUnblocker :: MonadBlock m => Blocker -> m a -> m a-addAndUnblocker u-  | u == alwaysUnblock = id-  | otherwise          = catchPatternErr $ \ u' -> patternViolation (u <> u')--addOrUnblocker :: MonadBlock m => Blocker -> m a -> m a-addOrUnblocker u-  | u == neverUnblock = id-  | otherwise         = catchPatternErr $ \ u' -> patternViolation (unblockOnEither u u')- -- | Add new a constraint addConstraint' :: Blocker -> Constraint -> TCM () addConstraint' = addConstraintTo stSleepingConstraints@@ -187,33 +190,40 @@ addAwakeConstraint' :: Blocker -> Constraint -> TCM () addAwakeConstraint' = addConstraintTo stAwakeConstraints -addConstraintTo :: Lens' Constraints TCState -> Blocker -> Constraint -> TCM ()+addConstraintTo :: Lens' TCState Constraints -> Blocker -> Constraint -> TCM () addConstraintTo bucket unblock c = do-    pc <- build+    pc <- buildConstraint unblock c     stDirty `setTCLens` True     bucket `modifyTCLens` (pc :)-  where-    build | isBlocking c = buildConstraint unblock c-          | otherwise    = buildProblemConstraint_ unblock c-    isBlocking = \case-      SortCmp{}        -> False-      LevelCmp{}       -> False-      FindInstance{}   -> False-      HasBiggerSort{}  -> False-      HasPTSRule{}     -> False-      ValueCmp{}       -> True-      ValueCmpOnFace{} -> True-      ElimCmp{}        -> True-      UnBlock{}        -> True-      IsEmpty{}        -> True-      CheckSizeLtSat{} -> True-      CheckFunDef{}    -> True-      UnquoteTactic{}  -> True-      CheckMetaInst{}  -> True-      CheckType{}      -> True-      CheckLockedVars{} -> True-      UsableAtModality{} -> True +-- | A problem is considered solved if there are no unsolved blocking constraints belonging to it.+--   There's no really good principle for what constraints are blocking and which are not, but the+--   general idea is that nothing bad should happen if you assume a non-blocking constraint is+--   solvable, but it turns out it isn't. For instance, assuming an equality constraint between two+--   types that turns out to be false can lead to ill typed terms in places where we don't expect+--   them.+isBlockingConstraint :: Constraint -> Bool+isBlockingConstraint = \case+  SortCmp{}             -> False+  LevelCmp{}            -> False+  FindInstance{}        -> False+  ResolveInstanceHead{} -> False+  HasBiggerSort{}       -> False+  HasPTSRule{}          -> False+  CheckDataSort{}       -> False+  ValueCmp{}            -> True+  ValueCmpOnFace{}      -> True+  ElimCmp{}             -> True+  UnBlock{}             -> True+  IsEmpty{}             -> True+  CheckSizeLtSat{}      -> True+  CheckFunDef{}         -> True+  UnquoteTactic{}       -> True+  CheckMetaInst{}       -> True+  CheckType{}           -> True+  CheckLockedVars{}     -> True+  UsableAtModality{}    -> True+ -- | Start solving constraints nowSolvingConstraints :: MonadTCEnv m => m a -> m a nowSolvingConstraints = localTC $ \e -> e { envSolvingConstraints = True }@@ -224,6 +234,26 @@ -- | Add constraint if the action raises a pattern violation catchConstraint :: MonadConstraint m => Constraint -> m () -> m () catchConstraint c = catchPatternErr $ \ unblock -> addConstraint unblock c++isInstanceConstraint :: Constraint -> Bool+isInstanceConstraint FindInstance{} = True+isInstanceConstraint _              = False++canDropRecursiveInstance :: (ReadTCState m, HasOptions m) => m Bool+canDropRecursiveInstance =+  and2M ((^. stConsideringInstance) <$> getTCState)+        (not . optBacktrackingInstances <$> pragmaOptions)++shouldPostponeInstanceSearch :: (ReadTCState m, HasOptions m) => m Bool+shouldPostponeInstanceSearch = canDropRecursiveInstance `or2M` ((^. stPostponeInstanceSearch) <$> getTCState)++-- | Wake constraints matching the given predicate (and aren't instance+--   constraints if 'shouldPostponeInstanceSearch').+wakeConstraints' :: MonadConstraint m => (ProblemConstraint -> WakeUp) -> m ()+wakeConstraints' p = do+  skipInstance <- shouldPostponeInstanceSearch+  let skip c = skipInstance && isInstanceConstraint (clValue $ theConstraint c)+  wakeConstraints $ wakeUpWhen (not . skip) p  --------------------------------------------------------------------------- -- * Lenses
src/full/Agda/TypeChecking/Monad/Context.hs view
@@ -1,6 +1,9 @@  module Agda.TypeChecking.Monad.Context where +import Data.Text (Text)+import qualified Data.Text as T+ import Control.Monad                ( (<=<), forM, when ) import Control.Monad.Except import Control.Monad.Reader@@ -8,21 +11,20 @@ import Control.Monad.Trans.Control  ( MonadTransControl(..), liftThrough ) import Control.Monad.Trans.Identity ( IdentityT ) import Control.Monad.Trans.Maybe-import Control.Monad.Writer--- Control.Monad.Fail import is redundant since GHC 8.8.1-import Control.Monad.Fail (MonadFail)+import Control.Monad.Writer         ( WriterT ) +import Data.Foldable import qualified Data.List as List import qualified Data.Map as Map  import Agda.Syntax.Abstract.Name import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty import Agda.Syntax.Concrete.Name (NameInScope(..), LensInScope(..), nameRoot, nameToRawName) import Agda.Syntax.Internal import Agda.Syntax.Position import Agda.Syntax.Scope.Base -import Agda.TypeChecking.Free import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Substitute@@ -36,9 +38,11 @@ import Agda.Utils.ListT import Agda.Utils.List1 (List1, pattern (:|)) import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.Set1 as Set1 import Agda.Utils.Maybe-import Agda.Utils.Pretty import Agda.Utils.Size+import Agda.Utils.Tuple+import Agda.Utils.Update  import Agda.Utils.Impossible @@ -46,13 +50,15 @@  -- | Modify a 'Context' in a computation.  Warning: does not update --   the checkpoints. Use @updateContext@ instead.-{-# SPECIALIZE unsafeModifyContext :: (Context -> Context) -> TCM a -> TCM a #-}+{-# INLINE unsafeModifyContext #-} unsafeModifyContext :: MonadTCEnv tcm => (Context -> Context) -> tcm a -> tcm a unsafeModifyContext f = localTC $ \e -> e { envContext = f $ envContext e } +{-# INLINE modifyContextInfo #-} -- | Modify the 'Dom' part of context entries. modifyContextInfo :: MonadTCEnv tcm => (forall e. Dom e -> Dom e) -> tcm a -> tcm a-modifyContextInfo f = unsafeModifyContext $ map f+modifyContextInfo f = unsafeModifyContext $ map $ \case+    (CtxVar x a)   -> CtxVar x (f a)  -- | Change to top (=empty) context. Resets the checkpoints. {-# SPECIALIZE inTopContext :: TCM a -> TCM a #-}@@ -82,6 +88,7 @@ unsafeEscapeContext :: MonadTCM tcm => Int -> tcm a -> tcm a unsafeEscapeContext n = unsafeModifyContext $ drop n +{-# SPECIALIZE escapeContext :: Impossible -> Int -> TCM a -> TCM a #-} -- | Delete the last @n@ bindings from the context. Any occurrences of -- these variables are replaced with the given @err@. escapeContext :: MonadAddContext m => Impossible -> Int -> m a -> m a@@ -89,6 +96,7 @@  -- * Manipulating checkpoints -- +{-# SPECIALIZE checkpoint :: Substitution -> TCM a -> TCM a #-} -- | Add a new checkpoint. Do not use directly! checkpoint   :: (MonadDebug tcm, MonadTCM tcm, MonadFresh CheckpointId tcm, ReadTCState tcm)@@ -122,7 +130,7 @@   -- created under refined parent parameters, but as long as those modules   -- aren't named we shouldn't look at the checkpoint. The right thing to do   -- would be to not store these modules in the checkpoint map, but todo..-  stModuleCheckpoints `setTCLens` Map.union oldMods (old <$ Map.difference newMods oldMods)+  stModuleCheckpoints `setTCLens` Map.union oldMods (old <$ newMods)   unlessDebugPrinting $ reportSLn "tc.cxt.checkpoint" 105 "}"   return x @@ -146,7 +154,6 @@  -- * Adding to the context -{-# SPECIALIZE addCtx :: Name -> Dom Type -> TCM a -> TCM a #-} class MonadTCEnv m => MonadAddContext m where   -- | @addCtx x arg cont@ add a variable to the context.   --@@ -156,7 +163,7 @@   addCtx :: Name -> Dom Type -> m a -> m a    -- | Add a let bound variable to the context-  addLetBinding' :: Name -> Term -> Dom Type -> m a -> m a+  addLetBinding' :: Origin -> Name -> Term -> Dom Type -> m a -> m a    -- | Update the context.   --   Requires a substitution that transports things living in the old context@@ -172,8 +179,8 @@    default addLetBinding'     :: (MonadAddContext n, MonadTransControl t, t n ~ m)-    => Name -> Term -> Dom Type -> m a -> m a-  addLetBinding' x u a = liftThrough $ addLetBinding' x u a+    => Origin -> Name -> Term -> Dom Type -> m a -> m a+  addLetBinding' o x u a = liftThrough $ addLetBinding' o x u a    default updateContext     :: (MonadAddContext n, MonadTransControl t, t n ~ m)@@ -188,14 +195,16 @@       withFreshName r x $ run . cont     restoreT $ return st +{-# INLINE defaultAddCtx #-} -- | Default implementation of addCtx in terms of updateContext defaultAddCtx :: MonadAddContext m => Name -> Dom Type -> m a -> m a defaultAddCtx x a ret =-  updateContext (raiseS 1) (((x,) <$> a) :) ret+  updateContext (raiseS 1) (CtxVar x a :) ret  withFreshName_ :: (MonadAddContext m) => ArgName -> (Name -> m a) -> m a withFreshName_ = withFreshName noRange +instance MonadAddContext m => MonadAddContext (ChangeT m) instance MonadAddContext m => MonadAddContext (ExceptT e m) instance MonadAddContext m => MonadAddContext (IdentityT m) instance MonadAddContext m => MonadAddContext (MaybeT m)@@ -206,7 +215,7 @@  instance MonadAddContext m => MonadAddContext (ListT m) where   addCtx x a             = liftListT $ addCtx x a-  addLetBinding' x u a   = liftListT $ addLetBinding' x u a+  addLetBinding' o x u a = liftListT $ addLetBinding' o x u a   updateContext sub f    = liftListT $ updateContext sub f   withFreshName r x cont = ListT $ withFreshName r x $ runListT . cont @@ -228,27 +237,30 @@         setTCLens stUsedNames Map.empty         result <- f         newUsedNames <- useTC stUsedNames-        setTCLens stUsedNames $ Map.unionWith (++) origUsedNames newUsedNames+        setTCLens stUsedNames $ Map.unionWith (<>) origUsedNames newUsedNames         return (result , newUsedNames)        tellUsedName x = do         let concreteX = nameConcrete x             rawX      = nameToRawName concreteX             rootX     = nameRoot concreteX-        modifyTCLens (stUsedNames . key rootX) $ Just . (rawX:) . concat+        modifyTCLens (stUsedNames . key rootX) $+          Just . (Set1.insertSet rawX) . Set1.toSet'        tellShadowing x useds = case Map.lookup (nameRoot $ nameConcrete x) useds of         Just shadows -> do-          reportSDoc "tc.cxt.shadowing" 80 $ pure $ "names shadowing" <+> pretty x <+> ": " <+> prettyList_ (map pretty shadows)-          modifyTCLens stShadowingNames $ Map.insertWith (++) x shadows+          reportSDoc "tc.cxt.shadowing" 80 $ pure $+            "names shadowing" <+> pretty x <+> ": " <+>+            prettyList_ (map pretty $ toList shadows)+          modifyTCLens stShadowingNames $ Map.insertWith (<>) x shadows         Nothing      -> return ()  instance MonadAddContext TCM where   addCtx x a ret = applyUnless (isNoName x) (withShadowingNameTCM x) $     defaultAddCtx x a ret -  addLetBinding' x u a ret = applyUnless (isNoName x) (withShadowingNameTCM x) $-    defaultAddLetBinding' x u a ret+  addLetBinding' o x u a ret = applyUnless (isNoName x) (withShadowingNameTCM x) $+    defaultAddLetBinding' o x u a ret    updateContext sub f = unsafeModifyContext f . checkpoint sub @@ -262,7 +274,6 @@   addCtx x dom ret  -- | Various specializations of @addCtx@.-{-# SPECIALIZE addContext :: b -> TCM a -> TCM a #-} class AddContext b where   addContext :: (MonadAddContext m) => b -> m a -> m a   contextSize :: b -> Nat@@ -273,12 +284,18 @@ newtype KeepNames a = KeepNames a  instance {-# OVERLAPPABLE #-} AddContext a => AddContext [a] where-  addContext = flip (foldr addContext)+  addContext = flip (foldr addContext); {-# INLINABLE addContext #-}   contextSize = sum . map contextSize +instance AddContext ContextEntry where+  addContext (CtxVar x a) = addCtx x a+  {-# INLINE addContext #-}+  contextSize _ = 1+ instance AddContext (Name, Dom Type) where-  addContext = uncurry addCtx+  addContext = uncurry addCtx; {-# INLINE addContext #-}   contextSize _ = 1+{-# SPECIALIZE addContext :: (Name, Dom Type) -> TCM a -> TCM a #-}  instance AddContext (Dom (Name, Type)) where   addContext = addContext . distributeF@@ -330,11 +347,18 @@   addContext (s, dom) ret =     withFreshName noRange s $ \x -> addCtx (setNotInScope x) dom ret   contextSize _ = 1+{-# SPECIALIZE addContext :: (String, Dom Type) -> TCM a -> TCM a #-} +instance AddContext (Text, Dom Type) where+  addContext (s, dom) ret = addContext (T.unpack s, dom) ret+  contextSize _ = 1+{-# SPECIALIZE addContext :: (Text, Dom Type) -> TCM a -> TCM a #-}+ instance AddContext (KeepNames String, Dom Type) where   addContext (KeepNames s, dom) ret =     withFreshName noRange s $ \ x -> addCtx x dom ret   contextSize _ = 1+{-# SPECIALIZE addContext :: (KeepNames String, Dom Type) -> TCM a -> TCM a #-}  instance AddContext (Dom Type) where   addContext dom = addContext ("_" :: String, dom)@@ -353,12 +377,14 @@     loop EmptyTel          = ret     loop (ExtendTel t tel) = underAbstraction' KeepNames t tel loop   contextSize (KeepNames tel) = size tel+{-# SPECIALIZE addContext :: KeepNames Telescope -> TCM a -> TCM a #-}  instance AddContext Telescope where   addContext tel ret = loop tel where     loop EmptyTel          = ret     loop (ExtendTel t tel) = underAbstraction' id t tel loop   contextSize = size+{-# SPECIALIZE addContext :: Telescope -> TCM a -> TCM a #-}  -- | Go under an abstraction.  Do not extend context in case of 'NoAbs'. {-# SPECIALIZE underAbstraction :: Subst a => Dom Type -> Abs a -> (a -> TCM b) -> TCM b #-}@@ -393,104 +419,176 @@   => Dom Type -> (a -> m b) -> Abs a -> m (Abs b) mapAbstraction dom f x = (x $>) <$> underAbstraction dom x f -getLetBindings :: MonadTCM tcm => tcm [(Name,(Term,Dom Type))]+mapAbstraction_+  :: (Subst a, Subst b, MonadAddContext m)+  => (a -> m b) -> Abs a -> m (Abs b)+mapAbstraction_ = mapAbstraction __DUMMY_DOM__++{-# SPECIALIZE getLetBindings :: TCM [(Name, LetBinding)] #-}+getLetBindings :: MonadTCEnv tcm => tcm [(Name, LetBinding)] getLetBindings = do   bs <- asksTC envLetBindings-  forM (Map.toList bs) $ \ (n,o) -> (,) n <$> getOpen o+  forM (Map.toList bs) $ \ (n, o) -> (,) n <$> getOpen o  -- | Add a let bound variable-{-# SPECIALIZE addLetBinding' :: Name -> Term -> Dom Type -> TCM a -> TCM a #-}-defaultAddLetBinding' :: (ReadTCState m, MonadTCEnv m) => Name -> Term -> Dom Type -> m a -> m a-defaultAddLetBinding' x v t ret = do-    vt <- makeOpen (v, t)+{-# SPECIALIZE defaultAddLetBinding' :: Origin -> Name -> Term -> Dom Type -> TCM a -> TCM a #-}+defaultAddLetBinding' :: (ReadTCState m, MonadTCEnv m) => Origin -> Name -> Term -> Dom Type -> m a -> m a+defaultAddLetBinding' o x v t ret = do+    vt <- makeOpen $ LetBinding o v t     flip localTC ret $ \e -> e { envLetBindings = Map.insert x vt $ envLetBindings e }  -- | Add a let bound variable-{-# SPECIALIZE addLetBinding :: ArgInfo -> Name -> Term -> Type -> TCM a -> TCM a #-}-addLetBinding :: MonadAddContext m => ArgInfo -> Name -> Term -> Type -> m a -> m a-addLetBinding info x v t0 ret = addLetBinding' x v (defaultArgDom info t0) ret+{-# SPECIALIZE addLetBinding :: ArgInfo -> Origin -> Name -> Term -> Type -> TCM a -> TCM a #-}+addLetBinding :: MonadAddContext m => ArgInfo -> Origin -> Name -> Term -> Type -> m a -> m a+addLetBinding info o x v t0 ret = addLetBinding' o x v (defaultArgDom info t0) ret  +{-# SPECIALIZE removeLetBinding :: Name -> TCM a -> TCM a #-}+-- | Remove a let bound variable.+removeLetBinding :: MonadTCEnv m => Name -> m a -> m a+removeLetBinding x = localTC $ \ e -> e { envLetBindings = Map.delete x (envLetBindings e) }++{-# SPECIALIZE removeLetBindingsFrom :: Name -> TCM a -> TCM a #-}+-- | Remove a let bound variable and all let bindings introduced after it. For instance before+--   printing its body to avoid folding the binding itself, or using bindings defined later.+--   Relies on the invariant that names introduced later are sorted after earlier names.+removeLetBindingsFrom :: MonadTCEnv m => Name -> m a -> m a+removeLetBindingsFrom x = localTC $ \ e -> e { envLetBindings = fst $ Map.split x (envLetBindings e) }+ -- * Querying the context  -- | Get the current context.-{-# SPECIALIZE getContext :: TCM [Dom (Name, Type)] #-}-getContext :: MonadTCEnv m => m [Dom (Name, Type)]+{-# SPECIALIZE getContext :: TCM Context #-}+getContext :: MonadTCEnv m => m Context getContext = asksTC envContext  -- | Get the size of the current context. {-# SPECIALIZE getContextSize :: TCM Nat #-}-getContextSize :: (Applicative m, MonadTCEnv m) => m Nat-getContextSize = length <$> asksTC envContext+getContextSize :: (MonadTCEnv m) => m Nat+getContextSize = length <$> getContext --- | Generate @[var (n - 1), ..., var 0]@ for all declarations in the context.+{-# SPECIALIZE getContextVars :: TCM [(Int, Dom Name)] #-}+getContextVars :: (MonadTCEnv m) => m [(Int, Dom Name)]+getContextVars = contextVars <$> getContext++{-# SPECIALIZE getContextVars' :: TCM [(Int, Dom Name)] #-}+getContextVars' :: (MonadTCEnv m) => m [(Int, Dom Name)]+getContextVars' = contextVars' <$> getContext++contextVars :: Context -> [(Int, Dom Name)]+contextVars = reverse . contextVars'++contextVars' :: Context -> [(Int, Dom Name)]+contextVars' = zipWith mkVar [0..]+  where+    mkVar i (CtxVar x a) = (i, a $> x)++-- | Generate @[var (n - 1), ..., var 0]@ for all bound variables in the context. {-# SPECIALIZE getContextArgs :: TCM Args #-}-getContextArgs :: (Applicative m, MonadTCEnv m) => m Args-getContextArgs = reverse . zipWith mkArg [0..] <$> getContext-  where mkArg i dom = var i <$ argFromDom dom+getContextArgs :: (MonadTCEnv m) => m Args+getContextArgs = contextArgs <$> getContext +contextArgs :: Context -> Args+contextArgs = map (\(i,x) -> var i <$ argFromDom x) . contextVars+ -- | Generate @[var (n - 1), ..., var 0]@ for all declarations in the context. {-# SPECIALIZE getContextTerms :: TCM [Term] #-}-getContextTerms :: (Applicative m, MonadTCEnv m) => m [Term]-getContextTerms = map var . downFrom <$> getContextSize+getContextTerms :: (MonadTCEnv m) => m [Term]+getContextTerms = map unArg <$> getContextArgs +contextTerms :: Context -> [Term]+contextTerms = map unArg . contextArgs+ -- | Get the current context as a 'Telescope'. {-# SPECIALIZE getContextTelescope :: TCM Telescope #-}-getContextTelescope :: (Applicative m, MonadTCEnv m) => m Telescope-getContextTelescope = telFromList' nameToArgName . reverse <$> getContext+getContextTelescope :: (MonadTCEnv m) => m Telescope+getContextTelescope = contextToTel <$> getContext +contextToTel :: Context -> Telescope+contextToTel = go . reverse+  where+    go [] = EmptyTel+    go (CtxVar x a   : ctx) = ExtendTel a $ Abs (nameToArgName x) (go ctx)+ -- | Get the names of all declarations in the context. {-# SPECIALIZE getContextNames :: TCM [Name] #-}-getContextNames :: (Applicative m, MonadTCEnv m) => m [Name]-getContextNames = map (fst . unDom) <$> getContext+getContextNames :: (MonadTCEnv m) => m [Name]+getContextNames = contextNames <$> getContext +{-# SPECIALIZE getContextNames' :: TCM [Name] #-}+getContextNames' :: (MonadTCEnv m) => m [Name]+getContextNames' = contextNames' <$> getContext++contextNames :: Context -> [Name]+contextNames = map (unDom . snd) . contextVars++contextNames' :: Context -> [Name]+contextNames' = map (unDom . snd) . contextVars'+ -- | get type of bound variable (i.e. deBruijn index) ---{-# SPECIALIZE lookupBV' :: Nat -> TCM (Maybe (Dom (Name, Type))) #-}-lookupBV' :: MonadTCEnv m => Nat -> m (Maybe (Dom (Name, Type)))-lookupBV' n = do-  ctx <- getContext-  return $ raise (n + 1) <$> ctx !!! n+lookupBV_ :: Nat -> Context -> Maybe ContextEntry+lookupBV_ n ctx = raise (n + 1) <$> ctx !!! n -{-# SPECIALIZE lookupBV :: Nat -> TCM (Dom (Name, Type)) #-}-lookupBV :: (MonadFail m, MonadTCEnv m) => Nat -> m (Dom (Name, Type))+{-# SPECIALIZE lookupBV' :: Nat -> TCM (Maybe ContextEntry) #-}+lookupBV' :: MonadTCEnv m => Nat -> m (Maybe ContextEntry)+lookupBV' n = lookupBV_ n <$> getContext++{-# SPECIALIZE lookupBV :: Nat -> TCM ContextEntry #-}+lookupBV :: (MonadDebug m, MonadTCEnv m) => Nat -> m ContextEntry lookupBV n = do   let failure = do         ctx <- getContext-        fail $ "de Bruijn index out of scope: " ++ show n ++-               " in context " ++ prettyShow (map (fst . unDom) ctx)-  maybeM failure return $ lookupBV' n+        __IMPOSSIBLE_VERBOSE__ $ unwords+          [ "de Bruijn index out of scope:", show n+          , "in context", prettyShow $ map ctxEntryName ctx+          ]+  caseMaybeM (lookupBV' n) failure return +ctxEntryName :: ContextEntry -> Name+ctxEntryName (CtxVar x _) = x++ctxEntryDom :: ContextEntry -> Dom Type+ctxEntryDom (CtxVar _ a) = a++ctxEntryType :: ContextEntry -> Type+ctxEntryType = unDom . ctxEntryDom+ {-# SPECIALIZE domOfBV :: Nat -> TCM (Dom Type) #-}-domOfBV :: (Applicative m, MonadFail m, MonadTCEnv m) => Nat -> m (Dom Type)-domOfBV n = fmap snd <$> lookupBV n+domOfBV :: (MonadDebug m, MonadTCEnv m) => Nat -> m (Dom Type)+domOfBV n = ctxEntryDom <$> lookupBV n  {-# SPECIALIZE typeOfBV :: Nat -> TCM Type #-}-typeOfBV :: (Applicative m, MonadFail m, MonadTCEnv m) => Nat -> m Type+typeOfBV :: (MonadDebug m, MonadTCEnv m) => Nat -> m Type typeOfBV i = unDom <$> domOfBV i  {-# SPECIALIZE nameOfBV' :: Nat -> TCM (Maybe Name) #-}-nameOfBV' :: (Applicative m, MonadFail m, MonadTCEnv m) => Nat -> m (Maybe Name)-nameOfBV' n = fmap (fst . unDom) <$> lookupBV' n+nameOfBV' :: (MonadTCEnv m) => Nat -> m (Maybe Name)+nameOfBV' n = fmap ctxEntryName <$> lookupBV' n  {-# SPECIALIZE nameOfBV :: Nat -> TCM Name #-}-nameOfBV :: (Applicative m, MonadFail m, MonadTCEnv m) => Nat -> m Name-nameOfBV n = fst . unDom <$> lookupBV n+nameOfBV :: (MonadDebug m, MonadTCEnv m) => Nat -> m Name+nameOfBV n = ctxEntryName <$> lookupBV n  -- | Get the term corresponding to a named variable. If it is a lambda bound --   variable the deBruijn index is returned and if it is a let bound variable --   its definition is returned. {-# SPECIALIZE getVarInfo :: Name -> TCM (Term, Dom Type) #-}-getVarInfo :: (MonadFail m, MonadTCEnv m) => Name -> m (Term, Dom Type)+getVarInfo :: (MonadDebug m, MonadTCEnv m) => Name -> m (Term, Dom Type) getVarInfo x =-    do  ctx <- getContext+    do  ctx <- getContextVars'         def <- asksTC envLetBindings-        case List.findIndex ((==x) . fst . unDom) ctx of+        case List.findIndex ((== x) . unDom . snd) ctx of             Just n -> do                 t <- domOfBV n                 return (var n, t)             _       ->                 case Map.lookup x def of-                    Just vt -> getOpen vt-                    _       -> fail $ "unbound variable " ++ prettyShow (nameConcrete x) ++-                                " (id: " ++ prettyShow (nameId x) ++ ")"+                    Just vt -> do+                      LetBinding _ v t <- getOpen vt+                      return (v, t)+                    _ -> __IMPOSSIBLE_VERBOSE__ $ unwords+                      [ "unbound variable"+                      , prettyShow $ nameConcrete x+                      , "(id: " ++ prettyShow (nameId x) ++ ")"+                      ]
src/full/Agda/TypeChecking/Monad/Context.hs-boot view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Monad.Context where @@ -15,7 +16,7 @@  class MonadTCEnv m => MonadAddContext m where   addCtx :: Name -> Dom Type -> m a -> m a-  addLetBinding' :: Name -> Term -> Dom Type -> m a -> m a+  addLetBinding' :: Origin -> Name -> Term -> Dom Type -> m a -> m a   updateContext :: Substitution -> (Context -> Context) -> m a -> m a   withFreshName :: Range -> ArgName -> (Name -> m a) -> m a @@ -26,8 +27,8 @@    default addLetBinding'     :: (MonadAddContext n, MonadTransControl t, t n ~ m)-    => Name -> Term -> Dom Type -> m a -> m a-  addLetBinding' x u a = liftThrough $ addLetBinding' x u a+    => Origin -> Name -> Term -> Dom Type -> m a -> m a+  addLetBinding' o x u a = liftThrough $ addLetBinding' o x u a    default updateContext     :: (MonadAddContext n, MonadTransControl t, t n ~ m)
src/full/Agda/TypeChecking/Monad/Debug.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-}  module Agda.TypeChecking.Monad.Debug   ( module Agda.TypeChecking.Monad.Debug@@ -7,6 +8,7 @@ import qualified Control.Exception as E import qualified Control.DeepSeq as DeepSeq (force) +import Control.Applicative          ( liftA2 ) import Control.Monad.IO.Class       ( MonadIO(..) ) import Control.Monad.Except import Control.Monad.Reader@@ -17,20 +19,24 @@ import Control.Monad.Writer  import Data.Maybe+import Data.Time                    ( getCurrentTime, getCurrentTimeZone, utcToLocalTime )+import Data.Time.Format.ISO8601     ( iso8601Show )  import {-# SOURCE #-} Agda.TypeChecking.Errors import Agda.TypeChecking.Monad.Base  import Agda.Interaction.Options-import {-# SOURCE #-} Agda.Interaction.Response (Response(..))+import Agda.Interaction.Response.Base (Response_boot(..))  import Agda.Utils.CallStack ( HasCallStack, withCallerCallStack ) import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.ListT import Agda.Utils.Maybe+import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty+import Agda.Utils.ProfileOptions import Agda.Utils.Update import qualified Agda.Utils.Trie as Trie @@ -45,6 +51,7 @@   verboseBracket     :: VerboseKey -> VerboseLevel -> String -> m a -> m a    getVerbosity       :: m Verbosity+  getProfileOptions  :: m ProfileOptions    -- | Check whether we are currently debug printing.   isDebugPrinting    :: m Bool@@ -64,16 +71,29 @@     => VerboseKey -> VerboseLevel -> String -> m a -> m a   traceDebugMessage k n s = liftThrough $ traceDebugMessage k n s +#ifdef DEBUG   default verboseBracket     :: (MonadTransControl t, MonadDebug n, m ~ t n)     => VerboseKey -> VerboseLevel -> String -> m a -> m a   verboseBracket k n s = liftThrough $ verboseBracket k n s+#else+  default verboseBracket+    :: (MonadTransControl t, MonadDebug n, m ~ t n)+    => VerboseKey -> VerboseLevel -> String -> m a -> m a+  verboseBracket k n s ma = ma+  {-# INLINE verboseBracket #-}+#endif    default getVerbosity     :: (MonadTrans t, MonadDebug n, m ~ t n)     => m Verbosity   getVerbosity = lift getVerbosity +  default getProfileOptions+    :: (MonadTrans t, MonadDebug n, m ~ t n)+    => m ProfileOptions+  getProfileOptions = lift getProfileOptions+   default isDebugPrinting     :: (MonadTrans t, MonadDebug n, m ~ t n)     => m Bool@@ -90,6 +110,9 @@ defaultGetVerbosity :: HasOptions m => m Verbosity defaultGetVerbosity = optVerbose <$> pragmaOptions +defaultGetProfileOptions :: HasOptions m => m ProfileOptions+defaultGetProfileOptions = optProfiling <$> pragmaOptions+ defaultIsDebugPrinting :: MonadTCEnv m => m Bool defaultIsDebugPrinting = asksTC envIsDebugPrinting @@ -124,12 +147,25 @@     -- Force any lazy 'Impossible' exceptions to the surface and handle them.     s  <- liftIO . catchAndPrintImpossible k n . E.evaluate . DeepSeq.force $ s     cb <- getsTC $ stInteractionOutputCallback . stPersistentState-    cb (Resp_RunningInfo n s)++    -- Andreas, 2022-06-15, prefix with time stamp if `-v debug.time:100`:+    msg <- ifNotM (hasVerbosity "debug.time" 100) {-then-} (return s) {-else-} $ do+      now <- liftIO $ trailingZeros . iso8601Show <$> liftA2 utcToLocalTime getCurrentTimeZone getCurrentTime+      return $ concat [ now, ": ", s ]++    cb $ Resp_RunningInfo n msg     cont+    where+    -- Surprisingly, iso8601Show gives us _up to_ 6 fractional digits (microseconds),+    -- but not exactly 6.  https://github.com/haskell/time/issues/211+    -- So we need to do the padding ourselves.+    -- yyyy-mm-ddThh:mm:ss.ssssss+    -- 12345678901234567890123456+    trailingZeros = take 26 . (++ repeat '0')    formatDebugMessage k n d = catchAndPrintImpossible k n $ do     render <$> d `catchError` \ err -> do-      prettyError err <&> \ s -> vcat+      renderError err <&> \ s -> vcat         [ sep $ map text           [ "Printing debug message"           , k  ++ ":" ++ show n@@ -138,15 +174,21 @@         , nest 2 $ text s         ] +#ifdef DEBUG   verboseBracket k n s = applyWhenVerboseS k n $ \ m -> do     openVerboseBracket k n s     (m <* closeVerboseBracket k n) `catchError` \ e -> do       closeVerboseBracketException k n       throwError e+#else+  verboseBracket k n s ma = ma+  {-# INLINE verboseBracket #-}+#endif -  getVerbosity     = defaultGetVerbosity-  isDebugPrinting  = defaultIsDebugPrinting-  nowDebugPrinting = defaultNowDebugPrinting+  getVerbosity      = defaultGetVerbosity+  getProfileOptions = defaultGetProfileOptions+  isDebugPrinting   = defaultIsDebugPrinting+  nowDebugPrinting  = defaultNowDebugPrinting  -- MonadTrans default instances @@ -187,17 +229,44 @@ instance ReportS [Doc]     where reportS k n = reportSLn  k n . render . vcat instance ReportS Doc       where reportS k n = reportSLn  k n . render +#ifdef DEBUG+ -- | Conditionally println debug string. {-# SPECIALIZE reportSLn :: VerboseKey -> VerboseLevel -> String -> TCM () #-} reportSLn :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m () reportSLn k n s = verboseS k n $ displayDebugMessage k n $ s ++ "\n" +#else++{-# INLINE reportSLn #-}+reportSLn :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m ()+reportSLn _ _ _ = pure ()++#endif++-- | Conditionally println debug string. Works regardless of the debug flag.+{-# SPECIALIZE reportSLn :: VerboseKey -> VerboseLevel -> String -> TCM () #-}+alwaysReportSLn :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m ()+alwaysReportSLn k n s = verboseS k n $ displayDebugMessage k n $ s ++ "\n"++ __IMPOSSIBLE_VERBOSE__ :: (HasCallStack, MonadDebug m) => String -> m a-__IMPOSSIBLE_VERBOSE__ s = do { reportSLn "impossible" 10 s ; throwImpossible err }+__IMPOSSIBLE_VERBOSE__ s = do+  -- Andreas, 2023-07-19, issue #6728 is fixed by manually inlining reportSLn here.+  -- reportSLn "impossible" 10 s+  -- It seems like GHC 9.6 optimization does otherwise something that throws+  -- away the debug message.+  let k = "impossible"+  let n = 10+  verboseS k n $ displayDebugMessage k n $ s ++ "\n"++  throwImpossible err   where     -- Create the "Impossible" error using *our* caller as the call site.     err = withCallerCallStack Impossible +#ifdef DEBUG+ -- | Conditionally render debug 'Doc' and print it. {-# SPECIALIZE reportSDoc :: VerboseKey -> VerboseLevel -> TCM Doc -> TCM () #-} reportSDoc :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m ()@@ -210,6 +279,26 @@   x <- action   x <$ reportSDoc k n (debug x) +#else++-- | Conditionally render debug 'Doc' and print it.+{-# INLINE reportSDoc #-}+reportSDoc :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m ()+reportSDoc _ _ _ = pure ()++-- | Debug print the result of a computation.+{-# INLINE reportResult #-}+reportResult :: MonadDebug m => VerboseKey -> VerboseLevel -> (a -> TCM Doc) -> m a -> m a+reportResult _ _ _ action = action++#endif++-- | Conditionally render debug 'Doc' and print it. Works regardless of the debug flag.+{-# SPECIALIZE reportSDoc :: VerboseKey -> VerboseLevel -> TCM Doc -> TCM () #-}+alwaysReportSDoc :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m ()+alwaysReportSDoc k n d = verboseS k n $ do+  displayDebugMessage k n . (++ "\n") =<< formatDebugMessage k n (locallyTC eIsDebugPrinting (const True) d)+ unlessDebugPrinting :: MonadDebug m => m () -> m () unlessDebugPrinting = unlessM isDebugPrinting @@ -234,6 +323,9 @@ instance TraceS [Doc]     where traceS k n = traceSLn  k n . render . vcat instance TraceS Doc       where traceS k n = traceSLn  k n . render ++#ifdef DEBUG+ traceSLn :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m a -> m a traceSLn k n s = applyWhenVerboseS k n $ traceDebugMessage k n $ s ++ "\n" @@ -243,6 +335,20 @@   s <- formatDebugMessage k n $ locallyTC eIsDebugPrinting (const True) d   traceDebugMessage k n (s ++ "\n") cont +#else++{-# INLINE traceSLn #-}+traceSLn :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m a -> m a+traceSLn _ _ _ action = action++-- | Conditionally render debug 'Doc', print it, and then continue.+{-# INLINE traceSDoc #-}+traceSDoc :: MonadDebug m => VerboseKey -> VerboseLevel -> TCM Doc -> m a -> m a+traceSDoc _ _ _ action = action++#endif++ openVerboseBracket :: MonadDebug m => VerboseKey -> VerboseLevel -> String -> m () openVerboseBracket k n s = displayDebugMessage k n $ "{ " ++ s ++ "\n" @@ -263,27 +369,40 @@ --   reportSLn --   reportSDoc -parseVerboseKey :: VerboseKey -> [String]-parseVerboseKey = wordsBy (`elem` (".:" :: String))- -- | Check whether a certain verbosity level is activated. -- --   Precondition: The level must be non-negative. {-# SPECIALIZE hasVerbosity :: VerboseKey -> VerboseLevel -> TCM Bool #-} hasVerbosity :: MonadDebug m => VerboseKey -> VerboseLevel -> m Bool-hasVerbosity k n | n < 0     = __IMPOSSIBLE__-                 | otherwise = do-    t <- getVerbosity-    let ks = parseVerboseKey k-        m  = lastWithDefault 0 $ Trie.lookupPath ks t-    return (n <= m)+hasVerbosity k n = do+  t <- getVerbosity+  return $ case t of+    Strict.Nothing -> n <= 1+    Strict.Just t+      -- This code is not executed if no debug flags have been given.+      | t == Trie.singleton [] 0 ->+        -- A special case for "-v0".+        n <= 0+      | otherwise ->+        let ks = parseVerboseKey k+            m  = lastWithDefault 0 $ Trie.lookupPath ks t+        in n <= m  -- | Check whether a certain verbosity level is activated (exact match).  {-# SPECIALIZE hasExactVerbosity :: VerboseKey -> VerboseLevel -> TCM Bool #-} hasExactVerbosity :: MonadDebug m => VerboseKey -> VerboseLevel -> m Bool-hasExactVerbosity k n =-  (Just n ==) . Trie.lookup (parseVerboseKey k) <$> getVerbosity+hasExactVerbosity k n = do+  t <- getVerbosity+  return $ case t of+    Strict.Nothing -> n == 1+    Strict.Just t+      -- This code is not executed if no debug flags have been given.+      | t == Trie.singleton [] 0 ->+        -- A special case for "-v0".+        n == 0+      | otherwise ->+        Just n == Trie.lookup (parseVerboseKey k) t  -- | Run a computation if a certain verbosity level is activated (exact match). @@ -312,13 +431,11 @@ applyWhenVerboseS :: MonadDebug m => VerboseKey -> VerboseLevel -> (m a -> m a) -> m a -> m a applyWhenVerboseS k n f a = ifM (hasVerbosity k n) (f a) a --- | Verbosity lens.-verbosity :: VerboseKey -> Lens' VerboseLevel TCState-verbosity k = stPragmaOptions . verbOpt . Trie.valueAt (parseVerboseKey k) . defaultTo 0-  where-    verbOpt :: Lens' Verbosity PragmaOptions-    verbOpt f opts = f (optVerbose opts) <&> \ v -> opts { optVerbose = v }-    -- Andreas, 2019-08-20: this lens should go into Interaction.Option.Lenses!+-- | Check whether a certain profile option is activated.+{-# SPECIALIZE hasProfileOption :: ProfileOption -> TCM Bool #-}+hasProfileOption :: MonadDebug m => ProfileOption -> m Bool+hasProfileOption opt = containsProfileOption opt <$> getProfileOptions -    defaultTo :: Eq a => a -> Lens' a (Maybe a)-    defaultTo x f m = filterMaybe (== x) <$> f (fromMaybe x m)+-- | Run some code when the given profiling option is active.+whenProfile :: MonadDebug m => ProfileOption -> m () -> m ()+whenProfile opt = whenM (hasProfileOption opt)
src/full/Agda/TypeChecking/Monad/Debug.hs-boot view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.Monad.Debug where  import Data.Kind (Type)
src/full/Agda/TypeChecking/Monad/Env.hs view
@@ -1,17 +1,16 @@-module Agda.TypeChecking.Monad.Env where+{-# OPTIONS_GHC -Wunused-imports #-} +module Agda.TypeChecking.Monad.Env where  import qualified Data.List as List  import Data.Maybe (fromMaybe) - import Agda.Syntax.Common import Agda.Syntax.Abstract.Name  import Agda.TypeChecking.Monad.Base -import Agda.Utils.FileName import qualified Agda.Utils.SmallSet as SmallSet  import Agda.Utils.Impossible@@ -28,8 +27,10 @@     localTC $ \ e -> e { envCurrentModule = m }  -- | Get the path of the currently checked file-getCurrentPath :: MonadTCEnv m => m AbsolutePath-getCurrentPath = fromMaybe __IMPOSSIBLE__ <$> asksTC envCurrentPath+getCurrentPath :: (MonadTCEnv m, MonadFileId m) => m AbsolutePath+getCurrentPath = do+  i <- fromMaybe __IMPOSSIBLE__ <$> asksTC envCurrentPath+  fileFromId i  -- | Get the number of variables bound by anonymous modules. {-# SPECIALIZE getAnonymousVariables :: ModuleName -> TCM Nat #-}@@ -99,7 +100,8 @@  -- | Reduce @Def f vs@ only if @f@ is a projection. onlyReduceProjections :: MonadTCEnv m => m a -> m a-onlyReduceProjections = putAllowedReductions $ SmallSet.singleton ProjectionReductions+onlyReduceProjections = modifyAllowedReductions $ SmallSet.intersection $+  SmallSet.singleton ProjectionReductions  -- | Allow all reductions except for non-terminating functions (default). allowAllReductions :: MonadTCEnv m => m a -> m a@@ -112,7 +114,8 @@ -- | Allow all reductions when reducing types. Otherwise only allow --   inlined functions to be unfolded. onlyReduceTypes :: MonadTCEnv m => m a -> m a-onlyReduceTypes = putAllowedReductions $ SmallSet.fromList [TypeLevelReductions, InlineReductions]+onlyReduceTypes = modifyAllowedReductions $ SmallSet.intersection $+  SmallSet.fromList [TypeLevelReductions, InlineReductions]  -- | Update allowed reductions when working on types typeLevelReductions :: MonadTCEnv m => m a -> m a@@ -134,3 +137,9 @@ -- | Don't use call-by-need evaluation for the given computation. callByName :: TCM a -> TCM a callByName = localTC $ \ e -> e { envCallByNeed = False }++-- | Don't fold let bindings when printing. This is a bit crude since it disables any folding of let+--   bindings at all. In many cases it's better to use `removeLetBinding` before printing to drop+--   the let bindings that should not be folded.+dontFoldLetBindings :: MonadTCEnv m => m a -> m a+dontFoldLetBindings = localTC $ \ e -> e { envFoldLetBindings = False }
src/full/Agda/TypeChecking/Monad/Imports.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Monad.Imports   ( addImport@@ -7,11 +8,9 @@   , getDecodedModule   , getDecodedModules   , getImportPath-  , getImports   , getPrettyVisitedModules   , getVisitedModule   , getVisitedModules-  , isImported   , setDecodedModules   , setVisitedModules   , storeDecodedModule@@ -22,40 +21,57 @@ import Control.Arrow   ( (***) ) import Control.Monad   ( when ) -import Data.Set (Set)+import Data.Maybe (catMaybes) import qualified Data.Map as Map+import Data.Set (Set) import qualified Data.Set as Set -import Agda.Syntax.Abstract.Name-import qualified Agda.Syntax.Concrete.Name as C+import Agda.Syntax.Common.Pretty+import Agda.Syntax.TopLevelModuleName import Agda.TypeChecking.Monad.Base  import Agda.Utils.List ( caseListM )-import Agda.Utils.Pretty-+import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.List2 as List2+import Agda.Utils.Singleton (singleton)  import Agda.Utils.Impossible -addImport :: ModuleName -> TCM ()-addImport m = modifyTCLens stImportedModules $ Set.insert m+-- | Register the given module as imported in the current state.+--   Also recursively add its imports to the cumulative imports.+addImport :: TopLevelModuleName -> TCM ()+addImport top = do+  modifyTCLens' stImportedModules $ Set.insert top+  modifyTCLensM stImportedModulesTransitive $ completeTransitiveImports $ singleton top -addImportCycleCheck :: C.TopLevelModuleName -> TCM a -> TCM a-addImportCycleCheck m =-    localTC $ \e -> e { envImportPath = m : envImportPath e }+-- | @completeTransitiveImports ms ms'@.+--   Precondition: @ms@ disjoint from @ms'@.+completeTransitiveImports :: ReadTCState m => Set TopLevelModuleName -> ImportedModules -> m ImportedModules+completeTransitiveImports ms old = if null ms then return old else do -getImports :: TCM (Set ModuleName)-getImports = useTC stImportedModules+  -- Add the given imports to the current set.+  let next = old `Set.union` ms -isImported :: ModuleName -> TCM Bool-isImported m = Set.member m <$> getImports+  -- The interfaces for the modules we added to the transitive imports.+  is <- catMaybes <$> mapM getVisitedModule (Set.toList ms) -getImportPath :: TCM [C.TopLevelModuleName]+  -- The imports of these modules.+  let imps = Set.unions $ map (Set.fromList . map fst . iImportedModules . miInterface) is++  -- Recurse on the new imports.+  completeTransitiveImports (imps `Set.difference` next) next++addImportCycleCheck :: TopLevelModuleName -> TCM a -> TCM a+addImportCycleCheck m =+    localTC $ \e -> e { envImportPath = m : envImportPath e }++getImportPath :: TCM [TopLevelModuleName] getImportPath = asksTC envImportPath  visitModule :: ModuleInfo -> TCM () visitModule mi =   modifyTCLens stVisitedModules $-    Map.insert (toTopLevelModuleName $ iModuleName $ miInterface mi) mi+    Map.insert (iTopLevelModuleName $ miInterface mi) mi  setVisitedModules :: VisitedModules -> TCM () setVisitedModules ms = setTCLens stVisitedModules ms@@ -74,7 +90,7 @@   prettyCheckMode ModuleScopeChecked                 = " (scope only)"  getVisitedModule :: ReadTCState m-                 => C.TopLevelModuleName+                 => TopLevelModuleName                  -> m (Maybe ModuleInfo) getVisitedModule x = Map.lookup x <$> useTC stVisitedModules @@ -85,19 +101,19 @@ setDecodedModules ms = modifyTC $ \s ->   s { stPersistentState = (stPersistentState s) { stDecodedModules = ms } } -getDecodedModule :: C.TopLevelModuleName -> TCM (Maybe ModuleInfo)+getDecodedModule :: TopLevelModuleName -> TCM (Maybe ModuleInfo) getDecodedModule x = Map.lookup x . stDecodedModules . stPersistentState <$> getTC  storeDecodedModule :: ModuleInfo -> TCM () storeDecodedModule mi = modifyTC $ \s ->   s { stPersistentState =         (stPersistentState s) { stDecodedModules =-          Map.insert (toTopLevelModuleName $ iModuleName $ miInterface mi) mi $+          Map.insert (iTopLevelModuleName $ miInterface mi) mi $             stDecodedModules (stPersistentState s)         }   } -dropDecodedModule :: C.TopLevelModuleName -> TCM ()+dropDecodedModule :: TopLevelModuleName -> TCM () dropDecodedModule x = modifyTC $ \s ->   s { stPersistentState =         (stPersistentState s) { stDecodedModules =@@ -105,7 +121,7 @@                               }   } -withImportPath :: [C.TopLevelModuleName] -> TCM a -> TCM a+withImportPath :: [TopLevelModuleName] -> TCM a -> TCM a withImportPath path = localTC $ \e -> e { envImportPath = path }  -- | Assumes that the first module in the import path is the module we are@@ -113,5 +129,6 @@ checkForImportCycle :: TCM () checkForImportCycle = do   caseListM getImportPath __IMPOSSIBLE__ $ \ m ms -> do-    when (m `elem` ms) $ typeError $ CyclicModuleDependency-                                   $ dropWhile (/= m) $ reverse (m:ms)+    when (m `elem` ms) $ typeError $ CyclicModuleDependency $+      List2.snoc (List1.fromListSafe __IMPOSSIBLE__ $ dropWhile (/= m) $ reverse ms) m+        -- NB: we know that ms contains m, so even after dropWhile the list is not empty.
src/full/Agda/TypeChecking/Monad/MetaVars.hs view
@@ -4,58 +4,60 @@  import Prelude hiding (null) -import Control.DeepSeq--import Control.Monad                ( (<=<), guard )-import Control.Monad.Except-import Control.Monad.State+import Control.Monad.Except         ( ExceptT, MonadError )+import Control.Monad.State          ( StateT, execStateT, get, put )+import Control.Monad.Trans          ( MonadTrans, lift ) import Control.Monad.Trans.Identity ( IdentityT )-import Control.Monad.Reader-import Control.Monad.Writer--- Control.Monad.Fail import is redundant since GHC 8.8.1-import Control.Monad.Fail (MonadFail)+import Control.Monad.Trans.Maybe    ( MaybeT )+import Control.Monad.Reader         ( ReaderT(ReaderT), runReaderT )+import Control.Monad.Writer         ( WriterT, execWriterT, tell ) -import qualified Data.IntMap as IntMap-import Data.IntSet (IntSet)-import qualified Data.IntSet as IntSet+import qualified Data.HashMap.Strict as HMap import qualified Data.List as List+import qualified Data.Map.Strict as MapS import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Foldable as Fold +import GHC.Stack (HasCallStack)+ import Agda.Syntax.Common+import Agda.Syntax.Info ( MetaKind (InstanceMeta, UnificationMeta), MetaNameSuggestion ) import Agda.Syntax.Internal import Agda.Syntax.Internal.MetaVars import Agda.Syntax.Position import Agda.Syntax.Scope.Base+import Agda.Syntax.Common.Pretty (prettyShow)  import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Builtin (HasBuiltins) import Agda.TypeChecking.Monad.Trace import Agda.TypeChecking.Monad.Closure-import Agda.TypeChecking.Monad.Constraints (MonadConstraint)-import Agda.TypeChecking.Monad.Debug (MonadDebug, reportSLn)+import Agda.TypeChecking.Monad.Constraints (MonadConstraint(..))+import Agda.TypeChecking.Monad.Debug+  (MonadDebug, reportSLn, __IMPOSSIBLE_VERBOSE__) import Agda.TypeChecking.Monad.Context import Agda.TypeChecking.Monad.Signature (HasConstInfo)+import Agda.TypeChecking.Monad.State import Agda.TypeChecking.Substitute import {-# SOURCE #-} Agda.TypeChecking.Telescope  import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Functor ((<.>))+import Agda.Utils.Lens import Agda.Utils.List (nubOn) import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Permutation-import Agda.Utils.Pretty (prettyShow) import Agda.Utils.Tuple import qualified Agda.Utils.Maybe.Strict as Strict  import Agda.Utils.Impossible --- | Various kinds of metavariables.+-- | Various classes of metavariables. -data MetaKind =+data MetaClass =     Records     -- ^ Meta variables of record type.   | SingletonRecords@@ -64,10 +66,10 @@     -- ^ Meta variables of level type, if type-in-type is activated.   deriving (Eq, Enum, Bounded, Show) --- | All possible metavariable kinds.+-- | All possible metavariable classes. -allMetaKinds :: [MetaKind]-allMetaKinds = [minBound .. maxBound]+allMetaClasses :: [MetaClass]+allMetaClasses = [minBound .. maxBound]  data KeepMetas = KeepMetas | RollBackMetas @@ -104,9 +106,9 @@   -- metas.   assignTerm' :: MonadMetaSolver m => MetaId -> [Arg ArgName] -> Term -> m () -  -- | Eta expand a metavariable, if it is of the specified kind.-  --   Don't do anything if the metavariable is a blocked term.-  etaExpandMeta :: [MetaKind] -> MetaId -> m ()+  -- | Eta-expand a local meta-variable, if it is of the specified+  -- class. Don't do anything if the meta-variable is a blocked term.+  etaExpandMeta :: [MetaClass] -> MetaId -> m ()    -- | Update the status of the metavariable   updateMetaVar :: MetaId -> (MetaVariable -> MetaVariable) -> m ()@@ -116,95 +118,245 @@   --    rolled back and 'fallback' is run instead.   speculateMetas :: m () -> m KeepMetas -> m () +instance MonadMetaSolver m => MonadMetaSolver (ReaderT r m) where+  newMeta' inst f i p perm j = lift $ newMeta' inst f i p perm j+  assignV dir m us v cmp = lift $ assignV dir m us v cmp+  assignTerm' m us v = lift $ assignTerm' m us v+  etaExpandMeta k m = lift $ etaExpandMeta k m+  updateMetaVar m f = lift $ updateMetaVar m f+  speculateMetas fallback m = ReaderT $ \x -> speculateMetas (runReaderT fallback x) (runReaderT m x)+ -- | Switch off assignment of metas. dontAssignMetas :: (MonadTCEnv m, HasOptions m, MonadDebug m) => m a -> m a dontAssignMetas cont = do   reportSLn "tc.meta" 45 $ "don't assign metas"   localTC (\ env -> env { envAssignMetas = False }) cont --- | Get the meta store.-getMetaStore :: (ReadTCState m) => m MetaStore-getMetaStore = useR stMetaStore+-- | Is the meta-variable from another top-level module? -modifyMetaStore :: (MetaStore -> MetaStore) -> TCM ()-modifyMetaStore f = stMetaStore `modifyTCLens` f+isRemoteMeta :: ReadTCState m => m (MetaId -> Bool)+isRemoteMeta = do+  h <- currentModuleNameHash+  return (\m -> h /= metaModule m) +-- | If another meta-variable is created, then it will get this+-- 'MetaId' (unless the state is changed too much, for instance by+-- 'setTopLevelModule').++nextLocalMeta :: ReadTCState m => m MetaId+nextLocalMeta = useR stFreshMetaId++-- | Pairs of local meta-stores.++data LocalMetaStores = LocalMetaStores+  { openMetas :: LocalMetaStore+    -- ^ A 'MetaStore' containing open meta-variables.+  , solvedMetas :: LocalMetaStore+    -- ^ A 'MetaStore' containing instantiated meta-variables.+  }+ -- | Run a computation and record which new metas it created.-metasCreatedBy :: ReadTCState m => m a -> m (a, MetaStore)+metasCreatedBy ::+  forall m a. ReadTCState m => m a -> m (a, LocalMetaStores) metasCreatedBy m = do-  -- Compute largestMeta strictly to avoid leaking memory.-  !largestMeta <- force . fmap fst . IntMap.lookupMax <$>-                    useTC stMetaStore-  a            <- m-  ms           <- useTC stMetaStore-  let createdMetas = case largestMeta of-        Nothing          -> ms-        Just largestMeta -> snd $ IntMap.split largestMeta ms-  return (a, createdMetas)+  !nextMeta <- nextLocalMeta+  a         <- m+  os        <- created stOpenMetaStore   nextMeta+  ss        <- created stSolvedMetaStore nextMeta+  return (a, LocalMetaStores { openMetas = os, solvedMetas = ss })+  where+  created :: Lens' TCState LocalMetaStore -> MetaId -> m LocalMetaStore+  created store next = do+    ms <- useTC store+    return $ case MapS.splitLookup next ms of+      (_, Nothing, ms) -> ms+      (_, Just m,  ms) -> MapS.insert next m ms --- | Lookup a meta variable.-lookupMeta' :: ReadTCState m => MetaId -> m (Maybe MetaVariable)-lookupMeta' m = IntMap.lookup (metaId m) <$> getMetaStore+-- | Find information about the given local meta-variable, if any. -lookupMeta :: (MonadFail m, ReadTCState m) => MetaId -> m MetaVariable-lookupMeta m = fromMaybeM failure $ lookupMeta' m-  where failure = fail $ "no such meta variable " ++ prettyShow m+lookupLocalMeta' :: ReadTCState m => MetaId -> m (Maybe MetaVariable)+lookupLocalMeta' m = do+  mv <- lkup <$> useR stSolvedMetaStore+  case mv of+    mv@Just{} -> return mv+    Nothing   -> lkup <$> useR stOpenMetaStore+  where+  lkup = MapS.lookup m --- | Type of a term or sort meta.-metaType :: (MonadFail m, ReadTCState m) => MetaId -> m Type-metaType x = jMetaType . mvJudgement <$> lookupMeta x+-- | Find information about the given local meta-variable. --- | Update the information associated with a meta variable.-updateMetaVarTCM :: MetaId -> (MetaVariable -> MetaVariable) -> TCM ()-updateMetaVarTCM m f = modifyMetaStore $ IntMap.adjust f $ metaId m+lookupLocalMeta ::+  (HasCallStack, MonadDebug m, ReadTCState m) =>+  MetaId -> m MetaVariable+lookupLocalMeta m =+  fromMaybeM (__IMPOSSIBLE_VERBOSE__ err) $ lookupLocalMeta' m+  where+  err = "no such local meta-variable " ++ prettyShow m --- | Insert a new meta variable with associated information into the meta store.+-- | Find information about the (local or remote) meta-variable, if+-- any.+--+-- If no meta-variable is found, then the reason could be that the+-- dead-code elimination+-- ('Agda.TypeChecking.DeadCode.eliminateDeadCode') failed to find the+-- meta-variable, perhaps because some 'NamesIn' instance is+-- incorrectly defined.++{-# SPECIALIZE lookupMeta :: MetaId -> TCM (Maybe (Either RemoteMetaVariable MetaVariable)) #-}+lookupMeta ::+  ReadTCState m =>+  MetaId -> m (Maybe (Either RemoteMetaVariable MetaVariable))+lookupMeta m = do+  mv <- lookupLocalMeta' m+  case mv of+    Just mv -> return (Just (Right mv))+    Nothing -> fmap Left . HMap.lookup m <$> useR stImportedMetaStore++-- | Find the meta-variable's instantiation.++{-# SPECIALIZE lookupMetaInstantiation :: MetaId -> TCM MetaInstantiation #-}+lookupMetaInstantiation ::+  ReadTCState m => MetaId -> m MetaInstantiation+lookupMetaInstantiation m = do+  mi <- lookupMeta m+  case mi of+    Just (Left mv)  -> return (InstV $ rmvInstantiation mv)+    Just (Right mv) -> return (mvInstantiation mv)+    Nothing         -> __IMPOSSIBLE__++-- | Find the meta-variable's judgement.++lookupMetaJudgement :: ReadTCState m => MetaId -> m (Judgement MetaId)+lookupMetaJudgement m = do+  mi <- lookupMeta m+  case mi of+    Just (Left mv)  -> return (rmvJudgement mv)+    Just (Right mv) -> return (mvJudgement mv)+    Nothing         -> __IMPOSSIBLE__++-- | Find the meta-variable's modality.++lookupMetaModality :: ReadTCState m => MetaId -> m Modality+lookupMetaModality m = do+  mi <- lookupMeta m+  case mi of+    Just (Left mv)  -> return (rmvModality mv)+    Just (Right mv) -> return (getModality mv)+    Nothing         -> __IMPOSSIBLE__++{-# INLINE metaType #-}+-- | The type of a term or sort meta-variable.+metaType :: ReadTCState m => MetaId -> m Type+metaType x = jMetaType <$> lookupMetaJudgement x++-- | Update the information associated with a local meta-variable.+updateMetaVarTCM ::+  HasCallStack => MetaId -> (MetaVariable -> MetaVariable) -> TCM ()+updateMetaVarTCM m f = do+  mv <- lookupLocalMeta' m+  case mv of+    Nothing -> do+      mv <- lookupMeta m+      case mv of+        Nothing -> __IMPOSSIBLE_VERBOSE__+                     ("Meta-variable not found: " ++ prettyShow m)+        Just{}  -> __IMPOSSIBLE_VERBOSE__+                     ("Attempt to update remote meta-variable: " +++                      prettyShow m)+    Just mv -> do+      let mv'    = f mv+          insert = (`modifyTCLens` MapS.insert m mv')+          delete = (`modifyTCLens` MapS.delete m)+      case ( isOpenMeta (mvInstantiation mv)+           , isOpenMeta (mvInstantiation mv')+           ) of+        (True,  True)  -> insert stOpenMetaStore+        (False, False) -> insert stSolvedMetaStore+        (True,  False) -> do+          delete stOpenMetaStore+          insert stSolvedMetaStore+        (False, True)  -> __IMPOSSIBLE__++-- | Insert a new meta-variable with associated information into the+-- local meta store. insertMetaVar :: MetaId -> MetaVariable -> TCM ()-insertMetaVar m mv = modifyMetaStore $ IntMap.insert (metaId m) mv+insertMetaVar m mv+  | isOpenMeta (mvInstantiation mv) = insert stOpenMetaStore+  | otherwise                       = insert stSolvedMetaStore+  where+  insert = (`modifyTCLens` MapS.insert m mv) -getMetaPriority :: (MonadFail m, ReadTCState m) => MetaId -> m MetaPriority-getMetaPriority = mvPriority <.> lookupMeta+{-# INLINE getMetaPriority #-}+-- | Returns the 'MetaPriority' of the given local meta-variable.+getMetaPriority ::+  (HasCallStack, MonadDebug m, ReadTCState m) =>+  MetaId -> m MetaPriority+getMetaPriority = mvPriority <.> lookupLocalMeta -isSortMeta :: (MonadFail m, ReadTCState m) => MetaId -> m Bool-isSortMeta m = isSortMeta_ <$> lookupMeta m+isSortMeta :: ReadTCState m => MetaId -> m Bool+isSortMeta m = isSortJudgement <$> lookupMetaJudgement m  isSortMeta_ :: MetaVariable -> Bool-isSortMeta_ mv = case mvJudgement mv of-    HasType{} -> False-    IsSort{}  -> True+isSortMeta_ mv = isSortJudgement (mvJudgement mv) -getMetaType :: (MonadFail m, ReadTCState m) => MetaId -> m Type+isSortJudgement :: Judgement a -> Bool+isSortJudgement HasType{} = False+isSortJudgement IsSort{}  = True++-- | If a meta variable is still open, what is its kind?+--+metaInstantiationToMetaKind :: MetaInstantiation -> MetaKind+metaInstantiationToMetaKind = \case+  OpenMeta k                     -> k+  InstV{}                        -> empty+  BlockedConst{}                 -> empty+  PostponedTypeCheckingProblem{} -> empty++{-# SPECIALIZE getMetaType :: MetaId -> TCM Type #-}+getMetaType :: ReadTCState m => MetaId -> m Type getMetaType m = do-  mv <- lookupMeta m-  return $ case mvJudgement mv of+  j <- lookupMetaJudgement m+  return $ case j of     HasType{ jMetaType = t } -> t     IsSort{}  -> __IMPOSSIBLE__ --- | Compute the context variables that a meta should be applied to, accounting---   for pruning.+{-# SPECIALIZE getMetaContextArgs :: MetaVariable -> TCM Args #-}+-- | Compute the context variables that a local meta-variable should+-- be applied to, accounting for pruning. getMetaContextArgs :: MonadTCEnv m => MetaVariable -> m Args getMetaContextArgs MetaVar{ mvPermutation = p } = do   args <- getContextArgs   return $ permute (takeP (length args) p) args --- | Given a meta, return the type applied to the current context.-getMetaTypeInContext :: (MonadFail m, MonadTCEnv m, ReadTCState m, MonadReduce m, HasBuiltins m)-                     => MetaId -> m Type+{-# SPECIALIZE getMetaTypeInContext :: MetaId -> TCM Type #-}+-- | Given a local meta-variable, return the type applied to the+-- current context.+getMetaTypeInContext ::+  (HasBuiltins m, HasCallStack, MonadDebug m, MonadReduce m,+   MonadTCEnv m, ReadTCState m) =>+  MetaId -> m Type getMetaTypeInContext m = do-  mv@MetaVar{ mvJudgement = j } <- lookupMeta m+  mv@MetaVar{ mvJudgement = j } <- lookupLocalMeta m   case j of     HasType{ jMetaType = t } -> piApplyM t =<< getMetaContextArgs mv     IsSort{}                 -> __IMPOSSIBLE__ --- | Is it a meta that might be generalized?-isGeneralizableMeta :: (ReadTCState m, MonadFail m) => MetaId -> m DoGeneralize-isGeneralizableMeta x = unArg . miGeneralizable . mvInfo <$> lookupMeta x+{-# SPECIALIZE isGeneralizableMeta :: MetaId -> TCM DoGeneralize #-}+-- | Is it a local meta-variable that might be generalized?+isGeneralizableMeta ::+  (HasCallStack, MonadDebug m, ReadTCState m) =>+  MetaId -> m DoGeneralize+isGeneralizableMeta x =+  unArg . miGeneralizable . mvInfo <$> lookupLocalMeta x  -- | Check whether all metas are instantiated. --   Precondition: argument is a meta (in some form) or a list of metas. class IsInstantiatedMeta a where-  isInstantiatedMeta :: (MonadFail m, ReadTCState m) => a -> m Bool+  isInstantiatedMeta :: (ReadTCState m) => a -> m Bool +{-# SPECIALIZE isInstantiatedMeta :: Term -> TCM Bool #-}+{-# SPECIALIZE isInstantiatedMeta :: Type -> TCM Bool #-}+ instance IsInstantiatedMeta MetaId where   isInstantiatedMeta m = isJust <$> isInstantiatedMeta' m @@ -240,13 +392,13 @@ instance IsInstantiatedMeta a => IsInstantiatedMeta (Abs a) where   isInstantiatedMeta = isInstantiatedMeta . unAbs -isInstantiatedMeta' :: (MonadFail m, ReadTCState m) => MetaId -> m (Maybe Term)+{-# SPECIALIZE isInstantiatedMeta' :: MetaId -> TCM (Maybe Term) #-}+isInstantiatedMeta' :: (ReadTCState m) => MetaId -> m (Maybe Term) isInstantiatedMeta' m = do-  mv <- lookupMeta m-  return $ case mvInstantiation mv of-    InstV tel v -> Just $ foldr mkLam v tel-    _           -> Nothing-+  inst <- lookupMetaInstantiation m+  return $ case inst of+    InstV inst -> Just $ foldr mkLam (instBody inst) (instTel inst)+    _          -> Nothing  -- | Returns all metavariables in a constraint. Slightly complicated by the --   fact that blocked terms are represented by two meta variables. To find the@@ -269,16 +421,18 @@       UnquoteTactic t h g      -> return $ allMetas Set.singleton (t, h, g)       SortCmp _ s1 s2          -> return $ allMetas Set.singleton (Sort s1, Sort s2)       UnBlock x                -> Set.insert x . Set.unions <$> (mapM listenerMetas =<< getMetaListeners x)-      FindInstance x _         ->+      FindInstance _ x _       ->         -- #5093: We should not generalize over metas bound by instance constraints.         -- We keep instance constraints even if the meta is solved, to check that it could indeed         -- be filled by instance search. If it's solved, look in the solution.         caseMaybeM (isInstantiatedMeta' x) (return $ Set.singleton x) $ return . allMetas Set.singleton+      ResolveInstanceHead{}    -> return mempty       IsEmpty{}                -> return mempty       CheckFunDef{}            -> return mempty       CheckSizeLtSat{}         -> return mempty       HasBiggerSort{}          -> return mempty       HasPTSRule{}             -> return mempty+      CheckDataSort{}          -> return mempty       CheckMetaInst x          -> return mempty       CheckType t              -> return $ allMetas Set.singleton t       CheckLockedVars a b c d  -> return $ allMetas Set.singleton (a, b, c, d)@@ -299,7 +453,7 @@   r        <- getCurrentRange   cl       <- buildClosure r   gen      <- viewTC eGeneralizeMetas-  modality <- viewTC eModality+  modality <- currentModality   return MetaInfo     { miClosRange       = cl     , miModality        = modality@@ -319,8 +473,11 @@         "cannot set meta name; newMeta returns " ++ show u       return () -getMetaNameSuggestion :: (MonadFail m, ReadTCState m) => MetaId -> m MetaNameSuggestion-getMetaNameSuggestion mi = miNameSuggestion . mvInfo <$> lookupMeta mi+getMetaNameSuggestion ::+  (HasCallStack, MonadDebug m, ReadTCState m) =>+  MetaId -> m MetaNameSuggestion+getMetaNameSuggestion mi =+  miNameSuggestion . mvInfo <$> lookupLocalMeta mi  setMetaNameSuggestion :: MonadMetaSolver m => MetaId -> MetaNameSuggestion -> m () setMetaNameSuggestion mi s = unless (null s || isUnderscore s) $ do@@ -329,7 +486,8 @@   updateMetaVar mi $ \ mvar ->     mvar { mvInfo = (mvInfo mvar) { miNameSuggestion = s }} --- | Change the ArgInfo that will be used when generalizing over this meta.+-- | Change the ArgInfo that will be used when generalizing over this+-- local meta-variable. setMetaGeneralizableArgInfo :: MonadMetaSolver m => MetaId -> ArgInfo -> m () setMetaGeneralizableArgInfo m i = updateMetaVar m $ \ mv ->   mv { mvInfo = (mvInfo mv)@@ -357,9 +515,12 @@     => (InteractionPoints -> InteractionPoints) -> m ()   modifyInteractionPoints = lift . modifyInteractionPoints +instance MonadInteractionPoints m => MonadInteractionPoints (ExceptT e m)+instance MonadInteractionPoints m => MonadInteractionPoints (MaybeT m) instance MonadInteractionPoints m => MonadInteractionPoints (IdentityT m) instance MonadInteractionPoints m => MonadInteractionPoints (ReaderT r m) instance MonadInteractionPoints m => MonadInteractionPoints (StateT s m)+instance (MonadInteractionPoints m, Monoid w) => MonadInteractionPoints (WriterT w m)  instance MonadInteractionPoints TCM where   freshInteractionId = fresh@@ -388,7 +549,7 @@   ii <- case maybeId of     Just i  -> return $ InteractionId i     Nothing -> freshInteractionId-  let ip = InteractionPoint { ipRange = r, ipMeta = Nothing, ipSolved = False, ipClause = IPNoClause }+  let ip = InteractionPoint { ipRange = r, ipMeta = Nothing, ipSolved = False, ipClause = IPNoClause, ipBoundary = IPBoundary mempty }   case BiMap.insertLookupWithKey (\ key new old -> old) ii ip m of     -- If the interaction point is already present, we keep the old ip.     -- However, it needs to be at the same range as the new one.@@ -410,17 +571,18 @@   listToMaybe $ mapMaybe sameRange $ BiMap.toList m   where     sameRange :: (InteractionId, InteractionPoint) -> Maybe InteractionId-    sameRange (ii, InteractionPoint r' _ False _) | r == r' = Just ii+    sameRange (ii, InteractionPoint r' _ False _ _) | r == r' = Just ii     sameRange _ = Nothing --- | Hook up meta variable to interaction point.+{-# INLINABLE connectInteractionPoint #-}+-- | Hook up a local meta-variable to an interaction point. connectInteractionPoint   :: MonadInteractionPoints m   => InteractionId -> MetaId -> m () connectInteractionPoint ii mi = do   ipCl <- asksTC envClause   m <- useR stInteractionPoints-  let ip = InteractionPoint { ipRange = __IMPOSSIBLE__, ipMeta = Just mi, ipSolved = False, ipClause = ipCl }+  let ip = InteractionPoint { ipRange = __IMPOSSIBLE__, ipMeta = Just mi, ipSolved = False, ipClause = ipCl, ipBoundary = IPBoundary mempty }   -- The interaction point needs to be present already, we just set the meta.   case BiMap.insertLookupWithKey (\ key new old -> new { ipRange = ipRange old }) ii ip m of     (Nothing, _) -> __IMPOSSIBLE__@@ -441,16 +603,19 @@ getInteractionMetas =   mapMaybe ipMeta . filter (not . ipSolved) . BiMap.elems <$> useR stInteractionPoints -getUniqueMetasRanges :: (MonadFail m, ReadTCState m) => [MetaId] -> m [Range]+getUniqueMetasRanges ::+  (HasCallStack, MonadDebug m, ReadTCState m) => [MetaId] -> m [Range] getUniqueMetasRanges = fmap (nubOn id) . mapM getMetaRange -getUnsolvedMetas :: (MonadFail m, ReadTCState m) => m [Range]+getUnsolvedMetas ::+  (HasCallStack, MonadDebug m, ReadTCState m) => m [Range] getUnsolvedMetas = do   openMetas            <- getOpenMetas   interactionMetas     <- getInteractionMetas   getUniqueMetasRanges (openMetas List.\\ interactionMetas) -getUnsolvedInteractionMetas :: (MonadFail m, ReadTCState m) => m [Range]+getUnsolvedInteractionMetas ::+  (HasCallStack, MonadDebug m, ReadTCState m) => m [Range] getUnsolvedInteractionMetas = getUniqueMetasRanges =<< getInteractionMetas  -- | Get all metas that correspond to unsolved interaction ids.@@ -468,21 +633,21 @@ -- | Get the information associated to an interaction point. {-# SPECIALIZE lookupInteractionPoint :: InteractionId -> TCM InteractionPoint #-} lookupInteractionPoint-  :: (MonadFail m, ReadTCState m, MonadError TCErr m)+  :: (ReadTCState m, MonadError TCErr m, MonadTCEnv m)   => InteractionId -> m InteractionPoint lookupInteractionPoint ii =-  fromMaybeM err $ BiMap.lookup ii <$> useR stInteractionPoints-  where-    err  = fail $ "no such interaction point: " ++ show ii+  fromMaybeM (interactionError $ NoSuchInteractionPoint ii) $+    BiMap.lookup ii <$> useR stInteractionPoints +{-# SPECIALIZE lookupInteractionId :: InteractionId -> TCM MetaId #-} -- | Get 'MetaId' for an interaction point. --   Precondition: interaction point is connected. lookupInteractionId-  :: (MonadFail m, ReadTCState m, MonadError TCErr m, MonadTCEnv m)+  :: (ReadTCState m, MonadError TCErr m, MonadTCEnv m)   => InteractionId -> m MetaId-lookupInteractionId ii = fromMaybeM err2 $ ipMeta <$> lookupInteractionPoint ii-  where-    err2 = typeError $ GenericError $ "No type nor action available for hole " ++ prettyShow ii ++ ". Possible cause: the hole has not been reached during type checking (do you see yellow?)"+lookupInteractionId ii =+  fromMaybeM (interactionError $ NoActionForInteractionPoint ii) $+    ipMeta <$> lookupInteractionPoint ii  -- | Check whether an interaction id is already associated with a meta variable. lookupInteractionMeta :: ReadTCState m => InteractionId -> m (Maybe MetaId)@@ -493,7 +658,7 @@  -- | Generate new meta variable. newMeta :: MonadMetaSolver m => Frozen -> MetaInfo -> MetaPriority -> Permutation -> Judgement a -> m MetaId-newMeta = newMeta' Open+newMeta = newMeta' (OpenMeta UnificationMeta)  -- | Generate a new meta variable with some instantiation given. --   For instance, the instantiation could be a 'PostponedTypeCheckingProblem'.@@ -519,18 +684,21 @@ -- | Get the 'Range' for an interaction point. {-# SPECIALIZE getInteractionRange :: InteractionId -> TCM Range #-} getInteractionRange-  :: (MonadInteractionPoints m, MonadFail m, MonadError TCErr m)+  :: (MonadInteractionPoints m, MonadDebug m, MonadError TCErr m)   => InteractionId -> m Range getInteractionRange = ipRange <.> lookupInteractionPoint --- | Get the 'Range' for a meta variable.-getMetaRange :: (MonadFail m, ReadTCState m) => MetaId -> m Range-getMetaRange = getRange <.> lookupMeta+-- | Get the 'Range' for a local meta-variable.+getMetaRange ::+  (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m Range+getMetaRange = getRange <.> lookupLocalMeta -getInteractionScope-  :: (MonadFail m, ReadTCState m, MonadError TCErr m, MonadTCEnv m)-  => InteractionId -> m ScopeInfo-getInteractionScope = getMetaScope <.> lookupMeta <=< lookupInteractionId+getInteractionScope ::+  (MonadDebug m, ReadTCState m, MonadError TCErr m,+   MonadTCEnv m) =>+  InteractionId -> m ScopeInfo+getInteractionScope =+  getMetaScope <.> lookupLocalMeta <=< lookupInteractionId  withMetaInfo' :: (MonadTCEnv m, ReadTCState m, MonadTrace m) => MetaVariable -> m a -> m a withMetaInfo' mv = withMetaInfo (miClosRange $ mvInfo mv)@@ -539,31 +707,27 @@ withMetaInfo mI cont = enterClosure mI $ \ r ->   setCurrentRange r cont -withInteractionId-  :: (MonadFail m, ReadTCState m, MonadError TCErr m, MonadTCEnv m, MonadTrace m)-  => InteractionId -> m a -> m a+withInteractionId ::+  (MonadDebug m, ReadTCState m, MonadError TCErr m,+   MonadTCEnv m, MonadTrace m) =>+  InteractionId -> m a -> m a withInteractionId i ret = do   m <- lookupInteractionId i   withMetaId m ret -withMetaId-  :: (MonadFail m, MonadTCEnv m, ReadTCState m, MonadTrace m)-  => MetaId -> m a -> m a+withMetaId ::+  (HasCallStack, MonadDebug m, MonadTCEnv m, MonadTrace m,+   ReadTCState m) =>+  MetaId -> m a -> m a withMetaId m ret = do-  mv <- lookupMeta m+  mv <- lookupLocalMeta m   withMetaInfo' mv ret -getMetaVariables :: ReadTCState m => (MetaVariable -> Bool) -> m [MetaId]-getMetaVariables p = do-  store <- getMetaStore-  return [ MetaId i | (i, mv) <- IntMap.assocs store, p mv ]- getOpenMetas :: ReadTCState m => m [MetaId]-getOpenMetas = getMetaVariables (isOpenMeta . mvInstantiation)+getOpenMetas = MapS.keys <$> useR stOpenMetaStore  isOpenMeta :: MetaInstantiation -> Bool-isOpenMeta Open                           = True-isOpenMeta OpenInstance                   = True+isOpenMeta OpenMeta{}                     = True isOpenMeta BlockedConst{}                 = True isOpenMeta PostponedTypeCheckingProblem{} = True isOpenMeta InstV{}                        = False@@ -579,58 +743,101 @@ unlistenToMeta l m =   updateMetaVar m $ \mv -> mv { mvListeners = Set.delete l $ mvListeners mv } --- | Get the listeners to a meta.-getMetaListeners :: (MonadFail m, ReadTCState m) => MetaId -> m [Listener]-getMetaListeners m = Set.toList . mvListeners <$> lookupMeta m+-- | Get the listeners for a local meta-variable.+getMetaListeners ::+  (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m [Listener]+getMetaListeners m = Set.toList . mvListeners <$> lookupLocalMeta m  clearMetaListeners :: MonadMetaSolver m => MetaId -> m () clearMetaListeners m =   updateMetaVar m $ \mv -> mv { mvListeners = Set.empty } +-- | Do safe eta-expansions for meta (@SingletonRecords,Levels@).+etaExpandMetaSafe :: (MonadMetaSolver m) => MetaId -> m ()+etaExpandMetaSafe = etaExpandMeta [SingletonRecords,Levels]++-- | Eta expand metavariables listening on the current meta.+etaExpandListeners :: MonadMetaSolver m => MetaId -> m ()+etaExpandListeners m = do+  ls <- getMetaListeners m+  clearMetaListeners m  -- we don't really have to do this+  mapM_ wakeupListener ls++-- | Wake up a meta listener and let it do its thing+wakeupListener :: MonadMetaSolver m => Listener -> m ()+  -- Andreas 2010-10-15: do not expand record mvars, lazyness needed for irrelevance+wakeupListener (EtaExpand x)         = etaExpandMetaSafe x+wakeupListener (CheckConstraint _ c) = do+  --reportSDoc "tc.meta.blocked" 20 $ "waking boxed constraint" <+> prettyTCM c+  modifyAwakeConstraints (c:)+  solveAwakeConstraints++solveAwakeConstraints :: (MonadConstraint m) => m ()+solveAwakeConstraints = solveAwakeConstraints' False++solveAwakeConstraints' :: (MonadConstraint m) => Bool -> m ()+solveAwakeConstraints' = solveSomeAwakeConstraints (const True)+ --------------------------------------------------------------------------- -- * Freezing and unfreezing metas. --------------------------------------------------------------------------- --- | Freeze the given meta-variables and return those that were not---   already frozen.-freezeMetas :: MetaStore -> TCM IntSet+{-# SPECIALIZE freezeMetas :: LocalMetaStore -> TCM (Set MetaId) #-}+-- | Freeze the given meta-variables (but only if they are open) and+-- return those that were not already frozen.+freezeMetas :: forall m. (MonadTCState m, ReadTCState m) => LocalMetaStore -> m (Set MetaId) freezeMetas ms =   execWriterT $-  modifyTCLensM stMetaStore $-  execStateT (mapM_ freeze $ IntMap.keys ms)+  modifyTCLensM stOpenMetaStore $+  execStateT (mapM_ freeze $ MapS.keys ms)   where-  freeze :: Monad m => Int -> StateT MetaStore (WriterT IntSet m) ()+  freeze :: MetaId -> StateT LocalMetaStore (WriterT (Set MetaId) m) ()   freeze m = do     store <- get-    case IntMap.lookup m store of+    case MapS.lookup m store of       Just mvar         | mvFrozen mvar /= Frozen -> do-          lift $ tell (IntSet.singleton m)-          put $ IntMap.insert m (mvar { mvFrozen = Frozen }) store+          lift $ tell (Set.singleton m)+          put $ MapS.insert m (mvar { mvFrozen = Frozen }) store         | otherwise -> return ()-      Nothing -> __IMPOSSIBLE__+      Nothing -> return () --- | Thaw all meta variables.+-- | Thaw all open meta variables. unfreezeMetas :: TCM ()-unfreezeMetas = modifyMetaStore $ IntMap.map unfreeze+unfreezeMetas = stOpenMetaStore `modifyTCLens` MapS.map unfreeze   where   unfreeze :: MetaVariable -> MetaVariable   unfreeze mvar = mvar { mvFrozen = Instantiable } -isFrozen :: (MonadFail m, ReadTCState m) => MetaId -> m Bool+{-# SPECIALIZE isFrozen :: MetaId -> TCM Bool #-}+isFrozen ::+  (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m Bool isFrozen x = do-  mvar <- lookupMeta x+  mvar <- lookupLocalMeta x   return $ mvFrozen mvar == Frozen --- | Unfreeze meta and its type if this is a meta again.---   Does not unfreeze deep occurrences of metas.+withFrozenMetas ::+    (MonadMetaSolver m, MonadTCState m)+  => m a -> m a+withFrozenMetas act = do+  openMetas <- useR stOpenMetaStore+  frozenMetas <- freezeMetas openMetas+  result <- act+  forM_ frozenMetas $ \m ->+    updateMetaVar m $ \ mv -> mv { mvFrozen = Instantiable }+  return result++-- | Unfreeze a meta and its type if this is a meta again.+--   Does not unfreeze deep occurrences of meta-variables or remote+--   meta-variables. class UnFreezeMeta a where   unfreezeMeta :: MonadMetaSolver m => a -> m ()  instance UnFreezeMeta MetaId where-  unfreezeMeta x = do+  unfreezeMeta x = unlessM (($ x) <$> isRemoteMeta) $ do     updateMetaVar x $ \ mv -> mv { mvFrozen = Instantiable }     unfreezeMeta =<< metaType x+{-# SPECIALIZE unfreezeMeta :: MetaId -> TCM () #-}  instance UnFreezeMeta Type where   unfreezeMeta (El s t) = unfreezeMeta s >> unfreezeMeta t
src/full/Agda/TypeChecking/Monad/MetaVars.hs-boot view
@@ -1,11 +1,14 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Monad.MetaVars where  import Control.Monad.Reader import Control.Monad.State+import Control.Monad.Writer import Control.Monad.Trans.Identity ( IdentityT )+import Control.Monad.Trans.Maybe    ( MaybeT ) -import Agda.Syntax.Common (InteractionId)+import Agda.Syntax.Common (InteractionId, MetaId) import Agda.TypeChecking.Monad.Base  class (MonadTCEnv m, ReadTCState m) => MonadInteractionPoints m where@@ -23,7 +26,11 @@   modifyInteractionPoints = lift . modifyInteractionPoints  instance MonadInteractionPoints m => MonadInteractionPoints (IdentityT m)+instance MonadInteractionPoints m => MonadInteractionPoints (MaybeT m) instance MonadInteractionPoints m => MonadInteractionPoints (ReaderT r m) instance MonadInteractionPoints m => MonadInteractionPoints (StateT s m)+instance (MonadInteractionPoints m, Monoid w) => MonadInteractionPoints (WriterT w m)  instance MonadInteractionPoints TCM++isInteractionMeta :: ReadTCState m => MetaId -> m (Maybe InteractionId)
+ src/full/Agda/TypeChecking/Monad/Modality.hs view
@@ -0,0 +1,212 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{- | Modality.++Agda has support for several modalities, namely:++ * 'Cohesion'+ * 'Quantity'+ * 'Relevance'++In order to type check such modalities, we must store the current modality in+the typing context. This module provides functions to update the context based+on a given modality.++See "Agda.TypeChecking.Irrelevance".+-}++module Agda.TypeChecking.Monad.Modality where++import qualified Data.Map as Map++import Agda.Interaction.Options++import Agda.Syntax.Common++import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Context+import Agda.TypeChecking.Monad.Debug+import Agda.TypeChecking.Monad.Env++import Agda.Utils.Function+import Agda.Utils.Lens+import Agda.Utils.Monad++-- | data 'Relevance'+--   see "Agda.Syntax.Common".++-- * Operations on 'Dom'.++-- | Prepare parts of a parameter telescope for abstraction in constructors+--   and projections.+hideAndRelParams :: (LensHiding a, LensRelevance a) => a -> a+hideAndRelParams = hideOrKeepInstance . mapRelevance shapeIrrelevantToIrrelevant++-- * Operations on 'Context'.++-- | Modify the context whenever going from the l.h.s. (term side)+--   of the typing judgement to the r.h.s. (type side).+workOnTypes :: (MonadTCEnv m, HasOptions m, MonadDebug m)+            => m a -> m a+workOnTypes cont = do+  allowed <- optExperimentalIrrelevance <$> pragmaOptions+  verboseBracket "tc.irr" 60 "workOnTypes" $ workOnTypes' allowed cont++-- | Internal workhorse, expects value of --experimental-irrelevance flag+--   as argument.+workOnTypes' :: (MonadTCEnv m) => Bool -> m a -> m a+workOnTypes' experimental+  = applyWhen experimental (modifyContextInfo $ mapRelevance irrelevantToShapeIrrelevant)+  . applyQuantityToJudgement zeroQuantity+  . applyPolarityToContext (withStandardLock UnusedPolarity)+  . typeLevelReductions+  . localTC (\ e -> e { envWorkingOnTypes = True })++applyPolarityToContext :: (MonadTCEnv tcm, LensModalPolarity p) => p -> tcm a -> tcm a+applyPolarityToContext p = localTC+  $ over eContext     (map $ inverseApplyPolarity pol)+  . over eLetBindings (Map.map . fmap . onLetBindingType+                       $ inverseApplyPolarity pol)+  where+    pol = getModalPolarity p++-- | (Conditionally) wake up irrelevant variables and make them relevant.+--   For instance,+--   in an irrelevant function argument otherwise irrelevant variables+--   may be used, so they are awoken before type checking the argument.+--+--   Also allow the use of irrelevant definitions.+applyRelevanceToContext :: (MonadTCEnv tcm, LensRelevance r) => r -> tcm a -> tcm a+applyRelevanceToContext thing =+  applyUnless (isRelevant rel)+   $ applyRelevanceToContextOnly   rel+   . applyRelevanceToJudgementOnly rel+  where rel = getRelevance thing++-- | (Conditionally) wake up irrelevant variables and make them relevant.+--   For instance,+--   in an irrelevant function argument otherwise irrelevant variables+--   may be used, so they are awoken before type checking the argument.+--+--   Precondition: @Relevance /= Relevant@+applyRelevanceToContextOnly :: (MonadTCEnv tcm) => Relevance -> tcm a -> tcm a+applyRelevanceToContextOnly rel = localTC+  $ over eContext     (map $ inverseApplyRelevance rel)+  . over eLetBindings (Map.map . fmap . onLetBindingType $ inverseApplyRelevance rel)++-- | Apply relevance @rel@ the the relevance annotation of the (typing/equality)+--   judgement.  This is part of the work done when going into a @rel@-context.+--+--   Precondition: @Relevance /= Relevant@+applyRelevanceToJudgementOnly :: (MonadTCEnv tcm) => Relevance -> tcm a -> tcm a+applyRelevanceToJudgementOnly = localTC . over eRelevance . composeRelevance++-- | Like 'applyRelevanceToContext', but only act on context if+--   @--irrelevant-projections@.+--   See issue #2170.+applyRelevanceToContextFunBody :: (MonadTCM tcm, LensRelevance r) => r -> tcm a -> tcm a+applyRelevanceToContextFunBody thing cont =+  case getRelevance thing of+    Relevant{} -> cont+    rel -> applyWhenM (optIrrelevantProjections <$> pragmaOptions)+      (applyRelevanceToContextOnly rel) $    -- enable local irr. defs only when option+      applyRelevanceToJudgementOnly rel cont -- enable global irr. defs alway++-- | Apply the quantity to the quantity annotation of the+-- (typing/equality) judgement.+--+-- Precondition: The quantity must not be @'Quantity1' something@.+applyQuantityToJudgement ::+  (MonadTCEnv tcm, LensQuantity q) => q -> tcm a -> tcm a+applyQuantityToJudgement =+  localTC . over eQuantity . composeQuantity . getQuantity++-- | Apply inverse composition with the given cohesion to the typing context.+applyCohesionToContext :: (MonadTCEnv tcm, LensCohesion m) => m -> tcm a -> tcm a+applyCohesionToContext thing =+  case getCohesion thing of+    m | m == unitCohesion -> id+      | otherwise         -> applyCohesionToContextOnly   m+                             -- Cohesion does not apply to the judgment.++applyCohesionToContextOnly :: (MonadTCEnv tcm) => Cohesion -> tcm a -> tcm a+applyCohesionToContextOnly q = localTC+  $ over eContext     (map $ inverseApplyCohesion q)+  . over eLetBindings (Map.map . fmap . onLetBindingType $ inverseApplyCohesion q)++-- | Can we split on arguments of the given cohesion?+splittableCohesion :: (HasOptions m, LensCohesion a) => a -> m Bool+splittableCohesion a = do+  let c = getCohesion a+  pure (usableCohesion c) `and2M` (pure (c /= Flat) `or2M` do optFlatSplit <$> pragmaOptions)+++{-# SPECIALIZE applyModalityToContext :: Modality -> TCM a -> TCM a #-}+-- | (Conditionally) wake up irrelevant variables and make them relevant.+--   For instance,+--   in an irrelevant function argument otherwise irrelevant variables+--   may be used, so they are awoken before type checking the argument.+--+--   Also allow the use of irrelevant definitions.+--+--   This function might also do something for other modalities.+applyModalityToContext :: (MonadTCEnv tcm, LensModality m) => m -> tcm a -> tcm a+applyModalityToContext thing =+  case getModality thing of+    m | m == unitModality -> id+      | otherwise         -> applyModalityToContextOnly   m+                           . applyModalityToJudgementOnly m++-- | (Conditionally) wake up irrelevant variables and make them relevant.+--   For instance,+--   in an irrelevant function argument otherwise irrelevant variables+--   may be used, so they are awoken before type checking the+--   argument.+--+--   This function might also do something for other modalities, but+--   not for quantities.+--+--   Precondition: @Modality /= Relevant@+applyModalityToContextOnly :: (MonadTCEnv tcm) => Modality -> tcm a -> tcm a+applyModalityToContextOnly m = localTC+  $ over eContext (map $ inverseApplyModalityButNotQuantity m)+  . over eLetBindings+      (Map.map . fmap . onLetBindingType $ inverseApplyModalityButNotQuantity m)++-- | Apply the relevance and quantity components of the modality to+-- the modality annotation of the (typing/equality) judgement.+--+-- Precondition: The relevance component must not be 'Relevant'.+applyModalityToJudgementOnly :: (MonadTCEnv tcm) => Modality -> tcm a -> tcm a+applyModalityToJudgementOnly m =+  localTC $ over eRelevance (composeRelevance (getRelevance m)) .+            over eQuantity  (composeQuantity  (getQuantity m))++-- | Like 'applyModalityToContext', but only act on context (for Relevance) if+--   @--irrelevant-projections@.+--   See issue #2170.+applyModalityToContextFunBody :: (MonadTCM tcm, LensModality r) => r -> tcm a -> tcm a+applyModalityToContextFunBody thing cont = do+    ifM (optIrrelevantProjections <$> pragmaOptions)+      {-then-} (applyModalityToContext m cont)                -- enable global irr. defs always+      {-else-} (applyRelevanceToContextFunBody (getRelevance m)+               $ applyCohesionToContext (getCohesion m)+               $ applyPolarityToContext (getModalPolarity m)+               $ applyQuantityToJudgement (getQuantity m) cont) -- enable local irr. defs only when option+  where+    m = getModality thing++-- | Wake up irrelevant variables and make them relevant. This is used+--   when type checking terms in a hole, in which case you want to be able to+--   (for instance) infer the type of an irrelevant variable. In the course+--   of type checking an irrelevant function argument 'applyRelevanceToContext'+--   is used instead, which also sets the context relevance to 'Irrelevant'.+--   This is not the right thing to do when type checking interactively in a+--   hole since it also marks all metas created during type checking as+--   irrelevant (issue #2568).+--+--   Also set the current quantity to 0.+wakeIrrelevantVars :: (MonadTCEnv tcm) => tcm a -> tcm a+wakeIrrelevantVars+  = applyRelevanceToContextOnly irrelevant+  . applyQuantityToJudgement zeroQuantity
src/full/Agda/TypeChecking/Monad/Mutual.hs view
@@ -1,13 +1,11 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Monad.Mutual where  import Prelude hiding (null) --- import qualified Data.Set as Set-import qualified Data.Map as Map+import qualified Data.IntMap as IntMap  import Agda.Syntax.Info as Info import Agda.Syntax.Internal@@ -15,7 +13,6 @@ import Agda.TypeChecking.Monad.State  import Agda.Utils.Null-import Agda.Utils.Pretty ( prettyShow )  noMutualBlock :: TCM a -> TCM a noMutualBlock = localTC $ \e -> e { envMutualBlock = Nothing }@@ -32,19 +29,11 @@     -- Don't create a new mutual block if we're already inside one.     Just i -> m i --- | Set the mutual block info for a block,---   possibly overwriting the existing one.--setMutualBlockInfo :: MutualId -> Info.MutualInfo -> TCM ()-setMutualBlockInfo mi info = stMutualBlocks `modifyTCLens` Map.alter f mi-  where-  f Nothing                   = Just $ MutualBlock info empty-  f (Just (MutualBlock _ xs)) = Just $ MutualBlock info xs- -- | Set the mutual block info for a block if non-existing.  insertMutualBlockInfo :: MutualId -> Info.MutualInfo -> TCM ()-insertMutualBlockInfo mi info = stMutualBlocks `modifyTCLens` Map.alter f mi+insertMutualBlockInfo (MutualId i) info =+  stMutualBlocks `modifyTCLens` IntMap.alter f (fromIntegral i)   where   f Nothing = Just $ MutualBlock info empty   f (Just mb@(MutualBlock info0 xs))@@ -54,9 +43,9 @@ -- | Set the mutual block for a definition.  setMutualBlock :: MutualId -> QName -> TCM ()-setMutualBlock i x = do-  stMutualBlocks `modifyTCLens` Map.alter f i-  stSignature    `modifyTCLens` updateDefinition x (\ defn -> defn { defMutual = i })+setMutualBlock m@(MutualId i) x = do+  stMutualBlocks `modifyTCLens` IntMap.alter f (fromIntegral i)+  stSignature    `modifyTCLens` updateDefinition x \ defn -> defn { defMutual = m }   where   f Nothing                    = Just $ MutualBlock empty $ Set.singleton x   f (Just (MutualBlock mi xs)) = Just $ MutualBlock mi $ Set.insert x xs@@ -66,17 +55,7 @@ currentOrFreshMutualBlock :: TCM MutualId currentOrFreshMutualBlock = maybe fresh return =<< asksTC envMutualBlock -lookupMutualBlock :: MutualId -> TCM MutualBlock-lookupMutualBlock mi = do-  mbs <- useTC stMutualBlocks-  case Map.lookup mi mbs of-    Just mb -> return mb-    Nothing -> return empty -- can end up here if we ask for the current mutual block and there is none---- | Reverse lookup of a mutual block id for a names.-mutualBlockOf :: QName -> TCM MutualId-mutualBlockOf x = do-  mb <- Map.toList <$> useTC stMutualBlocks-  case filter (Set.member x . mutualNames . snd) mb of-    (i, _) : _ -> return i-    _          -> fail $ "No mutual block for " ++ prettyShow x+lookupMutualBlock :: ReadTCState tcm => MutualId -> tcm MutualBlock+lookupMutualBlock (MutualId i) =+  IntMap.findWithDefault empty (fromIntegral i) <$> useTC stMutualBlocks+    -- can be empty if we ask for the current mutual block and there is none
src/full/Agda/TypeChecking/Monad/Open.hs view
@@ -60,11 +60,9 @@       if m == cur then return o                   else return $ OpenThing (-1) (Map.filterWithKey (\ k _ -> k == 0) env) m x -    findParent m1 m2-      | Set.null keys = empty-      | otherwise     = return $ Set.findMax keys-      where-        keys = Set.intersection (Map.keysSet m1) (Map.keysSet m2)+    findParent m1 m2 = case Map.lookupMax (Map.intersection m1 m2) of+      Nothing       -> empty+      Just (max, _) -> return max  -- | An 'Open' is closed if it has checkpoint 0. isClosed :: Open a -> Bool
src/full/Agda/TypeChecking/Monad/Options.hs view
@@ -1,7 +1,8 @@  module Agda.TypeChecking.Monad.Options where -import Control.Arrow          ( (&&&) )+import Prelude hiding (null)+ import Control.Monad          ( unless, when ) import Control.Monad.IO.Class ( MonadIO(..) ) import Control.Monad.Except@@ -11,59 +12,79 @@  import qualified Data.Graph as Graph import Data.List (sort)-import Data.Maybe import Data.Map (Map) import qualified Data.Map as Map+import qualified Data.Set as Set  import System.Directory import System.FilePath  import Agda.Syntax.Common-import Agda.Syntax.Concrete (TopLevelModuleName)-import qualified Agda.Syntax.Concrete as C-import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.TopLevelModuleName+ import Agda.TypeChecking.Monad.Debug (reportSDoc) import Agda.TypeChecking.Warnings import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Imports import Agda.TypeChecking.Monad.State import Agda.TypeChecking.Monad.Benchmark+import Agda.TypeChecking.Monad.Trace+ import Agda.Interaction.FindFile-import Agda.Interaction.Options+import Agda.Interaction.Options hiding (setPragmaOptions) import qualified Agda.Interaction.Options.Lenses as Lens import Agda.Interaction.Library+import Agda.Interaction.Library.Base (LibCache(LibCache), libAbove, libFile, runLibM)+ import Agda.Utils.FileName-import Agda.Utils.Functor import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as G+import Agda.Utils.Lens import Agda.Utils.List-import Agda.Utils.Maybe-import Agda.Utils.Pretty-import Agda.Utils.Tuple+import Agda.Utils.List1 (List1)+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Null+import Agda.Syntax.Common.Pretty+import Agda.Utils.Size import Agda.Utils.WithDefault  import Agda.Utils.Impossible  -- | Sets the pragma options.-+--   Checks for unsafe combinations. setPragmaOptions :: PragmaOptions -> TCM () setPragmaOptions opts = do-  stPragmaOptions `modifyTCLens` Lens.mapSafeMode (Lens.getSafeMode opts ||)-  clo <- commandLineOptions-  let unsafe = unsafePragmaOptions clo opts-  when (Lens.getSafeMode opts && not (null unsafe)) $ warning $ SafeFlagPragma unsafe-  runOptM (checkOpts clo{ optPragmaOptions = opts }) >>= \case-    Left err   -> __IMPOSSIBLE__-    Right opts -> do-      stPragmaOptions `setTCLens` optPragmaOptions opts-      updateBenchmarkingStatus+  -- Check for unsafe pragma options if @--safe@ is on.+  when (Lens.getSafeMode opts) $+    unlessNull (unsafePragmaOptions opts) $ \ unsafe ->+      warning $ SafeFlagPragma $ Set.fromList unsafe +  stPragmaOptions `setTCLens` opts+  updateBenchmarkingStatus++-- | Check that that you don't turn on inconsistent options. For instance, if --a implies --b and+--   you have both --a and --no-b. Only warn for things that have changed compared to the old+--   options.+checkPragmaOptionConsistency :: PragmaOptions -> PragmaOptions -> TCM ()+checkPragmaOptionConsistency oldOpts newOpts = do+  mapM_ check impliedPragmaOptions+  where+    -- Only warn if both flags are set explicitly (Value rather than Default)+    check (ImpliesPragmaOption nameA valA flagA nameB valB flagB)+      | flagA newOpts == flagA oldOpts+      , flagB newOpts == flagB oldOpts  = pure () -- Nothing changed, don't check again.+      | Value vA <- flagA newOpts, vA == valA+      , Value vB <- flagB newOpts, vB /= valB = warning $ ConflictingPragmaOptions (nameA .= valA) (nameB .= valB)+      | otherwise                 = pure ()+      where+        name .= True  = name+        name .= False = "no-" ++ name+ -- | Sets the command line options (both persistent and pragma options -- are updated). -- -- Relative include directories are made absolute with respect to the -- current working directory. If the include directories have changed--- (thus, they are 'Left' now, and were previously @'Right' something@),--- then the state is reset (completely, see setIncludeDirs) .+-- then the state is reset (partly, see 'setIncludeDirs'). -- -- An empty list of relative include directories (@'Left' []@) is -- interpreted as @["."]@.@@ -78,15 +99,13 @@   -> CommandLineOptions   -> TCM () setCommandLineOptions' root opts = do-  runOptM (checkOpts opts) >>= \case-    Left err   -> __IMPOSSIBLE__-    Right opts -> do+  -- Andreas, 2022-11-19: removed a call to checkOpts which did nothing.       incs <- case optAbsoluteIncludePaths opts of         [] -> do           opts' <- setLibraryPaths root opts           let incs = optIncludePaths opts'           setIncludeDirs incs root-          getIncludeDirs+          List1.toList <$> getIncludeDirs         incs -> return incs       modifyTC $ Lens.setCommandLineOptions opts{ optAbsoluteIncludePaths = incs }       setPragmaOptions (optPragmaOptions opts)@@ -94,29 +113,71 @@  libToTCM :: LibM a -> TCM a libToTCM m = do-  cachedConfs <- useTC stProjectConfigs-  cachedLibs  <- useTC stAgdaLibFiles--  ((z, warns), (cachedConfs', cachedLibs')) <- liftIO $-    (`runStateT` (cachedConfs, cachedLibs)) $ runWriterT $ runExceptT m+  libCache <- useTC stLibCache+  ((z, warns), libCache') <- liftIO $ runLibM m libCache -  modifyTCLens stProjectConfigs $ const cachedConfs'-  modifyTCLens stAgdaLibFiles   $ const cachedLibs'+  setTCLens stLibCache libCache' -  unless (null warns) $ warnings $ map LibraryWarning warns+  List1.unlessNull warns \ warns -> warnings $ fmap LibraryWarning warns   case z of-    Left s  -> typeError $ GenericDocError s+    Left s  -> typeError $ LibraryError s     Right x -> return x -getAgdaLibFiles :: FilePath -> TCM [AgdaLibFile]-getAgdaLibFiles root = do+-- | Returns the library files for a given file.+--+-- Nothing is returned if 'optUseLibs' is 'False'.+--+-- An error is raised if 'optUseLibs' is 'True' and a library file is+-- located too far down the directory hierarchy (see+-- 'checkLibraryFileNotTooFarDown').++getAgdaLibFiles+  :: AbsolutePath        -- ^ The file name.+  -> TopLevelModuleName  -- ^ The top-level module name.+  -> TCM [AgdaLibFile]+getAgdaLibFiles f m = do+  ls <- getAgdaLibFilesWithoutTopLevelModuleName f+  mapM_ (checkLibraryFileNotTooFarDown m) ls+  return ls++-- | Returns potential library files for a file without a known+-- top-level module name.+--+-- Once the top-level module name is known one can use+-- 'checkLibraryFileNotTooFarDown' to check that the potential library+-- files were not located too far down the directory hierarchy.+--+-- Nothing is returned if 'optUseLibs' is 'False'.++getAgdaLibFilesWithoutTopLevelModuleName+  :: AbsolutePath  -- ^ The file.+  -> TCM [AgdaLibFile]+getAgdaLibFilesWithoutTopLevelModuleName f = do   useLibs <- optUseLibs <$> commandLineOptions-  if | useLibs   -> libToTCM $ mkLibM [] $ getAgdaLibFiles' root+  if | useLibs   -> libToTCM $ getAgdaLibFile root      | otherwise -> return []+  where+  root = takeDirectory $ filePath f -getLibraryOptions :: FilePath -> TCM [OptionsPragma]-getLibraryOptions root = map _libPragmas <$> getAgdaLibFiles root+-- | Checks that a library file for the module @A.B.C@ (say) in the+-- directory @dir/A/B@ is located at least two directories above the+-- file (not in @dir/A@ or @dir/A/B@). +checkLibraryFileNotTooFarDown ::+  TopLevelModuleName ->+  AgdaLibFile ->+  TCM ()+checkLibraryFileNotTooFarDown m lib =+  when (lib ^. libAbove < size m - 1) $ typeError $ LibTooFarDown m lib++-- | Returns the library options for a given file.++getLibraryOptions+  :: AbsolutePath        -- ^ The file name.+  -> TopLevelModuleName  -- ^ The top-level module name.+  -> TCM [OptionsPragma]+getLibraryOptions f m = map _libPragmas <$> getAgdaLibFiles f m+ setLibraryPaths   :: AbsolutePath      -- ^ The base directory of relative paths.@@ -158,13 +219,30 @@   -- or is a security risk.   return o{ optTrustedExecutables = trustedExes } +-- | Set pragma options without checking for consistency. setOptionsFromPragma :: OptionsPragma -> TCM ()-setOptionsFromPragma ps = do+setOptionsFromPragma = setOptionsFromPragma' False++-- | Set pragma options and check them for consistency.+checkAndSetOptionsFromPragma :: OptionsPragma -> TCM ()+checkAndSetOptionsFromPragma = setOptionsFromPragma' True++setOptionsFromPragma' :: Bool -> OptionsPragma -> TCM ()+setOptionsFromPragma' checkConsistency ps = setCurrentRange (pragmaRange ps) $ do     opts <- commandLineOptions-    runOptM (parsePragmaOptions ps opts) >>= \case-      Left err    -> typeError $ GenericError err-      Right opts' -> setPragmaOptions opts'+    let (z, warns) = runOptM (parsePragmaOptions ps opts)+    mapM_ (warning . OptionWarning) warns+    case z of+      Left err    -> typeError $ OptionError err+      Right opts' -> do +        -- Check consistency of implied options+        when checkConsistency $ do+          oldOpts <- pragmaOptions+          checkPragmaOptionConsistency oldOpts opts'++        setPragmaOptions opts'+ -- | Disable display forms. enableDisplayForms :: MonadTCEnv m => m a -> m a enableDisplayForms =@@ -184,12 +262,9 @@ -- Precondition: 'optAbsoluteIncludePaths' must be nonempty (i.e. -- 'setCommandLineOptions' must have run). -getIncludeDirs :: HasOptions m => m [AbsolutePath]+getIncludeDirs :: HasOptions m => m (List1 AbsolutePath) getIncludeDirs = do-  incs <- optAbsoluteIncludePaths <$> commandLineOptions-  case incs of-    [] -> __IMPOSSIBLE__-    _  -> return incs+  List1.fromListSafe __IMPOSSIBLE__ . optAbsoluteIncludePaths <$> commandLineOptions  -- | Makes the given directories absolute and stores them as include -- directories.@@ -208,24 +283,22 @@   oldIncs <- getsTC Lens.getAbsoluteIncludePaths    -- Add the current dir if no include path is given-  incs <- return $ if null incs then ["."] else incs+  incs <- return $ List1.fromListSafe (List1.singleton ".") incs   -- Make paths absolute-  incs <- return $  map (mkAbsolute . (filePath root </>)) incs+  incs <- return $ fmap (mkAbsolute . (filePath root </>)) incs    -- Andreas, 2013-10-30  Add default include dir-      -- NB: This is an absolute file name, but-      -- Agda.Utils.FilePath wants to check absoluteness anyway.-  primdir <- liftIO $ mkAbsolute <$> getPrimitiveLibDir+  primdir <- useTC stPrimitiveLibDir       -- We add the default dir at the end, since it is then       -- printed last in error messages.       -- Might also be useful to overwrite default imports...-  incs <- return $ nubOn id $ incs ++ [primdir]+  incs <- return $ List1.fromListSafe __IMPOSSIBLE__ $ nubOn id $ List1.toList $ incs <> List1.singleton primdir    reportSDoc "setIncludeDirs" 10 $ return $ vcat     [ "Old include directories:"     , nest 2 $ vcat $ map pretty oldIncs     , "New include directories:"-    , nest 2 $ vcat $ map pretty incs+    , nest 2 $ vcat $ fmap pretty incs     ]    -- Check whether the include dirs have changed.  If yes, reset state.@@ -241,22 +314,20 @@   -- up in a situation in which we use the contents of the file   -- "old-path/M.agda", when the user actually meant   -- "new-path/M.agda".-  when (sort oldIncs /= sort incs) $ do+  when (sort oldIncs /= sort (List1.toList incs)) $ do     ho <- getInteractionOutputCallback     tcWarnings <- useTC stTCWarnings -- restore already generated warnings-    projectConfs <- useTC stProjectConfigs  -- restore cached project configs & .agda-lib-    agdaLibFiles <- useTC stAgdaLibFiles    -- files, since they use absolute paths+    libCache   <- useTC stLibCache   -- restore cached project configs & .agda-lib files, since they use absolute paths     decodedModules <- getDecodedModules     (keptDecodedModules, modFile) <- modulesToKeep incs decodedModules     resetAllState     setTCLens stTCWarnings tcWarnings-    setTCLens stProjectConfigs projectConfs-    setTCLens stAgdaLibFiles agdaLibFiles+    setTCLens stLibCache libCache     setInteractionOutputCallback ho     setDecodedModules keptDecodedModules-    setTCLens stModuleToSource modFile+    setTCLens stModuleToSourceId modFile -  Lens.putAbsoluteIncludePaths incs+  Lens.putAbsoluteIncludePaths $ List1.toList incs   where   -- A decoded module is kept if its top-level module name is resolved   -- to the same absolute path using the old and the new include@@ -270,24 +341,24 @@   -- ModuleToSource structure, constructed using the new include   -- directories, is returned.   modulesToKeep-    :: [AbsolutePath]  -- New include directories.+    :: List1 AbsolutePath -- New include directories.     -> DecodedModules  -- Old decoded modules.-    -> TCM (DecodedModules, ModuleToSource)+    -> TCM (DecodedModules, ModuleToSourceId)   modulesToKeep incs old = process Map.empty Map.empty modules     where     -- A graph with one node per module in old, and an edge from m to     -- n if the module corresponding to m imports the module     -- corresponding to n.-    dependencyGraph :: G.Graph A.ModuleName ()+    dependencyGraph :: G.Graph TopLevelModuleName ()     dependencyGraph =       G.fromNodes-        [ iModuleName $ miInterface m+        [ iTopLevelModuleName $ miInterface m         | m <- Map.elems old         ]         `G.union`       G.fromEdges         [ G.Edge-            { source = iModuleName $ miInterface m+            { source = iTopLevelModuleName $ miInterface m             , target = d             , label = ()             }@@ -304,17 +375,16 @@                 -- Agda does not allow cycles in the dependency graph.                 __IMPOSSIBLE__               Graph.AcyclicSCC m ->-                case Map.lookup (A.toTopLevelModuleName m) old of+                case Map.lookup m old of                   Just m  -> m                   Nothing -> __IMPOSSIBLE__) $       G.sccs' dependencyGraph      process ::-      Map A.ModuleName ModuleInfo -> ModuleToSource -> [ModuleInfo] ->-      TCM (DecodedModules, ModuleToSource)+      Map TopLevelModuleName ModuleInfo -> ModuleToSourceId ->+      [ModuleInfo] -> TCM (DecodedModules, ModuleToSourceId)     process !keep !modFile [] = return       ( Map.fromList $-        map (mapFst A.toTopLevelModuleName) $         Map.toList keep       , modFile       )@@ -323,21 +393,23 @@           depsKept = all (`Map.member` keep) deps       (keep, modFile) <-         if not depsKept then return (keep, modFile) else do-        let n = iModuleName $ miInterface m-            t = A.toTopLevelModuleName n+        let t = iTopLevelModuleName $ miInterface m         oldF            <- findFile' t-        (newF, modFile) <- liftIO $ findFile'' incs t modFile+        (newF, modFile) <- runStateT (findFile'_ incs t) modFile         return $ case (oldF, newF) of           (Right f1, Right f2) | f1 == f2 ->-            (Map.insert n m keep, modFile)+            (Map.insert t m keep, modFile)           _ -> (keep, modFile)       process keep modFile ms  isPropEnabled :: HasOptions m => m Bool isPropEnabled = optProp <$> pragmaOptions +isLevelUniverseEnabled :: HasOptions m => m Bool+isLevelUniverseEnabled = optLevelUniverse <$> pragmaOptions+ isTwoLevelEnabled :: HasOptions m => m Bool-isTwoLevelEnabled = collapseDefault . optTwoLevel <$> pragmaOptions+isTwoLevelEnabled = optTwoLevel <$> pragmaOptions  {-# SPECIALIZE hasUniversePolymorphism :: TCM Bool #-} hasUniversePolymorphism :: HasOptions m => m Bool@@ -346,6 +418,9 @@ showImplicitArguments :: HasOptions m => m Bool showImplicitArguments = optShowImplicit <$> pragmaOptions +showGeneralizedArguments :: HasOptions m => m Bool+showGeneralizedArguments = (\opt -> optShowGeneralized opt) <$> pragmaOptions+ showIrrelevantArguments :: HasOptions m => m Bool showIrrelevantArguments = optShowIrrelevant <$> pragmaOptions @@ -364,14 +439,18 @@  withShowAllArguments' :: ReadTCState m => Bool -> m a -> m a withShowAllArguments' yes = withPragmaOptions $ \ opts ->-  opts { optShowImplicit = yes, optShowIrrelevant = yes }+  opts { _optShowImplicit = Value yes, _optShowIrrelevant = Value yes } +withoutPrintingGeneralization :: ReadTCState m => m a -> m a+withoutPrintingGeneralization = withPragmaOptions $ \ opts ->+  opts { _optShowGeneralized = Value False }+ -- | Change 'PragmaOptions' for a computation and restore afterwards. withPragmaOptions :: ReadTCState m => (PragmaOptions -> PragmaOptions) -> m a -> m a withPragmaOptions = locallyTCState stPragmaOptions  positivityCheckEnabled :: HasOptions m => m Bool-positivityCheckEnabled = not . optDisablePositivity <$> pragmaOptions+positivityCheckEnabled = optPositivityCheck <$> pragmaOptions  {-# SPECIALIZE typeInType :: TCM Bool #-} typeInType :: HasOptions m => m Bool@@ -392,7 +471,7 @@ getLanguage = do   opts <- pragmaOptions   return $-    if not (collapseDefault (optWithoutK opts)) then WithK else+    if not (optWithoutK opts) then WithK else     case optCubical opts of       Just variant -> Cubical variant       Nothing      -> WithoutK
src/full/Agda/TypeChecking/Monad/Options.hs-boot view
@@ -1,9 +1,11 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.Monad.Options where  import Agda.Interaction.Library.Base import Agda.Interaction.Options.HasOptions import Agda.TypeChecking.Monad.Base-import Agda.Utils.FileName+import Agda.Utils.List1 (List1)  libToTCM       :: LibM a -> TCM a-getIncludeDirs :: HasOptions m => m [AbsolutePath]+getIncludeDirs :: HasOptions m => m (List1 AbsolutePath)
src/full/Agda/TypeChecking/Monad/Pure.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | A typeclass collecting all 'pure' typechecking operations -- | (i.e. ones that do not modify the typechecking state, throw or -- | catch errors, or do IO other than debug printing).@@ -6,10 +8,10 @@ module Agda.TypeChecking.Monad.Pure where  import Control.Monad.Except ( ExceptT )-import Control.Monad.Trans.Maybe ( MaybeT ) import Control.Monad.Reader ( ReaderT ) import Control.Monad.State ( StateT ) import Control.Monad.Trans.Identity ( IdentityT )+import Control.Monad.Trans.Maybe ( MaybeT ) import Control.Monad.Writer ( WriterT )  import Agda.TypeChecking.Monad.Base@@ -19,6 +21,7 @@ import Agda.TypeChecking.Monad.Signature  import Agda.Utils.ListT+import Agda.Utils.Update  class   ( HasBuiltins m@@ -32,6 +35,7 @@  instance PureTCM TCM where instance PureTCM m => PureTCM (BlockT m)+instance PureTCM m => PureTCM (ChangeT m) instance PureTCM m => PureTCM (ExceptT e m) instance PureTCM m => PureTCM (IdentityT m) instance PureTCM m => PureTCM (ListT m)
src/full/Agda/TypeChecking/Monad/Pure.hs-boot view
@@ -1,15 +1,18 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Monad.Pure where +import Control.Monad.Except ( ExceptT ) import Control.Monad.Reader ( ReaderT ) import Control.Monad.State ( StateT ) import Control.Monad.Trans.Identity ( IdentityT )+import Control.Monad.Trans.Maybe ( MaybeT ) import Control.Monad.Writer ( WriterT )  import Agda.TypeChecking.Monad.Base import {-# SOURCE #-} Agda.TypeChecking.Monad.Builtin import {-# SOURCE #-} Agda.TypeChecking.Monad.Context-import Agda.TypeChecking.Monad.Debug+import {-# SOURCE #-} Agda.TypeChecking.Monad.Debug import {-# SOURCE #-} Agda.TypeChecking.Monad.Signature  class@@ -23,7 +26,9 @@   ) => PureTCM m where  instance PureTCM TCM where+instance PureTCM m => PureTCM (ExceptT e m) instance PureTCM m => PureTCM (IdentityT m)+instance PureTCM m => PureTCM (MaybeT m) instance PureTCM m => PureTCM (ReaderT r m) instance (PureTCM m, Monoid w) => PureTCM (WriterT w m) instance PureTCM m => PureTCM (StateT s m)
src/full/Agda/TypeChecking/Monad/Signature.hs view
@@ -4,8 +4,6 @@  import Prelude hiding (null) -import qualified Control.Monad.Fail as Fail- import Control.Arrow                 ( first, second ) import Control.Monad.Except          ( ExceptT ) import Control.Monad.State           ( StateT  )@@ -38,6 +36,7 @@ import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.Context+import Agda.TypeChecking.Monad.Constraints import Agda.TypeChecking.Monad.Env import Agda.TypeChecking.Monad.Mutual import Agda.TypeChecking.Monad.Open@@ -50,16 +49,18 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.CompiledClause import Agda.TypeChecking.Coverage.SplitTree+import {-# SOURCE #-} Agda.TypeChecking.InstanceArguments import {-# SOURCE #-} Agda.TypeChecking.CompiledClause.Compile import {-# SOURCE #-} Agda.TypeChecking.Polarity import {-# SOURCE #-} Agda.TypeChecking.Pretty import {-# SOURCE #-} Agda.TypeChecking.ProjectionLike import {-# SOURCE #-} Agda.TypeChecking.Reduce--import {-# SOURCE #-} Agda.Compiler.Treeless.Erase-import {-# SOURCE #-} Agda.Compiler.Builtin+import {-# SOURCE #-} Agda.TypeChecking.Opacity+import {-# SOURCE #-} Agda.TypeChecking.Telescope +import Agda.Utils.CallStack.Base import Agda.Utils.Either+import Agda.Utils.Function ( applyWhen ) import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List@@ -68,21 +69,102 @@ import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Pretty (prettyShow)+import Agda.Syntax.Common.Pretty (Doc, prettyShow) import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Update  import Agda.Utils.Impossible +-- | If the first argument is @'Erased' something@, then hard+-- compile-time mode is enabled when the continuation is run.++setHardCompileTimeModeIfErased+  :: Erased+  -> TCM a+     -- ^ Continuation.+  -> TCM a+setHardCompileTimeModeIfErased erased =+  localTC+    $ applyWhen (isErased erased) (set eHardCompileTimeMode True)+    . over eQuantity (`composeQuantity` asQuantity erased)++-- | If the quantity is \"erased\", then hard compile-time mode is+-- enabled when the continuation is run.+--+-- Precondition: The quantity must not be @'Quantity1' something@.++setHardCompileTimeModeIfErased'+  :: LensQuantity q+  => q+     -- ^ The quantity.+  -> TCM a+     -- ^ Continuation.+  -> TCM a+setHardCompileTimeModeIfErased' =+  setHardCompileTimeModeIfErased .+    fromMaybe __IMPOSSIBLE__ . erasedFromQuantity . getQuantity++-- | Use run-time mode in the continuation unless the current mode is+-- the hard compile-time mode.++setRunTimeModeUnlessInHardCompileTimeMode+  :: TCM a+     -- ^ Continuation.+  -> TCM a+setRunTimeModeUnlessInHardCompileTimeMode c =+  ifM (viewTC eHardCompileTimeMode) c $+  localTC (over eQuantity $ mapQuantity (`addQuantity` topQuantity)) c++-- | Use hard compile-time mode in the continuation if the first+-- argument is @'Erased' something@. Use run-time mode if the first+-- argument is @'NotErased' something@ and the current mode is not+-- hard compile-time mode.++setModeUnlessInHardCompileTimeMode+  :: Erased+  -> TCM a+     -- ^ Continuation.+  -> TCM a+setModeUnlessInHardCompileTimeMode erased c = case erased of+  Erased{}    -> setHardCompileTimeModeIfErased erased c+  NotErased{} -> do+    warnForPlentyInHardCompileTimeMode erased+    setRunTimeModeUnlessInHardCompileTimeMode c++-- | Warn if the user explicitly wrote @@ω@ or @@plenty@ but the+-- current mode is the hard compile-time mode.++warnForPlentyInHardCompileTimeMode :: Erased -> TCM ()+warnForPlentyInHardCompileTimeMode = \case+  Erased{}    -> return ()+  NotErased o -> do+    let warn = warning $ PlentyInHardCompileTimeMode o+    hard <- viewTC eHardCompileTimeMode+    if not hard then return () else case o of+      QωInferred{} -> return ()+      Qω{}         -> warn+      QωPlenty{}   -> warn+ -- | Add a constant to the signature. Lifts the definition to top level. addConstant :: QName -> Definition -> TCM () addConstant q d = do   reportSDoc "tc.signature" 20 $ "adding constant " <+> pretty q <+> " to signature"++  -- Every constant that gets added to the signature in hard+  -- compile-time mode is treated as erased.+  hard <- viewTC eHardCompileTimeMode+  d    <- if not hard then return d else do+    case erasedFromQuantity (getQuantity d) of+      Nothing     -> __IMPOSSIBLE__+      Just erased -> do+        warnForPlentyInHardCompileTimeMode erased+        return $ mapQuantity (zeroQuantity `composeQuantity`) d+   tel <- getContextTelescope   let tel' = replaceEmptyName "r" $ killRange $ case theDef d of               Constructor{} -> fmap hideOrKeepInstance tel-              Function{ funProjection = Just Projection{ projProper = Just{}, projIndex = n } } ->+              Function{ funProjection = Right Projection{ projProper = Just{}, projIndex = n } } ->                 let fallback = fmap hideOrKeepInstance tel in                 if n > 0 then fallback else                 -- if the record value is part of the telescope, its hiding should left unchanged@@ -96,22 +178,30 @@   i <- currentOrFreshMutualBlock   setMutualBlock i q   where-    new +++ old = new { defDisplay = defDisplay new ++ defDisplay old-                      , defInstance = defInstance new `mplus` defInstance old }+    new +++ old = new { defDisplay        = defDisplay new ++ defDisplay old+                      , defInstance       = defInstance new `mplus` defInstance old+                      , defArgOccurrences = if null (defArgOccurrences new)+                                              then defArgOccurrences old+                                              else defArgOccurrences new+                      , defPolarity       = if null (defPolarity new)+                                              then defPolarity old+                                              else defPolarity new+                      }  -- | A combination of 'addConstant' and 'defaultDefn'. The 'Language' -- does not need to be supplied.  addConstant' ::-  QName -> ArgInfo -> QName -> Type -> Defn -> TCM ()-addConstant' q info x t def = do+  QName -> ArgInfo -> Type -> Defn -> TCM ()+addConstant' q info t def = do   lang <- getLanguage-  addConstant q $ defaultDefn info x t lang def+  addConstant q $ defaultDefn info q t lang def  -- | Set termination info of a defined function symbol.-setTerminates :: QName -> Bool -> TCM ()+setTerminates :: MonadTCState m => QName -> Bool -> m () setTerminates q b = modifySignature $ updateDefinition q $ updateTheDef $ \case     def@Function{} -> def { funTerminates = Just b }+    def@Record{}   -> def { recTerminates = Just b }     def -> def  -- | Set CompiledClauses of a defined function symbol.@@ -135,52 +225,39 @@  -- | Lifts clauses to the top-level and adds them to definition. --   Also adjusts the 'funCopatternLHS' field if necessary.-addClauses :: QName -> [Clause] -> TCM ()+addClauses :: (MonadConstraint m, MonadTCState m) => QName -> [Clause] -> m () addClauses q cls = do   tel <- getContextTelescope   modifySignature $ updateDefinition q $     updateTheDef (updateFunClauses (++ abstract tel cls))     . updateDefCopatternLHS (|| isCopatternLHS cls) +  -- Jesper, 2022-10-13: unblock any constraints that were+  -- waiting for more clauses of this function+  wakeConstraints' $ wakeIfBlockedOnDef q . constraintUnblocker+ mkPragma :: String -> TCM CompilerPragma mkPragma s = CompilerPragma <$> getCurrentRange <*> pure s  -- | Add a compiler pragma `{-\# COMPILE <backend> <name> <text> \#-}` addPragma :: BackendName -> QName -> String -> TCM ()-addPragma b q s = ifM erased-  {- then -} (warning $ PragmaCompileErased b q)-  {- else -} $ do+addPragma b q s = do     pragma <- mkPragma s     modifySignature $ updateDefinition q $ addCompilerPragma b pragma -  where--  erased :: TCM Bool-  erased = do-    def <- theDef <$> getConstInfo q-    case def of-      -- If we have a defined symbol, we check whether it is erasable-      Function{} ->-        locallyTC      eActiveBackendName (const $ Just b) $-        locallyTCState stBackends         (const $ builtinBackends) $-        isErasable q-     -- Otherwise (Axiom, Datatype, Record type, etc.) we keep it-      _ -> pure False- getUniqueCompilerPragma :: BackendName -> QName -> TCM (Maybe CompilerPragma) getUniqueCompilerPragma backend q = do   ps <- defCompilerPragmas backend <$> getConstInfo q   case ps of     []  -> return Nothing     [p] -> return $ Just p-    (_:p1:_) ->-      setCurrentRange p1 $-            genericDocError =<< do-                  hang (text ("Conflicting " ++ backend ++ " pragmas for") <+> pretty q <+> "at") 2 $-                       vcat [ "-" <+> pretty (getRange p) | p <- ps ]+    _:p1:_ -> setCurrentRange p1 do+      typeError . CustomBackendError backend =<< do+        hang (hsep [ "Conflicting", pretty backend, "pragmas for", prettyTCM q, "at" ]) 2 $+          vcat [ "-" <+> pretty (getRange p) | p <- ps ]  setFunctionFlag :: FunctionFlag -> Bool -> QName -> TCM ()-setFunctionFlag flag val q = modifyGlobalDefinition q $ set (theDefLens . funFlag flag) val+setFunctionFlag flag val q = modifyGlobalDefinition q $ set (lensTheDef . funFlag flag) val  markStatic :: QName -> TCM () markStatic = setFunctionFlag FunStatic True@@ -191,13 +268,18 @@ markInjective :: QName -> TCM () markInjective q = modifyGlobalDefinition q $ \def -> def { defInjective = True } +markFirstOrder :: QName -> TCM ()+markFirstOrder = setFunctionFlag FunFirstOrder True+ unionSignatures :: [Signature] -> Signature unionSignatures ss = foldr unionSignature emptySignature ss-  where-    unionSignature (Sig a b c) (Sig a' b' c') =++unionSignature :: Signature -> Signature -> Signature+unionSignature (Sig a b c d) (Sig a' b' c' d') =       Sig (Map.union a a')-          (HMap.union b b')              -- definitions are unique (in at most one module)-          (HMap.unionWith mappend c c')  -- rewrite rules are accumulated+          (HMap.union b b')             -- definitions are unique (in at most one module)+          (HMap.unionWith mappend c c') -- rewrite rules are accumulated+          (d <> d')                     -- instances are accumulated  -- | Add a section to the signature. --@@ -278,7 +360,7 @@    -- Turn unfoldings into display forms   npars <- subtract (projectionArgs def) <$> getContextSize-  let dfs = catMaybes $ map (displayForm npars v) vs+  let dfs = map (displayForm npars v) vs   reportSDoc "tc.display.section" 20 $ nest 2 $ vcat     [ "displayForms:" <?> vcat [ "-" <+> (pretty y <+> "-->" <?> pretty df) | (y, df) <- dfs ] ] @@ -293,14 +375,16 @@     -- Given an unfolding `top = λ xs → y es` generate a display form     -- `y es ==> top xs`. The first `npars` variables in `xs` are module parameters     -- and should not be pattern variables, but matched literally.-    displayForm :: Nat -> Term -> Term -> Maybe (QName, DisplayForm)+    displayForm :: Nat -> Term -> Term -> (QName, DisplayForm)     displayForm npars top v =       case view v of-        (xs, Def y es)   -> (y,)         <$> mkDisplay xs es-        (xs, Con h i es) -> (conName h,) <$> mkDisplay xs es+        (xs, Def y es)   -> (y,)         $ mkDisplay xs es+        (xs, Con h i es) -> (conName h,) $ mkDisplay xs es         _ -> __IMPOSSIBLE__       where-        mkDisplay xs es = Just (Display (n - npars) es $ DTerm $ top `apply` args)+        mkDisplay xs es = Display (n - npars) es $ DTerm $ top `apply` args+          -- Andreas, 2023-01-26, #6476:+          -- I think this @apply@ is safe (rather than @DTerm' top (map Apply args)@).           where             n    = length xs             args = zipWith (\ x i -> var i <$ x) xs (downFrom n)@@ -353,30 +437,40 @@     -- and if a constructor is copied its datatype needs to be.     closeConstructors :: Ren QName -> TCM (Ren QName)     closeConstructors rd = do-        ds <- nubOn id . catMaybes <$> traverse constructorData (Map.keys rd)-        cs <- nubOn id . concat    <$> traverse dataConstructors (Map.keys rd)+        ds <- nubOn snd . catMaybes <$> traverse constructorData (Map.toList rd)+        cs <- nubOn snd . concat    <$> traverse dataConstructors (Map.toList rd)         new <- Map.unionsWith (<>) <$> traverse rename (ds ++ cs)         reportSDoc "tc.mod.apply.complete" 30 $           "also copying: " <+> pretty new         return $ Map.unionWith (<>) new rd       where-        rename :: QName -> TCM (Ren QName)-        rename x+        rename :: (ModuleName, QName) -> TCM (Ren QName)+        rename (m, x)           | x `Map.member` rd = pure mempty           | otherwise =-              Map.singleton x . pure . qnameFromList . singleton <$> freshName_ (prettyShow $ qnameName x)+              -- Ulf, 2024-06-24 (#7329):+              --   Here we used to generate an unqualified name, but this breaks things if the new+              --   module shows up in a module application later on. This is because we use the+              --   module name to figure out which arguments from the application are relevant for+              --   the current symbol (see argsToUse in applySection' below).+              --+              --   Instead we use the target module name of the thing that required x to be copied.+              --   For instance, if we are copying a data type A.B.D to X.Y.Z.D and its constructor+              --   mkD is not in the renaming, we add `A.B.mkD -> X.Y.Z.mkD` (instead of `A.B.mkD ->+              --   mkD` which we did before).+              Map.singleton x . pure . qualify m <$> freshName_ (prettyShow $ qnameName x) -        constructorData :: QName -> TCM (Maybe QName)-        constructorData x = do+        constructorData :: (QName, List1.List1 QName) -> TCM (Maybe (ModuleName, QName))+        constructorData (x, y List1.:| _) = do  -- All new names share the same module, so we can safely grab the first one           (theDef <$> getConstInfo x) <&> \case-            Constructor{ conData = d } -> Just d+            Constructor{ conData = d } -> Just (qnameModule y, d)             _                          -> Nothing -        dataConstructors :: QName -> TCM [QName]-        dataConstructors x = do+        dataConstructors :: (QName, List1.List1 QName) -> TCM [(ModuleName, QName)]+        dataConstructors (x, y List1.:| _) = do           (theDef <$> getConstInfo x) <&> \case-            Datatype{ dataCons = cs } -> cs-            Record{ recConHead = h }  -> [conName h]+            Datatype{ dataCons = cs } -> map (qnameModule y,) cs+            Record{ recConHead = h }  -> [(qnameModule y, conName h)]             _                         -> []  applySection' :: ModuleName -> Telescope -> ModuleName -> Args -> ScopeCopyInfo -> TCM ()@@ -410,6 +504,8 @@     -- equivalent valid names and either can be used.     copyName x = maybe x List1.head (Map.lookup x rd) +    copyConHead c = c { conName = copyName (conName c) }+     argsToUse x = do       let m = commonParentModule old x       reportSDoc "tc.mod.apply" 80 $ "Common prefix: " <+> pretty m@@ -428,7 +524,17 @@       reportSDoc "tc.mod.apply" 80 $ vcat         [ "copyDef" <+> pretty x <+> "->" <+> pretty y         , "ts' = " <+> pretty ts' ]-      copyDef' ts' np def+      -- The module telescope had been divided by some μ, so the corresponding+      -- top level definition had type μ \ Γ → B, so if we have a substitution+      -- Δ → Γ we actually want to apply μ \ - to it, so the new top-level+      -- definition we get will have signature μ \ Δ → B.  This is only valid+      -- for pure modality systems though.+      let ai = defArgInfo def+          m = unitModality { modCohesion = getCohesion ai+                           , modPolarity = getModalPolarity ai+                           }+      localTC (over eContext (map (mapModality (m `inverseComposeModality`)))) $+        copyDef' ts' np def       where         copyDef' ts np d = do           reportSDoc "tc.mod.apply" 60 $ "making new def for" <+> pretty y <+> "from" <+> pretty x <+> "with" <+> text (show np) <+> "args" <+> text (show $ defAbstract d)@@ -445,24 +551,23 @@           -- Issue5583: Don't skip constructures, because the original constructor doesn't always           -- work. For instance if it's only available in an anonymous module generated by           -- `open import M args`.-          whenJust inst $ \ c -> addNamedInstance y c+          whenJust inst $ \_ -> addTypedInstance' False False inst y t           -- Set display form for the old name if it's not a constructor. {- BREAKS fail/Issue478           -- Andreas, 2012-10-20 and if we are not an anonymous module-          -- unless (isAnonymousModuleName new || isCon || size ptel > 0) $ do+          -- unless (isAnonymousModuleName new || isCon || not (null ptel)) $ do -}           -- BREAKS fail/Issue1643a           -- -- Andreas, 2015-09-09 Issue 1643:           -- -- Do not add a display form for a bare module alias.-          -- when (not isCon && size ptel == 0 && not (null ts)) $ do-          when (size ptel == 0) $ do+          -- when (not isCon && null ptel && not (null ts)) $ do+          when (null ptel) $ do             addDisplayForms y           where             ts' = take np ts             t   = defType d `piApply` ts'             pol = defPolarity d `apply` ts'             occ = defArgOccurrences d `apply` ts'-            gen = defArgGeneralizable d `apply` ts'             inst = defInstance d             -- the name is set by the addConstant function             nd :: QName -> TCM Definition@@ -476,7 +581,6 @@                     , defType           = t                     , defPolarity       = pol                     , defArgOccurrences = occ-                    , defArgGeneralizable = gen                     , defGeneralizedParams = [] -- This is only needed for type checking data/record defs so no need to copy it.                     , defDisplay        = []                     , defMutual         = -1   -- TODO: mutual block?@@ -507,14 +611,20 @@             -- This is because we may abstract the record argument later again.             -- See succeed/ProjectionNotNormalized.agda             isVar0 t = case unArg t of Var 0 [] -> True; _ -> False+            proj :: Either ProjectionLikenessMissing Projection             proj   = case oldDef of-              Function{funProjection = Just p@Projection{projIndex = n}}+              Function{funProjection = Right p@Projection{projIndex = n}}                 | size ts' < n || (size ts' == n && maybe True isVar0 (lastMaybe ts'))-                -> Just $ p { projIndex = n - size ts'-                            , projLams  = projLams p `apply` ts'-                            , projProper= copyName <$> projProper p-                            }-              _ -> Nothing+                -> Right p { projIndex = n - size ts'+                           , projLams  = projLams p `apply` ts'+                           , projProper= copyName <$> projProper p+                           }+              -- Preserve no-projection-likeness flag if it exists, and+              -- it's set to @Left _@. For future reference: The match+              -- on left can't be simplified or it accidentally+              -- circumvents the guard above.+              Function{funProjection = Left projl} -> Left projl+              _ -> Left MaybeProjection             def =               case oldDef of                 Constructor{ conPars = np, conData = d } -> return $@@ -526,49 +636,53 @@                          , dataClause = Just cl                          , dataCons   = map copyName cs                          }-                Record{ recPars = np, recTel = tel } -> return $+                Record{ recPars = np, recTel = tel, recConHead = c, recFields = fs } -> return $                   oldDef { recPars    = np - size ts'                          , recClause  = Just cl                          , recTel     = apply tel ts'+                         , recConHead = copyConHead c+                         , recFields  = (map . fmap) copyName fs                          }-                GeneralizableVar -> return GeneralizableVar+                GeneralizableVar gv -> return $ GeneralizableVar $ gv `apply` ts'                 _ -> do                   (mst, _, cc) <- compileClauses Nothing [cl] -- Andreas, 2012-10-07 non need for record pattern translation+                  fun          <- emptyFunctionData                   let newDef =+                        set funProj   (oldDef ^. funProj) $                         set funMacro  (oldDef ^. funMacro) $                         set funStatic (oldDef ^. funStatic) $                         set funInline True $-                        emptyFunction-                        { funClauses        = [cl]-                        , funCompiled       = Just cc-                        , funSplitTree      = mst-                        , funMutual         = mutual-                        , funProjection     = proj-                        , funTerminates     = Just True-                        , funExtLam         = extlam-                        , funWith           = with+                        FunctionDefn fun+                        { _funClauses        = [cl]+                        , _funCompiled       = Just cc+                        , _funSplitTree      = mst+                        , _funMutual         = mutual+                        , _funProjection     = proj+                        , _funTerminates     = Just True+                        , _funExtLam         = extlam+                        , _funWith           = with                         }                   reportSDoc "tc.mod.apply" 80 $ ("new def for" <+> pretty x) <?> pretty newDef                   return newDef -            cl = Clause { clauseLHSRange  = getRange $ defClauses d-                        , clauseFullRange = getRange $ defClauses d-                        , clauseTel       = EmptyTel-                        , namedClausePats = []-                        , clauseBody      = Just $ dropArgs pars $ case oldDef of-                            Function{funProjection = Just p} -> projDropParsApply p ProjSystem rel ts'+            cl = Clause { clauseLHSRange    = getRange $ defClauses d+                        , clauseFullRange   = getRange $ defClauses d+                        , clauseTel         = EmptyTel+                        , namedClausePats   = []+                        , clauseBody        = Just $ dropArgs pars $ case oldDef of+                            Function{funProjection = Right p} -> projDropParsApply p ProjSystem rel ts'                             _ -> Def x $ map Apply ts'-                        , clauseType      = Just $ defaultArg t-                        , clauseCatchall  = False-                        , clauseExact       = Just True+                        , clauseType        = Just $ defaultArg t+                        , clauseCatchall    = empty                         , clauseRecursive   = Just False -- definitely not recursive                         , clauseUnreachable = Just False -- definitely not unreachable-                        , clauseEllipsis  = NoEllipsis+                        , clauseEllipsis    = NoEllipsis+                        , clauseWhereModule = Nothing                         }               where                 -- The number of remaining parameters. We need to drop the                 -- lambdas corresponding to these from the clause body above.-                pars = max 0 $ maybe 0 (pred . projIndex) proj+                pars = max 0 $ either (const 0) (pred . projIndex) proj                 rel  = getRelevance $ defArgInfo d      {- Example@@ -616,13 +730,14 @@ -- | Add a display form to a definition (could be in this or imported signature). addDisplayForm :: QName -> DisplayForm -> TCM () addDisplayForm x df = do+  -- Check whether display form is recursive and thus illegal.+  xs <- chaseDisplayForms df Set.empty+  if x `Set.member` xs then warning $ InvalidDisplayForm x "it is recursive" else do   d <- makeOpen df   let add = updateDefinition x $ \ def -> def{ defDisplay = d : defDisplay def }   ifM (isLocal x)     {-then-} (modifySignature add)     {-else-} (stImportsDisplayForms `modifyTCLens` HMap.insertWith (++) x [d])-  whenM (hasLoopingDisplayForm x) $-    typeError . GenericDocError =<< do "Cannot add recursive display form for" <+> pretty x  isLocal :: ReadTCState m => QName -> m Bool isLocal x = HMap.member x <$> useR (stSignature . sigDefinitions)@@ -635,25 +750,51 @@   ifM (isLocal q) (return $ ds ++ ds1 ++ ds2)                   (return $ ds1 ++ ds ++ ds2) +hasDisplayForms :: (HasConstInfo m, ReadTCState m) => QName -> m Bool+hasDisplayForms = fmap (not . null) . getDisplayForms+ -- | Find all names used (recursively) by display forms of a given name.-chaseDisplayForms :: QName -> TCM (Set QName)-chaseDisplayForms q = go Set.empty [q]-  where-    go :: Set QName        -- Accumulator.-       -> [QName]          -- Work list.  TODO: make work set to avoid duplicate chasing?-       -> TCM (Set QName)-    go used []       = pure used-    go used (q : qs) = do-      let rhs (Display _ _ e) = e   -- Only look at names in the right-hand side (#1870)-      let notYetUsed x = if x `Set.member` used then Set.empty else Set.singleton x-      ds <- namesIn' notYetUsed . map (rhs . dget)-            <$> (getDisplayForms q `catchError_` \ _ -> pure [])  -- might be a pattern synonym-      go (Set.union ds used) (Set.toList ds ++ qs)+--+class ChaseDisplayForms a where+  chaseDisplayForms ::+       a                 -- ^ Search this recursively for display form names.+    -> Set QName         -- ^ Already processed names (accumulator).+    -> TCM (Set QName)   -- ^ Found names (superset of accumulator) --- | Check if a display form is looping.-hasLoopingDisplayForm :: QName -> TCM Bool-hasLoopingDisplayForm q = Set.member q <$> chaseDisplayForms q+instance ChaseDisplayForms QName where+  chaseDisplayForms q used+    | q `Set.member` used = return used+    | otherwise           = do+        reportSDoc "tc.display.recursive" 90 $ sep+          [ "Chasing display form", prettyTCM q, "with accumulator", prettyTCM (Set.toList used) ]+        xs <- getDisplayForms q `catchError_` const (pure [])  -- might be a pattern synonym+        chaseDisplayForms xs (Set.insert q used) +instance ChaseDisplayForms DisplayTerm where+  chaseDisplayForms e used = do+    let notYetUsed x = if x `Set.member` used then Set.empty else Set.singleton x+    let ds = namesIn' notYetUsed e+    chaseDisplayForms ds used++instance ChaseDisplayForms DisplayForm where+  -- Only look at names in the right-hand side (#1870)+  chaseDisplayForms = chaseDisplayForms . dfRHS++instance ChaseDisplayForms a => ChaseDisplayForms (Open a) where+  chaseDisplayForms = chaseDisplayForms . openThing++instance ChaseDisplayForms a => ChaseDisplayForms (Set a) where+  chaseDisplayForms s = case Set.minView s of+    Nothing      -> return+    Just (x, s') -> chaseDisplayForms x >=> chaseDisplayForms s'++instance ChaseDisplayForms a => ChaseDisplayForms [a] where+  chaseDisplayForms []     = return+  chaseDisplayForms (x:xs) = chaseDisplayForms x >=> chaseDisplayForms xs+  -- NB: The following does not work because of lacking instance Ord LocalDisplayForm:+  -- chaseDisplayForms = chaseDisplayForms . Set.toList++ canonicalName :: HasConstInfo m => QName -> m QName canonicalName x = do   def <- theDef <$> getConstInfo x@@ -673,22 +814,6 @@   c2 <- canonicalName d2   if (c1 == c2) then return $ Just c1 else return Nothing --- | Can be called on either a (co)datatype, a record type or a---   (co)constructor.-whatInduction :: MonadTCM tcm => QName -> tcm Induction-whatInduction c = liftTCM $ do-  def <- theDef <$> getConstInfo c-  mz <- getBuiltinName' builtinIZero-  mo <- getBuiltinName' builtinIOne-  case def of-    Datatype{}                    -> return Inductive-    Record{} | not (recRecursive def) -> return Inductive-    Record{ recInduction = i    } -> return $ fromMaybe Inductive i-    Constructor{ conInd = i }     -> return i-    _ | Just c == mz || Just c == mo-                                  -> return Inductive-    _                             -> __IMPOSSIBLE__- -- | Does the given constructor come from a single-constructor type? -- -- Precondition: The name has to refer to a constructor.@@ -701,7 +826,7 @@       di <- theDef <$> getConstInfo d       return $ case di of         Record {}                  -> True-        Datatype { dataCons = cs } -> length cs == 1+        Datatype { dataCons = cs } -> natSize cs == 1         _                          -> __IMPOSSIBLE__     _ -> __IMPOSSIBLE__ @@ -709,16 +834,39 @@ data SigError   = SigUnknown String -- ^ The name is not in the signature; default error message.   | SigAbstract       -- ^ The name is not available, since it is abstract.+  | SigCubicalNotErasure+    -- ^ The name is not available because it was defined in Cubical+    -- Agda, but the current language is Erased Cubical Agda, and+    -- @--erasure@ is not active. --- | Standard eliminator for 'SigError'.-sigError :: (String -> a) -> a -> SigError -> a-sigError f a = \case-  SigUnknown s -> f s-  SigAbstract  -> a+-- | Generates a string error message corresponding to+-- 'SigCubicalNotErasure' for a given 'QName'.+notSoPrettySigCubicalNotErasure :: QName -> String+notSoPrettySigCubicalNotErasure q =+  "The name " ++ prettyShow q ++ " which was defined in Cubical " +++  "Agda can only be used in Erased Cubical Agda if the option " +++  "--erasure is used" +-- | Generates an error message corresponding to+-- 'SigCubicalNotErasure' for a given 'QName'.+prettySigCubicalNotErasure :: MonadPretty m => QName -> m Doc+prettySigCubicalNotErasure q = fsep $+  pwords "The name" +++  [prettyTCM q] +++  pwords "which was defined in Cubical Agda can only be used in" +++  pwords "Erased Cubical Agda if the option --erasure is used"++-- | An eliminator for 'SigError'. All constructors except for+-- 'SigAbstract' are assumed to be impossible.+sigError :: (HasCallStack, MonadDebug m) => QName -> m a -> SigError -> m a+sigError q a = \case+  SigUnknown s         -> __IMPOSSIBLE_VERBOSE__ s+  SigAbstract          -> a+  SigCubicalNotErasure -> __IMPOSSIBLE_VERBOSE__ $+    notSoPrettySigCubicalNotErasure q+ class ( Functor m       , Applicative m-      , Fail.MonadFail m       , HasOptions m       , MonadDebug m       , MonadTCEnv m@@ -726,17 +874,22 @@   -- | Lookup the definition of a name. The result is a closed thing, all free   --   variables have been abstracted over.   getConstInfo :: QName -> m Definition-  getConstInfo q = getConstInfo' q >>= \case+  getConstInfo q =+    getConstInfo' q >>= \case       Right d -> return d-      Left (SigUnknown err) -> __IMPOSSIBLE_VERBOSE__ err-      Left SigAbstract      -> __IMPOSSIBLE_VERBOSE__ $+      Left err -> flip (sigError q) err $+        __IMPOSSIBLE_VERBOSE__ $         "Abstract, thus, not in scope: " ++ prettyShow q    -- | Version that reports exceptions:   getConstInfo' :: QName -> m (Either SigError Definition)   -- getConstInfo' q = Right <$> getConstInfo q -- conflicts with default signature -  -- | Lookup the rewrite rules with the given head symbol.+  -- | Return the rewrite rules for the given head symbol that could be tried.+  --   Not categorically all rewrite rules are returned, in particular, none when+  --   reduction of the head symbol is disabled.+  --   Rewrite rules that only happen to be in the signature but are not in scope+  --   are also not returned.   getRewriteRulesFor :: QName -> m RewriteRules    -- Lifting HasConstInfo through monad transformers:@@ -753,11 +906,11 @@  {-# SPECIALIZE getConstInfo :: QName -> TCM Definition #-} +{-# SPECIALIZE getOriginalConstInfo :: QName -> TCM Definition #-} -- | The computation 'getConstInfo' sometimes tweaks the returned -- 'Definition', depending on the current 'Language' and the -- 'Language' of the 'Definition'. This variant of 'getConstInfo' does -- not perform any tweaks.- getOriginalConstInfo ::   (ReadTCState m, HasConstInfo m) => QName -> m Definition getOriginalConstInfo q = do@@ -766,19 +919,39 @@   case (lang, defLanguage def) of     (Cubical CErased, Cubical CFull) ->       locallyTCState-        stPragmaOptions-        (\opts -> opts { optCubical = Just CFull })+        (stPragmaOptions . lensOptCubical)+        (const $ Just CFull)         (getConstInfo q)     _ -> return def +-- | Return the rewrite rules for the given head symbol that could be tried.+--   Not categorically all rewrite rules are returned, e.g. none when+--   reduction of the head symbol is disabled.+--   Rewrite rules that only happen to be in the signature but are not in scope+--   are also not returned. defaultGetRewriteRulesFor :: (ReadTCState m, MonadTCEnv m) => QName -> m RewriteRules defaultGetRewriteRulesFor q = ifNotM (shouldReduceDef q) (return []) $ do+  getFilteredRewriteRulesFor True q++-- | If the 'Bool' parameter is 'True', get the rules in scope,+--   otherwise, get *all* rules unfiltered.+getFilteredRewriteRulesFor :: (ReadTCState m, MonadTCEnv m)+  => Bool            -- ^ Only return rewrite rules that are in scope?+  -> QName           -- ^ Head symbol.+  -> m RewriteRules  -- ^ Rules for the head symbol.+getFilteredRewriteRulesFor filt q = do   st <- getTCState-  let sig = st^.stSignature-      imp = st^.stImports-      look s = HMap.lookup q $ s ^. sigRewriteRules-  return $ mconcat $ catMaybes [look sig, look imp]+  let+    look :: Lens' TCState Signature -> Maybe RewriteRules+    look l = HMap.lookup q $ st ^. (l . sigRewriteRules) +  -- Restrict "imported" rewrite rules to those defined in modules we currently (transitively) import.+  let imps = st ^. stImportedModulesTransitive+  let inScope rew = rewTopModule rew `Set.member` imps+  let rewImported = applyWhen filt (filter inScope) <$> look stImports  -- stImports is actually a superset of imported symbols.++  return $ mconcat $ catMaybes [look stSignature, rewImported]+ -- | Get the original name of the projection --   (the current one could be from a module application). getOriginalProjection :: HasConstInfo m => QName -> m QName@@ -792,23 +965,29 @@     defaultGetConstInfo st env q   getConstInfo q = getConstInfo' q >>= \case       Right d -> return d-      Left (SigUnknown err) -> fail err-      Left SigAbstract      -> notInScopeError $ qnameToConcrete q+      Left (SigUnknown err)     -> fail err+      Left SigAbstract          -> notInScopeError $ qnameToConcrete q+      Left SigCubicalNotErasure -> typeError $ CubicalNotErasure q  defaultGetConstInfo   :: (HasOptions m, MonadDebug m, MonadTCEnv m)   => TCState -> TCEnv -> QName -> m (Either SigError Definition) defaultGetConstInfo st env q = do-    let defs  = st^.(stSignature . sigDefinitions)-        idefs = st^.(stImports . sigDefinitions)+    let defs  = st ^. stSignature . sigDefinitions+        idefs = st ^. stImports   . sigDefinitions     case catMaybes [HMap.lookup q defs, HMap.lookup q idefs] of         []  -> return $ Left $ SigUnknown $ "Unbound name: " ++ prettyShow q ++ showQNameId q-        [d] -> mkAbs env =<< fixQuantity d+        [d] -> checkErasureFixQuantity d >>= \case+                 Left err -> return (Left err)+                 Right d  -> mkAbs env d         ds  -> __IMPOSSIBLE_VERBOSE__ $ "Ambiguous name: " ++ prettyShow q     where       mkAbs env d-        | treatAbstractly' q' env =-          case makeAbstract d of+        -- Apply the reducibility rules (abstract, opaque) to check+        -- whether the definition should be hidden behind an+        -- 'AbstractDef'.+        | not (isAccessibleDef env st d{defName = q'}) =+          case alwaysMakeAbstract d of             Just d      -> return $ Right d             Nothing     -> return $ Left SigAbstract               -- the above can happen since the scope checker is a bit sloppy with 'abstract'@@ -826,15 +1005,20 @@                  initWithDefault __IMPOSSIBLE__ $ mnameToList m              } -      -- Names defined when --cubical is active are (to a large-      -- degree) treated as erased when --erased-cubical is used.-      fixQuantity d = do+      -- Names defined in Cubical Agda may only be used in Erased+      -- Cubical Agda if --erasure is used. In that case they are (to+      -- a large degree) treated as erased.+      checkErasureFixQuantity d = do         current <- getLanguage-        return $-          if defLanguage d == Cubical CFull &&-             current == Cubical CErased-          then setQuantity zeroQuantity d-          else d+        if defLanguage d == Cubical CFull &&+           current == Cubical CErased+        then do+          erasure <- optErasure <$> pragmaOptions+          return $+            if erasure+            then Right $ setQuantity zeroQuantity d+            else Left SigCubicalNotErasure+        else return $ Right d  -- HasConstInfo lifts through monad transformers -- (see default signatures in HasConstInfo class).@@ -874,14 +1058,35 @@ getForcedArgs :: HasConstInfo m => QName -> m [IsForced] getForcedArgs q = defForced <$> getConstInfo q +-- | Returns the occurences given explicitely as polarity annotations in the function type+getOccurrencesFromType :: Type -> TCM [Occurrence]+getOccurrencesFromType t = do+  polarityEnabled <- optPolarity <$> pragmaOptions+  if polarityEnabled then do+    telList <- telToList . theTel <$> telView t+    return $ modalPolarityToOccurrence . modPolarityAnn . getModalPolarity <$> telList+  else return []+ -- | Get argument occurrence info for argument @i@ of definition @d@ (never fails). getArgOccurrence :: QName -> Nat -> TCM Occurrence getArgOccurrence d i = do   def <- getConstInfo d-  return $! case theDef def of-    Constructor{} -> StrictPos-    _             -> fromMaybe Mixed $ defArgOccurrences def !!! i+  case theDef def of+    Constructor{} -> return StrictPos +    -- If the polarity checker has filled in the positivities of+    -- arguments for this function then we believe it, because it should+    -- agree with the signature.+    _ | Just pol <- defArgOccurrences def !!! i ->+      return pol++    -- Otherwise we use them from the type. Since telView can do+    -- reduction we'd rather not do this very often.+    _ -> do+      occs <- getOccurrencesFromType (defType def)++      pure $! fromMaybe Mixed $ occs !!! i+ -- | Sets the 'defArgOccurrences' for the given identifier (which -- should already exist in the signature). setArgOccurrences :: MonadTCState m => QName -> [Occurrence] -> m ()@@ -954,6 +1159,11 @@     _ -> Nothing  -- | Set the mutually recursive identifiers.+--+--   TODO: This produces data of quadratic size (which has to be processed upon serialization).+--   Presumably qs is usually short, but in some cases (for instance for generated code) it may be+--   long. It would be better to assign a unique identifier to each SCC, and store the names+--   separately. setMutual :: QName -> [QName] -> TCM () setMutual d m = modifySignature $ updateDefinition d $ updateTheDef $ \ def ->   case def of@@ -1100,11 +1310,11 @@ instantiateDef d = do   vs  <- freeVarsToApply $ defName d   verboseS "tc.sig.inst" 30 $ do-    ctx <- getContext+    ctx <- getContextNames     m   <- currentModule     reportSDoc "tc.sig.inst" 30 $       "instDef in" <+> pretty m <> ":" <+> pretty (defName d) <+>-      fsep (map pretty $ zipWith (<$) (reverse $ map (fst . unDom) ctx) vs)+      fsep (map pretty $ zipWith (<$) ctx vs)   return $ d `apply` vs  instantiateRewriteRule :: (Functor m, HasConstInfo m, HasOptions m,@@ -1123,17 +1333,16 @@                         => RewriteRules -> m RewriteRules instantiateRewriteRules = mapM instantiateRewriteRule --- | Give the abstract view of a definition.-makeAbstract :: Definition -> Maybe Definition-makeAbstract d =-  case defAbstract d of-    ConcreteDef -> return d-    AbstractDef -> do-      def <- makeAbs $ theDef d-      return d { defArgOccurrences = [] -- no positivity info for abstract things!-               , defPolarity       = [] -- no polarity info for abstract things!-               , theDef = def-               }+-- | Return the abstract view of a definition, /regardless/ of whether+-- the definition would be treated abstractly.+alwaysMakeAbstract :: Definition -> Maybe Definition+alwaysMakeAbstract d =+  do+    def <- makeAbs $ theDef d+    pure d { defArgOccurrences = [] -- no positivity info for abstract things!+           , defPolarity       = [] -- no polarity info for abstract things!+           , theDef = def+           }   where     makeAbs d@Axiom{}            = Just d     makeAbs d@DataOrRecSig{}     = Just d@@ -1148,7 +1357,7 @@     makeAbs d@Record{}    = Just $ AbstractDefn d     makeAbs Primitive{}   = __IMPOSSIBLE__     makeAbs PrimitiveSort{} = __IMPOSSIBLE__-    makeAbs AbstractDefn{}= __IMPOSSIBLE__+    makeAbs AbstractDefn{} = __IMPOSSIBLE__  -- | Enter abstract mode. Abstract definition in the current module are transparent. {-# SPECIALIZE inAbstractMode :: TCM a -> TCM a #-}@@ -1164,44 +1373,35 @@ ignoreAbstractMode :: MonadTCEnv m => m a -> m a ignoreAbstractMode = localTC $ \e -> e { envAbstractMode = IgnoreAbstractMode } --- | Enter concrete or abstract mode depending on whether the given identifier---   is concrete or abstract.+-- | Go under the given opaque block. The unfolding set will turn opaque+-- definitions transparent.+{-# SPECIALIZE underOpaqueId :: OpaqueId -> TCM a -> TCM a #-}+underOpaqueId :: MonadTCEnv m => OpaqueId -> m a -> m a+underOpaqueId i = localTC $ \e -> e { envCurrentOpaqueId = Just i }++-- | Outside of any opaque blocks.+{-# SPECIALIZE notUnderOpaque :: TCM a -> TCM a #-}+notUnderOpaque :: MonadTCEnv m => m a -> m a+notUnderOpaque = localTC $ \e -> e { envCurrentOpaqueId = Nothing }++-- | Enter the reducibility environment associated with a definition:+-- The environment will have the same concreteness as the name, and we+-- will be in the opaque block enclosing the name, if any. {-# SPECIALIZE inConcreteOrAbstractMode :: QName -> (Definition -> TCM a) -> TCM a #-} inConcreteOrAbstractMode :: (MonadTCEnv m, HasConstInfo m) => QName -> (Definition -> m a) -> m a inConcreteOrAbstractMode q cont = do   -- Andreas, 2015-07-01: If we do not ignoreAbstractMode here,   -- we will get ConcreteDef for abstract things, as they are turned into axioms.   def <- ignoreAbstractMode $ getConstInfo q-  case defAbstract def of-    AbstractDef -> inAbstractMode $ cont def-    ConcreteDef -> inConcreteMode $ cont def---- | Check whether a name might have to be treated abstractly (either if we're---   'inAbstractMode' or it's not a local name). Returns true for things not---   declared abstract as well, but for those 'makeAbstract' will have no effect.-treatAbstractly :: MonadTCEnv m => QName -> m Bool-treatAbstractly q = asksTC $ treatAbstractly' q+  let+    k1 = case defAbstract def of+      AbstractDef -> inAbstractMode+      ConcreteDef -> inConcreteMode --- | Andreas, 2015-07-01:---   If the @current@ module is a weak suffix of the identifier module,---   we can see through its abstract definition if we are abstract.---   (Then @treatAbstractly'@ returns @False@).------   If I am not mistaken, then we cannot see definitions in the @where@---   block of an abstract function from the perspective of the function,---   because then the current module is a strict prefix of the module---   of the local identifier.---   This problem is fixed by removing trailing anonymous module name parts---   (underscores) from both names.-treatAbstractly' :: QName -> TCEnv -> Bool-treatAbstractly' q env = case envAbstractMode env of-  ConcreteMode       -> True-  IgnoreAbstractMode -> False-  AbstractMode       -> not $ current `isLeChildModuleOf` m-  where-    current = dropAnon $ envCurrentModule env-    m       = dropAnon $ qnameModule q-    dropAnon (MName ms) = MName $ List.dropWhileEnd isNoName ms+    k2 = case defOpaque def of+      OpaqueDef i    -> underOpaqueId i+      TransparentDef -> notUnderOpaque+  k2 (k1 (cont def))  -- | Get type of a constant, instantiated to the current context. {-# SPECIALIZE typeOfConst :: QName -> TCM Type #-}@@ -1231,7 +1431,7 @@     Constructor{conPars = n} -> n     Primitive{}              -> 0     PrimitiveSort{}          -> 0-    AbstractDefn{}           -> __IMPOSSIBLE__+    AbstractDefn{}           -> 0 -- not impossible when quoting, PR #7828  -- | Is it the name of a record projection? {-# SPECIALIZE isProjection :: QName -> TCM (Maybe Projection) #-}@@ -1241,8 +1441,8 @@ isProjection_ :: Defn -> Maybe Projection isProjection_ def =   case def of-    Function { funProjection = result } -> result-    _                                   -> Nothing+    Function { funProjection = Right result } -> Just result+    _                                         -> Nothing  -- | Is it the name of a non-irrelevant record projection? {-# SPECIALIZE isProjection :: QName -> TCM (Maybe Projection) #-}@@ -1273,7 +1473,7 @@ projectionArgs = maybe 0 (max 0 . pred . projIndex) . isRelevantProjection_  -- | Check whether a definition uses copatterns.-usesCopatterns :: (HasConstInfo m) => QName -> m Bool+usesCopatterns :: (HasConstInfo m, HasBuiltins m) => QName -> m Bool usesCopatterns q = defCopatternLHS <$> getConstInfo q  -- | Apply a function @f@ to its first argument, producing the proper
src/full/Agda/TypeChecking/Monad/Signature.hs-boot view
@@ -1,7 +1,7 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Monad.Signature where -import qualified Control.Monad.Fail as Fail import Control.Monad.Reader import Control.Monad.State @@ -12,15 +12,16 @@   ( TCM, ReadTCState, HasOptions, MonadTCEnv   , Definition, RewriteRules   )-import Agda.TypeChecking.Monad.Debug (MonadDebug)+import {-# SOURCE #-} Agda.TypeChecking.Monad.Debug (MonadDebug) -import Agda.Utils.Pretty (prettyShow)+import Agda.Syntax.Common.Pretty (prettyShow) -data SigError = SigUnknown String | SigAbstract+data SigError = SigUnknown String | SigAbstract | SigCubicalNotErasure +notSoPrettySigCubicalNotErasure :: QName -> String+ class ( Functor m       , Applicative m-      , Fail.MonadFail m       , HasOptions m       , MonadDebug m       , MonadTCEnv m@@ -31,6 +32,9 @@       Left (SigUnknown err) -> __IMPOSSIBLE_VERBOSE__ err       Left SigAbstract      -> __IMPOSSIBLE_VERBOSE__ $         "Abstract, thus, not in scope: " ++ prettyShow q+      Left SigCubicalNotErasure -> __IMPOSSIBLE_VERBOSE__ $+        notSoPrettySigCubicalNotErasure q+   getConstInfo' :: QName -> m (Either SigError Definition)   -- getConstInfo' q = Right <$> getConstInfo q   getRewriteRulesFor :: QName -> m RewriteRules@@ -48,4 +52,3 @@  inFreshModuleIfFreeParams :: TCM a -> TCM a lookupSection :: (Functor m, ReadTCState m) => ModuleName -> m Telescope-
src/full/Agda/TypeChecking/Monad/SizedTypes.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Stuff for sized types that does not require modules --   "Agda.TypeChecking.Reduce" or "Agda.TypeChecking.Constraints"@@ -5,11 +6,9 @@  module Agda.TypeChecking.Monad.SizedTypes where -import Control.Monad.Except+import Control.Monad.Except ( MonadError(..) )  import qualified Data.Foldable as Fold-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Traversable as Trav  import Agda.Syntax.Common@@ -21,15 +20,56 @@ import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.Substitute +import Agda.Utils.CallStack import Agda.Utils.List+import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.Singleton  import Agda.Utils.Impossible  ------------------------------------------------------------------------+-- * Builtins+------------------------------------------------------------------------++-- | Ensure that option @--sized-types@ is on, for the given reason.+--+requireOptionSizedTypes :: (HasCallStack, HasOptions m, MonadTCError m) => String -> m ()+requireOptionSizedTypes reason = unlessM sizedTypesOption $+  typeError $ NeedOptionSizedTypes reason++getBuiltinSize :: (HasBuiltins m) => m (Maybe QName, Maybe QName)+getBuiltinSize = do+  size   <- getBuiltinName' builtinSize+  sizelt <- getBuiltinName' builtinSizeLt+  return (size, sizelt)++-- | Test whether the SIZELT builtin is defined.+haveSizeLt :: TCM Bool+haveSizeLt = isJust <$> getBuiltinName' builtinSizeLt++-- | Add polarity info to a SIZE builtin.+builtinSizeHook :: BuiltinId -> QName -> Type -> TCM ()+builtinSizeHook s q t = do+  when (s `elem` [builtinSizeLt, builtinSizeSuc]) $ do+    modifySignature $ updateDefinition q+      $ updateDefPolarity       (const [Covariant])+      . updateDefArgOccurrences (const [StrictPos])+  when (s == builtinSizeMax) $ do+    modifySignature $ updateDefinition q+      $ updateDefPolarity       (const [Covariant, Covariant])+      . updateDefArgOccurrences (const [StrictPos, StrictPos])+{-+      . updateDefType           (const tmax)+  where+    -- TODO: max : (i j : Size) -> Size< (suc (max i j))+    tmax =+-}++------------------------------------------------------------------------ -- * Testing for type 'Size' ------------------------------------------------------------------------ @@ -70,18 +110,6 @@         testType _                                    = Nothing     return testType -getBuiltinDefName :: (HasBuiltins m) => String -> m (Maybe QName)-getBuiltinDefName s = fromDef <$> getBuiltin' s-  where-    fromDef (Just (Def d [])) = Just d-    fromDef _                 = Nothing--getBuiltinSize :: (HasBuiltins m) => m (Maybe QName, Maybe QName)-getBuiltinSize = do-  size   <- getBuiltinDefName builtinSize-  sizelt <- getBuiltinDefName builtinSizeLt-  return (size, sizelt)- isSizeNameTest :: (HasOptions m, HasBuiltins m) => m (QName -> Bool) isSizeNameTest = ifM sizedTypesOption   isSizeNameTestRaw@@ -92,38 +120,6 @@   (size, sizelt) <- getBuiltinSize   return $ (`elem` [size, sizelt]) . Just --- | Test whether OPTIONS --sized-types and whether---   the size built-ins are defined.-haveSizedTypes :: TCM Bool-haveSizedTypes = do-    Def _ [] <- primSize-    Def _ [] <- primSizeInf-    Def _ [] <- primSizeSuc-    sizedTypesOption-  `catchError` \_ -> return False---- | Test whether the SIZELT builtin is defined.-haveSizeLt :: TCM Bool-haveSizeLt = isJust <$> getBuiltinDefName builtinSizeLt---- | Add polarity info to a SIZE builtin.-builtinSizeHook :: String -> QName -> Type -> TCM ()-builtinSizeHook s q t = do-  when (s `elem` [builtinSizeLt, builtinSizeSuc]) $ do-    modifySignature $ updateDefinition q-      $ updateDefPolarity       (const [Covariant])-      . updateDefArgOccurrences (const [StrictPos])-  when (s == builtinSizeMax) $ do-    modifySignature $ updateDefinition q-      $ updateDefPolarity       (const [Covariant, Covariant])-      . updateDefArgOccurrences (const [StrictPos, StrictPos])-{--      . updateDefType           (const tmax)-  where-    -- TODO: max : (i j : Size) -> Size< (suc (max i j))-    tmax =--}- ------------------------------------------------------------------------ -- * Constructors ------------------------------------------------------------------------@@ -140,6 +136,7 @@ sizeType_ :: QName -> Type sizeType_ size = El sizeSort $ Def size [] +{-# SPECIALIZE sizeType :: TCM Type #-} -- | The built-in type @SIZE@. sizeType :: (HasBuiltins m, MonadTCEnv m, ReadTCState m) => m Type sizeType = El sizeSort . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSize@@ -152,11 +149,12 @@       Just (Def x []) -> return $ Just x       _               -> return Nothing +{-# SPECIALIZE sizeSuc :: Nat -> Term -> TCM Term #-} sizeSuc :: HasBuiltins m => Nat -> Term -> m Term sizeSuc n v | n < 0     = __IMPOSSIBLE__             | n == 0    = return v             | otherwise = do-  Def suc [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSizeSuc+  suc <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSizeSuc   return $ fromMaybe __IMPOSSIBLE__ (iterate (sizeSuc_ suc) v !!! n)  sizeSuc_ :: QName -> Term -> Term@@ -164,11 +162,11 @@  -- | Transform list of terms into a term build from binary maximum. sizeMax :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)-        => NonEmpty Term -> m Term+        => List1 Term -> m Term sizeMax vs = case vs of   v :| [] -> return v   vs  -> do-    Def max [] <- primSizeMax+    max <- getBuiltinName_ builtinSizeMax     return $ foldr1 (\ u v -> Def max $ map (Apply . defaultArg) [u,v]) vs  @@ -183,8 +181,8 @@ sizeView :: (HasBuiltins m, MonadTCEnv m, ReadTCState m)          => Term -> m SizeView sizeView v = do-  Def inf [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSizeInf-  Def suc [] <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSizeSuc+  inf <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSizeInf+  suc <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSizeSuc   case v of     Def x []        | x == inf -> return SizeInf     Def x [Apply u] | x == suc -> return $ SizeSuc (unArg u)@@ -295,7 +293,7 @@ -- * View on sizes where maximum is pulled to the top ------------------------------------------------------------------------ -type SizeMaxView = NonEmpty DeepSizeView+type SizeMaxView = List1 DeepSizeView type SizeMaxView' = [DeepSizeView]  maxViewMax :: SizeMaxView -> SizeMaxView -> SizeMaxView@@ -310,7 +308,7 @@ maxViewCons _ (DSizeInf :| _) = singleton DSizeInf maxViewCons DSizeInf _        = singleton DSizeInf maxViewCons v ws = case sizeViewComparableWithMax v ws of-  NotComparable  -> NonEmpty.cons v ws+  NotComparable  -> List1.cons v ws   YesAbove _ ws' -> v :| ws'   YesBelow{}     -> ws
src/full/Agda/TypeChecking/Monad/State.hs view
@@ -2,23 +2,25 @@  module Agda.TypeChecking.Monad.State where - import qualified Control.Exception as E -import Control.Monad       (void)-import Control.Monad.Trans (MonadIO, liftIO)+import Control.DeepSeq           (rnf)+import Control.Exception         (evaluate)+import Control.Monad.Trans       (MonadIO, liftIO)+import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT)  import Data.Maybe-+import qualified Data.EnumMap.Strict as EnumMap+import qualified Data.HashMap.Strict as HMap import qualified Data.Map as Map--import qualified Data.List.NonEmpty as NonEmpty import Data.Set (Set) import qualified Data.Set as Set-import qualified Data.HashMap.Strict as HMap  import Agda.Benchmarking +import Agda.Compiler.Backend.Base (pattern Backend, backendName, mayEraseType)++import Agda.Interaction.Library ( classifyBuiltinModule_ ) import Agda.Interaction.Response   (InteractionOutputCallback, Response) @@ -29,6 +31,8 @@ import Agda.Syntax.Abstract.PatternSynonyms import Agda.Syntax.Abstract.Name import Agda.Syntax.Internal+import Agda.Syntax.Position+import Agda.Syntax.TopLevelModuleName  import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Warnings@@ -37,10 +41,13 @@ import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.CompiledClause -import Agda.Utils.Hash+import qualified Agda.Utils.BiMap as BiMap+import Agda.Utils.FileId ( File, getIdFile, registerFileId' ) import Agda.Utils.Lens-import Agda.Utils.Monad (bracket_)-import Agda.Utils.Pretty+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Syntax.Common.Pretty import Agda.Utils.Tuple  import Agda.Utils.Impossible@@ -48,44 +55,35 @@ -- | Resets the non-persistent part of the type checking state.  resetState :: TCM ()-resetState = do-    pers <- getsTC stPersistentState-    putTC $ initState { stPersistentState = pers }+resetState = modifyTC \ s -> initStateFromPersistentState (s ^. lensPersistentState)  -- | Resets all of the type checking state. -----   Keep only 'Benchmark' and backend information.+--   Keep only the session state (backend information, 'Benchmark', file ids).  resetAllState :: TCM ()-resetAllState = do-    b <- getBenchmark-    backends <- useTC stBackends-    putTC $ updatePersistentState (\ s -> s { stBenchmark = b }) initState-    stBackends `setTCLens` backends--- resetAllState = putTC initState+resetAllState = modifyTC \ s -> initStateFromSessionState (s ^. lensSessionState) +-- | Overwrite the 'TCState', but not the 'SessionTCState' part.+putTCPreservingSession :: TCState -> TCM ()+putTCPreservingSession = bracket_ get put . putTC where+  get = (,) <$> useTC lensSessionState <*> useTC stStatistics++  put (sess, stat) = do+    setTCLens lensSessionState sess+    setTCLens stStatistics stat+ -- | Restore 'TCState' after performing subcomputation. -----   In contrast to 'Agda.Utils.Monad.localState', the 'Benchmark'---   info from the subcomputation is saved.+--   In contrast to 'Agda.Utils.Monad.localState', the+--   'SessionTCState' from the subcomputation is saved. localTCState :: TCM a -> TCM a-localTCState = bracket_ getTC (\ s -> do-   b <- getBenchmark-   putTC s-   modifyBenchmark $ const b)+localTCState = bracket_ getTC putTCPreservingSession  -- | Same as 'localTCState' but also returns the state in which we were just --   before reverting it. localTCStateSaving :: TCM a -> TCM (a, TCState)-localTCStateSaving compute = do-  oldState <- getTC-  result <- compute-  newState <- getTC-  do-    b <- getBenchmark-    putTC oldState-    modifyBenchmark $ const b-  return (result, newState)+localTCStateSaving compute = localTCState $ liftA2 (,) compute getTC  -- | Same as 'localTCState' but keep all warnings. localTCStateSavingWarnings :: TCM a -> TCM a@@ -94,19 +92,6 @@   modifyTC $ over stTCWarnings $ const $ newState ^. stTCWarnings   return result -data SpeculateResult = SpeculateAbort | SpeculateCommit---- | Allow rolling back the state changes of a TCM computation.-speculateTCState :: TCM (a, SpeculateResult) -> TCM a-speculateTCState m = do-  ((x, res), newState) <- localTCStateSaving m-  case res of-    SpeculateAbort  -> return x-    SpeculateCommit -> x <$ putTC newState--speculateTCState_ :: TCM SpeculateResult -> TCM ()-speculateTCState_ m = void $ speculateTCState $ ((),) <$> m- -- | A fresh TCM instance. -- -- The computation is run in a fresh state, with the exception that@@ -117,30 +102,29 @@  freshTCM :: TCM a -> TCM (Either TCErr a) freshTCM m = do++  -- Run m in fresh TCM that only kept the current persistent state.   ps <- useTC lensPersistentState-  let s = set lensPersistentState ps initState-  r <- liftIO $ (Right <$> runTCM initEnv s m) `E.catch` (return . Left)+  let s0 = initStateFromPersistentState ps+  r <- liftIO $ (Right <$> runTCM initEnv s0 m) `E.catch` (return . Left)++  -- Keep m's changes to the persistent state, if possible.+  let keepPersistent s = setTCLens lensPersistentState $ s ^. lensPersistentState   case r of-    Right (a, s) -> do-      setTCLens lensPersistentState $ s ^. lensPersistentState-      return $ Right a-    Left err -> do+    Right (a, s) -> Right a <$ keepPersistent s+    Left err -> Left err <$       case err of-        TypeError { tcErrState = s } ->-          setTCLens lensPersistentState $ s ^. lensPersistentState-        IOException s _ _ ->-          setTCLens lensPersistentState $ s ^. lensPersistentState-        _ -> return ()-      return $ Left err+        TypeError { tcErrState = s } -> keepPersistent s+        IOException (Just s) _ _     -> keepPersistent s+        IOException Nothing  _ _     -> return ()+        GenericException _           -> return ()+        ParserError _                -> return ()+        PatternErr _                 -> return ()  --------------------------------------------------------------------------- -- * Lens for persistent states and its fields --------------------------------------------------------------------------- -lensPersistentState :: Lens' PersistentTCState TCState-lensPersistentState f s =-  f (stPersistentState s) <&> \ p -> s { stPersistentState = p }- updatePersistentState   :: (PersistentTCState -> PersistentTCState) -> (TCState -> TCState) updatePersistentState f s = s { stPersistentState = f (stPersistentState s) }@@ -150,45 +134,53 @@  -- | Lens for 'stAccumStatistics'. -lensAccumStatisticsP :: Lens' Statistics PersistentTCState+lensAccumStatisticsP :: Lens' PersistentTCState Statistics lensAccumStatisticsP f s = f (stAccumStatistics s) <&> \ a ->   s { stAccumStatistics = a } -lensAccumStatistics :: Lens' Statistics TCState+lensAccumStatistics :: Lens' TCState Statistics lensAccumStatistics =  lensPersistentState . lensAccumStatisticsP  --------------------------------------------------------------------------- -- * Scope --------------------------------------------------------------------------- +{-# INLINE getScope #-} -- | Get the current scope. getScope :: ReadTCState m => m ScopeInfo getScope = useR stScope +{-# INLINE setScope #-} -- | Set the current scope. setScope :: ScopeInfo -> TCM () setScope scope = modifyScope (const scope) +{-# INLINE modifyScope_ #-} -- | Modify the current scope without updating the inverse maps. modifyScope_ :: MonadTCState m => (ScopeInfo -> ScopeInfo) -> m () modifyScope_ f = stScope `modifyTCLens` f +{-# INLINE modifyScope #-} -- | Modify the current scope. modifyScope :: MonadTCState m => (ScopeInfo -> ScopeInfo) -> m () modifyScope f = modifyScope_ (recomputeInverseScopeMaps . f) +{-# INLINE useScope #-} -- | Get a part of the current scope.-useScope :: ReadTCState m => Lens' a ScopeInfo -> m a+useScope :: ReadTCState m => Lens' ScopeInfo a -> m a useScope l = useR $ stScope . l +{-# INLINE locallyScope #-} -- | Run a computation in a modified scope.-locallyScope :: ReadTCState m => Lens' a ScopeInfo -> (a -> a) -> m b -> m b+locallyScope :: ReadTCState m => Lens' ScopeInfo a -> (a -> a) -> m b -> m b locallyScope l = locallyTCState $ stScope . l +{-# INLINE withScope #-} -- | Run a computation in a local scope. withScope :: ReadTCState m => ScopeInfo -> m a -> m (a, ScopeInfo) withScope s m = locallyTCState stScope (recomputeInverseScopeMaps . const s) $ (,) <$> m <*> getScope +{-# INLINE withScope_ #-} -- | Same as 'withScope', but discard the scope from the computation. withScope_ :: ReadTCState m => ScopeInfo -> m a -> m a withScope_ s m = fst <$> withScope s m@@ -204,13 +196,13 @@ -- | Scope error. notInScopeError :: C.QName -> TCM a notInScopeError x = do-  printScope "unbound" 5 ""-  typeError $ NotInScope [x]+  printScope "unbound" 25 ""+  typeError $ NotInScope x  notInScopeWarning :: C.QName -> TCM () notInScopeWarning x = do-  printScope "unbound" 5 ""-  warning $ NotInScopeW [x]+  printScope "unbound" 25 ""+  warning $ NotInScopeW x  -- | Debug print the scope. printScope :: String -> Int -> String -> TCM ()@@ -224,15 +216,19 @@  -- ** Lens for 'stSignature' and 'stImports' +{-# INLINE modifySignature  #-} modifySignature :: MonadTCState m => (Signature -> Signature) -> m () modifySignature f = stSignature `modifyTCLens` f +{-# INLINE modifyImportedSignature #-} modifyImportedSignature :: MonadTCState m => (Signature -> Signature) -> m () modifyImportedSignature f = stImports `modifyTCLens` f +{-# INLINE getSignature #-} getSignature :: ReadTCState m => m Signature getSignature = useR stSignature +{-# SPECIALIZE modifyGlobalDefinition :: QName -> (Definition -> Definition) -> TCM () #-} -- | Update a possibly imported definition. Warning: changes made to imported --   definitions (during type checking) will not persist outside the current --   module. This function is currently used to update the compiled@@ -242,9 +238,11 @@   modifySignature         $ updateDefinition q f   modifyImportedSignature $ updateDefinition q f +{-# INLINE setSignature #-} setSignature :: MonadTCState m => Signature -> m () setSignature sig = modifySignature $ const sig +{-# SPECIALIZE withSignature :: Signature -> TCM a -> TCM a #-} -- | Run some computation in a different signature, restore original signature. withSignature :: (ReadTCState m, MonadTCState m) => Signature -> m a -> m a withSignature sig m = do@@ -275,6 +273,12 @@     where       setMatchable def = def { defMatchable = Set.insert f $ defMatchable def } +-- ** 'modify' methods for the signature++modifyRecEta :: MonadTCState m => QName -> (EtaEquality -> EtaEquality) -> m ()+modifyRecEta q f =+  modifySignature $ updateDefinition q $ over (lensTheDef . lensRecord . lensRecEta) f+ -- ** Modifiers for parts of the signature  lookupDefinition :: QName -> Signature -> Maybe Definition@@ -323,41 +327,153 @@ updateDefBlocked f def@Defn{ defBlocked = b } = def { defBlocked = f b }  ---------------------------------------------------------------------------+-- * File identification+---------------------------------------------------------------------------++-- | Translate an absolute path to a file id, and register a new file id+--   if the path has not seen before.+--   Also register whether the path belongs to one of Agda's builtin modules.+--+registerFileIdWithBuiltin :: File -> FileDictWithBuiltins -> (FileId, FileDictWithBuiltins)+registerFileIdWithBuiltin f (FileDictWithBuiltins d b primLibDir) =+  (fi, FileDictWithBuiltins d' b' primLibDir)+  where+    ((fi, new), d') = registerFileId' f d+    b' = case classifyBuiltinModule_ primLibDir f of+      Nothing -> b+      Just c  -> EnumMap.insert fi c b++instance MonadIO m => MonadFileId (TCMT m) where+  fileFromId fi = useTC stFileDict <&> (`getIdFile` fi)+  idFromFile = stateTCLens stFileDict . registerFileIdWithBuiltin++-- | Does the given 'FileId' belong to one of Agda's builtin modules?++isBuiltinModule :: ReadTCState m => FileId -> m (Maybe IsBuiltinModule)+isBuiltinModule fi = EnumMap.lookup fi <$> useTC stBuiltinModuleIds++-- | Does the given 'FileId' belong to one of Agda's builtin modules that only uses safe postulates?+--+-- Implies @isJust . 'isBuiltinModule'@.++isBuiltinModuleWithSafePostulates :: ReadTCState m => FileId -> m Bool+isBuiltinModuleWithSafePostulates fi = do+  isBuiltinModule fi <&> \case+    Nothing                                -> False+    Just IsBuiltinModule                   -> False+    Just IsBuiltinModuleWithSafePostulates -> True+    Just IsPrimitiveModule                 -> True++-- | Does the given 'FileId' belong to one of Agda's magical primitive modules?+--+-- Implies 'isBuiltinModuleWithSafePostulates'.++isPrimitiveModule :: ReadTCState m => FileId -> m Bool+isPrimitiveModule  fi = do+  isBuiltinModule fi <&> \case+    Nothing                                -> False+    Just IsBuiltinModule                   -> False+    Just IsBuiltinModuleWithSafePostulates -> False+    Just IsPrimitiveModule                 -> True++--------------------------------------------------------------------------- -- * Top level module --------------------------------------------------------------------------- +-- | Tries to convert a raw top-level module name to a top-level+-- module name.++topLevelModuleName :: RawTopLevelModuleName -> TCM TopLevelModuleName+topLevelModuleName raw = do+  hash <- BiMap.lookup raw <$> useR stTopLevelModuleNames+  case hash of+    Just hash -> return (unsafeTopLevelModuleName raw hash)+    Nothing   -> do+      let hash = hashRawTopLevelModuleName raw+      when (hash == noModuleNameHash) $ typeError $ ModuleNameHashCollision raw Nothing+      raw' <- BiMap.invLookup hash <$> useR stTopLevelModuleNames+      case raw' of+        Just raw' -> typeError $ ModuleNameHashCollision raw (Just raw')+        Nothing -> do+          stTopLevelModuleNames `modifyTCLens'`+            BiMap.insert (killRange raw) hash+          return (unsafeTopLevelModuleName raw hash)+ -- | Set the top-level module. This affects the global module id of freshly --   generated names. --- TODO: Is the hash-function collision-free? If not, then the--- implementation of 'setTopLevelModule' should be changed.+setTopLevelModule :: TopLevelModuleName -> TCM ()+setTopLevelModule top = do+  let hash = moduleNameId top+  stFreshNameId `setTCLens'` NameId 0 hash+  stFreshOpaqueId `setTCLens'` OpaqueId 0 hash+  stFreshMetaId `setTCLens'`+    MetaId { metaId     = 0+           , metaModule = hash+           } -setTopLevelModule :: C.QName -> TCM ()-setTopLevelModule x = stFreshNameId `setTCLens` NameId 0 (ModuleNameHash $ hashString $ prettyShow x)+-- | The name of the current top-level module, if any.+{-# SPECIALIZE+    currentTopLevelModule :: TCM (Maybe TopLevelModuleName) #-}+{-# SPECIALIZE+    currentTopLevelModule :: ReduceM (Maybe TopLevelModuleName) #-}+currentTopLevelModule ::+  (MonadTCEnv m, ReadTCState m) => m (Maybe TopLevelModuleName)+currentTopLevelModule = do+  useR stCurrentModule >>= \case+    Just (_, top) -> return (Just top)+    Nothing       -> listToMaybe <$> asksTC envImportPath  -- | Use a different top-level module for a computation. Used when generating --   names for imported modules.-withTopLevelModule :: C.QName -> TCM a -> TCM a+withTopLevelModule :: TopLevelModuleName -> TCM a -> TCM a withTopLevelModule x m = do-  next <- useTC stFreshNameId+  nextN <- useTC stFreshNameId+  nextM <- useTC stFreshMetaId+  nextO <- useTC stFreshOpaqueId   setTopLevelModule x   y <- m-  stFreshNameId `setTCLens` next+  stFreshMetaId `setTCLens` nextM+  stFreshNameId `setTCLens` nextN+  stFreshOpaqueId `setTCLens` nextO   return y +{-# SPECIALIZE currentModuleNameHash :: TCM ModuleNameHash #-} currentModuleNameHash :: ReadTCState m => m ModuleNameHash currentModuleNameHash = do   NameId _ h <- useTC stFreshNameId   return h  ------------------------------------------------------------------------------ * Foreign code+-- * Backends and foreign code --------------------------------------------------------------------------- +-- | Look for a backend of the given name.++lookupBackend :: ReadTCState m => BackendName -> m (Maybe Backend)+lookupBackend name = useTC stBackends <&> \ backends ->+  listToMaybe [ b | b@(Backend b') <- backends, backendName b' == name ]++-- | Get the currently active backend (if any).++activeBackend :: TCM (Maybe Backend)+activeBackend = runMaybeT $ do+  bname <- MaybeT $ asksTC envActiveBackendName+  lift $ fromMaybe __IMPOSSIBLE__ <$> lookupBackend bname++-- | Ask the active backend whether a type may be erased.+--   See issue #3732.++activeBackendMayEraseType :: QName -> TCM Bool+activeBackendMayEraseType q = do+  Backend b <- fromMaybe __IMPOSSIBLE__ <$> activeBackend+  mayEraseType b q+ addForeignCode :: BackendName -> String -> TCM () addForeignCode backend code = do   r <- asksTC envRange  -- can't use TypeChecking.Monad.Trace.getCurrentRange without cycle-  modifyTCLens (stForeignCode . key backend) $ Just . (ForeignCode r code :) . fromMaybe []+  modifyTCLens (stForeignCode . key backend) $+    Just . ForeignCodeStack . (ForeignCode r code :) . maybe [] getForeignCodeStack  --------------------------------------------------------------------------- -- * Interaction output callback@@ -401,7 +517,7 @@   defs <- traverse lookupSinglePatternSyn xs   case mergePatternSynDefs defs of     Just def   -> return def-    Nothing    -> typeError $ CannotResolveAmbiguousPatternSynonym (NonEmpty.zip xs defs)+    Nothing    -> typeError $ CannotResolveAmbiguousPatternSynonym $ List1.zip xs defs  lookupSinglePatternSyn :: QName -> TCM PatternSynDefn lookupSinglePatternSyn x = do@@ -415,37 +531,9 @@                 Nothing -> notInScopeError $ qnameToConcrete x  ------------------------------------------------------------------------------ * Benchmark-------------------------------------------------------------------------------- | Lens getter for 'Benchmark' from 'TCState'.-theBenchmark :: TCState -> Benchmark-theBenchmark = stBenchmark . stPersistentState---- | Lens map for 'Benchmark'.-updateBenchmark :: (Benchmark -> Benchmark) -> TCState -> TCState-updateBenchmark f = updatePersistentState $ \ s -> s { stBenchmark = f (stBenchmark s) }---- | Lens getter for 'Benchmark' from 'TCM'.-getBenchmark :: TCM Benchmark-getBenchmark = getsTC $ theBenchmark---- | Lens modify for 'Benchmark'.-modifyBenchmark :: (Benchmark -> Benchmark) -> TCM ()-modifyBenchmark = modifyTC' . updateBenchmark----------------------------------------------------------------------------- -- * Instance definitions --------------------------------------------------------------------------- --- | Look through the signature and reconstruct the instance table.-addImportedInstances :: Signature -> TCM ()-addImportedInstances sig = do-  let itable = Map.fromListWith Set.union-               [ (c, Set.singleton i)-               | (i, Defn{ defInstance = Just c }) <- HMap.toList $ sig ^. sigDefinitions ]-  stImportedInstanceDefs `modifyTCLens` Map.unionWith Set.union itable- -- | Lens for 'stInstanceDefs'. updateInstanceDefs :: (TempInstanceTable -> TempInstanceTable) -> (TCState -> TCState) updateInstanceDefs = over stInstanceDefs@@ -455,17 +543,18 @@  getAllInstanceDefs :: TCM TempInstanceTable getAllInstanceDefs = do-  (table,xs) <- useTC stInstanceDefs-  itable <- useTC stImportedInstanceDefs-  let !table' = Map.unionWith Set.union itable table+  (table, xs) <- useTC stInstanceDefs+  itable <- useTC (stImports . sigInstances)+  let table' = table <> itable+  () <- liftIO $ evaluate (rnf table')   return (table', xs)  getAnonInstanceDefs :: TCM (Set QName) getAnonInstanceDefs = snd <$> getAllInstanceDefs --- | Remove all instances whose type is still unresolved.-clearAnonInstanceDefs :: TCM ()-clearAnonInstanceDefs = modifyInstanceDefs $ mapSnd $ const Set.empty+-- | Remove an instance from the set of unresolved instances.+clearUnknownInstance :: QName -> TCM ()+clearUnknownInstance q = modifyInstanceDefs $ mapSnd $ Set.delete q  -- | Add an instance whose type is still unresolved. addUnknownInstance :: QName -> TCM ()@@ -474,16 +563,3 @@     "adding definition " ++ prettyShow x ++     " to the instance table (the type is not yet known)"   modifyInstanceDefs $ mapSnd $ Set.insert x---- | Add instance to some ``class''.-addNamedInstance-  :: QName  -- ^ Name of the instance.-  -> QName  -- ^ Name of the class.-  -> TCM ()-addNamedInstance x n = do-  reportSLn "tc.decl.instance" 10 $-    "adding definition " ++ prettyShow x ++ " to instance table for " ++ prettyShow n-  -- Mark x as instance for n.-  modifySignature $ updateDefinition x $ \ d -> d { defInstance = Just n }-  -- Add x to n's instances.-  modifyInstanceDefs $ mapFst $ Map.insertWith Set.union n $ Set.singleton x
src/full/Agda/TypeChecking/Monad/Statistics.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Collect statistics.  module Agda.TypeChecking.Monad.Statistics@@ -14,14 +16,12 @@ import qualified Data.Map as Map import qualified Text.PrettyPrint.Boxes as Boxes -import Agda.Syntax.Concrete.Name as C- import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Debug  import Agda.Utils.Maybe import Agda.Utils.Null-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.String  class ReadTCState m => MonadStatistics m where@@ -76,17 +76,17 @@ tickMax :: MonadStatistics m => String -> Integer -> m () tickMax s n = modifyCounter s (max n) --- | Print the given statistics if verbosity "profile.ticks" is given.+-- | Print the given statistics. printStatistics   :: (MonadDebug m, MonadTCEnv m, HasOptions m)-  => Int -> Maybe C.TopLevelModuleName -> Statistics -> m ()-printStatistics vl mmname stats = verboseS "profile.ticks" vl $ do+  => Maybe TopLevelModuleName -> Statistics -> m ()+printStatistics mmname stats = do   unlessNull (Map.toList stats) $ \ stats -> do     let -- First column (left aligned) is accounts.         col1 = Boxes.vcat Boxes.left  $ map (Boxes.text . fst) stats         -- Second column (right aligned) is numbers.         col2 = Boxes.vcat Boxes.right $ map (Boxes.text . showThousandSep . snd) stats         table = Boxes.hsep 1 Boxes.left [col1, col2]-    reportSLn "profile" 1 $ caseMaybe mmname "Accumulated statistics" $ \ mname ->+    alwaysReportSLn "" 1 $ caseMaybe mmname "Accumulated statistics" $ \ mname ->       "Statistics for " ++ prettyShow mname-    reportSLn "profile" 1 $ Boxes.render table+    alwaysReportSLn "" 1 $ Boxes.render table
src/full/Agda/TypeChecking/Monad/Trace.hs view
@@ -1,16 +1,20 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Monad.Trace where  import Prelude hiding (null) -import Control.Monad.Except-import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Trans.Identity-import Control.Monad.Writer+import Control.Monad.Except         ( ExceptT  (ExceptT  ), runExceptT   , throwError )+import Control.Monad.Reader         ( ReaderT  (ReaderT  ), runReaderT   )+import Control.Monad.State          ( StateT   (StateT   ), runStateT    )+import Control.Monad.Trans.Identity ( IdentityT(IdentityT), runIdentityT )+import Control.Monad.Trans.Maybe    ( MaybeT   (MaybeT   ), runMaybeT    )+import Control.Monad.Writer         ( WriterT  (WriterT  ), runWriterT   )  import qualified Data.Set as Set +import Agda.Syntax.Common.Pretty+import Agda.Syntax.Parser (PM, runPMIO) import Agda.Syntax.Position import qualified Agda.Syntax.Position as P @@ -22,13 +26,11 @@   hiding (ModuleInfo, MetaInfo, Primitive, Constructor, Record, Function, Datatype) import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.State+import Agda.TypeChecking.Warnings (warning)  import Agda.Utils.Function--import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Pretty (prettyShow)  --------------------------------------------------------------------------- -- * Trace@@ -61,12 +63,14 @@     CheckDataDef{}            -> True     CheckRecDef{}             -> True     CheckConstructor{}        -> True-    CheckConstructorFitsIn{}  -> True+    CheckIApplyConfluence{}   -> True+    CheckConArgFitsIn{}       -> True     CheckFunDefCall{}         -> True     CheckPragma{}             -> True     CheckPrimitive{}          -> True     CheckIsEmpty{}            -> True     CheckConfluence{}         -> True+    CheckModuleParameters{}   -> True     CheckWithFunctionType{}   -> True     CheckSectionApplication{} -> True     CheckNamedWhere{}         -> True@@ -87,17 +91,22 @@   traceCallM :: m Call -> m a -> m a   traceCallM call m = flip traceCall m =<< call -  -- | Reset 'envCall' to previous value in the continuation.+  -- | Like 'traceCall', but resets 'envCall' and the current ranges to the+  --   previous values in the continuation.   ---  -- Caveat: if the last 'traceCall' did not set an 'interestingCall',-  -- for example, only set the 'Range' with 'SetRange',-  -- we will revert to the last interesting call.   traceCallCPS :: Call -> ((a -> m b) -> m b) -> ((a -> m b) -> m b)   traceCallCPS call k ret = do-    mcall <- asksTC envCall++    -- Save current call and ranges.+    TCEnv{ envCall = mcall, envRange = r, envHighlightingRange = hr } <- askTC++    -- Run given computation under given call.     traceCall call $ k $ \ a -> do-      maybe id traceClosureCall mcall $ ret a +      -- Restore previous call and ranges for the continuation.+      localTC (\ e -> e{ envCall = mcall, envRange = r, envHighlightingRange = hr }) $+        ret a+   traceClosureCall :: Closure Call -> m a -> m a    -- | Lispify and print the given highlighting information.@@ -108,9 +117,15 @@     => RemoveTokenBasedHighlighting -> HighlightingInfo -> m ()   printHighlightingInfo r i = lift $ printHighlightingInfo r i +traceCallCPS' :: MonadTrace m => Call -> (m b -> m b) -> m b -> m b+traceCallCPS' c k ret = traceCallCPS c (\ret -> k (ret ())) (\() -> ret)+ instance MonadTrace m => MonadTrace (IdentityT m) where   traceClosureCall c f = IdentityT $ traceClosureCall c $ runIdentityT f +instance MonadTrace m => MonadTrace (MaybeT m) where+  traceClosureCall c f = MaybeT $ traceClosureCall c $ runMaybeT f+ instance MonadTrace m => MonadTrace (ReaderT r m) where   traceClosureCall c f = ReaderT $ \r -> traceClosureCall c $ runReaderT f r @@ -129,17 +144,6 @@     -- Since the fix of #2092 we may report an error outside the current file.     -- (For instance, if we import a module which then happens to have the     -- wrong name.)-    -- Thus, we no longer crash, but just report the alien range.-    -- -- Andreas, 2015-02-09 Make sure we do not set a range-    -- -- outside the current file-    verboseS "check.ranges" 90 $-      Strict.whenJust (rangeFile callRange) $ \f -> do-        currentFile <- asksTC envCurrentPath-        when (currentFile /= Just f) $ do-          reportSLn "check.ranges" 90 $-            prettyShow call ++-            " is setting the current range to " ++ show callRange ++-            " which is outside of the current file " ++ show currentFile      -- Compute update to 'Range' and 'Call' components of 'TCEnv'.     let withCall = localTC $ foldr (.) id $ concat $@@ -184,12 +188,14 @@       CheckDataDef{}            -> True       CheckRecDef{}             -> True       CheckConstructor{}        -> True-      CheckConstructorFitsIn{}  -> False+      CheckConArgFitsIn{}       -> False       CheckFunDefCall _ _ _ h   -> h       CheckPragma{}             -> True       CheckPrimitive{}          -> True       CheckIsEmpty{}            -> True       CheckConfluence{}         -> False+      CheckIApplyConfluence{}   -> False+      CheckModuleParameters{}   -> False       CheckWithFunctionType{}   -> True       CheckSectionApplication{} -> True       CheckNamedWhere{}         -> False@@ -208,10 +214,11 @@   printHighlightingInfo remove info = do     modToSrc <- useTC stModuleToSource     method   <- viewTC eHighlightingMethod-    reportS "highlighting" 50+    reportSDoc "highlighting" 50 $ pure $ vcat       [ "Printing highlighting info:"-      , show info-      , "  modToSrc = " ++ show modToSrc+      , nest 2 $ (text . show) info+      , "File modules:"+      , nest 2 $ pretty modToSrc       ]     unless (null info) $ do       appInteractionOutputCallback $@@ -262,3 +269,26 @@     return v     where     p rs x = printHighlightingInfo KeepHighlighting (singleton rs x)++---------------------------------------------------------------------------+-- * Warnings in the parser+---------------------------------------------------------------------------++-- | Running the Parse monad, raising parser warnings.++runPM :: PM a -> TCM a+runPM m = do+  (res, ws) <- runPMIO m+  forM_ ws \ w -> setCurrentRange w $ warning $ ParseWarning w+  case res of+    Left  e -> throwError $ ParserError e+    Right a -> return a++-- | Running the Parse monad, dropping parser warnings.++runPMDropWarnings :: PM a -> TCM a+runPMDropWarnings m = do+  (res, _ws) <- runPMIO m+  case res of+    Left  e -> throwError $ ParserError e+    Right a -> return a
src/full/Agda/TypeChecking/Names.hs view
@@ -1,7 +1,7 @@  {-| EDSL to construct terms without touching De Bruijn indices. -e.g. if given t, u :: Term, Γ ⊢ t, u : A, we can build "λ f. f t u" like this:+e.g. given t, u :: Term, Γ ⊢ t, u : A, we can build "λ f. f t u" like this:  runNames [] $ do   -- @open@ binds @t@ and @u@ to computations that know how to weaken themselves in@@ -9,21 +9,19 @@    [t,u] <- mapM open [t,u] -  -- @lam@ gives the illusion of HOAS by providing f as a computation+  -- @lam@ gives the illusion of HOAS by providing f as a computation.   -- It also extends the internal context with the name "f", so that   -- @t@ and @u@ will get weakened in the body.-  -- Then we finish the job using the (<@>) combinator from Agda.TypeChecking.Primitive+  -- We apply f with the (<@>) combinator from Agda.TypeChecking.Primitive.    lam "f" $ \ f -> f <@> t <@> u  -} module Agda.TypeChecking.Names where --- Control.Monad.Fail import is redundant since GHC 8.8.1-import Control.Monad.Fail (MonadFail)- import Control.Monad          ( liftM2, unless ) import Control.Monad.Except   ( MonadError )+import Control.Monad.Identity ( Identity, runIdentity ) import Control.Monad.IO.Class ( MonadIO(..) ) import Control.Monad.Reader   ( MonadReader(..), ReaderT, runReaderT ) import Control.Monad.State    ( MonadState )@@ -36,18 +34,17 @@  import Agda.TypeChecking.Monad hiding (getConstInfo, typeOfConst) import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Free+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Pretty ()  -- instances only  import Agda.Utils.Fail (Fail, runFail_)--instance HasBuiltins m => HasBuiltins (NamesT m) where-  getBuiltinThing b = lift $ getBuiltinThing b+import Agda.Utils.List1 ( List1, pattern (:|) )+import Agda.Utils.Impossible  newtype NamesT m a = NamesT { unName :: ReaderT Names m a }   deriving ( Functor            , Applicative            , Monad-           , MonadFail            , MonadTrans            , MonadState s            , MonadIO@@ -60,75 +57,193 @@            , MonadReduce            , MonadError e            , MonadAddContext+           , HasBuiltins            , HasConstInfo            , PureTCM            ) --- deriving instance MonadState s m => MonadState s (NamesT m) +-- | A list of variable names from a context. type Names = [String]  runNamesT :: Names -> NamesT m a -> m a runNamesT n m = runReaderT (unName m) n --- We use @Fail@ instead of @Identity@ because the computation can fail.-runNames :: Names -> NamesT Fail a -> a-runNames n m = runFail_ (runNamesT n m)+runNames :: Names -> NamesT Identity a -> a+runNames n m = runIdentity (runNamesT n m)  currentCxt :: Monad m => NamesT m Names currentCxt = NamesT ask -cxtSubst :: MonadFail m => Names -> NamesT m (Substitution' a)+{-# INLINABLE cxtSubst #-}+-- | @cxtSubst Γ@ returns the substitution needed to go+--   from Γ to the current context.+--+--   Precondition @Γ@ is not a subcontext of the current one.+cxtSubst :: Monad m => Names -> NamesT m (Substitution' a) cxtSubst ctx = do   ctx' <- currentCxt   if (ctx `isSuffixOf` ctx')      then return $ raiseS (length ctx' - length ctx)-     else fail $ "thing out of context (" ++ show ctx ++ " is not a sub context of " ++ show ctx' ++ ")"+     else+      -- trace ("out of context (" ++ show ctx ++ " is not a sub context of " ++ show ctx' ++ ")")+       __IMPOSSIBLE__ -inCxt :: (MonadFail m, Subst a) => Names -> a -> NamesT m a++{-# INLINABLE inCxt #-}+-- | @inCxt Γ t@ takes a @t@ in context @Γ@ and produce an action that+--   will return @t@ weakened to the current context.+--+--   Fails whenever @cxtSubst Γ@ would.+inCxt :: (Monad m, Subst a) => Names -> a -> NamesT m a inCxt ctx a = do   sigma <- cxtSubst ctx   return $ applySubst sigma a --- closed terms+-- | Closed terms cl' :: Applicative m => a -> NamesT m a cl' = pure  cl :: Monad m => m a -> NamesT m a cl = lift -open :: (MonadFail m, Subst a) => a -> NamesT m (NamesT m a)+{-# INLINABLE open #-}+-- | Open terms in the current context.+open :: (Monad m, Subst a) => a -> NamesT m (NamesT m a) open a = do   ctx <- NamesT ask   pure $ inCxt ctx a -bind' :: (MonadFail m, Subst b, DeBruijn b, Subst a, Free a) => ArgName -> (NamesT m b -> NamesT m a) -> NamesT m a+-- | Monadic actions standing for variables.+--+--   @b@ is quantified over so the same variable can be used e.g. both+--   as a pattern and as an expression.+type Var m = forall b. (Subst b, DeBruijn b) => NamesT m b+++{-# INLINE bind #-}+-- | @bind n f@ provides @f@ with a fresh variable, which can be used in any extended context.+--+--   Returns an @Abs@ which binds the extra variable.+bind :: Monad m => ArgName -> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a) -> NamesT m (Abs a)+bind n f = Abs n <$> bind' n f++{-# INLINABLE bind' #-}+-- | Like @bind@ but returns a bare term.+bind' :: Monad m => ArgName -> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a) -> NamesT m a bind' n f = do   cxt <- NamesT ask   (NamesT . local (n:) . unName $ f (inCxt (n:cxt) (deBruijnVar 0))) -bind :: ( MonadFail m-        , Subst b-        , DeBruijn b-        , Subst a-        , Free a-        ) =>-        ArgName -> (NamesT m b -> NamesT m a) -> NamesT m (Abs a)-bind n f = Abs n <$> bind' n f -glam :: MonadFail m+-- * Helpers to build lambda abstractions.++glam :: Monad m      => ArgInfo -> ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term-glam info n f = Lam info <$> bind n f+glam info n f = Lam info <$> bind n (\ x -> f x) -glamN :: (Functor m, MonadFail m) =>+lam :: Monad m+    => ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term+lam n f = glam defaultArgInfo n f++ilam :: Monad m+    => ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term+ilam n f = glam defaultIrrelevantArgInfo n f+++-- * Combinators for n-ary binders.++data AbsN a = AbsN { absNName :: [ArgName], unAbsN :: a } deriving (Functor,Foldable,Traversable)++instance Subst a => Subst (AbsN a) where+  type SubstArg (AbsN a) = SubstArg a+  applySubst rho (AbsN xs a) = AbsN xs (applySubst (liftS (length xs) rho) a)++-- | Will crash on @NoAbs@+toAbsN :: Abs (AbsN a) -> AbsN a+toAbsN (Abs n x') = AbsN (n : absNName x') (unAbsN x')+toAbsN NoAbs{}    = __IMPOSSIBLE__++{-# INLINABLE absAppN #-}+absAppN :: Subst a => AbsN a -> [SubstArg a] -> a+absAppN f xs = parallelS (reverse xs) `applySubst` unAbsN f++type ArgVars m = (forall b. (Subst b, DeBruijn b) => [NamesT m (Arg b)])++type Vars m = (forall b. (Subst b, DeBruijn b) => [NamesT m b])++{-# INLINABLE bindN #-}+bindN :: ( Monad m+        ) =>+        [ArgName] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)+bindN [] f = AbsN [] <$> f []+bindN (x:xs) f = toAbsN <$> bind x (\ x -> bindN xs (\ xs -> f (x:xs)))++{-# INLINABLE bindNArg #-}+bindNArg :: ( Monad m+        ) =>+        [Arg ArgName] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)+bindNArg [] f = AbsN [] <$> f []+bindNArg (Arg i x:xs) f = toAbsN <$> bind x (\ x -> bindNArg xs (\ xs -> f ((Arg i <$> x):xs)))+++type Vars1 m = (forall b. (Subst b, DeBruijn b) => List1 (NamesT m b))++bindN1 :: Monad m+  => List1 ArgName -> (Vars1 m -> NamesT m a) -> NamesT m (AbsN a)+bindN1 (x :| xs) f = toAbsN <$> bind x (\ x -> bindN xs (\ xs -> f (x :| xs)))++glamN :: (Functor m, Monad m) =>          [Arg ArgName] -> (NamesT m Args -> NamesT m Term) -> NamesT m Term glamN [] f = f $ pure [] glamN (Arg i n:ns) f = glam i n $ \ x -> glamN ns (\ xs -> f ((:) <$> (Arg i <$> x) <*> xs)) -lam :: MonadFail m-    => ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term-lam n f = glam defaultArgInfo n f -ilam :: MonadFail m-    => ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term-ilam n f = glam (setRelevance Irrelevant defaultArgInfo) n f+applyN :: ( Monad m+        , Subst a+        ) =>+        NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a+applyN f xs = do+  f <- f+  xs <- sequence xs+  unless (length xs == length (absNName f)) $ __IMPOSSIBLE__+  return $ absAppN f xs++{-# INLINABLE applyN' #-}+applyN' :: ( Monad m+        , Subst a+        ) =>+        NamesT m (AbsN a) -> NamesT m [SubstArg a] -> NamesT m a+applyN' f xs = do+  f <- f+  xs <- xs+  unless (length xs == length (absNName f)) $ __IMPOSSIBLE__+  return $ absAppN f xs++{-# INLINABLE abstractN #-}+abstractN :: ( Monad m+             , Abstract a+             ) =>+             NamesT m Telescope -> (Vars m -> NamesT m a) -> NamesT m a+abstractN tel f = do+  tel <- tel+  u <- bindN (teleNames tel) f+  return $ abstract tel $ unAbsN u++{-# INLINABLE abstractT #-}+abstractT :: ( Monad m+             , Abstract a+             ) =>+             String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a+abstractT n ty f = do+  u <- bind n f+  ty <- ty+  let tel = ExtendTel (defaultDom ty) $ Abs n EmptyTel+  return $ abstract tel $ unAbs u+++lamTel :: Monad m => NamesT m (Abs [Term]) -> NamesT m ([Term])+lamTel t = map (Lam defaultArgInfo) . sequenceA <$> t++appTel :: Monad m => NamesT m [Term] -> NamesT m Term -> NamesT m [Term]+appTel = liftM2 (\ fs x -> map (`apply` [Arg defaultArgInfo x]) fs)
+ src/full/Agda/TypeChecking/Opacity.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE NondecreasingIndentation #-}+module Agda.TypeChecking.Opacity+  ( saturateOpaqueBlocks++  , isAccessibleDef+  , hasAccessibleDef+  )+  where++import Control.Monad.State+import Control.Exception+import Control.DeepSeq+import Control.Monad++import qualified Data.HashMap.Strict as HashMap+import qualified Data.Map.Strict as Map+import qualified Data.HashSet as HashSet+import qualified Data.List as List+import Data.HashMap.Strict (HashMap)+import Data.HashSet (HashSet)+import Data.Map.Strict (Map)+import Data.Foldable+import Data.Maybe++import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Internal+import Agda.Syntax.Position+import Agda.Syntax.Common++import Agda.TypeChecking.Warnings+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Monad++import Agda.Utils.Impossible+import Agda.Utils.Monad+import Agda.Utils.Lens++-- | Ensure that opaque blocks defined in the current module have+-- saturated unfolding sets.+saturateOpaqueBlocks+  :: forall m. (MonadTCState m, ReadTCState m, MonadFresh OpaqueId m, MonadDebug m, MonadTrace m, MonadWarning m, MonadIO m)+  => m ()+saturateOpaqueBlocks = entry where+  entry = do+    known   <- useTC stOpaqueBlocks+    inverse <- useTC stOpaqueIds+    OpaqueId _ ourmod <- fresh++    canonical <- useTC stCopiedNames+    backcopies <- useTC stNameCopies++    reportSDoc "tc.opaque.copy" 45 $ "Canonical names of copied definitions:" $+$ pretty (HashMap.toList canonical)+    reportSDoc "tc.opaque.copy" 45 $ "Backcopies:" $+$ pretty (HashMap.toList (toList <$> backcopies))++    let+      isOurs (OpaqueId _ mod, _) = mod == ourmod+      canonise name = fromMaybe name (HashMap.lookup name canonical)+      ours = snd <$> filter isOurs (Map.toAscList known)++    () <- liftIO $ evaluate (rnf (canonical, backcopies))++    reportSDoc "tc.opaque" 30 $ vcat $+      text "Opaque blocks defined in this module:":map pretty ours++    -- Only compute transitive closure for opaque blocks declared in+    -- the current top-level module. Deserialised blocks are always+    -- closed, so this work would be redundant.+    (blocks, names) <- computeClosure canonise known inverse ours++    -- Associate copies with the opaque blocks of their originals. Since+    -- modules importing this one won't know how to canonicalise names+    -- we have defined, we make the work easier for them by associating+    -- copies with their original's opaque blocks.+    let names' = foldr addBackcopy names (HashMap.toList backcopies)++    reportSDoc "tc.opaque.sat" 30 $ vcat $+      text "Saturated local opaque blocks":[ pretty block | b@(_,block) <- Map.toList blocks, isOurs b ]++    reportSDoc "tc.opaque.sat.full" 50 $ text "Saturated opaque blocks:" $+$ pretty blocks++    modifyTC' $ \st -> st { stPostScopeState = (stPostScopeState st)+      { stPostOpaqueBlocks = blocks+      , stPostOpaqueIds    = names'+      } }++  -- Actually compute the closure.+  computeClosure+    :: (QName -> QName)+    -> Map OpaqueId OpaqueBlock+      -- Accumulates the satured opaque blocks; also contains the+      -- opaque blocks of imported modules.+    -> Map QName OpaqueId+      -- Accumulates a mapping from names to opaque blocks; also+      -- contains imported opaque names.+    -> [OpaqueBlock]+      -- List of our opaque blocks, in dependency order.+    -> m ( Map OpaqueId OpaqueBlock+         , Map QName OpaqueId+         )+  computeClosure canonise !blocks !names [] = pure (blocks, names)+  computeClosure canonise blocks names (block:xs) = setCurrentRange (opaqueRange block) $ do+    let+      yell nm accum = setCurrentRange (getRange nm) $ do+        warning (UnfoldTransparentName nm)+        pure accum++      -- Add the unfolding-set of the given name to the accumulator+      -- value.+      transitive prenom accum = fromMaybe (yell prenom accum) $ do+        -- NB: If the name is a local copy, we won't yet have added the+        -- copy name to an opaque block, but we will have added the+        -- reduced name (provided it is opaque)+        let nm = canonise prenom+        id    <- Map.lookup nm names+        block <- Map.lookup id blocks+        pure . pure $ HashSet.union (opaqueUnfolding block) accum++    reportSDoc "tc.opaque.copy" 45 $+      vcat [ "Stated unfolding clause:  " <+> pretty (HashSet.toList (opaqueUnfolding block))+           , "with (sub)canonical names:" <+> pretty (canonise <$> HashSet.toList (opaqueUnfolding block))+           ]++    -- Compute the transitive closure: bring in names+    --+    --   ... that are defined as immediate children of the opaque block+    --   ... that are unfolded by the parent opaque block+    --   ... that are implied by each name in the unfolding clause.+    closed <- foldrM transitive+      (  opaqueDecls block+      <> foldMap opaqueUnfolding (opaqueParent block >>= flip Map.lookup blocks)+      )+      (opaqueUnfolding block)++    let+      block' = block { opaqueUnfolding = closed }++      -- Update the mapping from names to blocks, so that future+      -- references to names defined in our opaque block will know the+      -- right unfolding set.+      names' = HashSet.foldr (\name -> Map.insert name (opaqueId block)) names+        (opaqueDecls block)++    computeClosure canonise (Map.insert (opaqueId block) block' blocks) names' xs++  addBackcopy :: (QName, HashSet QName) -> Map QName OpaqueId -> Map QName OpaqueId+  addBackcopy (from, prop) map+    | Just id <- Map.lookup from map = foldr (flip Map.insert id) map prop+    | otherwise = map++-- | Decide whether or not a definition is reducible. Returns 'True' if+-- the definition /can/ step.+isAccessibleDef :: TCEnv -> TCState -> Definition -> Bool++-- IgnoreAbstractMode ignores both abstract and opaque. It is used for+-- getting the original definition (for inConcreteOrAbstractMode), and+-- for "normalise ignoring abstract" interactively.+isAccessibleDef env state defn+  | envAbstractMode env == IgnoreAbstractMode = True++-- Otherwise, actually apply the reducibility rules..+isAccessibleDef env state defn =+  let+    -- Reducibility rules for abstract definitions:+    concretise def = case envAbstractMode env of+      -- Being outside an abstract block has no effect on concreteness+      ConcreteMode       -> def++      -- This clause is redundant with the preceding guard but GHC can't+      -- figure it out:+      IgnoreAbstractMode -> ConcreteDef++      AbstractMode+        -- Symbols from enclosing modules will be made concrete:+        | current `isLeChildModuleOf` m -> ConcreteDef++        -- Symbols from child modules, or unrelated modules, will keep+        -- the same concreteness:+        | otherwise                     -> def+      where+        current = dropAnon $ envCurrentModule env+        m       = dropAnon $ qnameModule (defName defn)+        dropAnon (MName ms) = MName $ List.dropWhileEnd isNoName ms++    -- Reducibility rule for opaque definitions: If we are operating+    -- under an unfolding block,+    clarify def = case envCurrentOpaqueId env of+      Just oid ->+        let+          block = fromMaybe __IMPOSSIBLE__ $ Map.lookup oid (view stOpaqueBlocks state)++          -- Then any name which is a member of the unfolding-set+          -- associated to that block will be unfolded.+          okay = defName defn `HashSet.member` opaqueUnfolding block+        in if okay then TransparentDef else def+      Nothing -> def++    -- Short-circuit the map lookup for vanilla definitions+    plainDef = defAbstract defn == ConcreteDef+            && defOpaque   defn == TransparentDef++  in plainDef+  || ( concretise (defAbstract defn) == ConcreteDef+    && clarify    (defOpaque defn)   == TransparentDef)++-- | Will the given 'QName' have a proper definition, or will it be+-- wrapped in an 'AbstractDefn'?+hasAccessibleDef+  :: (ReadTCState m, MonadTCEnv m, HasConstInfo m) => QName -> m Bool+hasAccessibleDef qn = do+  env <- askTC+  st <- getTCState+  ignoreAbstractMode $ do+    def <- getConstInfo qn+    pure $ isAccessibleDef env st def
+ src/full/Agda/TypeChecking/Opacity.hs-boot view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Opacity where++import {-# SOURCE #-} Agda.TypeChecking.Monad.Signature (HasConstInfo)+import Agda.TypeChecking.Monad.Base++import Agda.Syntax.Abstract.Name++isAccessibleDef :: TCEnv -> TCState -> Definition -> Bool++hasAccessibleDef+  :: (ReadTCState m, MonadTCEnv m, HasConstInfo m) => QName -> m Bool
src/full/Agda/TypeChecking/Patterns/Abstract.hs view
@@ -7,11 +7,11 @@ import Control.Monad.Except  import qualified Data.List as List+import Data.Functor import Data.Void  import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Pattern-import Agda.Syntax.Abstract.Views import Agda.Syntax.Concrete (FieldAssignment') import Agda.Syntax.Common import Agda.Syntax.Info as A@@ -20,6 +20,7 @@ import Agda.Syntax.Position  import Agda.TypeChecking.Monad+import Agda.TypeChecking.Pretty import Agda.TypeChecking.Warnings (raiseWarningsOnUsage)  import Agda.Utils.Impossible@@ -31,27 +32,19 @@   => A.Pattern -> m A.Pattern expandLitPattern = \case   A.LitP info (LitNat n)-    | n < 0     -> negLit -- Andreas, issue #2365, negative literals not yet supported.-    | n > 20    -> tooBig+    | n < 0     -> typeError NegativeLiteralInPattern  -- Andreas, issue #2365, negative literals not yet supported.+    | n > 20    -> typeError LiteralTooBig     | otherwise -> do-      Con z _ _ <- primZero-      Con s _ _ <- primSuc+      z <- getBuiltinName_ builtinZero+      s <- getBuiltinName_ builtinSuc       let r     = getRange info-      let zero  = A.ConP cinfo (unambiguous $ setRange r $ conName z) []-          suc p = A.ConP cinfo (unambiguous $ setRange r $ conName s) [defaultNamedArg p]+      let zero  = A.ConP cinfo (unambiguous $ setRange r z) []+          suc p = A.ConP cinfo (unambiguous $ setRange r s) [defaultNamedArg p]           cinfo = A.ConPatInfo ConOCon info ConPatEager       return $ foldr ($) zero $ List.genericReplicate n suc   p -> return p -  where-    tooBig = typeError $ GenericError $-      "Matching on natural number literals is done by expanding " ++-      "the literal to the corresponding constructor pattern, so " ++-      "you probably don't want to do it this way."-    negLit = typeError $ GenericError $-      "Negative literals are not supported in patterns" - -- | Expand away (deeply) all pattern synonyms in a pattern.  -- Unfortunately, the more general type signature@@ -89,7 +82,12 @@     -- synonyms could get into dot patterns (which is __IMPOSSIBLE__).     p <- expandPatternSynonyms' (vacuous p :: A.Pattern' e) -    case A.insertImplicitPatSynArgs (A.WildP . PatRange) (getRange x) ns as of+    reportSDoc "scope.patsyn" 80 $ vcat+      [ "calling insertImplicitPatSynArgs"+      , "- patsyn parameters: " <+> (text . show) (killRange ns)+      , "- patsyn arguments:  " <+> (text . show) (fmap (fmap void) as)+      ]+    case A.insertImplicitPatSynArgs (\ _h r -> A.WildP (PatRange r)) (getRange x) ns as of       Nothing       -> typeError $ BadArgumentsToPatternSynonym x       Just (_, _:_) -> typeError $ TooFewArgumentsToPatternSynonym x       Just (s, [])  -> do
src/full/Agda/TypeChecking/Patterns/Internal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Tools to manipulate patterns in internal syntax --   in the TCM (type checking monad).
src/full/Agda/TypeChecking/Patterns/Match.hs view
@@ -19,12 +19,14 @@ import Agda.TypeChecking.Reduce.Monad import Agda.TypeChecking.Substitute import Agda.TypeChecking.Monad hiding (constructorForm)+import Agda.TypeChecking.Monad.Builtin (getName', builtinHComp) import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records  import Agda.Utils.Empty import Agda.Utils.Functor (for, ($>), (<&>)) import Agda.Utils.Maybe+import Agda.Utils.Monad ( anyM, or2M) import Agda.Utils.Null import Agda.Utils.Singleton import Agda.Utils.Size@@ -32,11 +34,11 @@  import Agda.Utils.Impossible --- | If matching is inconclusive (@DontKnow@) we want to know whether---   it is due to a particular meta variable.+-- | If matching is inconclusive (@DontKnow@) we want to know whether it is on a+--   lazy pattern and whether it is due to a particular meta variable. data Match a = Yes Simplification (IntMap (Arg a))              | No-             | DontKnow (Blocked ())+             | DontKnow OnlyLazy (Blocked ())   deriving Functor  instance Null (Match a) where@@ -56,17 +58,17 @@ buildSubstitution :: (DeBruijn a)                   => Impossible -> Int -> IntMap (Arg a) -> Substitution' a buildSubstitution err n vs = foldr cons idS $ matchedArgs' n vs-  where cons Nothing  = Strengthen err+  where cons Nothing  = strengthenS' err 1         cons (Just v) = consS (unArg v)   instance Semigroup (Match a) where     -- @NotBlocked (StuckOn e)@ means blocked by a variable.     -- In this case, no instantiation of meta-variables will make progress.-    DontKnow b <> DontKnow b'      = DontKnow $ b <> b'-    DontKnow m <> _                = DontKnow m-    _          <> DontKnow m       = DontKnow m-    -- One could imagine DontKnow _ <> No = No, but would break the+    DontKnow l b <> DontKnow l' b' = DontKnow (l <> l') (b <> b')+    DontKnow l m <> _              = DontKnow l m+    _            <> DontKnow l m   = DontKnow l m+    -- One could imagine DontKnow _ _ <> No = No, but would break the     -- equivalence to case-trees (Issue 2964).     No         <> _                = No     _          <> No               = No@@ -76,6 +78,18 @@     mempty = empty     mappend = (<>) +-- | Whether the inconclusive matches are only on lazy patterns.+data OnlyLazy = OnlyLazy | NonLazy++instance Semigroup OnlyLazy where+  NonLazy  <> _        = NonLazy+  _        <> NonLazy  = NonLazy+  OnlyLazy <> OnlyLazy = OnlyLazy++instance Monoid OnlyLazy where+  mempty = OnlyLazy+  mappend = (<>)+ -- | Instead of 'zipWithM', we need to use this lazy version --   of combining pattern matching computations. @@ -117,7 +131,10 @@             -- contain ill-typed terms due to eta-expansion at wrong             -- type.             return (r <> r', v' : vs)-          DontKnow m -> return (DontKnow m, v' : vs)+          DontKnow OnlyLazy _ -> do+            (r', _vs') <- loop ps vs+            return (r <> r', v' : vs)+          DontKnow NonLazy m -> return (DontKnow NonLazy m, v' : vs)           Yes{} -> do             (r', vs') <- loop ps vs             return (r <> r', v' : vs')@@ -180,6 +197,7 @@ matchCopattern p       (Apply v) = mapSnd Apply <$> matchPattern p v matchCopattern p       e@(IApply x y r) = mapSnd (mergeElim e) <$> matchPattern p (defaultArg r) +{-# SPECIALIZE matchPatterns :: [NamedArg DeBruijnPattern] -> [Arg Term] -> TCM (Match Term, [Arg Term]) #-} matchPatterns :: MonadMatch m               => [NamedArg DeBruijnPattern]               -> [Arg Term]@@ -220,43 +238,48 @@       NotBlocked _ (Lit l')           | l == l'            -> return (Yes YesSimplification empty , arg')           | otherwise          -> return (No                          , arg')-      Blocked b _              -> return (DontKnow $ Blocked b ()     , arg')-      NotBlocked r t           -> return (DontKnow $ NotBlocked r' () , arg')+      Blocked b _              -> return (DontKnow NonLazy $ Blocked b ()     , arg')+      NotBlocked r t           -> return (DontKnow NonLazy $ NotBlocked r' () , arg')         where r' = stuckOn (Apply arg') r    -- Case constructor pattern.   (ConP c cpi ps, Arg info v) -> do-    if not (conPRecord cpi) then fallback c ps (Arg info v) else do-    isEtaRecordCon (conName c) >>= \case-      Nothing -> fallback c ps (Arg info v)-      Just fs -> do-        -- Case: Eta record constructor.-        -- This case is necessary if we want to use the clauses before-        -- record pattern translation (e.g., in type-checking definitions by copatterns).-        unless (size fs == size ps) __IMPOSSIBLE__-        mapSnd (Arg info . Con c (fromConPatternInfo cpi) . map Apply) <$> do-          matchPatterns ps $ for fs $ \ (Arg ai f) -> Arg ai $ v `applyE` [Proj ProjSystem f]-    where-    isEtaRecordCon :: HasConstInfo m => QName -> m (Maybe [Arg QName])-    isEtaRecordCon c = do-      (theDef <$> getConstInfo c) >>= \case-        Constructor{ conData = d } -> do-          (theDef <$> getConstInfo d) >>= \case-            r@Record{ recFields = fs } | YesEta <- recEtaEquality r -> return $ Just $ map argFromDom fs-            _ -> return Nothing-        _ -> __IMPOSSIBLE__+    let lazy = if conPLazy cpi then OnlyLazy else NonLazy+    if not (conPRecord cpi) then fallback c lazy ps (Arg info v) else do+    isEtaRecordConstructor (conName c) >>= \case+      Nothing -> fallback c lazy ps (Arg info v)+      -- Case: Eta record constructor.+      -- This case is necessary if we want to use the clauses before+      -- record pattern translation (e.g., in type-checking definitions by copatterns).+      Just (_r, def) -> do+        reportSDoc "tc.match" 50 $ vcat+          [ "matchPattern: eta record"+          , nest 2 $ "c  = " <+> prettyTCM c+          , nest 2 $ "ps = " <+> prettyTCMPatternList ps+          , nest 2 $ "v  = " <+> prettyTCM v+          ]+        -- Issue #7266: in case we are brazenly matching potentially ill-typed arguments,+        -- `v` might be an application of a *different* constructor.+        -- In that case we certainly have no match.+        case v of+          Con c' _ _ | c /= c' -> return (No, u)+          _ -> do+            let fs = map argFromDom $ _recFields def+            unless (size fs == size ps) __IMPOSSIBLE__+            mapSnd (Arg info . Con c (fromConPatternInfo cpi) . map Apply) <$> do+              matchPatterns ps $ for fs $ \ (Arg ai f) -> Arg ai $ v `applyE` [Proj ProjSystem f]   (DefP o q ps, v) -> do     let f (Def q' vs) | q == q' = Just (Def q, vs)         f _                     = Nothing-    fallback' f ps v+    fallback' f NonLazy ps v  where     -- Default: not an eta record constructor.   fallback :: MonadMatch m-           => ConHead -> [NamedArg DeBruijnPattern] -> Arg Term -> m (Match Term, Arg Term)-  fallback c ps v = do+           => ConHead -> OnlyLazy -> [NamedArg DeBruijnPattern] -> Arg Term -> m (Match Term, Arg Term)+  fallback c lazy ps v = do     let f (Con c' ci' vs) | c == c' = Just (Con c' ci',vs)         f _                         = Nothing-    fallback' f ps v+    fallback' f lazy ps v    -- Regardless of blocking, constructors and a properly applied @hcomp@   -- can be matched on.@@ -268,24 +291,24 @@         t@Con{} -> Just t         t@(Def q [l,a,phi,u,u0]) | Just q == mhcomp                 -> Just t+        -- TODO this covers the transpIx functions, but it's a hack.+        t@(Def q _) | NotBlocked{blockingStatus = MissingClauses _} <- r -> Just t         _       -> Nothing    -- DefP hcomp and ConP matching.   fallback' :: MonadMatch m             => (Term -> Maybe (Elims -> Term , Elims))+            -> OnlyLazy             -> [NamedArg DeBruijnPattern]             -> Arg Term             -> m (Match Term, Arg Term)-  fallback' mtc ps (Arg info v) = do+  fallback' mtc lazy ps (Arg info v) = do         isMatchable <- isMatchable'          w <- reduceB v         -- Unfold delayed (corecursive) definitions one step. This is         -- only necessary if c is a coinductive constructor, but-        -- 1) it does not hurt to do it all the time, and-        -- 2) whatInduction c sometimes crashes because c may point to-        --    an axiom at this stage (if we are checking the-        --    projection functions for a record type).+        -- it does not hurt to do it all the time. {-         w <- case w of                NotBlocked r (Def f es) ->   -- Andreas, 2014-06-12 TODO: r == ReallyNotBlocked sufficient?@@ -307,20 +330,18 @@           b | Just t <- isMatchable b ->             case mtc t of               Just (bld, vs) -> do-                (m, vs1) <- yesSimplification <$> matchPatterns ps (fromMaybe __IMPOSSIBLE__ $ allApplyElims vs)-                return (m, Arg info $ bld (mergeElims vs vs1))+                (m, vs1) <- matchPatterns ps (fromMaybe __IMPOSSIBLE__ $ allApplyElims vs)+                return (yesSimplification m, Arg info $ bld (mergeElims vs vs1))               Nothing                                     -> return (No                          , arg)-          Blocked b _               -> return (DontKnow $ Blocked b ()     , arg)-          NotBlocked r _            -> return (DontKnow $ NotBlocked r' () , arg)+          Blocked b _               -> return (DontKnow lazy $ Blocked b ()     , arg)+          NotBlocked r _            -> return (DontKnow lazy $ NotBlocked r' () , arg)             where r' = stuckOn (Apply arg) r --- ASR (08 November 2014). The type of the function could be------ @(Match Term, [Arg Term]) -> (Match Term, [Arg Term])@.-yesSimplification :: (Match a, b) -> (Match a, b)-yesSimplification (Yes _ vs, us) = (Yes YesSimplification vs, us)-yesSimplification r              = r+yesSimplification :: Match a -> Match a+yesSimplification = \case+  Yes _ vs -> Yes YesSimplification vs+  m -> m  -- Matching patterns against patterns ------------------------------------- @@ -360,3 +381,25 @@                -> m (Match DeBruijnPattern) matchPatternsP ps qs = do   mconcat <$> zipWithM matchPatternP (map namedArg ps) qs+++-- | Does the pattern perform a match that could fail?+properlyMatching :: HasConstInfo m => Pattern' a -> m Bool+properlyMatching = properlyMatching' True True++properlyMatching' :: HasConstInfo m+  => Bool       -- ^ Should absurd patterns count as proper match?+  -> Bool       -- ^ Should projection patterns count as proper match?+  -> Pattern' a -- ^ The pattern.+  -> m Bool+properlyMatching' absP projP = \case+  p | absP && patternOrigin p == Just PatOAbsurd -> return True+  ConP con ci ps    -- eta record constructors do not count as proper matches themselves+    | conPRecord ci -> (isNothing <$> isEtaRecordConstructor (conName con)) `or2M` anyM (properlyMatching . namedArg) ps+    | otherwise     -> return True+  LitP{}    -> return True+  DefP{}    -> return True+  ProjP{}   -> return projP+  VarP{}    -> return False+  DotP{}    -> return False+  IApplyP{} -> return False
src/full/Agda/TypeChecking/Patterns/Match.hs-boot view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Patterns.Match where @@ -10,7 +11,9 @@  import Agda.Utils.Impossible -data Match a = Yes Simplification (IntMap (Arg a)) | No | DontKnow (Blocked ())+data Match a = Yes Simplification (IntMap (Arg a)) | No | DontKnow OnlyLazy (Blocked ())++data OnlyLazy = OnlyLazy | NonLazy  buildSubstitution :: (DeBruijn a) => Impossible -> Int -> IntMap (Arg a) -> Substitution' a
src/full/Agda/TypeChecking/Polarity.hs view
@@ -33,7 +33,7 @@ import Agda.Utils.List import Agda.Utils.Maybe ( whenNothingM ) import Agda.Utils.Monad-import Agda.Utils.Pretty ( prettyShow )+import Agda.Syntax.Common.Pretty ( prettyShow ) import Agda.Utils.Singleton import Agda.Utils.Size
src/full/Agda/TypeChecking/Polarity.hs-boot view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Polarity where
src/full/Agda/TypeChecking/Positivity.hs view
@@ -1,17 +1,17 @@+{-# LANGUAGE NondecreasingIndentation #-}  -- | Check that a datatype is strictly positive. module Agda.TypeChecking.Positivity where -import Prelude hiding ( null )+import Prelude hiding ( null, (!!) )  import Control.Applicative hiding (empty) import Control.DeepSeq-import Control.Monad        ( forM_, guard, liftM2 )-import Control.Monad.Reader ( MonadReader(..), asks, Reader, runReader )+import Control.Monad.Reader ( MonadReader(..), asks, ReaderT, runReaderT )  import Data.Either import qualified Data.Foldable as Fold-import Data.Function+import Data.Function (on) import Data.Graph (SCC(..)) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap@@ -22,16 +22,20 @@ import qualified Data.Sequence as DS import Data.Set (Set) import qualified Data.Set as Set+import Data.Strict.These  import Debug.Trace +import Agda.Interaction.Options.Base ( optPolarity ) import Agda.Syntax.Common import qualified Agda.Syntax.Info as Info import Agda.Syntax.Internal+import Agda.Syntax.Internal.Pattern import Agda.Syntax.Position (HasRange(..), noRange) import Agda.TypeChecking.Datatypes ( isDataOrRecordType ) import Agda.TypeChecking.Functions import Agda.TypeChecking.Monad+import Agda.TypeChecking.Patterns.Match ( properlyMatching ) import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records@@ -44,11 +48,12 @@ import Agda.Utils.Function (applyUnless) import Agda.Utils.Functor import Agda.Utils.List+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import qualified Agda.Utils.Pretty as P-import Agda.Utils.Pretty (Pretty, prettyShow)+import qualified Agda.Syntax.Common.Pretty as P+import Agda.Syntax.Common.Pretty (Pretty, prettyShow) import Agda.Utils.SemiRing import Agda.Utils.Singleton import Agda.Utils.Size@@ -60,8 +65,11 @@ -- | Check that the datatypes in the mutual block containing the given --   declarations are strictly positive. --+--   Find polarity of datatypes parameters and indices.+-- --   Also add information about positivity and recursivity of records --   to the signature.+-- checkStrictlyPositive :: Info.MutualInfo -> Set QName -> TCM () checkStrictlyPositive mi qset = do   -- compute the occurrence graph for qs@@ -100,16 +108,24 @@         ]   reportSLn "tc.pos.graph.sccs" 15 $     "  sccs = " ++ prettyShow [ scc | CyclicSCC scc <- sccs ]-  forM_ sccs $ \case-    -- If the mutuality information has never been set, we set it to []-    AcyclicSCC (DefNode q) -> whenM (isNothing <$> getMutual q) $ do-      reportSLn "tc.pos.mutual" 10 $ "setting " ++ prettyShow q ++ " to non-recursive"-      -- Andreas, 2017-04-26, issue #2555-      -- We should not have @DefNode@s pointing outside our formal mutual block.-      unless (Set.member q qset) __IMPOSSIBLE__-      setMutual q []-    AcyclicSCC (ArgNode{}) -> return ()-    CyclicSCC scc          -> setMut [ q | DefNode q <- scc ]++  -- #7133: Note that the graph doesn't necessarily contain all of qs in the case where there are no+  -- occurrences of a name, but we still need to setMutual for them.+  let sccMap = Map.unions [ case scc of+                              AcyclicSCC (DefNode q) -> Map.singleton q []+                              AcyclicSCC ArgNode{}   -> mempty+                              CyclicSCC scc          -> Map.fromList [ (q, qs) | q <- qs ]+                                where qs = [ q | DefNode q <- scc ]+                          | scc <- sccs ]+  inAbstractMode $ forM_ qs $ \ q ->+    whenM (isNothing <$> getMutual q) $ do+      let qs = fromMaybe [] $ Map.lookup q sccMap+      reportSLn "tc.pos.mutual" 10 $ "setting " ++ prettyShow q ++ " to " +++                                     if | null qs        -> "non-recursive"+                                        | length qs == 1 -> "recursive"+                                        | otherwise      -> "mutually recursive"+      setMutual q qs+   mapM_ (checkPos g gstar) qs   reportSDoc "tc.pos.tick" 100 $ "checked positivity" @@ -117,9 +133,9 @@     checkPos :: Graph Node (Edge OccursWhere) ->                 Graph Node Occurrence ->                 QName -> TCM ()-    checkPos g gstar q = inConcreteOrAbstractMode q $ \ _def -> do+    checkPos g gstar q = inConcreteOrAbstractMode q $ \ def -> do       -- we check positivity only for data or record definitions-      whenJustM (isDatatype q) $ \ dr -> do+      whenJust (isDatatype def) $ \ dr -> do         reportSDoc "tc.pos.check" 10 $ "Checking positivity of" <+> prettyTCM q          let loop :: Maybe Occurrence@@ -190,32 +206,17 @@         -- 'Inductive' or 'Coinductive'.  Otherwise, error.         unlessM (isJust . recInduction . theDef <$> getConstInfo q) $           setCurrentRange (nameBindingSite $ qnameName q) $-            typeError . GenericDocError =<<-              "Recursive record" <+> prettyTCM q <+>-              "needs to be declared as either inductive or coinductive"+            typeError $ RecursiveRecordNeedsInductivity q      occ (Edge o _) = o -    isDatatype :: QName -> TCM (Maybe DataOrRecord)-    isDatatype q = do-      def <- theDef <$> getConstInfo q-      return $ case def of+    isDatatype :: Definition -> Maybe DataOrRecord+    isDatatype def = do+      case theDef def of         Datatype{dataClause = Nothing} -> Just IsData         Record  {recClause  = Nothing, recPatternMatching } -> Just $ IsRecord recPatternMatching         _ -> Nothing -    -- Set the mutually recursive identifiers for a SCC.-    setMut :: [QName] -> TCM ()-    setMut [] = return ()  -- nothing to do-    setMut qs = forM_ qs $ \ q -> do-      reportSLn "tc.pos.mutual" 10 $ "setting " ++ prettyShow q ++ " to (mutually) recursive"-      setMutual q qs-      -- TODO: The previous line produces data of quadratic size-      -- (which has to be processed upon serialization).  Presumably qs is-      -- usually short, but in some cases (for instance for generated-      -- code) it may be long. Wouldn't it be better to assign a-      -- unique identifier to each SCC, and avoid storing lists?-     -- Set the polarity of the arguments to a couple of definitions     setArgOccs :: Set QName -> [QName] -> Graph Node Occurrence -> TCM ()     setArgOccs qset qs g = do@@ -233,6 +234,7 @@         let findOcc i = fromMaybe Unused $ Graph.lookup (ArgNode q i) (DefNode q) g             args = -- caseMaybe (Map.lookup q maxs) (replicate n Unused) $ \ m ->               map findOcc [0 .. n-1]  -- [0 .. max m (n - 1)] -- triggers issue #3049+         reportSDoc "tc.pos.args" 10 $ sep           [ "args of" <+> prettyTCM q <+> "="           , nest 2 $ prettyList $ map prettyTCM args@@ -240,8 +242,22 @@         -- The list args can take a long time to compute, but contains         -- small elements, and is stored in the interface (right?), so         -- it is computed deep-strictly.-        setArgOccurrences q $!! args+        modifyArgOccurrences q (mergeOccs $!! args)+       where+      mergeOccs :: [Occurrence] -> [Occurrence] -> [Occurrence]+      mergeOccs poccs toccs =+        -- Lucas, 2022-12-01:+        -- `poccs` are the occurences computed by the positivity-checker+        -- `toccs` are the occurences/polarities explicitely given by the user+        --   (and enforced through type-checking)+        -- We consider the polarities explicitely given (toccs) to take priority over the ones+        -- found out by the positivity checker.+        -- Note: Alas, this is hard to enforce given that non-annotated variables are+        -- always annotated with Mixed polarity. If the annotated polarity is Mixed,+        -- for now we always rely on the result from the positivity analysis.+        align poccs toccs <&> mergeThese (\a b -> if b == Mixed then a else b)+       -- Andreas, 2018-11-23, issue #3404       -- Only assign argument occurrences to things which have a definition.       -- Things without a definition would be judged "constant" in all arguments,@@ -261,28 +277,21 @@  getDefArity :: Definition -> TCM Int getDefArity def = do-  subtract (projectionArgs def) <$> arity' (defType def)-  where-  -- A variant of "\t -> arity <$> instantiateFull t".-  arity' :: Type -> TCM Int-  arity' t = do-    t <- instantiate t-    case unEl t of-      Pi _ t -> succ <$> arity' (unAbs t)-      _      -> return 0+  TelV tel _ <- telView (defType def)+  return $ size tel - projectionArgs def  -- Computing occurrences -------------------------------------------------- -data Item = AnArg Nat+data Item = AnArg Nat [Occurrence]           | ADef QName   deriving (Eq, Ord, Show)  instance HasRange Item where-  getRange (AnArg _) = noRange+  getRange (AnArg _ _) = noRange   getRange (ADef qn)   = getRange qn  instance Pretty Item where-  prettyPrec p (AnArg i) = P.mparens (p > 9) $ "AnArg" P.<+> P.pretty i+  prettyPrec p (AnArg i t) = P.mparens (p > 9) $ "AnArg" P.<+> P.pretty i P.<+> P.pretty t   prettyPrec p (ADef qn) = P.mparens (p > 9) $ "ADef"  P.<+> P.pretty qn  type Occurrences = Map Item [OccursWhere]@@ -338,7 +347,7 @@       keep = case (m, i) of         (Nothing, _)      -> True         (_, ADef _)       -> True-        (Just m, AnArg i) -> i < m+        (Just m, AnArg i _) -> i < m  -- | An interpreter for 'OccurrencesBuilder'. --@@ -373,7 +382,7 @@   }  -- | Monad for computing occurrences.-type OccM = Reader OccEnv+type OccM = ReaderT OccEnv ReduceM  instance (Semigroup a, Monoid a) => Monoid (OccM a) where   mempty  = return mempty@@ -395,7 +404,9 @@ getOccurrences vars a = do   reportSDoc "tc.pos.occ" 70 $ "computing occurrences in " <+> text (show a)   reportSDoc "tc.pos.occ" 20 $ "computing occurrences in " <+> prettyTCM a-  runReader (occurrences a) . OccEnv vars . fmap nameOfInf <$> coinductionKit+  reportSDoc "tc.pos.var" 20 $ "variables in context: " <+> pretty vars+  env <- OccEnv vars . fmap nameOfInf <$> coinductionKit+  runReduceM $ runReaderT (occurrences a) env  class ComputeOccurrences a where   occurrences :: a -> OccM OccurrencesBuilder@@ -407,14 +418,18 @@   occurrences cl = do     let ps    = namedClausePats cl         items = IntMap.elems $ patItems ps -- sorted from low to high DBI-    (Concat (mapMaybe matching (zip [0..] ps)) <>) <$> do+    -- TODO #3733: handle hcomp/transp clauses properly+    if hasDefP ps then return mempty else do+      argOccs <- mapMaybeM matching $ zip [0..] ps+      (Concat argOccs <>) <$> do       withExtendedOccEnv' items $         occurrences $ clauseBody cl     where-      matching (i, p)-        | properlyMatching (namedThing $ unArg p) =-            Just $ OccursAs Matched $ OccursHere $ AnArg i-        | otherwise                  = Nothing+      matching :: (Int, NamedArg (Pattern' a)) -> OccM (Maybe OccurrencesBuilder)+      matching (i, p) = do+        properlyMatching (namedThing $ unArg p) >>= \case+          True -> return $ Just $ OccursAs Matched $ OccursHere $ AnArg i []+          False -> return Nothing        -- @patItems ps@ creates a map from the pattern variables of @ps@       -- to the index of the argument they are bound in.@@ -426,14 +441,26 @@         where           ixs = map dbPatVarIndex $ lefts $ map unArg $ patternVars $ namedThing <$> p -          makeEntry x = singleton (x, Just $ AnArg i)+          makeEntry x = singleton (x, Just $ AnArg i [])  instance ComputeOccurrences Term where   occurrences v = case unSpine v of-    Var i args -> (asks (occI . vars)) <> (OccursAs VarArg <$> occurrences args)+    Var i args ->+      asks (occI . vars) <> do+        occs <- mapM occurrences args++        -- Lucas, 2022-12-01: Now, variables may have the polarities of their arguments+        -- stored in the context (say, if the variable refers to a datatype parameter)+        item <- reader ((!! i) . vars)++        let getPol i = fromMaybe Mixed $ do+              AnArg _ aoccs <- item+              aoccs !!! i++        return $ Concat $ zipWith (\i -> OccursAs (VarArg (getPol i) i)) [0..] occs       where-      occI vars = maybe mempty OccursHere $ indexWithDefault unbound vars i-      unbound = flip trace __IMPOSSIBLE__ $+        occI vars = maybe mempty OccursHere $ indexWithDefault unbound vars i+        unbound = flip trace __IMPOSSIBLE__ $               "impossible: occurrence of de Bruijn index " ++ show i ++               " in vars " ++ show vars ++ " is unbound" @@ -480,6 +507,9 @@   occurrences (Apply a)      = occurrences a   occurrences (IApply x y a) = occurrences (x,(y,a)) -- TODO Andrea: conservative +instance (ComputeOccurrences x, ComputeOccurrences a) => ComputeOccurrences (Boundary' x a) where+  occurrences = occurrences . theBoundary+ instance ComputeOccurrences a => ComputeOccurrences (Arg a)   where instance ComputeOccurrences a => ComputeOccurrences (Dom a)   where instance ComputeOccurrences a => ComputeOccurrences [a]       where@@ -488,6 +518,9 @@ instance (ComputeOccurrences a, ComputeOccurrences b) => ComputeOccurrences (a, b) where   occurrences (x, y) = occurrences x <> occurrences y +instance ComputeOccurrences Int where+  occurrences _ = mempty+ -- | Computes the number of occurrences of different 'Item's in the -- given definition. --@@ -504,7 +537,8 @@     let a = defAbstract def     m <- asksTC envAbstractMode     cur <- asksTC envCurrentModule-    "computeOccurrences" <+> prettyTCM q <+> text (show a) <+> text (show m)+    o <- asksTC envCurrentOpaqueId+    "computeOccurrences" <+> prettyTCM q <+> text (show a) <+> text (show o) <+> text (show m)       <+> prettyTCM cur   OccursAs (InDefOf q) <$> case theDef def of @@ -514,33 +548,42 @@         mapM (getOccurrences []) cs      Datatype{dataClause = Just c} -> getOccurrences [] =<< instantiateFull c-    Datatype{dataPars = np0, dataCons = cs}       -> do+    Datatype{dataPars = np0, dataCons = cs, dataTranspIx = trx} -> do       -- Andreas, 2013-02-27 (later edited by someone else): First,       -- include each index of an inductive family.-      TelV tel _ <- telView $ defType def+      TelV telD _ <- telView $ defType def       -- Andreas, 2017-04-26, issue #2554: count first index as parameter if it has type Size.       -- We compute sizeIndex=1 if first first index has type Size, otherwise sizeIndex==0-      sizeIndex <- caseList (drop np0 $ telToList tel) (return 0) $ \ dom _ -> do+      sizeIndex <- caseList (drop np0 $ telToList telD) (return 0) $ \ dom _ -> do         caseMaybeM (isSizeType dom) (return 0) $ \ _ -> return 1       let np = np0 + sizeIndex-      let xs = [np .. size tel - 1] -- argument positions corresponding to indices-      let ioccs = Concat $ map (OccursHere . AnArg) [np0 .. np - 1]-                        ++ map (OccursAs IsIndex . OccursHere . AnArg) xs+      let xs = [np .. size telD - 1] -- argument positions corresponding to indices++      let ioccs = Concat $ map (\i -> OccursHere $ AnArg i []) [np0 .. np - 1]+                        ++ map (\i -> OccursAs IsIndex $ OccursHere $ AnArg i []) xs+       -- Then, we compute the occurrences in the constructor types.       let conOcc c = do             -- Andreas, 2020-02-15, issue #4447:             -- Allow UnconfimedReductions here to make sure we get the constructor type             -- in same way as it was obtained when the data types was checked.-            TelV tel t <- putAllowedReductions allReductions $-              telViewPath . defType =<< getConstInfo c+            (TelV tel t, bnd) <- putAllowedReductions allReductions $+              telViewPathBoundary . defType =<< getConstInfo c             let (tel0,tel1) = splitTelescopeAt np tel             -- Do not collect occurrences in the data parameters.             -- Normalization needed e.g. for test/succeed/Bush.agda.             -- (Actually, for Bush.agda, reducing the parameters should be sufficient.)             tel1' <- addContext tel0 $ normalise $ tel1-            let vars = map (Just . AnArg) . downFrom++            -- Make parameters into context items, with polarity info+            pvars <- parametersToItems tel0 np+            let telvars = replicate (size tel1') Nothing ++ pvars++            reportSLn "tc.pos.params" 50 $ "Adding datatypes parameters in context " ++ prettyShow pvars+             -- Occurrences in the types of the constructor arguments.-            mappend (OccursAs (ConArgType c) <$> getOccurrences (vars np) tel1') $ do+            (OccursAs (ConArgType c) <$> getOccurrences pvars tel1') <>+              (OccursAs (ConEndpoint c) <$> getOccurrences telvars bnd) <> do               -- Occurrences in the indices of the data type the constructor targets.               -- Andreas, 2020-02-15, issue #4447:               -- WAS: @t@ is not necessarily a data type, but it could be something@@ -549,13 +592,12 @@               -- In any case, if @t@ is not showing itself as the data type, we need to               -- do something conservative.  We will just collect *all* occurrences               -- and flip their sign (variance) using 'LeftOfArrow'.-              let fallback = OccursAs LeftOfArrow <$> getOccurrences (vars $ size tel) t -- NB::Defined but not used               case unEl t of                 Def q' vs                   | q == q' -> do                       let indices = fromMaybe __IMPOSSIBLE__ $ allApplyElims $ drop np vs-                      OccursAs (IndArgType c) . OnlyVarsUpTo np <$> getOccurrences (vars $ size tel) indices-                  | otherwise -> __IMPOSSIBLE__  -- fallback -- this ought to be impossible now (but wasn't, see #4447)+                      OccursAs (IndArgType c) . OnlyVarsUpTo np <$> getOccurrences telvars indices+                  | otherwise -> __IMPOSSIBLE__  -- this ought to be impossible now (but wasn't, see #4447)                 Pi{}       -> __IMPOSSIBLE__  -- eliminated  by telView                 MetaV{}    -> __IMPOSSIBLE__  -- not a constructor target; should have been solved by now                 Var{}      -> __IMPOSSIBLE__  -- not a constructor target@@ -566,13 +608,17 @@                 Level{}    -> __IMPOSSIBLE__  -- not a type                 DontCare{} -> __IMPOSSIBLE__  -- not a type                 Dummy{}    -> __IMPOSSIBLE__-      mconcat $ pure ioccs : map conOcc cs +      -- If the data type has a transport constructor (i.e. it's an+      -- indexed family in cubical mode) we should also consider it for+      -- positivity.+      mconcat $ pure ioccs : map conOcc (cs ++ maybeToList trx)+     Record{recClause = Just c} -> getOccurrences [] =<< instantiateFull c     Record{recPars = np, recTel = tel} -> do       let (tel0,tel1) = splitTelescopeAt np tel-          vars = map (Just . AnArg) $ downFrom np-      getOccurrences vars =<< addContext tel0 (normalise tel1) -- Andreas, 2017-01-01, issue #1899, treat like data types+      pvars <- parametersToItems tel0 np+      getOccurrences pvars =<< addContext tel0 (normalise tel1) -- Andreas, 2017-01-01, issue #1899, treat like data types      -- Arguments to other kinds of definitions are hard-wired.     Constructor{}      -> mempty@@ -582,7 +628,14 @@     PrimitiveSort{}    -> mempty     GeneralizableVar{} -> mempty     AbstractDefn{}     -> __IMPOSSIBLE__+  where+    parametersToItems :: Telescope -> Nat -> TCM [Maybe Item]+    parametersToItems tel n = reverse <$>+      zipWithM (\i -> fmap (Just . AnArg i) . getOccurrencesFromType)+        [0 .. n -1]+        (snd . unDom <$> telToList tel) + -- Building the occurrence graph ------------------------------------------  data Node = DefNode !QName@@ -716,7 +769,7 @@     OccursHere' i ->       let o = OccursWhere (getRange i) cs os in       case i of-        AnArg i ->+        AnArg i t ->           return $ applyUnless (null pol) (Graph.Edge             { Graph.source = ArgNode q i             , Graph.target = to@@ -739,7 +792,7 @@     -> Where     -> TCM (Maybe Node, Occurrence)   mkEdge' to !pol = \case-    VarArg         -> mixed+    VarArg p i     -> addPol p     MetaArg        -> mixed     LeftOfArrow    -> negative     DefArg d i     -> do@@ -750,6 +803,7 @@     UnderInf       -> addPol GuardPos -- Andreas, 2012-06-09: ∞ is guarding     ConArgType _   -> keepGoing     IndArgType _   -> mixed+    ConEndpoint _  -> keepGoing     InClause _     -> keepGoing     Matched        -> mixed -- consider arguments matched against as used     IsIndex        -> mixed -- And similarly for indices.@@ -763,8 +817,7 @@     addPol pol' = return (Nothing, otimes pol pol')    isGuarding d = do-    isDR <- isDataOrRecordType d-    return $ case isDR of+    isDataOrRecordType d <&> \case       Just IsData -> GuardPos  -- a datatype is guarding       _           -> StrictPos @@ -795,7 +848,7 @@        -- Removes consecutive duplicates.       uniq :: [OccursWhere] -> [OccursWhere]-      uniq = map head . List.groupBy ((==) `on` snd')+      uniq = map List1.head . List1.groupBy ((==) `on` snd')         where         snd' (OccursWhere _ _ ws) = ws @@ -832,12 +885,16 @@                           [prettyTCM q]         UnderInf     -> pwords "under" ++                         [do -- this cannot fail if an 'UnderInf' has been generated-                            Def inf _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinInf+                            inf <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinInf                             prettyTCM inf]-        VarArg       -> pwords "in an argument of a bound variable"+        VarArg p i   -> pwords "in an argument of a bound variable at position" ++ [prettyTCM i]+                        ++ pwords "which uses its argument with polarity" ++ [ pretty p ]         MetaArg      -> pwords "in an argument of a metavariable"         ConArgType c -> pwords "in the type of the constructor" ++ [prettyTCM c]         IndArgType c -> pwords "in an index of the target type of the constructor" ++ [prettyTCM c]+        ConEndpoint c+                     -> pwords "in an endpoint of the target of the" +++                        pwords "higher constructor" ++ [prettyTCM c]         InClause i   -> pwords "in the" ++ nth i ++ pwords "clause"         Matched      -> pwords "as matched against"         IsIndex      -> pwords "as an index"
src/full/Agda/TypeChecking/Positivity/Occurrence.hs view
@@ -1,18 +1,22 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ -- | Occurrences.  module Agda.TypeChecking.Positivity.Occurrence-  ( Occurrence(..)+  ( PragmaPolarities+  , Occurrence(..)   , OccursWhere(..)   , Where(..)   , boundToEverySome   , productOfEdgesInBoundedWalk+  , modalPolarityToOccurrence   ) where +import Prelude hiding (null)+ import Control.DeepSeq import Control.Monad -import Data.Data (Data)- import Data.Foldable (toList)  import Data.Map.Strict (Map)@@ -22,13 +26,14 @@ import GHC.Generics (Generic)  import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty import Agda.Syntax.Abstract.Name import Agda.Syntax.Position  import Agda.Utils.Graph.AdjacencyMap.Unidirectional (Graph) import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph+import Agda.Utils.List1 (List1) import Agda.Utils.Null-import Agda.Utils.Pretty import Agda.Utils.SemiRing import Agda.Utils.Size @@ -38,6 +43,9 @@  -- Operations and instances in Agda.TypeChecking.Positivity. +-- | List of polarities stemming from POLARITY pragma.+type PragmaPolarities = List1 (Ranged Occurrence)+ -- | Description of an occurrence. data OccursWhere   = OccursWhere Range (Seq Where) (Seq Where)@@ -46,24 +54,32 @@     -- includes the main information, and if the first sequence is     -- non-empty, then it includes information about the context of     -- the second sequence.-  deriving (Show, Eq, Ord, Data, Generic)+  deriving (Show, Eq, Ord, Generic)  instance NFData OccursWhere +instance Null OccursWhere where+  empty = OccursWhere empty empty empty+  null (OccursWhere r wh1 wh2) = and [ null r, null wh1, null wh2 ]+ -- | One part of the description of an occurrence. data Where   = LeftOfArrow-  | DefArg QName Nat -- ^ in the nth argument of a define constant-  | UnderInf         -- ^ in the principal argument of built-in ∞-  | VarArg           -- ^ as an argument to a bound variable-  | MetaArg          -- ^ as an argument of a metavariable-  | ConArgType QName -- ^ in the type of a constructor-  | IndArgType QName -- ^ in a datatype index of a constructor-  | InClause Nat     -- ^ in the nth clause of a defined function-  | Matched          -- ^ matched against in a clause of a defined function-  | IsIndex          -- ^ is an index of an inductive family-  | InDefOf QName    -- ^ in the definition of a constant-  deriving (Show, Eq, Ord, Data, Generic)+  | DefArg QName Nat       -- ^ in the nth argument of a define constant+  | UnderInf               -- ^ in the principal argument of built-in ∞+  | VarArg Occurrence Nat  -- ^ as an argument to a bound variable.+                           --   The polarity, if given, is the polarity of+                           --   the argument the occurence is in+  | MetaArg                -- ^ as an argument of a metavariable+  | ConArgType QName       -- ^ in the type of a constructor+  | IndArgType QName       -- ^ in a datatype index of a constructor+  | ConEndpoint QName+                           -- ^ in an endpoint of a higher constructor+  | InClause Nat           -- ^ in the nth clause of a defined function+  | Matched                -- ^ matched against in a clause of a defined function+  | IsIndex                -- ^ is an index of an inductive family+  | InDefOf QName          -- ^ in the definition of a constant+  deriving (Show, Eq, Ord, Generic)  instance NFData Where @@ -78,7 +94,7 @@   | StrictPos -- ^ Strictly positive occurrence.   | GuardPos  -- ^ Guarded strictly positive occurrence (i.e., under ∞).  For checking recursive records.   | Unused    --  ^ No occurrence.-  deriving (Data, Show, Eq, Ord, Enum, Bounded)+  deriving (Show, Eq, Ord, Enum, Bounded)  -- Pretty instances. @@ -96,10 +112,12 @@     LeftOfArrow  -> "LeftOfArrow"     DefArg q i   -> "DefArg"     <+> pretty q <+> pretty i     UnderInf     -> "UnderInf"-    VarArg       -> "VarArg"+    VarArg k i   -> "VarArg" <+> pretty k <+> pretty i     MetaArg      -> "MetaArg"     ConArgType q -> "ConArgType" <+> pretty q     IndArgType q -> "IndArgType" <+> pretty q+    ConEndpoint q+                 -> "ConEndpoint" <+> pretty q     InClause i   -> "InClause"   <+> pretty i     Matched      -> "Matched"     IsIndex      -> "IsIndex"@@ -173,7 +191,8 @@ -- Agda.TypeChecking.Positivity.  instance Sized OccursWhere where-  size (OccursWhere _ cs os) = 1 + size cs + size os+  size    (OccursWhere _ cs os) = 1 + size cs + size os+  natSize (OccursWhere _ cs os) = 1 + natSize cs + natSize os  -- | The map contains bindings of the form @bound |-> ess@, satisfying -- the following property: for every non-empty list @w@,@@ -224,3 +243,11 @@         Just es@(_ : _) -> Just (foldr1 otimes (map Graph.label es))         Just []         -> __IMPOSSIBLE__         Nothing         -> Nothing++modalPolarityToOccurrence :: ModalPolarity -> Occurrence+modalPolarityToOccurrence = \case+  UnusedPolarity -> Unused+  StrictlyPositive -> StrictPos+  Positive -> JustPos+  Negative -> JustNeg+  MixedPolarity -> Mixed
src/full/Agda/TypeChecking/Pretty.hs view
@@ -1,7 +1,7 @@-+-- Each function here should either have an INLINE or a SPECIALIZE pragma.+-- module Agda.TypeChecking.Pretty     ( module Agda.TypeChecking.Pretty-    , module Data.Semigroup -- This re-export can be removed once <GHC-8.4 is dropped.     , module Reexport     ) where @@ -10,19 +10,21 @@ import Control.Applicative  (liftA2) import Control.Monad import Control.Monad.Except-import Control.Monad.Reader (ReaderT)-import Control.Monad.State  (StateT) +import qualified Data.Foldable as Fold import Data.Map (Map) import qualified Data.Map as Map+import Data.Set (Set) import qualified Data.Set as Set import Data.Maybe-import Data.String+import Data.String    () import Data.Semigroup (Semigroup((<>)))-import qualified Data.Foldable as Fold+import Data.Text      (Text)  import Agda.Syntax.Position import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty ( Pretty, prettyShow )+import qualified Agda.Syntax.Common.Pretty as P import Agda.Syntax.Fixity import Agda.Syntax.Internal import Agda.Syntax.Literal@@ -39,21 +41,26 @@ import qualified Agda.Syntax.Info as A import Agda.Syntax.Scope.Base  (AbstractName(..)) import Agda.Syntax.Scope.Monad (withContextPrecedence)+import Agda.Syntax.TopLevelModuleName  import Agda.TypeChecking.Coverage.SplitTree import Agda.TypeChecking.Monad import Agda.TypeChecking.Positivity.Occurrence+import Agda.TypeChecking.DiscrimTree.Types import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope +import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Graph.AdjacencyMap.Unidirectional (Graph) import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph import Agda.Utils.List1 ( List1, pattern (:|) ) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Null-import Agda.Utils.Permutation (Permutation)-import Agda.Utils.Pretty (Pretty, prettyShow)-import qualified Agda.Utils.Pretty as P+import Agda.Utils.Trie+import Agda.Utils.Permutation ( Permutation )+import qualified Agda.Utils.Maybe.Strict as S+import Agda.Utils.Size ( Sized, natSize )  import Agda.Utils.Impossible @@ -64,38 +71,47 @@ type Doc = P.Doc  comma, colon, equals :: Applicative m => m Doc-comma  = pure P.comma-colon  = pure P.colon-equals = pure P.equals+comma  = pure P.comma        ; {-# INLINE comma  #-}+colon  = pure P.colon        ; {-# INLINE colon  #-}+equals = pure P.equals       ; {-# INLINE equals #-} +{-# INLINE pretty #-} pretty :: (Applicative m, P.Pretty a) => a -> m Doc-pretty x = pure $ P.pretty x+pretty = pure . P.pretty +{-# INLINE prettyA #-} prettyA :: (ToConcrete a, P.Pretty (ConOfAbs a), MonadAbsToCon m) => a -> m Doc-prettyA x = AP.prettyA x+prettyA = AP.prettyA +{-# INLINE prettyAs #-}+-- Triggers error: [GHC-69441] RULE left-hand side too complicated to desugar: ...+-- {-# SPECIALIZE prettyAs :: (ToConcrete a, ConOfAbs a ~ [ce], P.Pretty ce) => a -> TCM Doc #-} prettyAs :: (ToConcrete a, ConOfAbs a ~ [ce], P.Pretty ce, MonadAbsToCon m) => a -> m Doc-prettyAs x = AP.prettyAs x--text :: Applicative m => String -> m Doc-text s = pure $ P.text s+prettyAs = AP.prettyAs -multiLineText :: Applicative m => String -> m Doc-multiLineText s = pure $ P.multiLineText s+fwords, text, multiLineText :: Applicative m => String -> m Doc+fwords        = pure . P.fwords        ; {-# INLINE fwords        #-}+text          = pure . P.text          ; {-# INLINE text          #-}+multiLineText = pure . P.multiLineText ; {-# INLINE multiLineText #-} +{-# INLINE pwords #-} pwords :: Applicative m => String -> [m Doc]-pwords s = map pure $ P.pwords s+pwords = map pure . P.pwords -fwords :: Applicative m => String -> m Doc-fwords s = pure $ P.fwords s+sep, fsep, hsep, hcat, vcat, vsep :: (Applicative m, Foldable t) => t (m Doc) -> m Doc+sep  = fmap P.sep  . sequenceAFoldable  ; {-# SPECIALIZE NOINLINE sep  :: [TCM Doc] -> TCM Doc #-} ; {-# SPECIALIZE NOINLINE sep  :: List1 (TCM Doc) -> TCM Doc #-}+fsep = fmap P.fsep . sequenceAFoldable  ; {-# SPECIALIZE NOINLINE fsep :: [TCM Doc] -> TCM Doc #-} ; {-# SPECIALIZE NOINLINE fsep :: List1 (TCM Doc) -> TCM Doc #-}+hsep = fmap P.hsep . sequenceAFoldable  ; {-# SPECIALIZE NOINLINE hsep :: [TCM Doc] -> TCM Doc #-} ; {-# SPECIALIZE NOINLINE hsep :: List1 (TCM Doc) -> TCM Doc #-}+hcat = fmap P.hcat . sequenceAFoldable  ; {-# SPECIALIZE NOINLINE hcat :: [TCM Doc] -> TCM Doc #-} ; {-# SPECIALIZE NOINLINE hcat :: List1 (TCM Doc) -> TCM Doc #-}+vcat = fmap P.vcat . sequenceAFoldable  ; {-# SPECIALIZE NOINLINE vcat :: [TCM Doc] -> TCM Doc #-} ; {-# SPECIALIZE NOINLINE vcat :: List1 (TCM Doc) -> TCM Doc #-}+vsep = fmap P.vsep . sequenceAFoldable  ; {-# SPECIALIZE NOINLINE vsep :: [TCM Doc] -> TCM Doc #-} ; {-# SPECIALIZE NOINLINE vsep :: List1 (TCM Doc) -> TCM Doc #-} -sep, fsep, hsep, hcat, vcat :: (Applicative m, Foldable t) => t (m Doc) -> m Doc-sep ds  = P.sep  <$> sequenceA (Fold.toList ds)-fsep ds = P.fsep <$> sequenceA (Fold.toList ds)-hsep ds = P.hsep <$> sequenceA (Fold.toList ds)-hcat ds = P.hcat <$> sequenceA (Fold.toList ds)-vcat ds = P.vcat <$> sequenceA (Fold.toList ds)+{-# INLINE sequenceAFoldable #-}+-- | @sequenceAFoldable == sequenceA . Fold.toList@+sequenceAFoldable :: (Applicative m, Foldable t) => t (m a) -> m [a]+sequenceAFoldable = Fold.foldr (liftA2 (:)) (pure []) +{-# INLINE hang #-} hang :: Applicative m => m Doc -> Int -> m Doc -> m Doc hang p n q = P.hang <$> p <*> pure n <*> q @@ -103,35 +119,44 @@ infixl 5 $$, $+$  ($$), ($+$), (<+>), (<?>) :: Applicative m => m Doc -> m Doc -> m Doc-d1 $$ d2  = (P.$$) <$> d1 <*> d2-d1 $+$ d2 = (P.$+$) <$> d1 <*> d2-d1 <+> d2 = (P.<+>) <$> d1 <*> d2-d1 <?> d2 = (P.<?>) <$> d1 <*> d2+($$ ) = liftA2 (P.$$)   ; {-# INLINE ($$)  #-}+($+$) = liftA2 (P.$+$)  ; {-# INLINE ($+$) #-}+(<+>) = liftA2 (P.<+>)  ; {-# INLINE (<+>) #-}+(<?>) = liftA2 (P.<?>)  ; {-# INLINE (<?>) #-}  nest :: Functor m => Int -> m Doc -> m Doc-nest n d   = P.nest n <$> d+nest = fmap . P.nest    ; {-# INLINE nest  #-}  braces, dbraces, brackets, parens, parensNonEmpty   , doubleQuotes, quotes :: Functor m => m Doc -> m Doc-braces d   = P.braces <$> d-dbraces d  = CP.dbraces <$> d-brackets d = P.brackets <$> d-parens d   = P.parens <$> d-parensNonEmpty d = P.parensNonEmpty <$> d-doubleQuotes   d = P.doubleQuotes   <$> d-quotes         d = P.quotes         <$> d+braces         = fmap P.braces         ; {-# INLINE braces         #-}+dbraces        = fmap CP.dbraces       ; {-# INLINE dbraces        #-}+brackets       = fmap P.brackets       ; {-# INLINE brackets       #-}+parens         = fmap P.parens         ; {-# INLINE parens         #-}+parensNonEmpty = fmap P.parensNonEmpty ; {-# INLINE parensNonEmpty #-}+doubleQuotes   = fmap P.doubleQuotes   ; {-# INLINE doubleQuotes   #-}+quotes         = fmap P.quotes         ; {-# INLINE quotes         #-}  pshow :: (Applicative m, Show a) => a -> m Doc-pshow = pure . P.pshow+pshow = pure . P.pshow                 ; {-# INLINE pshow          #-} +pluralS :: (Functor m, Sized a) => a -> m Doc -> m Doc+pluralS = fmap . P.pluralS             ; {-# INLINE pluralS        #-}+ -- | Comma-separated list in brackets.-prettyList :: (Applicative m, Semigroup (m Doc), Foldable t) => t (m Doc) -> m Doc-prettyList ds = P.pretty <$> sequenceA (Fold.toList ds)+{-# INLINE prettyList #-}+prettyList :: (Applicative m, Foldable t) => t (m Doc) -> m Doc+prettyList = fmap P.pretty . sequenceAFoldable  -- | 'prettyList' without the brackets.+{-# SPECIALIZE prettyList_ :: [TCM Doc]       -> TCM Doc #-}+{-# SPECIALIZE prettyList_ :: List1 (TCM Doc) -> TCM Doc #-} prettyList_ :: (Applicative m, Semigroup (m Doc), Foldable t) => t (m Doc) -> m Doc-prettyList_ ds = fsep $ punctuate comma ds+prettyList_ = fsep . punctuate comma +{-# INLINABLE punctuate #-}+{-# SPECIALIZE punctuate :: TCM Doc -> [TCM Doc] -> [TCM Doc] #-}+{-# SPECIALIZE punctuate :: TCM Doc -> List1 (TCM Doc) -> [TCM Doc] #-} punctuate :: (Applicative m, Semigroup (m Doc), Foldable t) => m Doc -> t (m Doc) -> [m Doc] punctuate d ts   | null ds   = []@@ -140,23 +165,25 @@     ds = Fold.toList ts     n  = length ds - 1 +{-# SPECIALIZE superscript :: Int -> TCM Doc #-}+superscript :: Applicative m => Int -> m Doc+superscript = pretty . reverse . go where+  digit = ("⁰¹²³⁴⁵⁶⁷⁸⁹" !!)+  go k+    | k <= 9    = [digit k]+    | otherwise = digit (k `mod` 10):go (k `div` 10)+ --------------------------------------------------------------------------- -- * The PrettyTCM class --------------------------------------------------------------------------- -type MonadPretty m =-  ( MonadReify m-  , MonadAbsToCon m-  , IsString (m Doc)-  , Null (m Doc)-  , Semigroup (m Doc)-  )+type MonadPretty m = MonadAbsToCon m  -- This instance is to satify the constraints of superclass MonadPretty: -- | This instance is more specific than a generic instance -- @Semigroup a => Semigroup (TCM a)@.-instance {-# OVERLAPPING #-} Semigroup (TCM Doc)         where (<>) = liftA2 (<>)-+instance {-# OVERLAPPING #-} Semigroup (TCM Doc) where+  (<>) = liftA2 (<>) ; {-# INLINE (<>) #-}  class PrettyTCM a where   prettyTCM :: MonadPretty m => a -> m Doc@@ -165,60 +192,100 @@ prettyTCMCtx :: (PrettyTCM a, MonadPretty m) => Precedence -> a -> m Doc prettyTCMCtx p = withContextPrecedence p . prettyTCM -instance {-# OVERLAPPING #-} PrettyTCM String where prettyTCM = text-instance PrettyTCM Bool        where prettyTCM = pretty-instance PrettyTCM C.Name      where prettyTCM = pretty-instance PrettyTCM C.QName     where prettyTCM = pretty-instance PrettyTCM Comparison  where prettyTCM = pretty-instance PrettyTCM Literal     where prettyTCM = pretty-instance PrettyTCM Nat         where prettyTCM = pretty-instance PrettyTCM ProblemId   where prettyTCM = pretty-instance PrettyTCM Range       where prettyTCM = pretty-instance PrettyTCM CheckpointId where prettyTCM = pretty--- instance PrettyTCM Interval where prettyTCM = pretty--- instance PrettyTCM Position where prettyTCM = pretty+instance {-# OVERLAPPING #-} PrettyTCM String where prettyTCM = text   ; {-# INLINE prettyTCM #-}+instance PrettyTCM Text                       where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM Bool                       where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM C.Name                     where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM C.QName                    where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM C.ImportedName             where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM C.LHS                      where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM TopLevelModuleName         where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM Comparison                 where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM Literal                    where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM Nat                        where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM ProblemId                  where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM Range                      where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM CheckpointId               where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM InteractionId              where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM Relevance                  where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM Quantity                   where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM Erased                     where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM ModalPolarity              where prettyTCM = pretty ; {-# INLINE prettyTCM #-}+instance PrettyTCM PolarityModality           where prettyTCM = pretty ; {-# INLINE prettyTCM #-} +instance PrettyTCM A.Expr                     where prettyTCM = prettyA; {-# INLINE prettyTCM #-}+instance PrettyTCM A.Pattern                  where prettyTCM = prettyA; {-# INLINE prettyTCM #-}+instance PrettyTCM A.TypedBinding             where prettyTCM = prettyA; {-# INLINE prettyTCM #-}++instance PrettyTCM Term               where prettyTCM = prettyA <=< reify         ; {-# SPECIALIZE prettyTCM :: Term              -> TCM Doc #-}+instance PrettyTCM Type               where prettyTCM = prettyA <=< reify         ; {-# SPECIALIZE prettyTCM :: Type              -> TCM Doc #-}+instance PrettyTCM Sort               where prettyTCM = prettyA <=< reify         ; {-# SPECIALIZE prettyTCM :: Sort              -> TCM Doc #-}+instance PrettyTCM DisplayTerm        where prettyTCM = prettyA <=< reify         ; {-# SPECIALIZE prettyTCM :: DisplayTerm       -> TCM Doc #-}+instance PrettyTCM NamedClause        where prettyTCM = prettyA <=< reify         ; {-# SPECIALIZE prettyTCM :: NamedClause       -> TCM Doc #-}+instance PrettyTCM (QNamed Clause)    where prettyTCM = prettyA <=< reify         ; {-# SPECIALIZE prettyTCM :: (QNamed Clause)   -> TCM Doc #-}+instance PrettyTCM Level              where prettyTCM = prettyA <=< reify . Level ; {-# SPECIALIZE prettyTCM :: Level             -> TCM Doc #-}+instance PrettyTCM (Named_ Term)      where prettyTCM = prettyA <=< reify         ; {-# SPECIALIZE prettyTCM :: (Named_ Term)     -> TCM Doc #-}+instance PrettyTCM (Arg Term)         where prettyTCM = prettyA <=< reify         ; {-# SPECIALIZE prettyTCM :: (Arg Term)        -> TCM Doc #-}+instance PrettyTCM (Arg Type)         where prettyTCM = prettyA <=< reify         ; {-# SPECIALIZE prettyTCM :: (Arg Type)        -> TCM Doc #-}+instance PrettyTCM (Arg Bool)         where prettyTCM = prettyA <=< reify         ; {-# SPECIALIZE prettyTCM :: (Arg Bool)        -> TCM Doc #-}+instance PrettyTCM (Arg String)       where prettyTCM = prettyA <=< reify         ; {-# SPECIALIZE prettyTCM :: (Arg String)      -> TCM Doc #-}+instance PrettyTCM (Arg A.Expr)       where prettyTCM = prettyA <=< reify         ; {-# SPECIALIZE prettyTCM :: (Arg A.Expr)      -> TCM Doc #-}+instance PrettyTCM (NamedArg A.Expr)  where prettyTCM = prettyA <=< reify         ; {-# SPECIALIZE prettyTCM :: (NamedArg A.Expr) -> TCM Doc #-}+instance PrettyTCM (NamedArg Term)    where prettyTCM = prettyA <=< reify         ; {-# SPECIALIZE prettyTCM :: (NamedArg Term)   -> TCM Doc #-}+instance PrettyTCM (Dom Type)         where prettyTCM = prettyA <=< reify         ; {-# SPECIALIZE prettyTCM :: (Dom Type)        -> TCM Doc #-}+instance PrettyTCM ContextEntry       where prettyTCM = prettyA <=< reify         ; {-# SPECIALIZE prettyTCM :: ContextEntry      -> TCM Doc #-}++instance PrettyTCM Permutation        where prettyTCM = text . show               ; {-# SPECIALIZE prettyTCM :: Permutation       -> TCM Doc #-}+instance PrettyTCM Polarity           where prettyTCM = text . show               ; {-# SPECIALIZE prettyTCM :: Polarity          -> TCM Doc #-}+instance PrettyTCM IsForced           where prettyTCM = text . show               ; {-# SPECIALIZE prettyTCM :: IsForced          -> TCM Doc #-}++instance PrettyTCM Name         where prettyTCM = fmap P.pretty . abstractToConcrete_ ; {-# SPECIALIZE prettyTCM :: Name          -> TCM Doc #-}+instance PrettyTCM QName        where prettyTCM = fmap P.pretty . abstractToConcrete_ ; {-# SPECIALIZE prettyTCM :: QName         -> TCM Doc #-}+instance PrettyTCM ModuleName   where prettyTCM = fmap P.pretty . abstractToConcrete_ ; {-# SPECIALIZE prettyTCM :: ModuleName    -> TCM Doc #-}++instance PrettyTCM AbstractName where prettyTCM = prettyTCM . anameName           ; {-# SPECIALIZE prettyTCM :: AbstractName -> TCM Doc #-}+instance PrettyTCM ConHead      where prettyTCM = prettyTCM . conName             ; {-# SPECIALIZE prettyTCM :: ConHead      -> TCM Doc #-}+instance PrettyTCM DBPatVar     where prettyTCM = prettyTCM . var . dbPatVarIndex ; {-# SPECIALIZE prettyTCM :: DBPatVar     -> TCM Doc #-}+instance PrettyTCM EqualityView where prettyTCM = prettyTCM . equalityUnview      ; {-# SPECIALIZE prettyTCM :: EqualityView -> TCM Doc #-}++-- Functors++instance (PrettyTCM a, Subst a) => PrettyTCM (Abs a) where+  prettyTCM a = underAbstraction_ a prettyTCM+{-# SPECIALIZE prettyTCM :: PrettyTCM a => Abs a -> TCM Doc #-}+ instance PrettyTCM a => PrettyTCM (Closure a) where   prettyTCM cl = enterClosure cl prettyTCM+{-# SPECIALIZE prettyTCM :: PrettyTCM a => Closure a -> TCM Doc #-}  instance {-# OVERLAPPABLE #-} PrettyTCM a => PrettyTCM [a] where   prettyTCM = prettyList . map prettyTCM+{-# SPECIALIZE prettyTCM :: PrettyTCM a => [a] -> TCM Doc #-} +instance {-# OVERLAPPABLE #-} PrettyTCM a => PrettyTCM (List1 a) where+  prettyTCM = prettyList . fmap prettyTCM+{-# SPECIALIZE prettyTCM :: PrettyTCM a => [a] -> TCM Doc #-}+ instance {-# OVERLAPPABLE #-} PrettyTCM a => PrettyTCM (Maybe a) where   prettyTCM = maybe empty prettyTCM+{-# SPECIALIZE prettyTCM :: PrettyTCM a => Maybe a -> TCM Doc #-} +instance PrettyTCM a => PrettyTCM (Set a) where+  prettyTCM = braces . prettyList_ . map prettyTCM . Set.toList+{-# SPECIALIZE prettyTCM :: PrettyTCM a => Set a -> TCM Doc #-}+ instance (PrettyTCM a, PrettyTCM b) => PrettyTCM (a,b) where   prettyTCM (a, b) = parens $ prettyTCM a <> comma <> prettyTCM b+{-# SPECIALIZE prettyTCM :: (PrettyTCM a, PrettyTCM b) => (a, b) -> TCM Doc #-}  instance (PrettyTCM a, PrettyTCM b, PrettyTCM c) => PrettyTCM (a,b,c) where   prettyTCM (a, b, c) = parens $     prettyTCM a <> comma <> prettyTCM b <> comma <> prettyTCM c--instance PrettyTCM Term               where prettyTCM = prettyA <=< reify-instance PrettyTCM Type               where prettyTCM = prettyA <=< reify-instance PrettyTCM Sort               where prettyTCM = prettyA <=< reify-instance PrettyTCM DisplayTerm        where prettyTCM = prettyA <=< reify-instance PrettyTCM NamedClause        where prettyTCM = prettyA <=< reify-instance PrettyTCM (QNamed Clause)    where prettyTCM = prettyA <=< reify-instance PrettyTCM Level              where prettyTCM = prettyA <=< reify . Level-instance PrettyTCM (Named_ Term)      where prettyTCM = prettyA <=< reify-instance PrettyTCM (Arg Term)         where prettyTCM = prettyA <=< reify-instance PrettyTCM (Arg Type)         where prettyTCM = prettyA <=< reify-instance PrettyTCM (Arg Bool)         where prettyTCM = prettyA <=< reify-instance PrettyTCM (Arg A.Expr)       where prettyTCM = prettyA <=< reify-instance PrettyTCM (NamedArg A.Expr)  where prettyTCM = prettyA <=< reify-instance PrettyTCM (NamedArg Term)    where prettyTCM = prettyA <=< reify-instance PrettyTCM (Dom Type)         where prettyTCM = prettyA <=< reify-instance PrettyTCM (Dom (Name, Type)) where prettyTCM = prettyA <=< reify--instance PrettyTCM Permutation where prettyTCM = text . show-instance PrettyTCM Polarity    where prettyTCM = text . show-instance PrettyTCM IsForced    where prettyTCM = text . show+{-# SPECIALIZE prettyTCM :: (PrettyTCM a, PrettyTCM b, PrettyTCM c) => (a, b, c) -> TCM Doc #-} -prettyR-  :: (R.ToAbstract r, PrettyTCM (R.AbsOfRef r), MonadPretty m, MonadError TCErr m)-  => r -> m Doc-prettyR = prettyTCM <=< toAbstractWithoutImplicit+instance PrettyTCM a => PrettyTCM (MaybeReduced a) where+  prettyTCM = prettyTCM . ignoreReduced+{-# SPECIALIZE prettyTCM :: PrettyTCM a => MaybeReduced a -> TCM Doc #-}  instance (Pretty a, PrettyTCM a, EndoSubst a) => PrettyTCM (Substitution' a) where   prettyTCM IdS        = "idS"@@ -228,28 +295,53 @@     where       (rho1, rho2) = splitS 1 rho       u            = lookupS rho2 0+{-# SPECIALIZE prettyTCM :: (Pretty a, PrettyTCM a, EndoSubst a) => Substitution' a -> TCM Doc #-}  instance PrettyTCM Clause where   prettyTCM cl = do     x <- qualify_ <$> freshName_ ("<unnamedclause>" :: String)     prettyTCM (QNamed x cl)+{-# SPECIALIZE prettyTCM :: Clause -> TCM Doc #-}  instance PrettyTCM a => PrettyTCM (Judgement a) where   prettyTCM (HasType a cmp t) = prettyTCM a <+> ":" <+> prettyTCM t   prettyTCM (IsSort  a t) = "Sort" <+> prettyTCM a <+> ":" <+> prettyTCM t+{-# SPECIALIZE prettyTCM :: PrettyTCM a => Judgement a -> TCM Doc #-}  instance PrettyTCM MetaId where   prettyTCM x = do     mn <- getMetaNameSuggestion x-    pretty $ NamedMeta mn x+    prettyTCM $ NamedMeta mn x+{-# SPECIALIZE prettyTCM :: MetaId -> TCM Doc #-} +instance PrettyTCM NamedMeta where+  prettyTCM (NamedMeta s m) = do+    current <- currentModuleNameHash+    prefix  <-+      if metaModule m == current+      then return empty+      else do+        modName <- BiMap.invLookup (metaModule m) <$>+                   useR stTopLevelModuleNames+        return $ case modName of+          Nothing      -> __IMPOSSIBLE__+          Just modName -> pretty modName <> text "."+    let inBetween = case s of+          ""  -> text "_"+          "_" -> text "_"+          s   -> text $ "_" ++ s ++ "_"+    prefix <> inBetween <> text (show (metaId m))+{-# SPECIALIZE prettyTCM :: NamedMeta -> TCM Doc #-}+ instance PrettyTCM a => PrettyTCM (Blocked a) where   prettyTCM (Blocked x a) = ("[" <+> prettyTCM a <+> "]") <> text (P.prettyShow x)   prettyTCM (NotBlocked _ x) = prettyTCM x+{-# SPECIALIZE prettyTCM :: PrettyTCM a => Blocked a -> TCM Doc #-}  instance (PrettyTCM k, PrettyTCM v) => PrettyTCM (Map k v) where   prettyTCM m = "Map" <> braces (sep $ punctuate comma     [ hang (prettyTCM k <+> "=") 2 (prettyTCM v) | (k, v) <- Map.toList m ])+{-# SPECIALIZE prettyTCM :: (PrettyTCM k, PrettyTCM v) => Map k v -> TCM Doc  #-}  -- instance {-# OVERLAPPING #-} PrettyTCM ArgName where --   prettyTCM = text . P.prettyShow@@ -259,41 +351,31 @@   prettyTCM (IApply x y v) = "I$" <+> prettyTCM v   prettyTCM (Apply v) = "$" <+> prettyTCM v   prettyTCM (Proj _ f)= "." <> prettyTCM f--instance PrettyTCM a => PrettyTCM (MaybeReduced a) where-  prettyTCM = prettyTCM . ignoreReduced--instance PrettyTCM EqualityView where-  prettyTCM v = prettyTCM $ equalityUnview v--instance PrettyTCM A.Expr where-  prettyTCM = prettyA--instance PrettyTCM A.TypedBinding where-  prettyTCM = prettyA--instance PrettyTCM Relevance where-  prettyTCM = pretty+{-# SPECIALIZE prettyTCM :: Elim -> TCM Doc #-} -instance PrettyTCM Quantity where-  prettyTCM = pretty+deriving instance (PrettyTCM x, PrettyTCM a) => PrettyTCM (Boundary' x a)  instance PrettyTCM Modality where   prettyTCM mod = hsep     [ prettyTCM (getQuantity mod)     , prettyTCM (getRelevance mod)+    , prettyTCM (getModalPolarity mod)     ]+{-# SPECIALIZE prettyTCM :: Modality -> TCM Doc #-}  instance PrettyTCM Blocker where   prettyTCM (UnblockOnAll us) = "all" <> parens (fsep $ punctuate "," $ map prettyTCM $ Set.toList us)   prettyTCM (UnblockOnAny us) = "any" <> parens (fsep $ punctuate "," $ map prettyTCM $ Set.toList us)   prettyTCM (UnblockOnMeta m) = prettyTCM m   prettyTCM (UnblockOnProblem p) = "problem" <+> pretty p+  prettyTCM (UnblockOnDef q) = "definition" <+> pretty q+{-# SPECIALIZE prettyTCM :: Blocker -> TCM Doc #-}  instance PrettyTCM CompareAs where   prettyTCM (AsTermsOf a) = ":" <+> prettyTCMCtx TopCtx a   prettyTCM AsSizes       = ":" <+> do prettyTCM =<< sizeType   prettyTCM AsTypes       = empty+{-# SPECIALIZE prettyTCM :: CompareAs -> TCM Doc #-}  instance PrettyTCM TypeCheckingProblem where   prettyTCM (CheckExpr cmp e a) =@@ -302,11 +384,11 @@     sep [ parens $ "_ :" <+> prettyTCM t0         , nest 2 $ prettyList $ map prettyA es         , nest 2 $ ":?" <+> prettyTCM t1 ]-  prettyTCM (CheckProjAppToKnownPrincipalArg cmp e _ _ _ t _ _ _ _) = prettyTCM (CheckExpr cmp e t)+  prettyTCM (CheckProjAppToKnownPrincipalArg cmp e _ _ _ _ t _ _ _ _) = prettyTCM (CheckExpr cmp e t)   prettyTCM (CheckLambda cmp (Arg ai (xs, mt)) e t) =     sep [ pure CP.lambda <+>-          (CP.prettyRelevance ai .-           CP.prettyHiding ai (if isNothing mt && length xs == 1 then id+          (prettyRelevance ai .+           prettyHiding ai (if isNothing mt && natSize xs == 1 then id                                else P.parens) <$> do             fsep $               map prettyTCM (List1.toList xs) ++@@ -319,37 +401,25 @@   prettyTCM (DoQuoteTerm _ v _) = do     e <- reify v     prettyTCM (A.App A.defaultAppInfo_ (A.QuoteTerm A.exprNoRange) (defaultNamedArg e))+  prettyTCM (DisambiguateConstructor (ConstructorDisambiguationData c0 cands args t) _) = do+    let e = foldl (A.App empty) (A.Con $ unambiguous c0) args+    "ambiguous constructor" <+> prettyA e <+> ":" <+> prettyTCM t+{-# SPECIALIZE prettyTCM :: TypeCheckingProblem -> TCM Doc #-}  instance PrettyTCM a => PrettyTCM (WithHiding a) where-  prettyTCM (WithHiding h a) = CP.prettyHiding h id <$> prettyTCM a--instance PrettyTCM Name where-  prettyTCM x = P.pretty <$> abstractToConcrete_ x--instance PrettyTCM QName where-  prettyTCM x = P.pretty <$> abstractToConcrete_ x--instance PrettyTCM ModuleName where-  prettyTCM x = P.pretty <$> abstractToConcrete_ x--instance PrettyTCM AbstractName where-  prettyTCM = prettyTCM . anameName--instance PrettyTCM ConHead where-  prettyTCM = prettyTCM . conName+  prettyTCM (WithHiding h a) = prettyHiding h id <$> prettyTCM a+{-# SPECIALIZE prettyTCM :: PrettyTCM a => WithHiding a -> TCM Doc #-}  instance PrettyTCM Telescope where   prettyTCM tel = P.fsep . map P.pretty <$> do-      tel <- reify tel-      runAbsToCon $ bindToConcrete tel return+      abstractToConcreteTelescope =<< reify tel+{-# SPECIALIZE prettyTCM :: Telescope -> TCM Doc #-}  newtype PrettyContext = PrettyContext Context  instance PrettyTCM PrettyContext where-  prettyTCM (PrettyContext ctx) = prettyTCM $ telFromList' nameToArgName $ reverse ctx--instance PrettyTCM DBPatVar where-  prettyTCM = prettyTCM . var . dbPatVarIndex+  prettyTCM (PrettyContext ctx) = prettyTCM $ contextToTel ctx+{-# SPECIALIZE prettyTCM :: PrettyContext -> TCM Doc #-}  instance PrettyTCM a => PrettyTCM (Pattern' a) where   prettyTCM :: forall m. MonadPretty m => Pattern' a -> m Doc@@ -377,55 +447,76 @@         prTy d = caseMaybe (conPType i) d $ \ t -> d  <+> ":" <+> prettyTCM t   prettyTCM (LitP _ l)    = text (P.prettyShow l)   prettyTCM (ProjP _ q)   = text ("." ++ P.prettyShow q)+{-# SPECIALIZE prettyTCM :: PrettyTCM a => Pattern' a -> TCM Doc #-} +{-# SPECIALIZE prettyTCMPatterns :: [NamedArg DeBruijnPattern] -> TCM [Doc] #-} -- | Proper pretty printing of patterns: prettyTCMPatterns :: MonadPretty m => [NamedArg DeBruijnPattern] -> m [Doc] prettyTCMPatterns = mapM prettyA <=< reifyPatterns +{-# SPECIALIZE prettyTCMPatternList :: [NamedArg DeBruijnPattern] -> TCM Doc #-} prettyTCMPatternList :: MonadPretty m => [NamedArg DeBruijnPattern] -> m Doc prettyTCMPatternList = prettyList . map prettyA <=< reifyPatterns +-- | For unquote.+{-# SPECIALIZE prettyR :: (R.ToAbstract r, PrettyTCM (R.AbsOfRef r)) => r -> TCM Doc #-}+prettyR :: (R.ToAbstract r, PrettyTCM (R.AbsOfRef r), MonadPretty m, MonadError TCErr m) => r -> m Doc+prettyR = prettyTCM <=< toAbstractWithoutImplicit+ instance PrettyTCM (Elim' DisplayTerm) where   prettyTCM (IApply x y v) = "$" <+> prettyTCM v   prettyTCM (Apply v) = "$" <+> prettyTCM (unArg v)   prettyTCM (Proj _ f)= "." <> prettyTCM f+{-# SPECIALIZE prettyTCM :: Elim' DisplayTerm -> TCM Doc #-}  instance PrettyTCM NLPat where   prettyTCM (PVar x bvs) = prettyTCM (Var x (map (Apply . fmap var) bvs))   prettyTCM (PDef f es) = parens $     prettyTCM f <+> fsep (map prettyTCM es)-  prettyTCM (PLam i u)  = parens $-    text ("λ " ++ absName u ++ " →") <+>-    addContext (absName u) (prettyTCM $ absBody u)-  prettyTCM (PPi a b)   = parens $-    text ("(" ++ absName b ++ " :") <+> (prettyTCM (unDom a) <> ") →") <+>-    addContext (absName b) (prettyTCM $ unAbs b)+  prettyTCM (PLam i u)  = parens $ fsep+    [ "λ"+    , prettyHiding i id <$> text (absName u)+    , "→"+    , addContext (absName u) $ prettyTCM $ absBody u+    ]+  prettyTCM (PPi a b)   = parens $ fsep+    [ prettyHiding a P.parens <$> fsep [ text $ absName b, ":", prettyTCM $ unDom a ]+    , "→"+    , addContext (absName b) $ prettyTCM $ unAbs b+    ]   prettyTCM (PSort s)        = prettyTCM s   prettyTCM (PBoundVar i []) = prettyTCM (var i)   prettyTCM (PBoundVar i es) = parens $ prettyTCM (var i) <+> fsep (map prettyTCM es)   prettyTCM (PTerm t)   = "." <> parens (prettyTCM t)+{-# SPECIALIZE prettyTCM :: NLPat -> TCM Doc #-}  instance PrettyTCM NLPType where   prettyTCM (NLPType s a) = prettyTCM a+{-# SPECIALIZE prettyTCM :: NLPType -> TCM Doc #-}  instance PrettyTCM NLPSort where   prettyTCM = \case-    PType l   -> parens $ "Set" <+> prettyTCM l-    PProp l   -> parens $ "Prop" <+> prettyTCM l-    PInf f n  -> prettyTCM (Inf f n :: Sort)+    PUniv u l -> parens $ text (showUniv u) <+> prettyTCM l+      -- Andreas, 2023-05-11, preserving Jesper's printing hack for now...+    PInf u n  -> prettyTCM (Inf u n :: Sort)     PSizeUniv -> prettyTCM (SizeUniv :: Sort)     PLockUniv -> prettyTCM (LockUniv :: Sort)+    PLevelUniv -> prettyTCM (LevelUniv :: Sort)+    PIntervalUniv -> prettyTCM (IntervalUniv :: Sort)+{-# SPECIALIZE prettyTCM :: NLPSort -> TCM Doc #-}  instance PrettyTCM (Elim' NLPat) where   prettyTCM (IApply x y v) = prettyTCM v-  prettyTCM (Apply v) = prettyTCM (unArg v)+  prettyTCM (Apply v) = prettyHiding v id <$> prettyTCM (unArg v)   prettyTCM (Proj _ f)= "." <> prettyTCM f+{-# SPECIALIZE prettyTCM :: Elim' NLPat -> TCM Doc #-}  instance PrettyTCM (Type' NLPat) where   prettyTCM = prettyTCM . unEl+{-# SPECIALIZE prettyTCM :: Type' NLPat -> TCM Doc #-}  instance PrettyTCM RewriteRule where-  prettyTCM (RewriteRule q gamma f ps rhs b c) = fsep+  prettyTCM (RewriteRule q gamma f ps rhs b _c _top) = fsep     [ prettyTCM q     , prettyTCM gamma <+> " |- "     , addContext gamma $ sep@@ -436,9 +527,11 @@       , prettyTCM b       ]     ]+{-# SPECIALIZE prettyTCM :: RewriteRule -> TCM Doc #-}  instance PrettyTCM Occurrence where   prettyTCM occ  = text $ "-[" ++ prettyShow occ ++ "]->"+{-# SPECIALIZE prettyTCM :: Occurrence -> TCM Doc #-}  -- | Pairing something with a node (for printing only). data WithNode n a = WithNode n a@@ -458,13 +551,39 @@         [ prettyTCM n         , nest 2 $ vcat $ map (prettyTCMWithNode . uncurry WithNode) $ Map.assocs es         ]+{-# SPECIALIZE NOINLINE prettyTCM :: (PrettyTCM n, PrettyTCMWithNode e) => (Graph n e) -> TCM Doc #-}  instance PrettyTCM SplitTag where   prettyTCM (SplitCon c)  = prettyTCM c   prettyTCM (SplitLit l)  = prettyTCM l   prettyTCM SplitCatchall = return underscore+{-# SPECIALIZE prettyTCM :: SplitTag -> TCM Doc #-}  instance PrettyTCM Candidate where   prettyTCM c = case candidateKind c of     (GlobalCandidate q) -> prettyTCM q     LocalCandidate      -> prettyTCM $ candidateTerm c+{-# SPECIALIZE prettyTCM :: Candidate -> TCM Doc #-}++instance PrettyTCM Key where+  prettyTCM = \case+    RigidK q a -> prettyTCM q <> superscript a+    LocalK i a -> "@" <> pretty i <> superscript a+    PiK h      -> "Pi" <+> pretty h+    ConstK     -> "Const"+    SortK      -> "Sort"+    FlexK      -> "_"+{-# SPECIALIZE prettyTCM :: Key -> TCM Doc #-}++instance PrettyTCM a => PrettyTCM (DiscrimTree a) where+  prettyTCM = vcat . go "  " where+    go ind EmptyDT     = ["fail"]+    go ind (DoneDT it) = ["done" <+> prettyTCM it]+    go ind (CaseDT var branches fallthrough) =+      ["case" <+> prettyTCM var <+> "of"]+      ++ concatMap (\(k, v) -> abduct ind (prettyTCM k <> " →") v) (Map.toList branches)+      ++ (guard (not (null fallthrough)) >> abduct ind ("* →") fallthrough)++    abduct ind f v | (l:ls) <- go ind v = ((ind <> f) <+> l):map (ind <>) ls+    abduct ind _ _ = __IMPOSSIBLE__+{-# SPECIALIZE prettyTCM :: PrettyTCM a => DiscrimTree a -> TCM Doc #-}
src/full/Agda/TypeChecking/Pretty.hs-boot view
@@ -1,9 +1,5 @@- module Agda.TypeChecking.Pretty where -import Control.Monad.Reader (ReaderT)-import Control.Monad.State  (StateT)- import Data.String (IsString) import Data.Semigroup (Semigroup) @@ -11,18 +7,14 @@ import Agda.Syntax.Internal  import Agda.TypeChecking.Monad.Base-import {-# SOURCE #-} Agda.TypeChecking.Monad.Builtin-import {-# SOURCE #-} Agda.TypeChecking.Monad.Context (MonadAddContext)-import Agda.TypeChecking.Monad.Debug (MonadDebug) import {-# SOURCE #-} Agda.TypeChecking.Monad.MetaVars (MonadInteractionPoints) import {-# SOURCE #-} Agda.TypeChecking.Monad.Pure (PureTCM)-import {-# SOURCE #-} Agda.TypeChecking.Monad.Signature (HasConstInfo)  import Agda.Utils.Null (Null)-import Agda.Utils.Pretty (Doc)-import qualified Agda.Utils.Pretty as P-+import Agda.Syntax.Common.Pretty (Doc)+import qualified Agda.Syntax.Common.Pretty as P +comma, colon, equals  :: Applicative m => m Doc text                  :: Applicative m => String -> m Doc sep, fsep, hsep, vcat :: (Applicative m, Foldable t) => t (m Doc) -> m Doc hang                  :: Applicative m => m Doc -> Int -> m Doc -> m Doc@@ -30,21 +22,19 @@ nest                  :: Functor m => Int -> m Doc -> m Doc pretty                :: (Applicative m, P.Pretty a) => a -> m Doc prettyList_           :: (Applicative m, Semigroup (m Doc), Foldable t) => t (m Doc) -> m Doc+pwords                :: Applicative m => String -> [m Doc]+braces, dbraces, brackets, parens, parensNonEmpty , doubleQuotes, quotes ::+  Functor m => m Doc -> m Doc --- Inlining definitions of MonadReify and MonadAbsToCon to avoid--- having to import them+-- The definition of MonadAbsToCon is inlined so that the module+-- Agda.Syntax.Translation.AbstractToConcrete does not need to be+-- imported. type MonadPretty m =-  ( ( PureTCM m-    , MonadInteractionPoints m-    , MonadFresh NameId m-    )-  , ( MonadTCEnv m-    , ReadTCState m-    , MonadStConcreteNames m-    , HasOptions m-    , HasBuiltins m-    , MonadDebug m-    )+  ( MonadFresh NameId m+  , MonadInteractionPoints m+  , MonadStConcreteNames m+  , HasOptions m+  , PureTCM m   , IsString (m Doc)   , Null (m Doc)   , Semigroup (m Doc)@@ -61,10 +51,12 @@ newtype PrettyContext = PrettyContext Context  instance PrettyTCM a => PrettyTCM (Closure a)+instance PrettyTCM a => PrettyTCM (Maybe a) instance PrettyTCM a => PrettyTCM [a]  instance PrettyTCM Name instance PrettyTCM QName+instance PrettyTCM NamedMeta instance PrettyTCM Term instance PrettyTCM Elim instance PrettyTCM Type
src/full/Agda/TypeChecking/Pretty/Call.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Pretty.Call where @@ -6,39 +7,39 @@ import Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Views import Agda.Syntax.Common-import Agda.Syntax.Fixity+import qualified Agda.Syntax.Common.Pretty as P import qualified Agda.Syntax.Concrete.Definitions as D import qualified Agda.Syntax.Info as A+import Agda.Syntax.Fixity+import Agda.Syntax.Internal import Agda.Syntax.Position import Agda.Syntax.Scope.Monad import Agda.Syntax.Translation.AbstractToConcrete  import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope import Agda.TypeChecking.Monad.Context import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Pretty -import Agda.Utils.Function import Agda.Utils.Null-import qualified Agda.Utils.Pretty as P  import Agda.Utils.Impossible -sayWhere :: MonadPretty m => HasRange a => a -> m Doc -> m Doc-sayWhere x d = applyUnless (null r) (prettyTCM r $$) d-  where r = getRange x+import Agda.Version (docsUrl) -sayWhen :: MonadPretty m => Range -> Maybe (Closure Call) -> m Doc -> m Doc-sayWhen r Nothing   m = sayWhere r m-sayWhen r (Just cl) m = sayWhere r (m $$ prettyTCM cl)+sayWhere :: MonadPretty m => HasRange a => a -> m Doc -> m Doc+sayWhere x d = prettyTCM (getRange x) $$ d  instance PrettyTCM CallInfo where-  prettyTCM c = do-    let call = prettyTCM $ callInfoCall c-        r    = callInfoRange c+  prettyTCM (CallInfo callInfoTarget callInfoCall) = do+    let call = prettyTCM callInfoCall+        r    = getRange callInfoTarget     if null $ P.pretty r       then call       else call $$ nest 2 ("(at" <+> prettyTCM r) <> ")"+  {-# SPECIALIZE prettyTCM :: CallInfo -> TCM Doc #-}  instance PrettyTCM Call where   prettyTCM = withContextPrecedence TopCtx . \case@@ -93,12 +94,22 @@       [ sep [ prettyTCM x <+> ":"             , nest 2 $ prettyTCM t ] ] -    CheckArguments r es t0 t1 -> fsep $-      pwords "when checking that" ++-      map hPretty es ++-      pwords (P.singPlural es "is a valid argument" "are valid arguments") ++-      pwords "to a function of type" ++-      [prettyTCM t0]+    CheckArguments r es t0 t1 -> do+      TelV tel cod <- telView t0+      let+        prefix =+          pwords "when checking that" +++          map hPretty es +++          pwords (P.singPlural es "is a valid argument" "are valid arguments")+      case unEl cod of+        Dummy{} -> fsep $+          prefix +++          pwords "to a function accepting arguments of type" +++          [prettyTCM tel]+        _ -> fsep $+          prefix +++          pwords "to a function of type" +++          [prettyTCM t0]      CheckMetaSolution r m a v -> fsep $       pwords "when checking that the solution" ++ [prettyTCM v] ++@@ -123,12 +134,21 @@      CheckConstructor{} -> __IMPOSSIBLE__ -    CheckConstructorFitsIn c t s -> fsep $-      pwords "when checking that the type" ++ [prettyTCM t] ++-      pwords "of the constructor" ++ [prettyTCM c] ++-      pwords "fits in the sort" ++ [prettyTCM s] ++-      pwords "of the datatype."+    CheckConArgFitsIn c f t s -> do+      woK <- withoutKOption+      let+        hint = fsep (pwords "Note: this argument is forced by the indices of" ++ [prettyTCM c <> comma] ++ pwords "so this definition would be allowed under --large-indices.")+        -- Only add hint about large-indices when --with-K+        addh d+          | f && not woK = d $$ empty $$ hint+          | otherwise    = d +      addh $ fsep $+        pwords "when checking that the type" ++ [prettyTCM t] +++        pwords "of an argument to the constructor" ++ [prettyTCM c] +++        pwords "fits in the sort" ++ [prettyTCM s] +++        pwords "of the datatype."+     CheckFunDefCall _ f _ _ ->       fsep $ pwords "when checking the definition of" ++ [prettyTCM f] @@ -140,9 +160,13 @@       pwords "when checking that the type of the primitive function" ++       [prettyTCM x] ++ pwords "is" ++ [prettyA e] +    CheckModuleParameters m _tel -> fsep $+      pwords "when checking the parameters of module" ++ [prettyA m]+     CheckWithFunctionType a -> fsep $       pwords "when checking that the type" ++-      [prettyTCM a] ++ pwords "of the generated with function is well-formed"+      [prettyTCM a] ++ pwords "of the generated with function is well-formed" +++      [parens $ text $ docsUrl "language/with-abstraction.html#ill-typed-with-abstractions"]      CheckDotPattern e v -> fsep $       pwords "when checking that the given dot pattern" ++ [prettyA e] ++@@ -169,13 +193,10 @@     ScopeCheckExpr e -> fsep $ pwords "when scope checking" ++ [pretty e]      ScopeCheckDeclaration d ->-      fwords ("when scope checking the declaration" ++ suffix) $$-      nest 2 (vcat $ map pretty ds)+      fsep (pwords "when scope checking the" ++ [ pluralS ds "declaration" ]) $$+      nest 2 (vcat $ fmap pretty ds)       where       ds     = D.notSoNiceDeclarations d-      suffix = case ds of-        [_] -> ""-        _   -> "s"      ScopeCheckLHS x p ->       fsep $ pwords "when scope checking the left-hand side" ++ [pretty p] ++@@ -185,16 +206,28 @@      SetRange r -> fsep (pwords "when doing something at") <+> prettyTCM r -    CheckSectionApplication _ m1 modapp -> fsep $+    CheckSectionApplication _ erased m1 modapp -> fsep $       pwords "when checking the module application" ++-      [prettyA $ A.Apply info m1 modapp initCopyInfo empty]+      [prettyA $ A.Apply info erased m1 modapp initCopyInfo empty]       where       info = A.ModuleInfo noRange noRange Nothing Nothing Nothing      ModuleContents -> fsep $ pwords "when retrieving the contents of a module" +    CheckIApplyConfluence _ qn fn l r t -> do+      vcat+        [ fsep (pwords "when checking that a clause of" ++ [prettyTCM qn] ++ pwords "has the correct boundary.")+        , ""+        , "Specifically, the terms"+        , nest 2 (prettyTCM l)+        , "and"+        , nest 2 (prettyTCM r)+        , fsep (pwords "must be equal, since" ++ [prettyTCM fn] ++ pwords "could reduce to either.")+        ]+     where     hPretty :: MonadPretty m => Arg (Named_ Expr) -> m Doc     hPretty a = do       withContextPrecedence (ArgumentCtx PreferParen) $         pretty =<< abstractToConcreteHiding a a+  {-# SPECIALIZE prettyTCM :: Call -> TCM Doc #-}
src/full/Agda/TypeChecking/Pretty/Call.hs-boot view
@@ -1,12 +1,8 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Pretty.Call where -import Agda.Syntax.Position- import Agda.TypeChecking.Monad.Base--import {-# SOURCE #-} Agda.TypeChecking.Pretty (MonadPretty)--import Agda.Utils.Pretty+import {-# SOURCE #-} Agda.TypeChecking.Pretty (PrettyTCM) -sayWhen :: MonadPretty m => Range -> Maybe (Closure Call) -> m Doc -> m Doc+instance PrettyTCM Call
src/full/Agda/TypeChecking/Pretty/Constraint.hs view
@@ -4,9 +4,13 @@ import Prelude hiding (null)  import qualified Data.Set as Set+import Data.Foldable (Foldable)+import qualified Data.Foldable as Foldable import qualified Data.List as List-import Data.Function+import Data.Function (on) +import Control.Monad+ import Agda.Syntax.Common import Agda.Syntax.Position import qualified Agda.Syntax.Abstract as A@@ -22,9 +26,10 @@ import Agda.TypeChecking.Telescope  import Agda.Utils.Null-import qualified Agda.Utils.Pretty as P+import qualified Agda.Syntax.Common.Pretty as P import Agda.Utils.Impossible +{-# SPECIALIZE prettyConstraint :: ProblemConstraint -> TCM Doc #-} prettyConstraint :: MonadPretty m => ProblemConstraint -> m Doc prettyConstraint c = f (locallyTCState stInstantiateBlocking (const True) $ prettyTCM c)   where@@ -34,34 +39,58 @@           then d           else d $$ nest 4 ("[ at" <+> prettyTCM r <+> "]") -interestingConstraint :: ProblemConstraint -> Bool-interestingConstraint pc = go $ clValue (theConstraint pc)-  where-    go UnBlock{} = False-    go _         = True+{-# SPECIALIZE interestingConstraint :: ProblemConstraint -> TCM Bool #-}+interestingConstraint :: MonadPretty m => ProblemConstraint -> m Bool+interestingConstraint pc =+  case clValue (theConstraint pc) of+    UnBlock m -> lookupMetaInstantiation m >>= \case+      PostponedTypeCheckingProblem cl -> enterClosure cl \case+        DisambiguateConstructor{} -> return True+        _ -> return False+      _ -> return False+    _ -> return True +{-# SPECIALIZE prettyInterestingConstraints :: [ProblemConstraint] -> TCM [Doc] #-} prettyInterestingConstraints :: MonadPretty m => [ProblemConstraint] -> m [Doc]-prettyInterestingConstraints cs = mapM (prettyConstraint . stripPids) $ List.sortBy (compare `on` isBlocked) cs'-  where+prettyInterestingConstraints cs = do+  cs' <- filterM interestingConstraint cs+  let     isBlocked = not . null . allBlockingProblems . constraintUnblocker-    cs' = filter interestingConstraint cs     interestingPids = Set.unions $ map (allBlockingProblems . constraintUnblocker) cs'     stripPids (PConstr pids unblock c) = PConstr (Set.intersection pids interestingPids) unblock c+  mapM (prettyConstraint . stripPids) $ List.sortBy (compare `on` isBlocked) cs' -instance PrettyTCM ProblemConstraint where-  prettyTCM (PConstr pids unblock c) = prettyTCM c <?> parensNonEmpty (sep [blockedOn unblock, prPids (Set.toList pids)])-    where-      prPids []    = empty-      prPids [pid] = "belongs to problem" <+> prettyTCM pid-      prPids pids  = "belongs to problems" <+> fsep (punctuate "," $ map prettyTCM pids) -      comma | null pids = empty-            | otherwise = ","+prettyRangeConstraint ::+  (MonadPretty m, Foldable f, Null (f ProblemId)) => Range -> f ProblemId -> Blocker -> Doc -> m Doc+prettyRangeConstraint r pids unblock c =+  return c <?>+  sep [ prange r+      , parensNonEmpty $ sep+          [ blockedOn unblock+          , prPids (Foldable.toList pids)+          ]+      ]+  where+  prPids []    = empty+  prPids [pid] = "belongs to problem" <+> prettyTCM pid+  prPids pids  = "belongs to problems" <+> fsep (punctuate "," $ map prettyTCM pids) -      blockedOn (UnblockOnAll bs) | Set.null bs = empty-      blockedOn (UnblockOnAny bs) | Set.null bs = "stuck" <> comma-      blockedOn u = "blocked on" <+> (prettyTCM u <> comma)+  comma | null pids = empty+        | otherwise = "," +  blockedOn (UnblockOnAll bs) | Set.null bs = empty+  blockedOn (UnblockOnAny bs) | Set.null bs = "stuck" <> comma+  blockedOn u = "blocked on" <+> (prettyTCM u <> comma)++  prange r | null s    = pure empty+           | otherwise = text $ " [ at " ++ s ++ " ]"+    where s = P.prettyShow r++instance PrettyTCM ProblemConstraint where+  prettyTCM (PConstr pids unblock c) =+    prettyRangeConstraint noRange pids unblock =<< prettyTCM c+ instance PrettyTCM Constraint where     prettyTCM = \case         ValueCmp cmp ty s t -> prettyCmp (prettyTCM cmp) s t <?> prettyTCM ty@@ -73,14 +102,11 @@         LevelCmp cmp a b         -> prettyCmp (prettyTCM cmp) a b         SortCmp cmp s1 s2        -> prettyCmp (prettyTCM cmp) s1 s2         UnBlock m   -> do-            -- BlockedConst t <- mvInstantiation <$> lookupMeta m-            mi <- mvInstantiation <$> lookupMeta m-            case mi of+            lookupMetaInstantiation m >>= \case               BlockedConst t -> prettyCmp ":=" m t               PostponedTypeCheckingProblem cl -> enterClosure cl $ \p ->                 prettyCmp ":=" m p-              Open{}  -> __IMPOSSIBLE__-              OpenInstance{} -> __IMPOSSIBLE__+              OpenMeta{}  -> __IMPOSSIBLE__               InstV{} -> empty               -- Andreas, 2017-01-11, issue #2637:               -- The size solver instantiates some metas with infinity@@ -93,30 +119,40 @@               --     , show m ++ show args ++ " := " ++ show t               --     ]               --   __IMPOSSIBLE__-        FindInstance m mcands -> do-            t <- getMetaTypeInContext m-            TelV tel _ <- telViewUpTo' (-1) notVisible t-            sep [ "Resolve instance argument" <?> prettyCmp ":" m t-                  -- #4071: Non-visible arguments to the meta are in scope of the candidates add-                  --        those here to not get out of scope deBruijn indices when printing-                  --        unsolved constraints.-                , addContext tel cands-                ]++        FindInstance _ m mcands -> do+          t <- getMetaTypeInContext m+          TelV tel _ <- telViewUpTo' (-1) notVisible t+          sep [ "Resolve instance argument" <?> prettyCmp ":" m t+                -- #4071: Non-visible arguments to the meta are in scope of the candidates add+                --        those here to not get out of scope deBruijn indices when printing+                --        unsolved constraints.+              , addContext tel cands+              ]           where-            cands =-              case mcands of-                Nothing -> "No candidates yet"-                Just cnds ->-                  hang "Candidates" 2 $ vcat-                    [ hang (overlap c <+> prettyTCM c <+> ":") 2 $-                            prettyTCM (candidateType c) | c <- cnds ]-              where overlap c | candidateOverlappable c = "overlap"-                              | otherwise               = empty+            overlap c = case candidateOverlap c of+              FieldOverlap   -> "overlap"+              Incoherent     -> "[incoherent]"+              Overlappable   -> "[overlappable]"+              Overlapping    -> "[overlapping]"+              Overlaps       -> "[overlaps]"+              DefaultOverlap -> empty++            cands = case mcands of+              Nothing -> "No candidates yet"+              Just cnds -> hang "Candidates" 2 $ vcat+                [ hang (overlap c <+> prettyTCM c <+> ":") 2 $+                    prettyTCM (candidateType c)+                | c <- cnds+                ]++        ResolveInstanceHead q ->+            "Resolve target type of instance: " <?> prettyTCM q         IsEmpty r t ->             "Is empty:" <?> prettyTCMCtx TopCtx t         CheckSizeLtSat t ->             "Is not empty type of sizes:" <?> prettyTCMCtx TopCtx t-        CheckFunDef d i q cs err -> do+        CheckFunDef i q cs err -> do             t <- defType <$> getConstInfo q             vcat [ "Check definition of" <+> prettyTCM q <+> ":" <+> prettyTCM t                  , nest 2 $ "stuck because" <?> prettyTCM err ]@@ -127,8 +163,10 @@         UnquoteTactic v _ _ -> do           e <- reify v           prettyTCM (A.App A.defaultAppInfo_ (A.Unquote A.exprNoRange) (defaultNamedArg e))+        CheckDataSort q s -> do+          hsep [ "Sort", prettyTCM s, "of", prettyTCM q, "admits data/record definitions." ]         CheckMetaInst x -> do-          m <- lookupMeta x+          m <- lookupLocalMeta x           case mvJudgement m of             HasType{ jMetaType = t } -> prettyTCM x <+> ":" <+> prettyTCM t             IsSort{} -> prettyTCM x <+> "is a sort"@@ -136,7 +174,8 @@           prettyTCM t <+> "is a well-formed type"         CheckLockedVars t ty lk lk_ty -> do           "Lock" <+> prettyTCM lk <+> "|-" <+> prettyTCMCtx TopCtx t <+> ":" <+> prettyTCM ty-        UsableAtModality mod t -> "Is usable at" <+> prettyTCM mod <+> ":" <+> prettyTCM t+        UsableAtModality _ ms mod t -> "Is usable at" <+> text (verbalize mod) <+> "modality:" <+> prettyTCM t+          -- TODO: print @ms : Maybe Sort@ as well?        where         prettyCmp
src/full/Agda/TypeChecking/Pretty/Constraint.hs-boot view
@@ -1,9 +1,12 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Pretty.Constraint where -import Text.PrettyPrint (Doc)-import Agda.TypeChecking.Pretty (MonadPretty)+import Agda.Syntax.Common.Pretty (Doc)+import Agda.TypeChecking.Pretty (MonadPretty, PrettyTCM) import Agda.TypeChecking.Monad.Base (ProblemConstraint)  prettyInterestingConstraints :: MonadPretty m => [ProblemConstraint] -> m [Doc]-interestingConstraint        :: ProblemConstraint -> Bool+interestingConstraint        :: MonadPretty m => ProblemConstraint -> m Bool++instance PrettyTCM ProblemConstraint
src/full/Agda/TypeChecking/Pretty/Warning.hs view
@@ -1,72 +1,111 @@ -module Agda.TypeChecking.Pretty.Warning where+module Agda.TypeChecking.Pretty.Warning+  ( applyFlagsToTCWarnings+  , applyFlagsToTCWarningsPreserving+  , filterTCWarnings+  , getAllUnsolvedWarnings+  , getAllWarnings+  , getAllWarningsOfTCErr+  , getAllWarningsPreserving+  , prettyDuplicateFields+  , prettyTCWarnings+  , prettyTCWarnings'+  , prettyTooManyFields+  , prettyWarning+  , tcWarningsToError+  )+where  import Prelude hiding ( null ) -import Control.Monad ( guard )---- Control.Monad.Fail import is redundant since GHC 8.8.1-import Control.Monad.Fail ( MonadFail )+import Control.Monad ( guard, filterM, forM, (<=<) )  import Data.Char ( toLower )-import Data.Function+import qualified Data.Foldable as Fold+import Data.Function (on)+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet+import qualified Data.List as List import Data.Maybe--import qualified Data.Set as Set import Data.Set (Set)--import qualified Data.List as List+import qualified Data.Set  as Set import qualified Data.Text as T  import Agda.TypeChecking.Monad.Base+import qualified Agda.TypeChecking.Monad.Base.Warning as W+import Agda.TypeChecking.Monad.Builtin import {-# SOURCE #-} Agda.TypeChecking.Errors import Agda.TypeChecking.Monad.MetaVars import Agda.TypeChecking.Monad.Options import Agda.TypeChecking.Monad.Debug+import Agda.TypeChecking.Monad.Constraints import Agda.TypeChecking.Monad.State ( getScope )-import Agda.TypeChecking.Monad ( localTCState )+import Agda.TypeChecking.Monad ( localTCState, enterClosure ) import Agda.TypeChecking.Positivity () --instance only import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Pretty.Call+import Agda.TypeChecking.Pretty.Call () -- instance PrettyTCM CallInfo import {-# SOURCE #-} Agda.TypeChecking.Pretty.Constraint (prettyInterestingConstraints, interestingConstraint) import Agda.TypeChecking.Warnings (MonadWarning, isUnsolvedWarning, onlyShowIfUnsolved, classifyWarning, WhichWarnings(..), warning_)-import Agda.TypeChecking.Monad.Constraints (getAllConstraints)+import {-# SOURCE #-} Agda.TypeChecking.MetaVars -import Agda.Syntax.Common ( ImportedName'(..), fromImportedName, partitionImportedNames )-import Agda.Syntax.Position+import Agda.Syntax.Common+  ( ImportedName'(..), fromImportedName, partitionImportedNames+  , IsOpaque(OpaqueDef, TransparentDef)+  , ProjOrigin(..)+  , getHiding+  )+import Agda.Syntax.Common.Pretty ( Pretty, prettyShow, singPlural )+import qualified Agda.Syntax.Common.Pretty as P import qualified Agda.Syntax.Concrete as C-import Agda.Syntax.Scope.Base ( concreteNamesInScope, NameOrModule(..) ) import Agda.Syntax.Internal+import Agda.Syntax.Position+import Agda.Syntax.Scope.Base ( concreteNamesInScope, NameOrModule(..) ) import Agda.Syntax.Translation.InternalToAbstract  import Agda.Interaction.Options+import Agda.Interaction.Options.Errors import Agda.Interaction.Options.Warnings +import Agda.Utils.Boolean  ( toBool )+import Agda.Utils.FileName ( filePath )+import Agda.Utils.Functor  ( (<.>) ) import Agda.Utils.Lens import Agda.Utils.List ( editDistance )+import Agda.Utils.List1 ( List1, pattern (:|), (<|) ) import qualified Agda.Utils.List1 as List1+import Agda.Utils.Monad ( anyM, ifM ) import Agda.Utils.Null-import Agda.Utils.Pretty ( Pretty, prettyShow )-import qualified Agda.Utils.Pretty as P+import Agda.Utils.Singleton+import qualified Agda.Utils.Set1 as Set1+import Agda.Utils.WithDefault  ( pattern Value ) +import Agda.Utils.Impossible+ instance PrettyTCM TCWarning where-  prettyTCM w@(TCWarning loc _ _ _ _) = do+  prettyTCM w@(TCWarning loc _ _ doc _ _) = doc <$ do     reportSLn "warning" 2 $ "Warning raised at " ++ prettyShow loc-    pure $ tcWarningPrintedWarning w +instance PrettyTCM Warning where+  prettyTCM = prettyWarning++{-# SPECIALIZE prettyWarning :: Warning -> TCM Doc #-} prettyWarning :: MonadPretty m => Warning -> m Doc prettyWarning = \case      UnsolvedMetaVariables ms  ->       fsep ( pwords "Unsolved metas at the following locations:" )-      $$ nest 2 (vcat $ map prettyTCM ms)+      $$ nest 2 (vcat $ fmap prettyTCM $ Set1.toAscList ms)      UnsolvedInteractionMetas is ->       fsep ( pwords "Unsolved interaction metas at the following locations:" )-      $$ nest 2 (vcat $ map prettyTCM is)+      $$ nest 2 (vcat $ fmap prettyTCM $ Set1.toAscList is) +    InteractionMetaBoundaries is ->+      fsep ( pwords "Interaction meta(s) at the following location(s) have unsolved boundary constraints:" )+      $$ nest 2 (vcat $ fmap prettyTCM $ Set1.toAscList is)+     UnsolvedConstraints cs -> do-      pcs <- prettyInterestingConstraints cs+      pcs <- prettyInterestingConstraints $ List1.toList cs       if null pcs         then fsep $ pwords "Unsolved constraints"  -- #4065: keep minimal warning text         else vcat@@ -74,89 +113,196 @@           , nest 2 $ return $ P.vcat $ List.nub pcs           ] -    TerminationIssue because -> do+    TerminationIssue errs1 -> do       dropTopLevel <- topLevelModuleDropper-      fwords "Termination checking failed for the following functions:"-        $$ nest 2 (fsep $ punctuate comma $-             map (pretty . dropTopLevel) $-               concatMap termErrFunctions because)-        $$ fwords "Problematic calls:"-        $$ nest 2 (fmap (P.vcat . List.nub) $-              mapM prettyTCM $ List.sortBy (compare `on` callInfoRange) $-              concatMap termErrCalls because)+      let errs = List1.toList errs1+      let (guardednessHelps, guardednessHelpsNot) =+            List.partition (toBool . termErrGuardednessHelps) errs+      let report hint because = if null because then empty else do+            vcat+              [ fwords "Termination checking failed for the following functions:"+              , fwords hint+              , nest 2 $ fsep $ punctuate comma $+                  map (pretty . dropTopLevel) $+                    concatMap termErrFunctions because+              , fwords "Problematic calls:"+              , nest 2 $ fmap (P.vcat . List.nub) $+                  mapM prettyTCM $ List.sortOn getRange $+                    concatMap termErrCalls because+              ]+      -- Andreas, 2025-04-01, issue #6657+      -- Hint towards --guardedness where appropriate, but not when --sized-types is on.+      -- Andreas, 2025-04-12, issue #7796+      -- Also not when --no-guardedness is explicitly given (rather than the default).+      opts <- pragmaOptions+      let haveSizedTypes = optSizedTypes opts+      let guardedness    = _optGuardedness opts+      reportSDoc "tc.warning.termination" 50 $ vcat+        [ "printing TerminationIssue"+        , "sized-types = " <+> (text . show) haveSizedTypes+        , "guardedness = " <+> (text . show) guardedness+        ]+      if guardedness == Value False then report empty errs else do+        let+          hint = concat $ concat+            [ [ "(Option --guardedness might fix this problem" ]+            , [ ", but it is not --safe to use with --sized-types" | haveSizedTypes ]+            , [ ".)" ]+            ]+        vcat [ report hint guardednessHelps+             , report empty guardednessHelpsNot+             ] -    UnreachableClauses f pss -> fsep $-      pwords "Unreachable" ++ pwords (plural (length pss) "clause")-        where-          plural 1 thing = thing-          plural n thing = thing ++ "s"+    UnreachableClauses _f pss -> "Unreachable" <+> pluralS pss "clause" -    CoverageIssue f pss -> fsep (-      pwords "Incomplete pattern matching for" ++ [prettyTCM f <> "."] ++-      pwords "Missing cases:") $$ nest 2 (vcat $ map display pss)-        where+    CoverageIssue f pss -> vcat+        [ fsep $ concat+          [ pwords "Incomplete pattern matching for"+          , [ prettyTCM f <> "." ]+          , pwords "Missing cases:"+          ]+        , nest 2 $ vcat $ fmap display pss+        ]+      where         display (tel, ps) = prettyTCM $ NamedClause f True $           empty { clauseTel = tel, namedClausePats = ps }      CoverageNoExactSplit f cs -> vcat $-      fsep (pwords "Exact splitting is enabled, but the following" ++ pwords (P.singPlural cs "clause" "clauses") +++      fsep (pwords "Exact splitting is enabled, but the following" ++ [ pluralS cs "clause" ] ++             pwords "could not be preserved as definitional equalities in the translation to a case tree:"-           ) :-      map (nest 2 . prettyTCM . NamedClause f True) cs+           ) <|+      fmap (nest 2 . prettyTCM . NamedClause f True) cs +    InlineNoExactSplit f c -> vcat $+      [ fsep $+          pwords "Exact splitting is enabled, but the following clause" +++          pwords "is no longer a definitional equality because it was translated to a copattern match:"+      , nest 2 . prettyTCM . NamedClause f True $ c+      ]+     NotStrictlyPositive d ocs -> fsep $       [prettyTCM d] ++ pwords "is not strictly positive, because it occurs"       ++ [prettyTCM ocs] -    CantGeneralizeOverSorts ms -> vcat+    ConstructorDoesNotFitInData dataOrRecord c s1 s2 err -> msg $$+      case err of+        TypeError _loc s e -> withTCState (const s) $ enterClosure e \ e ->+          parens ("Reason:" <+> prettyTCM e)+        _ ->+          prettyTCM err+      where+        msg = sep+          [ "Constructor" <+> prettyTCM c+          , "of inferred sort" <+> prettyTCM s1+          , ("does not fit into" <+> prettyTCM dataOrRecord <+> "type of sort" <+> prettyTCM s2) <> "."+          ]++    CoinductiveEtaRecord name -> vcat+      [ fsep $ pwords "Not switching on eta-equality for coinductive records."+      , fsep $ pwords "If you must, use pragma" ++ [ "{-# ETA", prettyTCM name, "#-}" ]+      ]++    UnsupportedIndexedMatch doc -> vcat+      [ fsep (pwords "This clause uses pattern-matching features that are not yet supported by Cubical Agda,"+           ++ pwords "the function to which it belongs will not compute when applied to transports."+             )+      , ""+      , "Reason:" <+> pure doc+      , ""+      ]++    CantGeneralizeOverSorts ms -> do+      rms <- forM (Fold.toList ms) \ x -> (,x) <$> getMetaRange x+      vcat             [ text "Cannot generalize over unsolved sort metas:"-            , nest 2 $ vcat [ prettyTCM x <+> text "at" <+> (pretty =<< getMetaRange x) | x <- ms ]+            , nest 2 $ vcat [ prettyTCM x <+> text "at" <+> pretty r | (r,x) <- List.sort rms ]             , fsep $ pwords "Suggestion: add a `variable Any : Set _` and replace unsolved metas by Any"             ] -    AbsurdPatternRequiresNoRHS ps -> fwords $+    AbsurdPatternRequiresAbsentRHS -> fwords $       "The right-hand side must be omitted if there " ++       "is an absurd pattern, () or {}, in the left-hand side."      OldBuiltin old new -> fwords $-      "Builtin " ++ old ++ " no longer exists. " ++-      "It is now bound by BUILTIN " ++ new+      "Builtin " ++ getBuiltinId old ++ " no longer exists. " +++      "It is now bound by BUILTIN " ++ getBuiltinId new +    BuiltinDeclaresIdentifier b -> fwords $+      "BUILTIN " ++ getBuiltinId b ++ " declares an identifier " +++      "(no longer expects an already defined identifier)"+     EmptyRewritePragma -> fsep . pwords $ "Empty REWRITE pragma"      EmptyWhere         -> fsep . pwords $ "Empty `where' block (ignored)" +    -- TODO: linearity+    -- FixingQuantity s q q' -> fsep $ concat+    --   [ pwords "Replacing illegal quantity", [ pretty q ], pwords s, [ "by", pretty q' ] ]++    FixingRelevance s r r' -> fsep $ concat+      [ pwords "Replacing illegal relevance", [ p r ]+      , pwords s, [ "by", p r' ]+      ]+      where p r = text $ "`" ++ verbalize r ++ "'"++    FixingCohesion s c c' -> fsep $ concat+      [ pwords "Replacing illegal cohesion", [ p c ]+      , pwords s, [ "by", p c' ]+      ]+      where p c = text $ "`" ++ verbalize c ++ "'"++    FixingPolarity s q q' ->  fsep $ concat+      [ pwords "Replacing illegal polarity", [ p q ]+      , pwords s, [ "by", p q' ]+      ]+      where p q = text $ "`" ++ verbalize q ++ "'"+     IllformedAsClause s -> fsep . pwords $       "`as' must be followed by an identifier" ++ s      ClashesViaRenaming nm xs -> fsep $ concat $       [ [ case nm of NameNotModule -> "Name"; ModuleNotName -> "Module" ]       , pwords "clashes introduced by `renaming':"-      , map prettyTCM xs+      , map prettyTCM $ Fold.toList xs       ]      UselessPatternDeclarationForRecord s -> fwords $ unwords       [ "`pattern' attribute ignored for", s, "record" ]+      -- the @s@ is a qualifier like "eta" or "coinductive" -    UselessPublic -> fwords $ "Keyword `public' is ignored here"+    UselessPublic reason ->+      case reason of+         UselessPublicLet+           -> fwords $ "Ignoring `public'; useless in let bindings"+         UselessPublicNoOpen+           -> fwords $ "Ignoring `public'; useless without `open' here"+         UselessPublicPreamble+           -> fwords $ "Ignoring `public'; cannot reexport outside of the `module' body"+         UselessPublicAnonymousModule+           -> fwords $ "Ignoring `public'; cannot reexport from unopened anonymous module"      UselessHiding xs -> fsep $ concat       [ pwords "Ignoring names in `hiding' directive:"-      , punctuate "," $ map pretty xs+      , punctuate "," $ fmap pretty xs       ]      UselessInline q -> fsep $       pwords "It is pointless for INLINE'd function" ++ [prettyTCM q] ++       pwords "to have a separate Haskell definition" -    WrongInstanceDeclaration -> fwords "Terms marked as eligible for instance search should end with a name, so `instance' is ignored here."+    UselessTactic -> fwords $ "Ignoring `tactic' attribute for non-hidden (explicit or instance) binder" +    WrongInstanceDeclaration -> fwords $+      "Instances should be of type {Γ} → C, where C evaluates to a postulated name or the name of " +++      "a data or record type, so `instance' is ignored here."+     InstanceWithExplicitArg q -> fsep $       pwords "Instance declarations with explicit arguments are never considered by instance search," ++       pwords "so making" ++ [prettyTCM q] ++ pwords "into an instance has no effect."      InstanceNoOutputTypeName b -> fsep $-      pwords "Instance arguments whose type does not end in a named or variable type are never considered by instance search," +++      pwords "Instance arguments whose type is not {Γ} → C, where C evaluates to a postulated type, " +++      pwords "a parameter type or the name of a data or record type, are never considered by instance search," ++       pwords "so having an instance argument" ++ [return b] ++ pwords "has no effect."      InstanceArgWithExplicitArg b -> fsep $@@ -171,54 +317,34 @@              pwords "also mean that you need to increase the maximum depth using the flag" ++              pwords "--inversion-max-depth=N" -    NoGuardednessFlag q ->-      fsep $ [ prettyTCM q ] ++ pwords "is declared coinductive, but option" ++-             pwords "--guardedness is not enabled. Coinductive functions on" ++-             pwords "this type will likely be rejected by the termination" ++-             pwords "checker unless this flag is enabled."--    GenericWarning d -> return d--    GenericNonFatalError d -> return d--    GenericUseless _r d -> return d--    SafeFlagPostulate e -> fsep $-      pwords "Cannot postulate" ++ [pretty e] ++ pwords "with safe flag"+    InvalidCharacterLiteral c -> fsep $+      pwords "Invalid character literal" ++ [text $ show c] +++      pwords "(surrogate code points are not supported)" -    SafeFlagPragma xs ->-      let plural | length xs == 1 = ""-                 | otherwise      = "s"-      in fsep $ [fwords ("Cannot set OPTIONS pragma" ++ plural)]-                ++ map text xs ++ [fwords "with safe flag."]+    UselessPragma _r d -> return d -    SafeFlagNonTerminating -> fsep $-      pwords "Cannot use NON_TERMINATING pragma with safe flag."+    SafeFlagPostulate q -> fsep $+      pwords "Cannot postulate" ++ [prettyTCM q] ++ pwords "with safe flag" -    SafeFlagTerminating -> fsep $-      pwords "Cannot use TERMINATING pragma with safe flag."+    SafeFlagPragma sset -> vcat $ concat+      [ [ fwords $ singPlural (words =<< xs) id (++ "s") "The --safe mode does not allow OPTIONS pragma" ]+      , map text xs+      ]+      where xs = Set.toAscList sset      SafeFlagWithoutKFlagPrimEraseEquality -> fsep (pwords "Cannot use primEraseEquality with safe and without-K flags.")      WithoutKFlagPrimEraseEquality -> fsep (pwords "Using primEraseEquality with the without-K flag is inconsistent.") -    SafeFlagNoPositivityCheck -> fsep $-      pwords "Cannot use NO_POSITIVITY_CHECK pragma with safe flag."--    SafeFlagPolarity -> fsep $-      pwords "Cannot use POLARITY pragma with safe flag."--    SafeFlagNoUniverseCheck -> fsep $-      pwords "Cannot use NO_UNIVERSE_CHECK pragma with safe flag."--    SafeFlagEta -> fsep $-      pwords "Cannot use ETA pragma with safe flag."--    SafeFlagInjective -> fsep $-      pwords "Cannot use INJECTIVE pragma with safe flag."+    ConflictingPragmaOptions a b -> fsep $ pwords $ unwords+      [ "Conflicting options", yes a, "and", no b, "(" ++ yes a, "implies", yes b ++ ")."+      , "Ignoring", no b ++ "." ]+      where+        yes s = "--" ++ s+        no ('n' : 'o' : '-' : s) = "--" ++ s+        no s                     = "--no-" ++ s -    SafeFlagNoCoverageCheck -> fsep $-      pwords "Cannot use NON_COVERING pragma with safe flag."+    OptionWarning ow -> pretty ow      ParseWarning pw -> pretty pw @@ -226,7 +352,7 @@       [text old] ++ pwords "has been deprecated. Use" ++ [text new] ++ pwords       "instead. This will be an error in Agda" ++ [text version <> "."] -    NicifierIssue w -> sayWhere (getRange w) $ pretty w+    NicifierIssue w -> pretty w      UserWarning str -> text (T.unpack str) @@ -239,7 +365,7 @@       ys, ms :: [C.ImportedName]       ys            = map ImportedName   ys0       ms            = map ImportedModule ms0-      (ys0, ms0)    = partitionImportedNames xs+      (ys0, ms0)    = partitionImportedNames $ List1.toList xs       suggestion zs = maybe empty parens . didYouMean (map C.QName zs) fromImportedName      DuplicateUsing xs -> fsep $ pwords "Duplicates in `using` directive:" ++ map pretty (List1.toList xs)@@ -248,14 +374,92 @@      LibraryWarning lw -> pretty lw -    InfectiveImport o m -> fsep $-      pwords "Importing module" ++ [pretty m] ++ pwords "using the" ++-      [pretty o] ++ pwords "flag from a module which does not."+    InfectiveImport msg -> return msg -    CoInfectiveImport o m -> fsep $-      pwords "Importing module" ++ [pretty m] ++ pwords "not using the" ++-      [pretty o] ++ pwords "flag from a module which does."+    CoInfectiveImport msg -> return msg +    NotARewriteRule x amb -> hsep $ concat+        [ [ pretty x ]+        , pwords "is not a legal rewrite rule, since the left-hand side is"+        , case amb of+            YesAmbiguous xs -> [ "ambiguous:", pretty xs ]+            NotAmbiguous -> pwords "neither a defined symbol nor a constructor"+        ]++    IllegalRewriteRule q reason -> case reason of+      LHSNotDefinitionOrConstructor -> hsep+        [ prettyTCM q , " is not a legal rewrite rule, since the left-hand side is neither a defined symbol nor a constructor" ]+      VariablesNotBoundByLHS xs -> hsep+        [ prettyTCM q+        , " is not a legal rewrite rule, since the following variables are not bound by the left hand side: "+        , prettyList_ (map (prettyTCM . var) $ IntSet.toList xs)+        ]+      VariablesBoundMoreThanOnce xs -> do+        (prettyTCM q+          <+> " is not a legal rewrite rule, since the following parameters are bound more than once on the left hand side: "+          <+> hsep (List.intersperse "," $ map (prettyTCM . var) $ IntSet.toList xs))+          <> ". Perhaps you can use a postulate instead of a constructor as the head symbol?"+      LHSReduces v v' -> fsep+        [ prettyTCM q <+> " is not a legal rewrite rule, since the left-hand side "+        , prettyTCM v <+> " reduces to " <+> prettyTCM v' ]+      HeadSymbolIsProjectionLikeFunction f -> hsep+        [ prettyTCM q , " is not a legal rewrite rule, since the head symbol"+        , hd , "is a projection-like function."+        , "You can turn off the projection-like optimization for", hd+        , "with the pragma {-# NOT_PROJECTION_LIKE", hd, "#-}"+        , "or globally with the flag --no-projection-like"+        ]+        where hd = prettyTCM f+      HeadSymbolIsTypeConstructor f -> hsep+        [ prettyTCM q , " is not a legal rewrite rule, since the head symbol"+        , prettyTCM f , "is a type constructor."+        ]+      HeadSymbolContainsMetas f -> hsep+        [ prettyTCM q , "is not a legal rewrite rule, since the definition of the head symbol"+        , prettyTCM f , "contains unsolved metavariables and confluence checking is enabled."+        ]+      ConstructorParametersNotGeneral c vs -> vcat+        [ prettyTCM q <+> text " is not a legal rewrite rule, since the constructor parameters are not fully general:"+        , nest 2 $ text "Constructor: " <+> prettyTCM c+        , nest 2 $ text "Parameters: " <+> prettyList (map prettyTCM vs)+        ]+      ContainsUnsolvedMetaVariables ms -> hsep+        [ prettyTCM q , " is not a legal rewrite rule, since"+        , "it contains the unsolved meta variable(s)", prettyList_ (fmap prettyTCM $ Set1.toList ms)+        ]+      BlockedOnProblems ps -> hsep+        [ prettyTCM q , " is not a legal rewrite rule, since"+        , "it is blocked on problem(s)", prettyList_ (fmap prettyTCM $ Set1.toList ps)+        ]+      RequiresDefinitions qs -> hsep+        [ prettyTCM q , " is not a legal rewrite rule, since"+        , "it requires the definition(s) of", prettyList_ (fmap prettyTCM $ Set1.toList qs)+        ]+      DoesNotTargetRewriteRelation -> hsep+        [ prettyTCM q , " does not target rewrite relation" ]+      BeforeFunctionDefinition -> hsep+        [ "Rewrite rule from function "+        , prettyTCM q+        , " cannot be added before the function definition"+        ]+      BeforeMutualFunctionDefinition r -> hsep+        [ "Rewrite rule from function "+        , prettyTCM q+        , " cannot be added before the definition of mutually defined"+        , prettyTCM r+        ]+      DuplicateRewriteRule ->+        "Rewrite rule " <+> prettyTCM q <+> " has already been added"++    ConfluenceCheckingIncompleteBecauseOfMeta f -> fsep+      [ "Confluence checking incomplete because the definition of"+      , prettyTCM f+      , text "contains unsolved metavariables."+      ]++    ConfluenceForCubicalNotSupported -> fsep $ pwords $+      "Confluence checking for --cubical is not yet supported, confluence checking might be incomplete"+     RewriteNonConfluent lhs rhs1 rhs2 err -> fsep       [ "Local confluence check failed:"       , prettyTCM lhs , "reduces to both"@@ -298,20 +502,71 @@         ]       ] +    DuplicateRecordDirective dir ->+      "Ignoring duplicate record directive: " <+> pretty dir+     PragmaCompileErased bn qn -> fsep $ concat       [ pwords "The backend"-      , [ text bn+      , [ prettyTCM bn         , "erases"         , prettyTCM qn         ]       , pwords "so the COMPILE pragma will be ignored."       ] -    NotInScopeW xs -> vcat+    PragmaCompileList -> fsep $ pwords+      "Ignoring GHC pragma for builtin lists; they always compile to Haskell lists."++    PragmaCompileMaybe -> fsep $ pwords+      "Ignoring GHC pragma for builtin MAYBE; it always compiles to Haskell Maybe."++    PragmaCompileUnparsable s -> fwords $ "Ignoring unparsable GHC pragma '" ++ s ++ "'"++    PragmaCompileWrong _x s -> fwords s++    PragmaCompileWrongName x amb -> hsep $ concat+      [ pwords "Cannot COMPILE"+      , [ pretty x ]+      , pwords "since it is"+      , case amb of+          YesAmbiguous xs -> [ "ambiguous:", pretty xs ]+          NotAmbiguous -> pwords "neither a defined symbol nor a constructor"+      ]++    PragmaExpectsDefinedSymbol pragma _x -> hsep $ concat+      [ pwords "Target of"+      , [ text pragma ]+      , pwords "pragma should be a defined symbol"+      ]++    PragmaExpectsUnambiguousConstructorOrFunction pragma _x amb -> hsep $ concat+      [ pwords "Target of"+      , [ text pragma ]+      , pwords "pragma should be"+      , case amb of+          YesAmbiguous xs -> pwords "unambiguous, but it resolves to:" ++ [ pretty xs ]+          NotAmbiguous -> pwords "a function, constructor, or projection"+      ]++    PragmaExpectsUnambiguousProjectionOrFunction pragma _x amb -> hsep $ concat+      [ pwords "Target of"+      , [ text pragma ]+      , pwords "pragma should be"+      , case amb of+          YesAmbiguous xs -> pwords "unambiguous, but it resolves to:" ++ [ pretty xs ]+          NotAmbiguous -> pwords "a function or projection"+      ]++    NoMain topLevelModule -> vcat+      [ fsep $ pwords "No main function defined in" ++ [prettyTCM topLevelModule <> "."]+      , fsep $ pwords "Use option --no-main to suppress this warning."+      ]++    NotInScopeW x -> vcat       [ fsep $ pwords "Not in scope:"       , do         inscope <- Set.toList . concreteNamesInScope <$> getScope-        prettyNotInScopeNames True (suggestion inscope) xs+        prettyNotInScopeNames True (suggestion inscope) $ singleton x       ]       where       suggestion inscope x = nest 2 $ par $ concat@@ -326,34 +581,138 @@         s = P.prettyShow x      AsPatternShadowsConstructorOrPatternSynonym patsyn -> fsep $ concat-      [ pwords "Name bound in @-pattern ignored because it shadows"-      , if patsyn then pwords "pattern synonym" else [ "constructor" ]+      [ pwords "Name bound in @-pattern ignored because it shadows a"+      , [ pure $ P.pretty patsyn ]       ] +    PatternShadowsConstructor x c -> fsep $+      pwords "The pattern variable" ++ [prettyTCM x] +++      pwords "has the same name as the constructor" ++ [prettyTCM c]++    PlentyInHardCompileTimeMode o -> fsep $+      pwords "Ignored use of" ++ [pretty o] +++      pwords "in hard compile-time mode"+     RecordFieldWarning w -> prettyRecordFieldWarning w +    MissingTypeSignatureForOpaque name isOpaque -> vcat+        [ "Missing type signature for" <+> text what <+> "definition" <+> (prettyTCM name <> ".")+        , fsep $ pwords $+            "Types of " ++ what ++ " definitions are never inferred since this would leak " +++            "information that should be " ++ what ++ "."+        ]+      where+        what = case isOpaque of+          TransparentDef -> "abstract"+          OpaqueDef _    -> "opaque"+++    NotAffectedByOpaque -> fwords "Only function definitions can be marked opaque. This definition will be treated as transparent."++    UnfoldingWrongName x -> fsep $+      pwords "Name in unfolding clause should be unambiguous defined name:" ++ [prettyTCM x]++    UnfoldTransparentName qn -> fsep $+      pwords "The name" ++ [prettyTCM qn <> ","] ++ pwords "mentioned by an unfolding clause, does not belong to an opaque block. This has no effect."++    AbstractInLetBindings -> fsep $ pwords "Abstract definitions are not allowed in let bindings."+    MacroInLetBindings    -> fsep $ pwords "Macros can not be defined in let bindings."++    UselessOpaque -> "This `opaque` block has no effect."++    HiddenNotInArgumentPosition e -> fsep $+      [pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" +++      pwords "a function expecting an implicit argument."++    InstanceNotInArgumentPosition e -> fsep $+      [pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" +++      pwords "a function expecting an instance argument."++    InvalidDisplayForm x reason -> fsep $ concat+        [ pwords "Ignoring invalid display form for"+        , [ prettyTCM x ]+        , if null reason then [] else "because" : pwords reason+        ]++    UnusedVariablesInDisplayForm xs -> vcat+      [ fsep $ concat+        [ pwords "The following"+        , pwords $ singPlural xs "variable is" "variables are"+        , pwords "bound on the left hand side but unused on the right hand side of the display form:"+        ]+      , nest 2 $ fsep $ fmap pretty xs+      , fsep $ concat+        [ [ "Replace" ]+        , pwords $ singPlural xs "it by an underscore" "them by underscores"+        , pwords "to pacify this warning"+        ]+      ]++    TooManyArgumentsToSort q args -> fsep $ concat+      [ pwords "Too many arguments given to sort"+      , [ prettyTCM q ]+      ]++    RewritesNothing -> fsep $ pwords "`rewrite' did not apply"++    WithClauseProjectionFixityMismatch p0 o' q o -> fsep $ concat+        [ pwords "With clause pattern"+        , [ prettyA p0 ]+        , pwords "is not an instance of its parent pattern"+        , [ P.fsep <$> prettyTCMPatterns [q] ]+        , pwords "since the parent pattern is"+        , pwords $ prettyProjOrigin o+        , pwords "and the with clause pattern is"+        , pwords $ prettyProjOrigin o'+        ]+      where+        prettyProjOrigin ProjPrefix  = "a prefix projection"+        prettyProjOrigin ProjPostfix = "a postfix projection"+        prettyProjOrigin ProjSystem  = __IMPOSSIBLE__++    FaceConstraintCannotBeHidden ai -> fsep $+      pwords "Face constraint patterns cannot be" ++ [ pretty (getHiding ai), "arguments"]++    FaceConstraintCannotBeNamed x -> fsep $+      pwords "Ignoring name" ++ ["`" <> pretty x <> "`"] ++ pwords "given to face constraint pattern"++    CustomBackendWarning backend warn -> (text backend <> ":") <?> pure warn++    TopLevelPolarity x p -> fsep $+      ["Definition", prettyTCM x, "has explicit polarity annotation", pretty p, "which is currently not supported"]++    TooManyPolarities x occs -> fsep $+      [prettyTCM $ length occs] +++      pwords "too many polarities given in the POLARITY pragma for" +++      [prettyTCM x]++instance PrettyTCM DataOrRecord_ where+  prettyTCM = \case+    IsData{}   -> "data"+    IsRecord{} -> "record"+++{-# SPECIALIZE prettyRecordFieldWarning :: RecordFieldWarning -> TCM Doc #-} prettyRecordFieldWarning :: MonadPretty m => RecordFieldWarning -> m Doc prettyRecordFieldWarning = \case-  DuplicateFieldsWarning xrs    -> prettyDuplicateFields $ map fst xrs-  TooManyFieldsWarning q ys xrs -> prettyTooManyFields q ys $ map fst xrs+  W.DuplicateFields xrs    -> prettyDuplicateFields    $ fmap fst xrs+  W.TooManyFields q ys xrs -> prettyTooManyFields q ys $ fmap fst xrs -prettyDuplicateFields :: MonadPretty m => [C.Name] -> m Doc+prettyDuplicateFields :: MonadPretty m => List1 C.Name -> m Doc prettyDuplicateFields xs = fsep $ concat-    [ pwords "Duplicate"-    , fields xs-    , punctuate comma (map pretty xs)+    [ [ "Duplicate", pluralS xs "field" ]+    , punctuate comma (fmap pretty xs)     , pwords "in record"     ]-  where-  fields ys = P.singPlural ys [text "field"] [text "fields"] -prettyTooManyFields :: MonadPretty m => QName -> [C.Name] -> [C.Name] -> m Doc+{-# SPECIALIZE prettyTooManyFields :: QName -> [C.Name] -> List1 C.Name -> TCM Doc  #-}+prettyTooManyFields :: MonadPretty m => QName -> [C.Name] -> List1 C.Name -> m Doc prettyTooManyFields r missing xs = fsep $ concat     [ pwords "The record type"     , [prettyTCM r]     , pwords "does not have the"     , fields xs-    , punctuate comma (map pretty xs)+    , punctuate comma (fmap pretty xs)     , if null missing then [] else concat       [ pwords "but it would have the"       , fields missing@@ -361,8 +720,9 @@       ]     ]   where-  fields ys = P.singPlural ys [text "field"] [text "fields"]+    fields ys = [ pluralS ys "field" ] +{-# SPECIALIZE prettyNotInScopeNames :: (Pretty a, HasRange a) => Bool -> (a -> TCM Doc) -> [a] -> TCM Doc #-} -- | Report a number of names that are not in scope. prettyNotInScopeNames   :: (MonadPretty m, Pretty a, HasRange a)@@ -378,6 +738,7 @@     , suggestion x     ] +{-# SPECIALIZE didYouMean :: (Pretty a, Pretty b) => [C.QName] -> (a -> b) -> a -> Maybe (TCM Doc) #-} -- | Suggest some corrections to a misspelled name. didYouMean   :: (MonadPretty m, Pretty a, Pretty b)@@ -402,24 +763,24 @@   ys           = map prettyShow $ filter (close (strip $ canon x) . strip . C.unqualify) inscope  -prettyTCWarnings :: [TCWarning] -> TCM String-prettyTCWarnings = fmap (unlines . List.intersperse "") . prettyTCWarnings'+prettyTCWarnings :: Set TCWarning -> TCM String+prettyTCWarnings = List.intercalate "\n" <.> map P.render <.> prettyTCWarnings' -prettyTCWarnings' :: [TCWarning] -> TCM [String]-prettyTCWarnings' = mapM (fmap P.render . prettyTCM) . filterTCWarnings+prettyTCWarnings' :: Set TCWarning -> TCM [Doc]+prettyTCWarnings' = traverse prettyTCM <=< filterTCWarnings  -- | If there are several warnings, remove the unsolved-constraints warning -- in case there are no interesting constraints to list.-filterTCWarnings :: [TCWarning] -> [TCWarning]-filterTCWarnings = \case+filterTCWarnings :: Set TCWarning -> TCM [TCWarning]+filterTCWarnings wset = case Set.toAscList wset of   -- #4065: Always keep the only warning-  [w] -> [w]+  [w] -> return [w]   -- Andreas, 2019-09-10, issue #4065:   -- If there are several warnings, remove the unsolved-constraints warning   -- in case there are no interesting constraints to list.-  ws  -> (`filter` ws) $ \ w -> case tcWarning w of-    UnsolvedConstraints cs -> any interestingConstraint cs-    _ -> True+  ws  -> (`filterM` ws) $ \ w -> case tcWarning w of+    UnsolvedConstraints cs -> anyM interestingConstraint cs+    _ -> pure True   -- | Turns warnings, if any, into errors.@@ -427,7 +788,7 @@ tcWarningsToError mws = case (unsolvedHoles, otherWarnings) of    ([], [])                   -> return ()    (_unsolvedHoles@(_:_), []) -> typeError SolvedButOpenHoles-   (_, ws@(_:_))              -> typeError $ NonFatalErrors ws+   (_ , w : ws)               -> typeError $ NonFatalErrors $ Set1.fromList (w :| ws)    where    -- filter out unsolved interaction points for imported module so    -- that we get the right error message (see test case Fail/Issue1296)@@ -439,15 +800,15 @@ -- | Depending which flags are set, one may happily ignore some -- warnings. -applyFlagsToTCWarningsPreserving :: HasOptions m => Set WarningName -> [TCWarning] -> m [TCWarning]+applyFlagsToTCWarningsPreserving :: HasOptions m => Set WarningName -> Set TCWarning -> m (Set TCWarning) applyFlagsToTCWarningsPreserving additionalKeptWarnings ws = do   -- For some reason some SafeFlagPragma seem to be created multiple times.   -- This is a way to collect all of them and remove duplicates.-  let pragmas w = case tcWarning w of { SafeFlagPragma ps -> ([w], ps); _ -> ([], []) }-  let sfp = case fmap List.nub (foldMap pragmas ws) of-              (TCWarning loc r w p b:_, sfp) ->-                 [TCWarning loc r (SafeFlagPragma sfp) p b]-              _                        -> []+  let pragmas w = case tcWarning w of { SafeFlagPragma ps -> ([w], ps); _ -> ([], empty) }+  let sfp = case foldMap pragmas ws of+              (TCWarning loc r w doc str b : _, sfp) ->+                 singleton $ TCWarning loc r (SafeFlagPragma sfp) doc str b+              _ -> empty    pragmaWarnings <- (^. warningSet) . optWarningMode <$> pragmaOptions   let warnSet = Set.union pragmaWarnings additionalKeptWarnings@@ -456,55 +817,71 @@   let cleanUp w = let wName = warningName w in         wName /= SafeFlagPragma_         && wName `Set.member` warnSet-        && case w of-          UnsolvedMetaVariables ums    -> not $ null ums-          UnsolvedInteractionMetas uis -> not $ null uis-          UnsolvedConstraints ucs      -> not $ null ucs-          _                            -> True -  return $ sfp ++ filter (cleanUp . tcWarning) ws+  return $ Set.union sfp $ Set.filter (cleanUp . tcWarning) ws -applyFlagsToTCWarnings :: HasOptions m => [TCWarning] -> m [TCWarning]+applyFlagsToTCWarnings :: HasOptions m => Set TCWarning -> m (Set TCWarning) applyFlagsToTCWarnings = applyFlagsToTCWarningsPreserving Set.empty -getAllUnsolvedWarnings :: (MonadFail m, ReadTCState m, MonadWarning m) => m [TCWarning]+{-# SPECIALIZE isBoundaryConstraint :: ProblemConstraint -> TCM (Maybe Range) #-}+isBoundaryConstraint :: (ReadTCState m, MonadTCM m) => ProblemConstraint -> m (Maybe Range)+isBoundaryConstraint c =+  enterClosure (theConstraint c) $ \case+    ValueCmp _ _ (MetaV mid xs) y | Just xs <- allApplyElims xs ->+      fmap g <$> liftTCM (isFaceConstraint mid xs)+    ValueCmp _ _ y (MetaV mid xs) | Just xs <- allApplyElims xs ->+      fmap g <$> liftTCM (isFaceConstraint mid xs)+    _ -> pure Nothing+  where+    g (a, _, _, _) = getRange a++{-# SPECIALIZE getAllUnsolvedWarnings :: TCM [TCWarning] #-}+getAllUnsolvedWarnings :: (ReadTCState m, MonadWarning m, MonadTCM m) => m [TCWarning] getAllUnsolvedWarnings = do   unsolvedInteractions <- getUnsolvedInteractionMetas-  unsolvedConstraints  <- getAllConstraints-  unsolvedMetas        <- getUnsolvedMetas -  let checkNonEmpty c rs = c rs <$ guard (not $ null rs)+  allCons <- getAllConstraints+  unsolvedConstraints  <- filterM (fmap isNothing . isBoundaryConstraint) allCons+  interactionBoundary  <- catMaybes <$> traverse isBoundaryConstraint allCons +  unsolvedMetas        <- getUnsolvedMetas+   mapM warning_ $ catMaybes-                [ checkNonEmpty UnsolvedInteractionMetas unsolvedInteractions-                , checkNonEmpty UnsolvedMetaVariables    unsolvedMetas-                , checkNonEmpty UnsolvedConstraints      unsolvedConstraints ]+    [ UnsolvedInteractionMetas  . Set1.fromList <$> List1.nonEmpty unsolvedInteractions+    , UnsolvedMetaVariables     . Set1.fromList <$> List1.nonEmpty unsolvedMetas+    , UnsolvedConstraints                       <$> List1.nonEmpty unsolvedConstraints+    , InteractionMetaBoundaries . Set1.fromList <$> List1.nonEmpty interactionBoundary+    ]  -- | Collect all warnings that have accumulated in the state. -getAllWarnings :: (MonadFail m, ReadTCState m, MonadWarning m) => WhichWarnings -> m [TCWarning]+{-# SPECIALIZE getAllWarnings :: WhichWarnings -> TCM (Set TCWarning) #-}+getAllWarnings :: (ReadTCState m, MonadWarning m, MonadTCM m) => WhichWarnings -> m (Set TCWarning) getAllWarnings = getAllWarningsPreserving Set.empty -getAllWarningsPreserving :: (MonadFail m, ReadTCState m, MonadWarning m) => Set WarningName -> WhichWarnings -> m [TCWarning]+{-# SPECIALIZE getAllWarningsPreserving :: Set WarningName -> WhichWarnings -> TCM (Set TCWarning) #-}+getAllWarningsPreserving ::+  (ReadTCState m, MonadWarning m, MonadTCM m) => Set WarningName -> WhichWarnings -> m (Set TCWarning) getAllWarningsPreserving keptWarnings ww = do-  unsolved            <- getAllUnsolvedWarnings+  unsolved            <- Set.fromList <$> getAllUnsolvedWarnings   collectedTCWarnings <- useTC stTCWarnings -  let showWarn w = classifyWarning w <= ww &&-                    not (null unsolved && onlyShowIfUnsolved w)+  -- E.g. the InversionDepthReached warning is only shown when we have unsolved constraints.+  let showWarn+        | null unsolved = \ w -> classifyWarning w <= ww && not (onlyShowIfUnsolved w)+        | otherwise     = \ w -> classifyWarning w <= ww -  fmap (filter (showWarn . tcWarning))-    $ applyFlagsToTCWarningsPreserving keptWarnings-    $ reverse $ unsolved ++ collectedTCWarnings+  Set.filter (showWarn . tcWarning) <$> do+    applyFlagsToTCWarningsPreserving keptWarnings $+      unsolved `Set.union` collectedTCWarnings -getAllWarningsOfTCErr :: TCErr -> TCM [TCWarning]-getAllWarningsOfTCErr err = case err of+getAllWarningsOfTCErr :: TCErr -> TCM (Set TCWarning)+getAllWarningsOfTCErr = \case   TypeError _ tcst cls -> case clValue cls of-    NonFatalErrors{} -> return []+    NonFatalErrors{} -> return empty     _ -> localTCState $ do       putTC tcst-      ws <- getAllWarnings AllWarnings       -- We filter out the unsolved(Metas/Constraints) to stay       -- true to the previous error messages.-      return $ filter (not . isUnsolvedWarning . tcWarning) ws-  _ -> return []+      Set.filter (not . isUnsolvedWarning . tcWarning) <$> getAllWarnings AllWarnings+  _ -> return empty
src/full/Agda/TypeChecking/Pretty/Warning.hs-boot view
@@ -1,7 +1,9 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.Pretty.Warning where -import Agda.Utils.Pretty import Agda.TypeChecking.Monad.Base import {-# SOURCE #-} Agda.TypeChecking.Pretty (MonadPretty)+import Agda.Syntax.Common.Pretty  prettyWarning :: MonadPretty m => Warning -> m Doc
src/full/Agda/TypeChecking/Primitive.hs view
@@ -1,6 +1,8 @@+{-# OPTIONS_GHC -Wunused-imports #-}  {-| Primitive functions, such as addition on builtin integers. -}+ module Agda.TypeChecking.Primitive        ( module Agda.TypeChecking.Primitive.Base        , module Agda.TypeChecking.Primitive.Cubical@@ -8,7 +10,6 @@        ) where  import Data.Char-import Data.Function (on) import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Set as Set@@ -19,7 +20,6 @@  import qualified Agda.Interaction.Options.Lenses as Lens -import Agda.Syntax.Position import Agda.Syntax.Common hiding (Nat) import Agda.Syntax.Internal import Agda.Syntax.Internal.Generic (TermLike(..))@@ -33,16 +33,18 @@ import Agda.TypeChecking.Telescope import Agda.TypeChecking.Level -import Agda.TypeChecking.Quote (quoteTermWithKit, quoteTypeWithKit, quotingKit)+import Agda.TypeChecking.Quote (quoteTermWithKit, quoteTypeWithKit, quoteDomWithKit, quotingKit) import Agda.TypeChecking.Primitive.Base import Agda.TypeChecking.Primitive.Cubical import Agda.TypeChecking.Warnings  import Agda.Utils.Char import Agda.Utils.Float+import Agda.Utils.Functor import Agda.Utils.List+import Agda.Utils.Maybe (fromMaybeM) import Agda.Utils.Monad-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.Singleton import Agda.Utils.Size @@ -91,7 +93,7 @@ instance (PrimType a, PrimType b) => PrimType (a, b) instance (PrimType a, PrimType b) => PrimTerm (a, b) where   primTerm _ = do-    sigKit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit+    sigKit <- fromMaybeM (typeError $ NoBindingForBuiltin BuiltinSigma) getSigmaKit     let sig = Def (sigmaName sigKit) []     a'       <- primType (undefined :: a)     b'       <- primType (undefined :: b)@@ -153,46 +155,47 @@ -- From Agda term to Haskell value  class ToTerm a where-  toTerm  :: TCM (a -> Term)-  toTermR :: TCM (a -> ReduceM Term)+  toTerm  :: TCM (a -> ReduceM Term) -  toTermR = (pure .) <$> toTerm+toTermTCM :: ToTerm a => TCM (a -> TCM Term)+toTermTCM = (runReduceM .) <$> toTerm -instance ToTerm Nat     where toTerm = return $ Lit . LitNat . toInteger-instance ToTerm Word64  where toTerm = return $ Lit . LitWord64-instance ToTerm Lvl     where toTerm = return $ Level . ClosedLevel . unLvl-instance ToTerm Double  where toTerm = return $ Lit . LitFloat-instance ToTerm Char    where toTerm = return $ Lit . LitChar-instance ToTerm Text    where toTerm = return $ Lit . LitString-instance ToTerm QName   where toTerm = return $ Lit . LitQName+instance ToTerm Nat     where toTerm = return $ pure . Lit . LitNat . toInteger+instance ToTerm Word64  where toTerm = return $ pure . Lit . LitWord64+instance ToTerm Lvl     where toTerm = return $ pure . Level . ClosedLevel . unLvl+instance ToTerm Double  where toTerm = return $ pure . Lit . LitFloat+instance ToTerm Char    where toTerm = return $ pure . Lit . LitChar+instance ToTerm Text    where toTerm = return $ pure . Lit . LitString+instance ToTerm QName   where toTerm = return $ pure . Lit . LitQName instance ToTerm MetaId  where   toTerm = do-    file <- getCurrentPath-    return $ Lit . LitMeta file+    top <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule+    return $ pure . Lit . LitMeta top  instance ToTerm Integer where   toTerm = do     pos     <- primIntegerPos     negsuc  <- primIntegerNegSuc-    fromNat <- toTerm :: TCM (Nat -> Term)-    let intToTerm = fromNat . fromIntegral :: Integer -> Term-    let fromInt n | n >= 0    = apply pos    [defaultArg $ intToTerm n]-                  | otherwise = apply negsuc [defaultArg $ intToTerm (-n - 1)]+    fromNat <- toTerm @Nat+    let intToTerm = fromNat . fromIntegral @Integer+    let fromInt n | n >= 0    = apply1 pos    <$> intToTerm n+                  | otherwise = apply1 negsuc <$> intToTerm (-n - 1)     return fromInt  instance ToTerm Bool where   toTerm = do     true  <- primTrue     false <- primFalse-    return $ \b -> if b then true else false+    return $ \b -> pure $ if b then true else false  instance ToTerm Term where-  toTerm  = do kit <- quotingKit; runReduceF (quoteTermWithKit kit)-  toTermR = do quoteTermWithKit <$> quotingKit;+  toTerm = do quoteTermWithKit <$> quotingKit +instance ToTerm (Dom Type) where+  toTerm = do quoteDomWithKit <$> quotingKit+ instance ToTerm Type where-  toTerm  = do kit <- quotingKit; runReduceF (quoteTypeWithKit kit)-  toTermR = quoteTypeWithKit <$> quotingKit+  toTerm = quoteTypeWithKit <$> quotingKit  instance ToTerm ArgInfo where   toTerm = do@@ -202,15 +205,15 @@     ins  <- primInstance     rel  <- primRelevant     irr  <- primIrrelevant-    return $ \ i -> info `applys`+    return $ \ i -> pure $ info `applys`       [ case getHiding i of           NotHidden  -> vis           Hidden     -> hid           Instance{} -> ins       , case getRelevance i of-          Relevant   -> rel-          Irrelevant -> irr-          NonStrict  -> rel+          Relevant        {} -> rel+          Irrelevant      {} -> irr+          ShapeIrrelevant {} -> rel       ]  instance ToTerm Fixity' where@@ -222,28 +225,42 @@     aToTm  <- toTerm     fixity <- primFixityFixity     return $ \ Fixity{fixityAssoc = a, fixityLevel = l} ->-      fixity `apply` [defaultArg (aToTm a), defaultArg (lToTm l)]+      apply2 fixity <$> aToTm a <*> lToTm l  instance ToTerm Associativity where   toTerm = do     lassoc <- primAssocLeft     rassoc <- primAssocRight     nassoc <- primAssocNon-    return $ \ a ->+    return $ \ a -> pure $       case a of         NonAssoc   -> nassoc         LeftAssoc  -> lassoc         RightAssoc -> rassoc +instance ToTerm Blocker where+  toTerm = do+    all <- primAgdaBlockerAll+    any <- primAgdaBlockerAny+    meta <- primAgdaBlockerMeta+    lists <- buildList+    metaTm <- toTerm+    let go (UnblockOnAny xs)    = apply1 any . lists <$> mapM go (Set.toList xs)+        go (UnblockOnAll xs)    = apply1 all . lists <$> mapM go (Set.toList xs)+        go (UnblockOnMeta m)    = apply1 meta <$> metaTm m+        go (UnblockOnDef _)     = __IMPOSSIBLE__+        go (UnblockOnProblem _) = __IMPOSSIBLE__+    pure go+ instance ToTerm FixityLevel where   toTerm = do-    (iToTm :: PrecedenceLevel -> Term) <- toTerm+    iToTm <- toTerm     related   <- primPrecRelated     unrelated <- primPrecUnrelated     return $ \ p ->       case p of-        Unrelated -> unrelated-        Related n -> related `apply` [defaultArg $ iToTm n]+        Unrelated -> pure unrelated+        Related n -> apply1 related <$> iToTm n  instance (ToTerm a, ToTerm b) => ToTerm (a, b) where   toTerm = do@@ -251,7 +268,7 @@     let con = Con (sigmaCon sigKit) ConOSystem []     fromA <- toTerm     fromB <- toTerm-    pure $ \ (a, b) -> con `apply` map defaultArg [fromA a, fromB b]+    pure $ \ (a, b) -> apply2 con <$> fromA a <*> fromB b  -- | @buildList A ts@ builds a list of type @List A@. Assumes that the terms --   @ts@ all have type @A@.@@ -267,14 +284,14 @@   toTerm = do     mkList <- buildList     fromA  <- toTerm-    return $ mkList . map fromA+    return $ mkList <.> mapM fromA  instance ToTerm a => ToTerm (Maybe a) where   toTerm = do     nothing <- primNothing     just    <- primJust     fromA   <- toTerm-    return $ maybe nothing (apply1 just . fromA)+    return $ maybe (pure nothing) (apply1 just <.> fromA)  -- From Haskell value to Agda term @@ -297,11 +314,11 @@         Con c ci [Apply u]           | c == pos    ->             redBind (toNat u)-              (\ u' -> notReduced $ arg $ Con c ci [Apply $ ignoreReduced u']) $ \ n ->+              (\ u' -> pure $ notReduced $ arg $ Con c ci [Apply $ ignoreReduced u']) $ \ n ->             redReturn $ fromIntegral n           | c == negsuc ->             redBind (toNat u)-              (\ u' -> notReduced $ arg $ Con c ci [Apply $ ignoreReduced u']) $ \ n ->+              (\ u' -> pure $ notReduced $ arg $ Con c ci [Apply $ ignoreReduced u']) $ \ n ->             redReturn $ fromIntegral $ -n - 1         _ -> return $ NoReduction (reduced b) @@ -381,10 +398,12 @@           Con c ci es             | c == cons, Just [x,xs] <- allApplyElims es ->               redBind (toA x)-                  (\x' -> notReduced $ arg $ Con c ci (map Apply [ignoreReduced x',xs])) $ \y ->+                  (\x' -> pure $ notReduced $ arg $ Con c ci (map Apply [ignoreReduced x',xs])) $ \y ->               redBind                   (mkList nil cons toA fromA xs)-                  (fmap $ \xs' -> arg $ Con c ci (map Apply [defaultArg $ fromA y, xs'])) $ \ys ->+                  (\ xsR -> do+                    yTm <- fromA y+                    pure $ for xsR $ \xs' -> arg $ Con c ci (map Apply [defaultArg yTm, xs'])) $ \ys ->               redReturn (y : ys)           _ -> return $ NoReduction (reduced b) @@ -403,7 +422,7 @@         Con c ci es           | c == just, Just [x] <- allApplyElims es ->             redBind (toA x)-              (\ x' -> notReduced $ arg $ Con c ci [Apply (ignoreReduced x')])+              (\ x' -> pure $ notReduced $ arg $ Con c ci [Apply (ignoreReduced x')])               (redReturn . Just)         _ -> return $ NoReduction (reduced b) @@ -452,53 +471,60 @@       Con{} -> redReturn $ refl t       _     -> return $ NoReduction $ map notReduced ts +-- | Converts 'MetaId's to natural numbers.++metaToNat :: MetaId -> Nat+metaToNat m =+  fromIntegral (moduleNameHash $ metaModule m) * 2 ^ 64 ++  fromIntegral (metaId m)+ primMetaToNatInjective :: TCM PrimitiveImpl primMetaToNatInjective = do   meta  <- primType (undefined :: MetaId)   nat   <- primType (undefined :: Nat)-  toNat <- primFunName <$> getPrimitive "primMetaToNat"+  toNat <- primFunName <$> getPrimitive PrimMetaToNat   mkPrimInjective meta nat toNat  primCharToNatInjective :: TCM PrimitiveImpl primCharToNatInjective = do   char  <- primType (undefined :: Char)   nat   <- primType (undefined :: Nat)-  toNat <- primFunName <$> getPrimitive "primCharToNat"+  toNat <- primFunName <$> getPrimitive PrimCharToNat   mkPrimInjective char nat toNat  primStringToListInjective :: TCM PrimitiveImpl primStringToListInjective = do   string <- primType (undefined :: Text)   chars  <- primType (undefined :: String)-  toList <- primFunName <$> getPrimitive "primStringToList"+  toList <- primFunName <$> getPrimitive PrimStringToList   mkPrimInjective string chars toList  primStringFromListInjective :: TCM PrimitiveImpl primStringFromListInjective = do   chars  <- primType (undefined :: String)   string <- primType (undefined :: Text)-  fromList <- primFunName <$> getPrimitive "primStringFromList"+  fromList <- primFunName <$> getPrimitive PrimStringFromList   mkPrimInjective chars string fromList  primWord64ToNatInjective :: TCM PrimitiveImpl primWord64ToNatInjective =  do   word  <- primType (undefined :: Word64)   nat   <- primType (undefined :: Nat)-  toNat <- primFunName <$> getPrimitive "primWord64ToNat"+  toNat <- primFunName <$> getPrimitive PrimWord64ToNat   mkPrimInjective word nat toNat  primFloatToWord64Injective :: TCM PrimitiveImpl primFloatToWord64Injective = do   float  <- primType (undefined :: Double)-  word   <- primType (undefined :: Word64)-  toWord <- primFunName <$> getPrimitive "primFloatToWord64"-  mkPrimInjective float word toWord+  mword  <- primType (undefined :: Maybe Word64)+  toWord <- primFunName <$> getPrimitive PrimFloatToWord64+  mkPrimInjective float mword toWord  primQNameToWord64sInjective :: TCM PrimitiveImpl primQNameToWord64sInjective = do   name    <- primType (undefined :: QName)   words   <- primType (undefined :: (Word64, Word64))-  toWords <- primFunName <$> getPrimitive "primQNameToWord64s"+  toWords <- primFunName <$> getPrimitive PrimQNameToWord64s   mkPrimInjective name words toWords  getRefl :: TCM (Arg Term -> Term)@@ -624,7 +650,7 @@   let varEl s a = El (varSort s) <$> a       varT s a  = varEl s (varM a)   refl  <- primRefl-  force <- primFunName <$> getPrimitive "primForce"+  force <- primFunName <$> getPrimitive PrimForce   genPrimForce (nPi "x" (varT 3 1) $                 nPi "f" (nPi "y" (varT 4 2) $ varEl 4 $ varM 2 <@> varM 0) $                 varEl 4 $ primEquality <#> varM 4 <#> (varM 2 <@> varM 1)@@ -652,33 +678,21 @@     b' <- levelView' $ unArg b     redReturn $ Level $ levelLub a' b' -mkPrimSetOmega :: IsFibrant -> TCM PrimitiveImpl-mkPrimSetOmega f = do-  let t = sort $ Inf f 1-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \_ -> redReturn $ Sort $ Inf f 0- primLockUniv' :: TCM PrimitiveImpl primLockUniv' = do   let t = sort $ Type $ levelSuc $ Max 0 []   return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \_ -> redReturn $ Sort LockUniv --- mkPrimStrictSet :: TCM PrimitiveImpl--- mkPrimStrictSet = do---   t <- nPi "ℓ" (el primLevel) (pure $ sort $ SSet $ Max 0 [Plus 1 $ var 0])---   return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \ ~[a] -> do---     l <- levelView' $ unArg a---     redReturn $ Sort $ SSet l- mkPrimFun1TCM :: (FromTerm a, ToTerm b) =>                  TCM Type -> (a -> ReduceM b) -> TCM PrimitiveImpl mkPrimFun1TCM mt f = do     toA   <- fromTerm-    fromB <- toTermR+    fromB <- toTerm     t     <- mt     return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \ts ->       case ts of         [v] ->-          redBind (toA v) singleton $ \ x -> do+          redBind (toA v) (pure . singleton) $ \ x -> do             b <- fromB =<< f x             case allMetas Set.singleton b of               ms | Set.null ms -> redReturn b@@ -695,8 +709,8 @@     return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \ts ->       case ts of         [v] ->-          redBind (toA v) singleton $ \ x ->-          redReturn $ fromB $ f x+          redBind (toA v) (pure . singleton) $ \ x ->+          redReturn =<< fromB (f x)         _ -> __IMPOSSIBLE__  mkPrimFun2 :: ( PrimType a, FromTerm a, ToTerm a@@ -713,11 +727,13 @@       case ts of         [v,w] ->           redBind (toA v)-              (\v' -> [v', notReduced w]) $ \x ->+              (\v' -> pure [v', notReduced w]) $ \x ->           redBind (toB w)-              (\w' -> [ reduced $ notBlocked $ Arg (argInfo v) (fromA x)-                      , w']) $ \y ->-          redReturn $ fromC $ f x y+              (\w' -> do+                xTm <- fromA x+                pure [reduced $ notBlocked $ Arg (argInfo v) xTm , w']+              ) $ \y ->+          redReturn =<< fromC (f x y)         _ -> __IMPOSSIBLE__  mkPrimFun3 :: ( PrimType a, FromTerm a, ToTerm a@@ -733,16 +749,22 @@     t <- primType f     return $ PrimImpl t $ primFun __IMPOSSIBLE__ 3 $ \ts ->       let argFrom fromX a x =-            reduced $ notBlocked $ Arg (argInfo a) (fromX x)+            reduced . notBlocked . Arg (argInfo a) <$> fromX x       in case ts of         [a,b,c] ->           redBind (toA a)-              (\a' -> [a', notReduced b, notReduced c]) $ \x ->+              (\a' -> pure [a', notReduced b, notReduced c]) $ \x ->           redBind (toB b)-              (\b' -> [argFrom fromA a x, b', notReduced c]) $ \y ->+              (\b' -> sequence+                [ argFrom fromA a x+                , pure b'+                , pure $ notReduced c ]) $ \y ->           redBind (toC c)-              (\c' -> [ argFrom fromA a x, argFrom fromB b y, c']) $ \z ->-          redReturn $ fromD $ f x y z+              (\c' -> sequence+                [ argFrom fromA a x+                , argFrom fromB b y+                , pure c' ]) $ \z ->+          redReturn =<< fromD (f x y z)         _ -> __IMPOSSIBLE__  mkPrimFun4 :: ( PrimType a, FromTerm a, ToTerm a@@ -760,24 +782,31 @@     t <- primType f     return $ PrimImpl t $ primFun __IMPOSSIBLE__ 4 $ \ts ->       let argFrom fromX a x =-            reduced $ notBlocked $ Arg (argInfo a) (fromX x)+            reduced . notBlocked . Arg (argInfo a) <$> fromX x       in case ts of         [a,b,c,d] ->           redBind (toA a)-              (\a' -> a' : map notReduced [b,c,d]) $ \x ->+              (\a' -> pure $ a' : map notReduced [b, c, d]) $ \x ->           redBind (toB b)-              (\b' -> [argFrom fromA a x, b', notReduced c, notReduced d]) $ \y ->+              (\b' -> sequence+                [ argFrom fromA a x+                , pure b'+                , pure $ notReduced c+                , pure $ notReduced d ]) $ \y ->           redBind (toC c)-              (\c' -> [ argFrom fromA a x-                      , argFrom fromB b y-                      , c', notReduced d]) $ \z ->+              (\c' -> sequence+                [ argFrom fromA a x+                , argFrom fromB b y+                , pure c'+                , pure $ notReduced d ]) $ \z ->           redBind (toD d)-              (\d' -> [ argFrom fromA a x-                      , argFrom fromB b y-                      , argFrom fromC c z-                      , d']) $ \w ->+              (\d' -> sequence+                [ argFrom fromA a x+                , argFrom fromB b y+                , argFrom fromC c z+                , pure d' ]) $ \w -> -          redReturn $ fromE $ f x y z w+          redReturn =<< fromE (f x y z w)         _ -> __IMPOSSIBLE__  @@ -790,7 +819,7 @@ type Rel  a = a -> a -> Bool type Pred a = a -> Bool -primitiveFunctions :: Map String (TCM PrimitiveImpl)+primitiveFunctions :: Map PrimitiveId (TCM PrimitiveImpl) primitiveFunctions = localTCStateSavingWarnings <$> Map.fromListWith __IMPOSSIBLE__   -- Issue #4375          ^^^^^^^^^^^^^^^^^^^^^^^^^^   --   Without this the next fresh checkpoint id gets changed building the primitive functions. This@@ -814,35 +843,31 @@   -- , "primIntegerLess"     |-> mkPrimFun2 ((<)        :: Rel Integer)   -- , "primIntegerAbs"      |-> mkPrimFun1 (Nat . abs  :: Integer -> Nat)   -- , "primNatToInteger"    |-> mkPrimFun1 (toInteger  :: Nat -> Integer)-  [ "primShowInteger"     |-> mkPrimFun1 (T.pack . prettyShow :: Integer -> Text)+  [ PrimShowInteger     |-> mkPrimFun1 (T.pack . prettyShow :: Integer -> Text)    -- Natural number functions-  , "primNatPlus"         |-> mkPrimFun2 ((+)                     :: Op Nat)-  , "primNatMinus"        |-> mkPrimFun2 ((\x y -> max 0 (x - y)) :: Op Nat)-  , "primNatTimes"        |-> mkPrimFun2 ((*)                     :: Op Nat)-  , "primNatDivSucAux"    |-> mkPrimFun4 ((\k m n j -> k + div (max 0 $ n + m - j) (m + 1)) :: Nat -> Nat -> Op Nat)-  , "primNatModSucAux"    |->+  , PrimNatPlus           |-> mkPrimFun2 ((+)                     :: Op Nat)+  , PrimNatMinus          |-> mkPrimFun2 ((\x y -> max 0 (x - y)) :: Op Nat)+  , PrimNatTimes          |-> mkPrimFun2 ((*)                     :: Op Nat)+  , PrimNatDivSucAux      |-> mkPrimFun4 ((\k m n j -> k + div (max 0 $ n + m - j) (m + 1)) :: Nat -> Nat -> Op Nat)+  , PrimNatModSucAux      |->       let aux :: Nat -> Nat -> Op Nat           aux k m n j | n > j     = mod (n - j - 1) (m + 1)                       | otherwise = k + n       in mkPrimFun4 aux-  , "primNatEquality"     |-> mkPrimFun2 ((==) :: Rel Nat)-  , "primNatLess"         |-> mkPrimFun2 ((<)  :: Rel Nat)-  , "primShowNat"         |-> mkPrimFun1 (T.pack . prettyShow :: Nat -> Text)--  -- Machine words-  , "primWord64ToNat"     |-> mkPrimFun1 (fromIntegral :: Word64 -> Nat)-  , "primWord64FromNat"   |-> mkPrimFun1 (fromIntegral :: Nat -> Word64)-  , "primWord64ToNatInjective" |-> primWord64ToNatInjective+  , PrimNatEquality       |-> mkPrimFun2 ((==) :: Rel Nat)+  , PrimNatLess           |-> mkPrimFun2 ((<)  :: Rel Nat)+  , PrimShowNat           |-> mkPrimFun1 (T.pack . prettyShow :: Nat -> Text) -  -- Level functions-  , "primLevelZero"       |-> mkPrimLevelZero-  , "primLevelSuc"        |-> mkPrimLevelSuc-  , "primLevelMax"        |-> mkPrimLevelMax+  -- -- Machine words+  , PrimWord64ToNat      |-> mkPrimFun1 (fromIntegral :: Word64 -> Nat)+  , PrimWord64FromNat    |-> mkPrimFun1 (fromIntegral :: Nat -> Word64)+  , PrimWord64ToNatInjective |-> primWord64ToNatInjective -  -- Sorts-  , "primSetOmega"        |-> mkPrimSetOmega IsFibrant-  , "primStrictSetOmega"  |-> mkPrimSetOmega IsStrict+  -- -- Level functions+  , PrimLevelZero         |-> mkPrimLevelZero+  , PrimLevelSuc          |-> mkPrimLevelSuc+  , PrimLevelMax          |-> mkPrimLevelMax    -- Floating point functions   --@@ -853,114 +878,110 @@   -- `primFloatFloor`, `primFloatCeiling`, and `primFloatDecode`. The conversion   -- `primFloatRatio` represents NaN as (0,0), and the infinities as (±1,0).   ---  , "primFloatEquality"          |-> mkPrimFun2 doubleEq-  , "primFloatInequality"        |-> mkPrimFun2 doubleLe-  , "primFloatLess"              |-> mkPrimFun2 doubleLt-  , "primFloatIsInfinite"        |-> mkPrimFun1 (isInfinite :: Double -> Bool)-  , "primFloatIsNaN"             |-> mkPrimFun1 (isNaN :: Double -> Bool)-  , "primFloatIsNegativeZero"    |-> mkPrimFun1 (isNegativeZero :: Double -> Bool)-  , "primFloatIsSafeInteger"     |-> mkPrimFun1 isSafeInteger-  , "primFloatToWord64"          |-> mkPrimFun1 doubleToWord64-  , "primFloatToWord64Injective" |-> primFloatToWord64Injective-  , "primNatToFloat"             |-> mkPrimFun1 (intToDouble :: Nat -> Double)-  , "primIntToFloat"             |-> mkPrimFun1 (intToDouble :: Integer -> Double)-  , "primFloatRound"             |-> mkPrimFun1 doubleRound-  , "primFloatFloor"             |-> mkPrimFun1 doubleFloor-  , "primFloatCeiling"           |-> mkPrimFun1 doubleCeiling-  , "primFloatToRatio"           |-> mkPrimFun1 doubleToRatio-  , "primRatioToFloat"           |-> mkPrimFun2 ratioToDouble-  , "primFloatDecode"            |-> mkPrimFun1 doubleDecode-  , "primFloatEncode"            |-> mkPrimFun2 doubleEncode-  , "primShowFloat"              |-> mkPrimFun1 (T.pack . show :: Double -> Text)-  , "primFloatPlus"              |-> mkPrimFun2 doublePlus-  , "primFloatMinus"             |-> mkPrimFun2 doubleMinus-  , "primFloatTimes"             |-> mkPrimFun2 doubleTimes-  , "primFloatNegate"            |-> mkPrimFun1 doubleNegate-  , "primFloatDiv"               |-> mkPrimFun2 doubleDiv-  , "primFloatPow"               |-> mkPrimFun2 doublePow-  , "primFloatSqrt"              |-> mkPrimFun1 doubleSqrt-  , "primFloatExp"               |-> mkPrimFun1 doubleExp-  , "primFloatLog"               |-> mkPrimFun1 doubleLog-  , "primFloatSin"               |-> mkPrimFun1 doubleSin-  , "primFloatCos"               |-> mkPrimFun1 doubleCos-  , "primFloatTan"               |-> mkPrimFun1 doubleTan-  , "primFloatASin"              |-> mkPrimFun1 doubleASin-  , "primFloatACos"              |-> mkPrimFun1 doubleACos-  , "primFloatATan"              |-> mkPrimFun1 doubleATan-  , "primFloatATan2"             |-> mkPrimFun2 doubleATan2-  , "primFloatSinh"              |-> mkPrimFun1 doubleSinh-  , "primFloatCosh"              |-> mkPrimFun1 doubleCosh-  , "primFloatTanh"              |-> mkPrimFun1 doubleTanh-  , "primFloatASinh"             |-> mkPrimFun1 doubleASinh-  , "primFloatACosh"             |-> mkPrimFun1 doubleCosh-  , "primFloatATanh"             |-> mkPrimFun1 doubleTanh+  , PrimFloatEquality            |-> mkPrimFun2 doubleEq+  , PrimFloatInequality          |-> mkPrimFun2 doubleLe+  , PrimFloatLess                |-> mkPrimFun2 doubleLt+  , PrimFloatIsInfinite          |-> mkPrimFun1 (isInfinite :: Double -> Bool)+  , PrimFloatIsNaN               |-> mkPrimFun1 (isNaN :: Double -> Bool)+  , PrimFloatIsNegativeZero      |-> mkPrimFun1 (isNegativeZero :: Double -> Bool)+  , PrimFloatIsSafeInteger       |-> mkPrimFun1 isSafeInteger+  , PrimFloatToWord64            |-> mkPrimFun1 doubleToWord64+  , PrimFloatToWord64Injective   |-> primFloatToWord64Injective+  , PrimNatToFloat               |-> mkPrimFun1 (intToDouble :: Nat -> Double)+  , PrimIntToFloat               |-> mkPrimFun1 (intToDouble :: Integer -> Double)+  , PrimFloatRound               |-> mkPrimFun1 doubleRound+  , PrimFloatFloor               |-> mkPrimFun1 doubleFloor+  , PrimFloatCeiling             |-> mkPrimFun1 doubleCeiling+  , PrimFloatToRatio             |-> mkPrimFun1 doubleToRatio+  , PrimRatioToFloat             |-> mkPrimFun2 ratioToDouble+  , PrimFloatDecode              |-> mkPrimFun1 doubleDecode+  , PrimFloatEncode              |-> mkPrimFun2 doubleEncode+  , PrimShowFloat                |-> mkPrimFun1 (T.pack . show :: Double -> Text)+  , PrimFloatPlus                |-> mkPrimFun2 doublePlus+  , PrimFloatMinus               |-> mkPrimFun2 doubleMinus+  , PrimFloatTimes               |-> mkPrimFun2 doubleTimes+  , PrimFloatNegate              |-> mkPrimFun1 doubleNegate+  , PrimFloatDiv                 |-> mkPrimFun2 doubleDiv+  , PrimFloatPow                 |-> mkPrimFun2 doublePow+  , PrimFloatSqrt                |-> mkPrimFun1 doubleSqrt+  , PrimFloatExp                 |-> mkPrimFun1 doubleExp+  , PrimFloatLog                 |-> mkPrimFun1 doubleLog+  , PrimFloatSin                 |-> mkPrimFun1 doubleSin+  , PrimFloatCos                 |-> mkPrimFun1 doubleCos+  , PrimFloatTan                 |-> mkPrimFun1 doubleTan+  , PrimFloatASin                |-> mkPrimFun1 doubleASin+  , PrimFloatACos                |-> mkPrimFun1 doubleACos+  , PrimFloatATan                |-> mkPrimFun1 doubleATan+  , PrimFloatATan2               |-> mkPrimFun2 doubleATan2+  , PrimFloatSinh                |-> mkPrimFun1 doubleSinh+  , PrimFloatCosh                |-> mkPrimFun1 doubleCosh+  , PrimFloatTanh                |-> mkPrimFun1 doubleTanh+  , PrimFloatASinh               |-> mkPrimFun1 doubleASinh+  , PrimFloatACosh               |-> mkPrimFun1 doubleCosh+  , PrimFloatATanh               |-> mkPrimFun1 doubleTanh    -- Character functions-  , "primCharEquality"       |-> mkPrimFun2 ((==) :: Rel Char)-  , "primIsLower"            |-> mkPrimFun1 isLower-  , "primIsDigit"            |-> mkPrimFun1 isDigit-  , "primIsAlpha"            |-> mkPrimFun1 isAlpha-  , "primIsSpace"            |-> mkPrimFun1 isSpace-  , "primIsAscii"            |-> mkPrimFun1 isAscii-  , "primIsLatin1"           |-> mkPrimFun1 isLatin1-  , "primIsPrint"            |-> mkPrimFun1 isPrint-  , "primIsHexDigit"         |-> mkPrimFun1 isHexDigit-  , "primToUpper"            |-> mkPrimFun1 toUpper-  , "primToLower"            |-> mkPrimFun1 toLower-  , "primCharToNat"          |-> mkPrimFun1 (fromIntegral . fromEnum :: Char -> Nat)-  , "primCharToNatInjective" |-> primCharToNatInjective-  , "primNatToChar"          |-> mkPrimFun1 (integerToChar . unNat)-  , "primShowChar"           |-> mkPrimFun1 (T.pack . prettyShow . LitChar)+  , PrimCharEquality         |-> mkPrimFun2 ((==) :: Rel Char)+  , PrimIsLower              |-> mkPrimFun1 isLower+  , PrimIsDigit              |-> mkPrimFun1 isDigit+  , PrimIsAlpha              |-> mkPrimFun1 isAlpha+  , PrimIsSpace              |-> mkPrimFun1 isSpace+  , PrimIsAscii              |-> mkPrimFun1 isAscii+  , PrimIsLatin1             |-> mkPrimFun1 isLatin1+  , PrimIsPrint              |-> mkPrimFun1 isPrint+  , PrimIsHexDigit           |-> mkPrimFun1 isHexDigit+  , PrimToUpper              |-> mkPrimFun1 toUpper+  , PrimToLower              |-> mkPrimFun1 toLower+  , PrimCharToNat            |-> mkPrimFun1 (fromIntegral . fromEnum :: Char -> Nat)+  , PrimCharToNatInjective   |-> primCharToNatInjective+  , PrimNatToChar            |-> mkPrimFun1 (integerToChar . unNat)+  , PrimShowChar             |-> mkPrimFun1 (T.pack . prettyShow . LitChar)    -- String functions-  , "primStringToList"            |-> mkPrimFun1 T.unpack-  , "primStringToListInjective"   |-> primStringToListInjective-  , "primStringFromList"          |-> mkPrimFun1 T.pack-  , "primStringFromListInjective" |-> primStringFromListInjective-  , "primStringAppend"            |-> mkPrimFun2 (T.append :: Text -> Text -> Text)-  , "primStringEquality"          |-> mkPrimFun2 ((==) :: Rel Text)-  , "primShowString"              |-> mkPrimFun1 (T.pack . prettyShow . LitString)-  , "primStringUncons"            |-> mkPrimFun1 T.uncons+  , PrimStringToList              |-> mkPrimFun1 T.unpack+  , PrimStringToListInjective     |-> primStringToListInjective+  , PrimStringFromList            |-> mkPrimFun1 T.pack+  , PrimStringFromListInjective   |-> primStringFromListInjective+  , PrimStringAppend              |-> mkPrimFun2 (T.append :: Text -> Text -> Text)+  , PrimStringEquality            |-> mkPrimFun2 ((==) :: Rel Text)+  , PrimShowString                |-> mkPrimFun1 (T.pack . prettyShow . LitString)+  , PrimStringUncons              |-> mkPrimFun1 T.uncons    -- Other stuff-  , "primEraseEquality"   |-> primEraseEquality+  , PrimEraseEquality     |-> primEraseEquality     -- This needs to be force : A → ((x : A) → B x) → B x rather than seq because of call-by-name.-  , "primForce"           |-> primForce-  , "primForceLemma"      |-> primForceLemma-  , "primQNameEquality"   |-> mkPrimFun2 ((==) :: Rel QName)-  , "primQNameLess"       |-> mkPrimFun2 ((<) :: Rel QName)-  , "primShowQName"       |-> mkPrimFun1 (T.pack . prettyShow :: QName -> Text)-  , "primQNameFixity"     |-> mkPrimFun1 (nameFixity . qnameName)-  , "primQNameToWord64s"  |-> mkPrimFun1 ((\ (NameId x (ModuleNameHash y)) -> (x, y)) . nameId . qnameName+  , PrimForce             |-> primForce+  , PrimForceLemma        |-> primForceLemma+  , PrimQNameEquality     |-> mkPrimFun2 ((==) :: Rel QName)+  , PrimQNameLess         |-> mkPrimFun2 ((<) :: Rel QName)+  , PrimShowQName         |-> mkPrimFun1 (T.pack . prettyShow :: QName -> Text)+  , PrimQNameFixity       |-> mkPrimFun1 (nameFixity . qnameName)+  , PrimQNameToWord64s    |-> mkPrimFun1 ((\ (NameId x (ModuleNameHash y)) -> (x, y)) . nameId . qnameName                                           :: QName -> (Word64, Word64))-  , "primQNameToWord64sInjective" |-> primQNameToWord64sInjective-  , "primMetaEquality"    |-> mkPrimFun2 ((==) :: Rel MetaId)-  , "primMetaLess"        |-> mkPrimFun2 ((<) :: Rel MetaId)-  , "primShowMeta"        |-> mkPrimFun1 (T.pack . prettyShow :: MetaId -> Text)-  , "primMetaToNat"       |-> mkPrimFun1 (fromIntegral . metaId :: MetaId -> Nat)-  , "primMetaToNatInjective" |-> primMetaToNatInjective-  , "primIMin"            |-> primIMin'-  , "primIMax"            |-> primIMax'-  , "primINeg"            |-> primINeg'-  , "primPOr"             |-> primPOr-  , "primComp"            |-> primComp-  , builtinTrans          |-> primTrans'-  , builtinHComp          |-> primHComp'-  , "primIdJ"             |-> primIdJ-  , "primPartial"         |-> primPartial'-  , "primPartialP"        |-> primPartialP'-  , builtinGlue           |-> primGlue'-  , builtin_glue          |-> prim_glue'-  , builtin_unglue        |-> prim_unglue'-  , builtinFaceForall     |-> primFaceForall'-  , "primDepIMin"         |-> primDepIMin'-  , "primIdFace"          |-> primIdFace'-  , "primIdPath"          |-> primIdPath'-  , builtinIdElim         |-> primIdElim'-  , builtinSubOut         |-> primSubOut'-  , builtin_glueU         |-> prim_glueU'-  , builtin_unglueU       |-> prim_unglueU'-  , builtinLockUniv       |-> primLockUniv'+  , PrimQNameToWord64sInjective   |-> primQNameToWord64sInjective+  , PrimMetaEquality      |-> mkPrimFun2 ((==) :: Rel MetaId)+  , PrimMetaLess          |-> mkPrimFun2 ((<) :: Rel MetaId)+  , PrimShowMeta          |-> mkPrimFun1 (T.pack . prettyShow :: MetaId -> Text)+  , PrimMetaToNat         |-> mkPrimFun1 metaToNat+  , PrimMetaToNatInjective   |-> primMetaToNatInjective++  , PrimIMin              |-> primIMin'+  , PrimIMax              |-> primIMax'+  , PrimINeg              |-> primINeg'+  , PrimPOr               |-> primPOr+  , PrimComp              |-> primComp+  , PrimTrans             |-> primTrans'+  , PrimHComp             |-> primHComp'+  , PrimPartial           |-> primPartial'+  , PrimPartialP          |-> primPartialP'+  , PrimGlue              |-> primGlue'+  , Prim_glue             |-> prim_glue'+  , Prim_unglue           |-> prim_unglue'+  , PrimFaceForall        |-> primFaceForall'+  , PrimSubOut            |-> primSubOut'+  , Prim_glueU            |-> prim_glueU'+  , Prim_unglueU          |-> prim_unglueU'+  , PrimLockUniv          |-> primLockUniv'   ]   where     (|->) = (,)
src/full/Agda/TypeChecking/Primitive.hs-boot view
@@ -1,6 +1,9 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.Primitive where  import Data.Map (Map) import Agda.TypeChecking.Monad.Base+import Agda.Syntax.Builtin (PrimitiveId) -primitiveFunctions :: Map String (TCM PrimitiveImpl)+primitiveFunctions :: Map PrimitiveId (TCM PrimitiveImpl)
src/full/Agda/TypeChecking/Primitive/Base.hs view
@@ -2,8 +2,8 @@  module Agda.TypeChecking.Primitive.Base where --- Control.Monad.Fail import is redundant since GHC 8.8.1-import Control.Monad.Fail (MonadFail)+import Control.Monad             ( mzero )+import Control.Monad.Trans.Maybe ( MaybeT(..), runMaybeT )  import qualified Data.Map as Map @@ -24,7 +24,7 @@ import Agda.Utils.Functor import Agda.Utils.Impossible import Agda.Utils.Maybe-import Agda.Utils.Pretty ( prettyShow )+import Agda.Syntax.Common.Pretty ( prettyShow )  -- Type combinators @@ -34,8 +34,8 @@  (-->), (.-->), (..-->) :: Applicative m => m Type -> m Type -> m Type a --> b = garr id a b-a .--> b = garr (const $ Irrelevant) a b-a ..--> b = garr (const $ NonStrict) a b+a .--> b = garr (const irrelevant) a b+a ..--> b = garr (const shapeIrrelevant) a b  garr :: Applicative m => (Relevance -> Relevance) -> m Type -> m Type -> m Type garr f a b = do@@ -60,29 +60,38 @@ hPi = gpi $ setHiding Hidden defaultArgInfo nPi = gpi defaultArgInfo -hPi', nPi' :: (MonadFail m, MonadAddContext m, MonadDebug m)+hPi', nPi' :: (MonadAddContext m, MonadDebug m)            => String -> NamesT m Type -> (NamesT m Term -> NamesT m Type) -> NamesT m Type-hPi' s a b = hPi s a (bind' s b)-nPi' s a b = nPi s a (bind' s b)+hPi' s a b = hPi s a (bind' s (\ x -> b x))+nPi' s a b = nPi s a (bind' s (\ x -> b x)) +{-# INLINABLE pPi' #-} pPi' :: (MonadAddContext m, HasBuiltins m, MonadDebug m)      => String -> NamesT m Term -> (NamesT m Term -> NamesT m Type) -> NamesT m Type pPi' n phi b = toFinitePi <$> nPi' n (elSSet $ cl isOne <@> phi) b  where-   toFinitePi :: Type -> Type-   toFinitePi (El s (Pi d b)) = El s $ Pi (setRelevance Irrelevant $ d { domFinite = True }) b-   toFinitePi _               = __IMPOSSIBLE__-    isOne = fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinIsOne +-- | Turn a 'Pi' type into one whose domain is annotated finite, i.e.,+-- one that represents a @Partial@ element rather than an actual+-- function.+toFinitePi :: Type -> Type+toFinitePi (El s (Pi d b)) = El s $ Pi+  (setRelevance irrelevant d{ domIsFinite = True })+  b+toFinitePi _ = __IMPOSSIBLE__+ el' :: Applicative m => m Term -> m Term -> m Type el' l a = El <$> (tmSort <$> l) <*> a +els :: Applicative m => m Sort -> m Term -> m Type+els l a = El <$> l <*> a+ el's :: Applicative m => m Term -> m Term -> m Type el's l a = El <$> (SSet . atomicLevel <$> l) <*> a  elInf :: Functor m => m Term -> m Type-elInf t = (El (Inf IsFibrant 0) <$> t)+elInf t = (El (Inf UType 0) <$> t)  elSSet :: Functor m => m Term -> m Type elSSet t = (El (SSet $ ClosedLevel 0) <$> t)@@ -107,7 +116,7 @@ (<@>),(<#>),(<..>) :: Applicative m => m Term -> m Term -> m Term (<@>) = gApply NotHidden (<#>) = gApply Hidden-(<..>) = gApply' (setRelevance Irrelevant defaultArgInfo)+(<..>) = gApply' defaultIrrelevantArgInfo  (<@@>) :: Applicative m => m Term -> (m Term,m Term,m Term) -> m Term t <@@> (x,y,r) = do@@ -132,24 +141,21 @@ el :: Functor m => m Term -> m Type el t = El (mkType 0) <$> t +-- | The universe @Set0@ as a type. tset :: Applicative m => m Type tset = pure $ sort (mkType 0) +-- | @SizeUniv@ as a sort. sSizeUniv :: Sort--- sSizeUniv = mkType 0--- Andreas, 2016-04-14 switching off SizeUniv, unfixing issue #1428 sSizeUniv = SizeUniv +-- | @SizeUniv@ as a type. tSizeUniv :: Applicative m => m Type--- tSizeUniv = tset--- Andreas, 2016-04-14 switching off SizeUniv, unfixing issue #1428--- tSizeUniv = return $ El sSizeUniv $ Sort sSizeUniv--- Andreas, 2015-03-16 Since equality checking for types--- includes equality checking for sorts, we cannot put--- SizeUniv in Setω.  (SizeUniv : Setω) == (_0 : suc _0)--- will first instantiate _0 := Setω, which is wrong. tSizeUniv = pure $ sort sSizeUniv +tLevelUniv :: Applicative m => m Type+tLevelUniv = pure $ sort $ LevelUniv+ -- | Abbreviation: @argN = 'Arg' 'defaultArgInfo'@. argN :: e -> Arg e argN = Arg defaultArgInfo@@ -168,32 +174,37 @@ -- * Accessing the primitive functions --------------------------------------------------------------------------- -lookupPrimitiveFunction :: String -> TCM PrimitiveImpl+lookupPrimitiveFunction :: PrimitiveId -> TCM PrimitiveImpl lookupPrimitiveFunction x =   fromMaybe (do-                reportSDoc "tc.prim" 20 $ "Lookup of primitive function" <+> text x <+> "failed"-                typeError $ NoSuchPrimitiveFunction x)+                reportSDoc "tc.prim" 20 $ "Lookup of primitive function" <+> pretty x <+> "failed"+                typeError $ NoSuchPrimitiveFunction (getBuiltinId x))             (Map.lookup x primitiveFunctions) -lookupPrimitiveFunctionQ :: QName -> TCM (String, PrimitiveImpl)+lookupPrimitiveFunctionQ :: QName -> TCM (PrimitiveId, PrimitiveImpl) lookupPrimitiveFunctionQ q = do   let s = prettyShow (nameCanonical $ qnameName q)-  PrimImpl t pf <- lookupPrimitiveFunction s-  return (s, PrimImpl t $ pf { primFunName = q })+  case primitiveById s of+    Nothing -> typeError $ NoSuchPrimitiveFunction s+    Just s -> do+      PrimImpl t pf <- lookupPrimitiveFunction s+      return (s, PrimImpl t $ pf { primFunName = q }) -getBuiltinName :: (HasBuiltins m, MonadReduce m) => String -> m (Maybe QName)-getBuiltinName b = do-  caseMaybeM (getBuiltin' b) (return Nothing) (Just <.> getName)-  where-  getName v = do+getBuiltinName :: (HasBuiltins m, MonadReduce m) => BuiltinId -> m (Maybe QName)+getBuiltinName b = runMaybeT $ getQNameFromTerm =<< MaybeT (getBuiltin' b)++-- | Convert a name in 'Term' form back to 'QName'.+--+getQNameFromTerm :: MonadReduce m => Term -> MaybeT m QName+getQNameFromTerm v = do     v <- reduce v-    case unSpine $ v of+    case unSpine v of       Def x _   -> return x       Con x _ _ -> return $ conName x-      Lam _ b   -> getName $ unAbs b-      _ -> __IMPOSSIBLE__+      Lam _ b   -> getQNameFromTerm $ unAbs b+      _ -> mzero -isBuiltin :: (HasBuiltins m, MonadReduce m) => QName -> String -> m Bool+isBuiltin :: (HasBuiltins m, MonadReduce m) => QName -> BuiltinId -> m Bool isBuiltin q b = (Just q ==) <$> getBuiltinName b  ------------------------------------------------------------------------@@ -223,4 +234,4 @@             , sigmaFst  = unDom fst             , sigmaSnd  = unDom snd             }-        _ -> __IMPOSSIBLE__+        _ -> __IMPOSSIBLE__  -- This invariant is ensured in bindBuiltinSigma
src/full/Agda/TypeChecking/Primitive/Cubical.hs view
@@ -1,1821 +1,1366 @@ {-# LANGUAGE NondecreasingIndentation #-} -module Agda.TypeChecking.Primitive.Cubical where--import Prelude hiding (null, (!!))--import Control.Monad-import Control.Monad.Except-import Control.Monad.Trans ( lift )--import Data.Either ( partitionEithers )-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Foldable hiding (null)--import Agda.Interaction.Options ( optCubical )--import Agda.Syntax.Common-import Agda.Syntax.Internal--import Agda.TypeChecking.Names-import Agda.TypeChecking.Primitive.Base-import Agda.TypeChecking.Monad--import Agda.TypeChecking.Free-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Telescope--import Agda.Utils.Functor-import Agda.Utils.Impossible-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Tuple---- | Checks that the correct variant of Cubical Agda is activated.--- Note that @--erased-cubical@ \"counts as\" @--cubical@ in erased--- contexts.--requireCubical-  :: Cubical -- ^ Which variant of Cubical Agda is required?-  -> String -> TCM ()-requireCubical wanted s = do-  cubical         <- optCubical <$> pragmaOptions-  inErasedContext <- hasQuantity0 <$> getEnv-  case cubical of-    Just CFull -> return ()-    Just CErased | wanted == CErased || inErasedContext -> return ()-    _ -> typeError $ GenericError $ "Missing option " ++ opt ++ s-  where-  opt = case wanted of-    CFull   -> "--cubical"-    CErased -> "--cubical or --erased-cubical"--primIntervalType :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Type-primIntervalType = El (SSet $ ClosedLevel 0) <$> primInterval--primINeg' :: TCM PrimitiveImpl-primINeg' = do-  requireCubical CErased ""-  t <- primIntervalType --> primIntervalType-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \ ts -> do-    case ts of-     [x] -> do-       unview <- intervalUnview'-       view <- intervalView'-       sx <- reduceB' x-       ix <- intervalView (unArg $ ignoreBlocking sx)-       let-         ineg :: Arg Term -> Arg Term-         ineg = fmap (unview . f . view)-         f ix = case ix of-           IZero -> IOne-           IOne  -> IZero-           IMin x y -> IMax (ineg x) (ineg y)-           IMax x y -> IMin (ineg x) (ineg y)-           INeg x -> OTerm (unArg x)-           OTerm t -> INeg (Arg defaultArgInfo t)-       case ix of-        OTerm t -> return $ NoReduction [reduced sx]-        _       -> redReturn (unview $ f ix)-     _ -> __IMPOSSIBLE__--primDepIMin' :: TCM PrimitiveImpl-primDepIMin' = do-  requireCubical CErased ""-  t <- runNamesT [] $-       nPi' "φ" primIntervalType $ \ φ ->-       pPi' "o" φ (\ o -> primIntervalType) --> primIntervalType-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 2 $ \ ts -> do-    case ts of-      [x,y] -> do-        sx <- reduceB' x-        ix <- intervalView (unArg $ ignoreBlocking sx)-        itisone <- getTerm "primDepIMin" builtinItIsOne-        case ix of-          IZero -> redReturn =<< intervalUnview IZero-          IOne  -> redReturn =<< (pure (unArg y) <@> pure itisone)-          _     -> do-            sy <- reduceB' y-            iy <- intervalView =<< reduce' =<< (pure (unArg $ ignoreBlocking sy) <@> pure itisone)-            case iy of-              IZero -> redReturn =<< intervalUnview IZero-              IOne  -> redReturn (unArg $ ignoreBlocking sx)-              _     -> return $ NoReduction [reduced sx, reduced sy]-      _      -> __IMPOSSIBLE__--primIBin :: IntervalView -> IntervalView -> TCM PrimitiveImpl-primIBin unit absorber = do-  requireCubical CErased ""-  t <- primIntervalType --> primIntervalType --> primIntervalType-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 2 $ \ ts -> do-    case ts of-     [x,y] -> do-       sx <- reduceB' x-       ix <- intervalView (unArg $ ignoreBlocking sx)-       case ix of-         ix | ix ==% absorber -> redReturn =<< intervalUnview absorber-         ix | ix ==% unit     -> return $ YesReduction YesSimplification (unArg y)-         _     -> do-           sy <- reduceB' y-           iy <- intervalView (unArg $ ignoreBlocking sy)-           case iy of-            iy | iy ==% absorber -> redReturn =<< intervalUnview absorber-            iy | iy ==% unit     -> return $ YesReduction YesSimplification (unArg x)-            _                   -> return $ NoReduction [reduced sx,reduced sy]-     _ -> __IMPOSSIBLE__-  where-    (==%) IZero IZero = True-    (==%) IOne IOne = True-    (==%) _ _ = False---primIMin' :: TCM PrimitiveImpl-primIMin' = do-  requireCubical CErased ""-  primIBin IOne IZero--primIMax' :: TCM PrimitiveImpl-primIMax' = do-  requireCubical CErased ""-  primIBin IZero IOne--imax :: HasBuiltins m => m Term -> m Term -> m Term-imax x y = do-  x' <- x-  y' <- y-  intervalUnview (IMax (argN x') (argN y'))--imin :: HasBuiltins m => m Term -> m Term -> m Term-imin x y = do-  x' <- x-  y' <- y-  intervalUnview (IMin (argN x') (argN y'))---- ∀ {a}{c}{A : Set a}{x : A}(C : ∀ y → Id x y → Set c) → C x (conid i1 (\ i → x)) → ∀ {y} (p : Id x y) → C y p-primIdJ :: TCM PrimitiveImpl-primIdJ = do-  requireCubical CErased ""-  t <- runNamesT [] $-       hPi' "a" (el $ cl primLevel) $ \ a ->-       hPi' "c" (el $ cl primLevel) $ \ c ->-       hPi' "A" (sort . tmSort <$> a) $ \ bA ->-       hPi' "x" (el' a bA) $ \ x ->-       nPi' "C" (nPi' "y" (el' a bA) $ \ y ->-                 el' a (cl primId <#> a <#> bA <@> x <@> y) --> (sort . tmSort <$> c)) $ \ bC ->-       el' c (bC <@> x <@>-            (cl primConId <#> a <#> bA <#> x <#> x <@> cl primIOne-                       <@> lam "i" (\ _ -> x))) -->-       hPi' "y" (el' a bA) (\ y ->-        nPi' "p" (el' a $ cl primId <#> a <#> bA <@> x <@> y) $ \ p ->-        el' c $ bC <@> y <@> p)-  conidn <- getBuiltinName builtinConId-  conid  <- primConId-  -- TODO make a kit-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 8 $ \ ts -> do-    unview <- intervalUnview'-    let imax x y = do x' <- x; unview . IMax (argN x') . argN <$> y;-        imin x y = do x' <- x; unview . IMin (argN x') . argN <$> y;-        ineg x = unview . INeg . argN <$> x-    mcomp <- getTerm' "primComp"-    case ts of-     [la,lc,a,x,c,d,y,eq] -> do-       seq    <- reduceB' eq-       case unArg $ ignoreBlocking $ seq of-         (Def q [Apply la,Apply a,Apply x,Apply y,Apply phi,Apply p])-           | Just q == conidn, Just comp <- mcomp -> do-          redReturn $ runNames [] $ do-             [lc,c,d,la,a,x,y,phi,p] <- mapM (open . unArg) [lc,c,d,la,a,x,y,phi,p]-             let w i = do-                   [x,y,p,i] <- sequence [x,y,p,i]-                   pure $ p `applyE` [IApply x y i]-             pure comp <#> lam "i" (\ _ -> lc)-                       <@> lam "i" (\ i ->-                              c <@> (w i)-                                <@> (pure conid <#> la <#> a <#> x <#> (w i)-                                                <@> (phi `imax` ineg i)-                                                <@> lam "j" (\ j -> w $ imin i j)))-                       <#> phi-                       <@> lam "i" (\ _ -> nolam <$> d) -- TODO block-                       <@> d-         _ -> return $ NoReduction $ map notReduced [la,lc,a,x,c,d,y] ++ [reduced seq]-     _ -> __IMPOSSIBLE__--primIdElim' :: TCM PrimitiveImpl-primIdElim' = do-  requireCubical CErased ""-  t <- runNamesT [] $-       hPi' "a" (el $ cl primLevel) $ \ a ->-       hPi' "c" (el $ cl primLevel) $ \ c ->-       hPi' "A" (sort . tmSort <$> a) $ \ bA ->-       hPi' "x" (el' a bA) $ \ x ->-       nPi' "C" (nPi' "y" (el' a bA) $ \ y ->-                 el' a (cl primId <#> a <#> bA <@> x <@> y) --> (sort . tmSort <$> c)) $ \ bC ->-       nPi' "φ" primIntervalType (\ phi ->-        nPi' "y" (el's a $ cl primSub <#> a <@> bA <@> phi <@> lam "o" (const x)) $ \ y ->-        let pathxy = (cl primPath <#> a <@> bA <@> x <@> oucy)-            oucy = (cl primSubOut <#> a <#> bA <#> phi <#> lam "o" (const x) <@> y)-            reflx = (lam "o" $ \ _ -> lam "i" $ \ _ -> x) -- TODO Andrea, should block on o-        in-        nPi' "w" (el's a $ cl primSub <#> a <@> pathxy <@> phi <@> reflx) $ \ w ->-        let oucw = (cl primSubOut <#> a <#> pathxy <#> phi <#> reflx <@> w) in-        el' c $ bC <@> oucy <@> (cl primConId <#> a <#> bA <#> x <#> oucy <@> phi <@> oucw))-       -->-       hPi' "y" (el' a bA) (\ y ->-        nPi' "p" (el' a $ cl primId <#> a <#> bA <@> x <@> y) $ \ p ->-        el' c $ bC <@> y <@> p)-  conid <- primConId-  sin <- primSubIn-  path <- primPath-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 8 $ \ ts -> do-    case ts of-      [a,c,bA,x,bC,f,y,p] -> do-        sp <- reduceB' p-        case unArg $ ignoreBlocking sp of-          Def q [Apply _a, Apply _bA, Apply _x, Apply _y, Apply phi , Apply w] -> do-            let y' = sin `apply` [a,bA                            ,phi,argN $ unArg y]-            let w' = sin `apply` [a,argN $ path `apply` [a,bA,x,y],phi,argN $ unArg w]-            redReturn $ unArg f `apply` [phi, defaultArg y', defaultArg w']-          _ -> return $ NoReduction $ map notReduced [a,c,bA,x,bC,f,y] ++ [reduced sp]-      _ -> __IMPOSSIBLE__---primPOr :: TCM PrimitiveImpl-primPOr = do-  requireCubical CErased ""-  t    <- runNamesT [] $-          hPi' "a" (el $ cl primLevel)    $ \ a  ->-          nPi' "i" primIntervalType $ \ i  ->-          nPi' "j" primIntervalType $ \ j  ->-          hPi' "A" (pPi' "o" (imax i j) $ \o -> el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->-          ((pPi' "i1" i $ \ i1 -> el' a $ bA <..> (cl primIsOne1 <@> i <@> j <@> i1))) -->-          ((pPi' "j1" j $ \ j1 -> el' a $ bA <..> (cl primIsOne2 <@> i <@> j <@> j1))) -->-          pPi' "o" (imax i j) (\ o -> el' a $ bA <..> o)-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ ts -> do-    case ts of-     [l,i,j,a,u,v] -> do-       si <- reduceB' i-       vi <- intervalView $ unArg $ ignoreBlocking si-       case vi of-        IOne -> redReturn (unArg u)-        IZero -> redReturn (unArg v)-        _ -> do-          sj <- reduceB' j-          vj <- intervalView $ unArg $ ignoreBlocking sj-          case vj of-            IOne -> redReturn (unArg v)-            IZero -> redReturn (unArg u)-            _ -> return $ NoReduction [notReduced l,reduced si,reduced sj,notReduced a,notReduced u,notReduced v]---     _ -> __IMPOSSIBLE__--primPartial' :: TCM PrimitiveImpl-primPartial' = do-  requireCubical CErased ""-  t <- runNamesT [] $-       hPi' "a" (el $ cl primLevel) (\ a ->-        nPi' "φ" primIntervalType $ \ _ ->-        nPi' "A" (sort . tmSort <$> a) $ \ bA ->-        (sort . tmSSort <$> a))-  isOne <- primIsOne-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 3 $ \ ts -> do-    case ts of-      [l,phi,a] -> do-          (El s (Pi d b)) <- runNamesT [] $ do-                             [l,a,phi] <- mapM (open . unArg) [l,a,phi]-                             elSSet (pure isOne <@> phi) --> el' l a-          redReturn $ Pi (setRelevance Irrelevant $ d { domFinite = True }) b-      _ -> __IMPOSSIBLE__--primPartialP' :: TCM PrimitiveImpl-primPartialP' = do-  requireCubical CErased ""-  t <- runNamesT [] $-       hPi' "a" (el $ cl primLevel) (\ a ->-        nPi' "φ" primIntervalType $ \ phi ->-        nPi' "A" (pPi' "o" phi $ \ _ -> el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->-        (sort . tmSSort <$> a))-  let toFinitePi :: Type -> Term-      toFinitePi (El _ (Pi d b)) = Pi (setRelevance Irrelevant $ d { domFinite = True }) b-      toFinitePi _               = __IMPOSSIBLE__-  v <- runNamesT [] $-        lam "a" $ \ l ->-        lam "φ" $ \ phi ->-        lam "A" $ \ a ->-        toFinitePi <$> nPi' "p" (elSSet $ cl primIsOne <@> phi) (\ p -> el' l (a <@> p))-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \ _ -> redReturn v--primSubOut' :: TCM PrimitiveImpl-primSubOut' = do-  requireCubical CErased ""-  t    <- runNamesT [] $-          hPi' "a" (el $ cl primLevel) $ \ a ->-          hPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->-          hPi' "φ" primIntervalType $ \ phi ->-          hPi' "u" (el's a $ cl primPartial <#> a <@> phi <@> bA) $ \ u ->-          el's a (cl primSub <#> a <@> bA <@> phi <@> u) --> el' a bA-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ ts -> do-    case ts of-      [a,bA,phi,u,x] -> do-        view <- intervalView'-        sphi <- reduceB' phi-        case view $ unArg $ ignoreBlocking sphi of-          IOne -> redReturn =<< (return (unArg u) <..> (getTerm builtinSubOut builtinItIsOne))-          _ -> do-            sx <- reduceB' x-            mSubIn <- getBuiltinName' builtinSubIn-            case unArg $ ignoreBlocking $ sx of-              Def q [_,_,_, Apply t] | Just q == mSubIn -> redReturn (unArg t)-              _ -> return $ NoReduction $ map notReduced [a,bA] ++ [reduced sphi, notReduced u, reduced sx]-      _ -> __IMPOSSIBLE__--primIdFace' :: TCM PrimitiveImpl-primIdFace' = do-  requireCubical CErased ""-  t <- runNamesT [] $-       hPi' "a" (el $ cl primLevel) $ \ a ->-       hPi' "A" (sort . tmSort <$> a) $ \ bA ->-       hPi' "x" (el' a bA) $ \ x ->-       hPi' "y" (el' a bA) $ \ y ->-       el' a (cl primId <#> a <#> bA <@> x <@> y)-       --> primIntervalType-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ ts -> do-    case ts of-      [l,bA,x,y,t] -> do-        st <- reduceB' t-        mConId <- getName' builtinConId-        case unArg (ignoreBlocking st) of-          Def q [_,_,_,_, Apply phi,_] | Just q == mConId -> redReturn (unArg phi)-          _ -> return $ NoReduction $ map notReduced [l,bA,x,y] ++ [reduced st]-      _ -> __IMPOSSIBLE__--primIdPath' :: TCM PrimitiveImpl-primIdPath' = do-  requireCubical CErased ""-  t <- runNamesT [] $-       hPi' "a" (el $ cl primLevel) $ \ a ->-       hPi' "A" (sort . tmSort <$> a) $ \ bA ->-       hPi' "x" (el' a bA) $ \ x ->-       hPi' "y" (el' a bA) $ \ y ->-       el' a (cl primId <#> a <#> bA <@> x <@> y)-       --> el' a (cl primPath <#> a <#> bA <@> x <@> y)-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ ts -> do-    case ts of-      [l,bA,x,y,t] -> do-        st <- reduceB' t-        mConId <- getName' builtinConId-        case unArg (ignoreBlocking st) of-          Def q [_,_,_,_,_,Apply w] | Just q == mConId -> redReturn (unArg w)-          _ -> return $ NoReduction $ map notReduced [l,bA,x,y] ++ [reduced st]-      _ -> __IMPOSSIBLE__---primTrans' :: TCM PrimitiveImpl-primTrans' = do-  requireCubical CErased ""-  t    <- runNamesT [] $-          hPi' "a" (primIntervalType --> el (cl primLevel)) $ \ a ->-          nPi' "A" (nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA ->-          nPi' "φ" primIntervalType $ \ phi ->-          (el' (a <@> cl primIZero) (bA <@> cl primIZero) --> el' (a <@> cl primIOne) (bA <@> cl primIOne))-  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 4 $ \ ts nelims -> do-    primTransHComp DoTransp ts nelims--primHComp' :: TCM PrimitiveImpl-primHComp' = do-  requireCubical CErased ""-  t    <- runNamesT [] $-          hPi' "a" (el $ cl primLevel) $ \ a ->-          hPi' "A" (sort . tmSort <$> a) $ \ bA ->-          hPi' "φ" primIntervalType $ \ phi ->-          nPi' "i" primIntervalType (\ i -> pPi' "o" phi $ \ _ -> el' a bA) -->-          (el' a bA --> el' a bA)-  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 5 $ \ ts nelims -> do-    primTransHComp DoHComp ts nelims--data TranspOrHComp = DoTransp | DoHComp deriving (Eq,Show)--cmdToName :: TranspOrHComp -> String-cmdToName DoTransp = builtinTrans-cmdToName DoHComp  = builtinHComp--data FamilyOrNot a-  = IsFam { famThing :: a }-  | IsNot { famThing :: a }-  deriving (Eq,Show,Functor,Foldable,Traversable)--instance Reduce a => Reduce (FamilyOrNot a) where-  reduceB' x = traverse id <$> traverse reduceB' x-  reduce' x = traverse reduce' x----- | Define a "ghcomp" version of gcomp. Normal comp looks like:------ comp^i A [ phi -> u ] u0 = hcomp^i A(1/i) [ phi -> forward A i u ] (forward A 0 u0)------ So for "gcomp" we compute:------ gcomp^i A [ phi -> u ] u0 = hcomp^i A(1/i) [ phi -> forward A i u, ~ phi -> forward A 0 u0 ] (forward A 0 u0)------ The point of this is that gcomp does not produce any empty--- systems (if phi = 0 it will reduce to "forward A 0 u".-mkGComp :: HasBuiltins m => String -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term)-mkGComp s = do-  let getTermLocal = getTerm s-  tPOr <- getTermLocal "primPOr"-  tIMax <- getTermLocal builtinIMax-  tIMin <- getTermLocal builtinIMin-  tINeg <- getTermLocal builtinINeg-  tHComp <- getTermLocal builtinHComp-  tTrans <- getTermLocal builtinTrans-  io      <- getTermLocal builtinIOne-  iz      <- getTermLocal builtinIZero-  let ineg j = pure tINeg <@> j-      imax i j = pure tIMax <@> i <@> j-  let forward la bA r u = pure tTrans <#> lam "i" (\ i -> la <@> (i `imax` r))-                                      <@> lam "i" (\ i -> bA <@> (i `imax` r))-                                      <@> r-                                      <@> u-  return $ \ la bA phi u u0 ->-    pure tHComp <#> (la <@> pure io)-                <#> (bA <@> pure io)-                <#> imax phi (ineg phi)-                <@> lam "i" (\ i ->-                      pure tPOr <#> (la <@> i)-                                <@> phi-                                <@> ineg phi-                                <@> ilam "o" (\ a -> bA <@> i)-                                <@> ilam "o" (\ o -> forward la bA i (u <@> i <..> o))-                                <@> ilam "o" (\ o -> forward la bA (pure iz) u0))-                <@> forward la bA (pure iz) u0---unglueTranspGlue :: PureTCM m =>-                  Arg Term-                  -> Arg Term-                  -> FamilyOrNot-                       (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)-                  -> m Term--- ...    |- psi, u0--- ..., i |- la, lb, bA, phi, bT, e-unglueTranspGlue psi u0 (IsFam (la, lb, bA, phi, bT, e)) = do-      let-        localUse = builtinTrans ++ " for " ++ builtinGlue-        getTermLocal = getTerm localUse-      tPOr <- getTermLocal "primPOr"-      tIMax <- getTermLocal builtinIMax-      tIMin <- getTermLocal builtinIMin-      tINeg <- getTermLocal builtinINeg-      tHComp <- getTermLocal builtinHComp-      tTrans <- getTermLocal builtinTrans-      tForall  <- getTermLocal builtinFaceForall-      tEFun  <- getTermLocal builtinEquivFun-      tEProof <- getTermLocal builtinEquivProof-      tglue   <- getTermLocal builtin_glue-      tunglue <- getTermLocal builtin_unglue-      io      <- getTermLocal builtinIOne-      iz      <- getTermLocal builtinIZero-      tLMax   <- getTermLocal builtinLevelMax-      tPath   <- getTermLocal builtinPath-      tTransp <- getTermLocal builtinTranspProof-      tItIsOne <- getTermLocal builtinItIsOne-      kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit-      runNamesT [] $ do-        let ineg j = pure tINeg <@> j-            imax i j = pure tIMax <@> i <@> j-            imin i j = pure tIMin <@> i <@> j--        gcomp <- mkGComp localUse--        let transpFill la bA phi u0 i =-              pure tTrans <#> ilam "j" (\ j -> la <@> imin i j)-                          <@> ilam "j" (\ j -> bA <@> imin i j)-                          <@> (imax phi (ineg i))-                          <@> u0-        [psi,u0] <- mapM (open . unArg) [psi,u0]--        -- glue1 t a = glue la[i1/i] lb[i1/i] bA[i1/i] phi[i1/i] bT[i1/i] e[i1/i] t a-        glue1 <- do-          g <- open $ (tglue `apply`) . map ((setHiding Hidden) . (subst 0 io)) $ [la, lb, bA, phi, bT, e]-          return $ \ t a -> g <@> t <@> a--        [la, lb, bA, phi, bT, e] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [la, lb, bA, phi, bT, e]--        -- Andreas, 2022-03-24, fixing #5838-        -- Following the updated note-        ---        --   Simon Huber, A Cubical Type Theory for Higher Inductive Types-        --   https://simhu.github.io/misc/hcomp.pdf (February 2022)-        ---        -- See: https://github.com/agda/agda/issues/5755#issuecomment-1043797776--        -- unglue_u0 i = unglue la[i/i] lb[i/i] bA[i/i] phi[i/i] bT[i/i] e[i/i] u0-        let unglue_u0 i =-              foldl (<#>) (pure tunglue) (map (<@> i) [la, lb, bA, phi, bT, e]) <@> u0--        view <- intervalView'--        let-          tf i o = transpFill lb (lam "i" $ \ i -> bT <@> i <..> o) psi u0 i-          t1 o = tf (pure io) o--          -- compute "forall. phi"-          forallphi = pure tForall <@> phi--          -- a1 with gcomp-          a1 = gcomp la bA-                 (imax psi forallphi)-                 (lam "i" $ \ i -> pure tPOr <#> (la <@> i)-                                             <@> psi-                                             <@> forallphi-                                             <@> ilam "o" (\ a -> bA <@> i)-                                             <@> ilam "o" (\ _ -> unglue_u0 i)-                                             <@> ilam "o" (\ o -> pure tEFun <#> (lb <@> i)-                                                                               <#> (la <@> i)-                                                                               <#> (bT <@> i <..> o)-                                                                               <#> (bA <@> i)-                                                                               <@> (e <@> i <..> o)-                                                                               <@> (tf i o)))-                 (unglue_u0 (pure iz))--          max l l' = pure tLMax <@> l <@> l'-          sigCon x y = pure (Con (sigmaCon kit) ConOSystem []) <@> x <@> y-          w i o = pure tEFun <#> (lb <@> i)-                             <#> (la <@> i)-                             <#> (bT <@> i <..> o)-                             <#> (bA <@> i)-                             <@> (e <@> i <..> o)-          fiber la lb bA bB f b =-            (pure (Def (sigmaName kit) []) <#> la-                                           <#> lb-                                           <@> bA-                                           <@> lam "a" (\ a -> pure tPath <#> lb <#> bB <@> (f <@> a) <@> b))--          -- We don't have to do anything special for "~ forall. phi"-          -- here (to implement "ghcomp") as it is taken care off by-          -- tEProof in t1'alpha below-          pe o = -- o : [ φ 1 ]-            pure tPOr <#> max (la <@> pure io) (lb <@> pure io)-                      <@> psi-                      <@> forallphi-                      <@> ilam "o" (\ _ ->-                             fiber (lb <@> pure io) (la <@> pure io)-                                   (bT <@> (pure io) <..> o) (bA <@> pure io)-                                   (w (pure io) o) a1)-                      <@> ilam "o" (\ o -> sigCon u0 (lam "_" $ \ _ -> a1))-                      <@> ilam "o" (\ o -> sigCon (t1 o) (lam "_" $ \ _ -> a1))--          -- "ghcomp" is implemented in the proof of tEProof-          -- (see src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda)-          t1'alpha o = -- o : [ φ 1 ]-             pure tEProof <#> (lb <@> pure io)-                          <#> (la <@> pure io)-                          <@> (bT <@> pure io <..> o)-                          <@> (bA <@> pure io)-                          <@> (e <@> pure io <..> o)-                          <@> a1-                          <@> (imax psi forallphi)-                          <@> pe o--          -- TODO: optimize?-          t1' o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaFst kit)])-          alpha o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaSnd kit)])-          a1' = pure tHComp-                  <#> (la <@> pure io)-                  <#> (bA <@> pure io)-                  <#> (imax (phi <@> pure io) psi)-                  <@> lam "j" (\ j ->-                         pure tPOr <#> (la <@> pure io) <@> (phi <@> pure io) <@> psi <@> ilam "o" (\ _ -> bA <@> pure io)-                                   <@> ilam "o" (\ o -> alpha o <@@> (w (pure io) o <@> t1' o,a1,j))-                                   <@> ilam "o" (\ _ -> a1))-                  <@> a1-        -- glue1 (ilam "o" t1') a1'-        a1'-unglueTranspGlue _ _ _ = __IMPOSSIBLE__--data TermPosition = Head | Eliminated deriving (Eq,Show)--headStop :: PureTCM m => TermPosition -> m Term -> m Bool-headStop tpos phi-  | Head <- tpos = do-      phi <- intervalView =<< (reduce =<< phi)-      return $ not $ isIOne phi-  | otherwise = return False--compGlue :: PureTCM m =>-                  TranspOrHComp-                  -> Arg Term-                  -> Maybe (Arg Term)-                  -> Arg Term-                  -> FamilyOrNot-                       (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)-                  -> TermPosition-                  -> m (Maybe Term)-compGlue DoHComp psi (Just u) u0 (IsNot (la, lb, bA, phi, bT, e)) tpos = do-      let getTermLocal = getTerm $ (builtinHComp ++ " for " ++ builtinGlue)-      tPOr <- getTermLocal "primPOr"-      tIMax <- getTermLocal builtinIMax-      tIMin <- getTermLocal builtinIMin-      tINeg <- getTermLocal builtinINeg-      tHComp <- getTermLocal builtinHComp-      tEFun  <- getTermLocal builtinEquivFun-      tglue   <- getTermLocal builtin_glue-      tunglue <- getTermLocal builtin_unglue-      io      <- getTermLocal builtinIOne-      tItIsOne <- getTermLocal builtinItIsOne-      view <- intervalView'-      runNamesT [] $ do-        [psi, u, u0] <- mapM (open . unArg) [psi, u, u0]-        [la, lb, bA, phi, bT, e] <- mapM (open . unArg) [la, lb, bA, phi, bT, e]-        ifM (headStop tpos phi) (return Nothing) $ Just <$> do--        let-          hfill la bA phi u u0 i = pure tHComp <#> la-                                               <#> bA-                                               <#> (pure tIMax <@> phi <@> (pure tINeg <@> i))-                                               <@> lam "j" (\ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <@> ilam "o" (\ a -> bA)-                                                     <@> ilam "o" (\ o -> u <@> (pure tIMin <@> i <@> j) <..> o)-                                                     <@> ilam "o" (\ _ -> u0))-                                               <@> u0-          tf i o = hfill lb (bT <..> o) psi u u0 i-          unglue g = pure tunglue <#> la <#> lb <#> bA <#> phi <#> bT <#> e <@> g-          a1 = pure tHComp <#> la <#> bA <#> (pure tIMax <@> psi <@> phi)-                           <@> lam "i" (\ i -> pure tPOr <#> la <@> psi <@> phi <@> ilam "_" (\ _ -> bA)-                                 <@> ilam "o" (\ o -> unglue (u <@> i <..> o))-                                 <@> ilam "o" (\ o -> pure tEFun <#> lb <#> la <#> (bT <..> o) <#> bA <@> (e <..> o) <@> tf i o))-                           <@> (unglue u0)-          t1 = tf (pure io)-        -- pure tglue <#> la <#> lb <#> bA <#> phi <#> bT <#> e <@> (ilam "o" $ \ o -> t1 o) <@> a1-        case tpos of-          Head -> t1 (pure tItIsOne)-          Eliminated -> a1---- ...    |- psi, u0--- ..., i |- la, lb, bA, phi, bT, e-compGlue DoTransp psi Nothing u0 (IsFam (la, lb, bA, phi, bT, e)) tpos = do-      let-        localUse = builtinTrans ++ " for " ++ builtinGlue-        getTermLocal = getTerm localUse-      tPOr <- getTermLocal "primPOr"-      tIMax <- getTermLocal builtinIMax-      tIMin <- getTermLocal builtinIMin-      tINeg <- getTermLocal builtinINeg-      tHComp <- getTermLocal builtinHComp-      tTrans <- getTermLocal builtinTrans-      tForall  <- getTermLocal builtinFaceForall-      tEFun  <- getTermLocal builtinEquivFun-      tEProof <- getTermLocal builtinEquivProof-      tglue   <- getTermLocal builtin_glue-      tunglue <- getTermLocal builtin_unglue-      io      <- getTermLocal builtinIOne-      iz      <- getTermLocal builtinIZero-      tLMax   <- getTermLocal builtinLevelMax-      tPath   <- getTermLocal builtinPath-      tTransp <- getTermLocal builtinTranspProof-      tItIsOne <- getTermLocal builtinItIsOne-      kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit-      runNamesT [] $ do-        let ineg j = pure tINeg <@> j-            imax i j = pure tIMax <@> i <@> j-            imin i j = pure tIMin <@> i <@> j--        gcomp <- mkGComp localUse--        let transpFill la bA phi u0 i =-              pure tTrans <#> ilam "j" (\ j -> la <@> imin i j)-                          <@> ilam "j" (\ j -> bA <@> imin i j)-                          <@> (imax phi (ineg i))-                          <@> u0-        [psi,u0] <- mapM (open . unArg) [psi,u0]--        -- glue1 t a = glue la[i1/i] lb[i1/i] bA[i1/i] phi[i1/i] bT[i1/i] e[i1/i] t a-        glue1 <- do-          g <- open $ (tglue `apply`) . map ((setHiding Hidden) . (subst 0 io)) $ [la, lb, bA, phi, bT, e]-          return $ \ t a -> g <@> t <@> a--        [la, lb, bA, phi, bT, e] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [la, lb, bA, phi, bT, e]--        -- Andreas, 2022-03-24, fixing #5838-        -- Following the updated note-        ---        --   Simon Huber, A Cubical Type Theory for Higher Inductive Types-        --   https://simhu.github.io/misc/hcomp.pdf (February 2022)-        ---        -- See: https://github.com/agda/agda/issues/5755#issuecomment-1043797776--        -- unglue_u0 i = unglue la[i/i] lb[i/i] bA[i/i] phi[i/i] bT[i/i] e[i/e] u0-        let unglue_u0 i =-              foldl (<#>) (pure tunglue) (map (<@> i) [la, lb, bA, phi, bT, e]) <@> u0--        view <- intervalView'--        ifM (headStop tpos (phi <@> pure io)) (return Nothing) $ Just <$> do-        let-          tf i o = transpFill lb (lam "i" $ \ i -> bT <@> i <..> o) psi u0 i-          t1 o = tf (pure io) o--          -- compute "forall. phi"-          forallphi = pure tForall <@> phi--          -- a1 with gcomp-          a1 = gcomp la bA-                 (imax psi forallphi)-                 (lam "i" $ \ i -> pure tPOr <#> (la <@> i)-                                             <@> psi-                                             <@> forallphi-                                             <@> ilam "o" (\ _ -> bA <@> i)-                                             <@> ilam "o" (\ _ -> unglue_u0 i)-                                             <@> ilam "o" (\ o -> pure tEFun <#> (lb <@> i)-                                                                               <#> (la <@> i)-                                                                               <#> (bT <@> i <..> o)-                                                                               <#> (bA <@> i)-                                                                               <@> (e <@> i <..> o)-                                                                               <@> (tf i o)))-                 (unglue_u0 (pure iz))--          max l l' = pure tLMax <@> l <@> l'-          sigCon x y = pure (Con (sigmaCon kit) ConOSystem []) <@> x <@> y-          w i o = pure tEFun <#> (lb <@> i)-                             <#> (la <@> i)-                             <#> (bT <@> i <..> o)-                             <#> (bA <@> i)-                             <@> (e <@> i <..> o)-          fiber la lb bA bB f b =-            (pure (Def (sigmaName kit) []) <#> la-                                           <#> lb-                                           <@> bA-                                           <@> lam "a" (\ a -> pure tPath <#> lb <#> bB <@> (f <@> a) <@> b))--          -- We don't have to do anything special for "~ forall. phi"-          -- here (to implement "ghcomp") as it is taken care off by-          -- tEProof in t1'alpha below-          pe o = -- o : [ φ 1 ]-            pure tPOr <#> max (la <@> pure io) (lb <@> pure io)-                      <@> psi-                      <@> forallphi-                      <@> ilam "o" (\ _ ->-                             fiber (lb <@> pure io) (la <@> pure io)-                                   (bT <@> (pure io) <..> o) (bA <@> pure io)-                                   (w (pure io) o) a1)-                      <@> ilam "o" (\ o -> sigCon u0 (lam "_" $ \ _ -> a1))-                      <@> ilam "o" (\ o -> sigCon (t1 o) (lam "_" $ \ _ -> a1))--          -- "ghcomp" is implemented in the proof of tEProof-          -- (see src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda)-          t1'alpha o = -- o : [ φ 1 ]-             pure tEProof <#> (lb <@> pure io)-                          <#> (la <@> pure io)-                          <@> (bT <@> pure io <..> o)-                          <@> (bA <@> pure io)-                          <@> (e <@> pure io <..> o)-                          <@> a1-                          <@> (imax psi forallphi)-                          <@> pe o--          -- TODO: optimize?-          t1' o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaFst kit)])-          alpha o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaSnd kit)])-          a1' = pure tHComp-                  <#> (la <@> pure io)-                  <#> (bA <@> pure io)-                  <#> (imax (phi <@> pure io) psi)-                  <@> lam "j" (\ j ->-                         pure tPOr <#> (la <@> pure io) <@> (phi <@> pure io) <@> psi <@> ilam "o" (\ _ -> bA <@> pure io)-                                   <@> ilam "o" (\ o -> alpha o <@@> (w (pure io) o <@> t1' o,a1,j))-                                   <@> ilam "o" (\ _ -> a1))-                  <@> a1--        -- glue1 (ilam "o" t1') a1'-        case tpos of-          Head -> t1' (pure tItIsOne)-          Eliminated -> a1'-compGlue cmd phi u u0 _ _ = __IMPOSSIBLE__--compHCompU :: PureTCM m =>-                    TranspOrHComp-                    -> Arg Term-                    -> Maybe (Arg Term)-                    -> Arg Term-                    -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)-                    -> TermPosition-                    -> m (Maybe Term)--compHCompU DoHComp psi (Just u) u0 (IsNot (la, phi, bT, bA)) tpos = do-      let getTermLocal = getTerm $ (builtinHComp ++ " for " ++ builtinHComp ++ " of Set")-      io      <- getTermLocal builtinIOne-      iz      <- getTermLocal builtinIZero-      tPOr <- getTermLocal "primPOr"-      tIMax <- getTermLocal builtinIMax-      tIMin <- getTermLocal builtinIMin-      tINeg <- getTermLocal builtinINeg-      tHComp <- getTermLocal builtinHComp-      tTransp  <- getTermLocal builtinTrans-      tglue   <- getTermLocal builtin_glueU-      tunglue <- getTermLocal builtin_unglueU-      tLSuc   <- getTermLocal builtinLevelSuc-      tSubIn <- getTermLocal builtinSubIn-      tItIsOne <- getTermLocal builtinItIsOne-      runNamesT [] $ do-        [psi, u, u0] <- mapM (open . unArg) [psi, u, u0]-        [la, phi, bT, bA] <- mapM (open . unArg) [la, phi, bT, bA]--        ifM (headStop tpos phi) (return Nothing) $ Just <$> do--        let-          hfill la bA phi u u0 i = pure tHComp <#> la-                                               <#> bA-                                               <#> (pure tIMax <@> phi <@> (pure tINeg <@> i))-                                               <@> lam "j" (\ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <@> ilam "o" (\ a -> bA)-                                                     <@> ilam "o" (\ o -> u <@> (pure tIMin <@> i <@> j) <..> o)-                                                     <@> ilam "o" (\ _ -> u0))-                                               <@> u0-          transp la bA a0 = pure tTransp <#> lam "i" (const la) <@> lam "i" bA <@> pure iz <@> a0-          tf i o = hfill la (bT <@> pure io <..> o) psi u u0 i-          bAS = pure tSubIn <#> (pure tLSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <@> bA-          unglue g = pure tunglue <#> la <#> phi <#> bT <#> bAS <@> g-          a1 = pure tHComp <#> la <#> bA <#> (pure tIMax <@> psi <@> phi)-                           <@> lam "i" (\ i -> pure tPOr <#> la <@> psi <@> phi <@> ilam "_" (\ _ -> bA)-                                 <@> ilam "o" (\ o -> unglue (u <@> i <..> o))-                                 <@> ilam "o" (\ o -> transp la (\ i -> bT <@> (pure tINeg <@> i) <..> o) (tf i o)))-                           <@> unglue u0-          t1 = tf (pure io)--        -- pure tglue <#> la <#> phi <#> bT <#> bAS <@> (ilam "o" $ \ o -> t1 o) <@> a1-        case tpos of-          Eliminated -> a1-          Head       -> t1 (pure tItIsOne)----compHCompU DoTransp psi Nothing u0 (IsFam (la, phi, bT, bA)) tpos = do-      let-        localUse = builtinTrans ++ " for " ++ builtinHComp ++ " of Set"-        getTermLocal = getTerm localUse-      tPOr <- getTermLocal "primPOr"-      tIMax <- getTermLocal builtinIMax-      tIMin <- getTermLocal builtinIMin-      tINeg <- getTermLocal builtinINeg-      tHComp <- getTermLocal builtinHComp-      tTrans <- getTermLocal builtinTrans-      tTranspProof <- getTermLocal builtinTranspProof-      tSubIn <- getTermLocal builtinSubIn-      tForall  <- getTermLocal builtinFaceForall-      io      <- getTermLocal builtinIOne-      iz      <- getTermLocal builtinIZero-      tLSuc   <- getTermLocal builtinLevelSuc-      tPath   <- getTermLocal builtinPath-      tItIsOne   <- getTermLocal builtinItIsOne-      kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit-      runNamesT [] $ do-        let ineg j = pure tINeg <@> j-            imax i j = pure tIMax <@> i <@> j-            imin i j = pure tIMin <@> i <@> j-            transp la bA a0 = pure tTrans <#> lam "i" (const la) <@> lam "i" bA <@> pure iz <@> a0--        gcomp <- mkGComp localUse--        let transpFill la bA phi u0 i =-              pure tTrans <#> ilam "j" (\ j -> la <@> imin i j)-                          <@> ilam "j" (\ j -> bA <@> imin i j)-                          <@> (imax phi (ineg i))-                          <@> u0-        [psi,u0] <- mapM (open . unArg) [psi,u0]-        glue1 <- do-          tglue   <- cl $ getTermLocal builtin_glueU-          [la, phi, bT, bA] <- mapM (open . unArg . subst 0 io) $ [la, phi, bT, bA]-          let bAS = pure tSubIn <#> (pure tLSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <@> bA-          g <- (open =<<) $ pure tglue <#> la <#> phi <#> bT <#> bAS-          return $ \ t a -> g <@> t <@> a--        [la, phi, bT, bA] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [la, phi, bT, bA]--        -- Andreas, 2022-03-25, issue #5838.-        -- Port the fix of @unglueTranspGlue@ and @compGlue DoTransp@-        -- also to @compHCompU DoTransp@, as suggested by Tom Jack and Anders Mörtberg.-        -- We define @unglue_u0 i@ that is first used with @i@ and then with @i0@.-        -- The original code used it only with @i0@.-        tunglue <- cl $ getTermLocal builtin_unglueU-        let bAS i =-              pure tSubIn  <#> (pure tLSuc <@> (la <@> i))-                           <#> (Sort . tmSort <$> (la <@> i))-                           <#> (phi <@> i)-                           <@> (bA <@> i)-        let unglue_u0 i =-              pure tunglue <#> (la <@> i)-                           <#> (phi <@> i)-                           <#> (bT <@> i)-                           <#> bAS i-                           <@> u0--        ifM (headStop tpos (phi <@> pure io)) (return Nothing) $ Just <$> do--        let-          lb = la-          tf i o = transpFill lb (lam "i" $ \ i -> bT <@> i <@> pure io <..> o) psi u0 i-          t1 o = tf (pure io) o--          -- compute "forall. phi"-          forallphi = pure tForall <@> phi--          -- a1 with gcomp-          a1 = gcomp la bA-                 (imax psi forallphi)-                 (lam "i" $ \ i -> pure tPOr <#> (la <@> i)-                                             <@> psi-                                             <@> forallphi-                                             <@> ilam "o" (\ _ -> bA <@> i)-                                             <@> ilam "o" (\ _ -> unglue_u0 i)-                                             <@> ilam "o" (\ o -> transp (la <@> i)-                                                                           (\ j -> bT <@> i <@> ineg j <..> o)-                                                                           (tf i o)))-                 (unglue_u0 (pure iz))--          w i o = lam "x" $-                  transp (la <@> i)-                         (\ j -> bT <@> i <@> ineg j <..> o)--          pt o = -- o : [ φ 1 ]-            pure tPOr <#> (la <@> pure io)-                      <@> psi-                      <@> forallphi-                      <@> ilam "o" (\ _ -> bT <@> pure io <@> pure io <..> o)-                      <@> ilam "o" (\ o -> u0)-                      <@> ilam "o" (\ o -> t1 o)--          -- "ghcomp" is implemented in the proof of tTranspProof-          -- (see src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda)-          t1'alpha o = -- o : [ φ 1 ]-             pure tTranspProof <#> (la <@> pure io)-                               <@> lam "i" (\ i -> bT <@> pure io <@> ineg i <..> o)-                               <@> imax psi forallphi-                               <@> pt o-                               <@> (pure tSubIn <#> (la <@> pure io) <#> (bA <@> pure io)-                                                <#> imax psi forallphi-                                                <@> a1)--          -- TODO: optimize?-          t1' o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaFst kit)])-          alpha o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaSnd kit)])-          a1' = pure tHComp-                  <#> (la <@> pure io)-                  <#> (bA <@> pure io)-                  <#> (imax (phi <@> pure io) psi)-                  <@> lam "j" (\ j ->-                         pure tPOr <#> (la <@> pure io) <@> (phi <@> pure io) <@> psi <@> ilam "o" (\ _ -> bA <@> pure io)-                                   <@> ilam "o" (\ o -> alpha o <@@> (w (pure io) o <@> t1' o,a1,j))-                                   <@> ilam "o" (\ _ -> a1))-                  <@> a1--        -- glue1 (ilam "o" t1') a1'-        case tpos of-          Eliminated -> a1'-          Head       -> t1' (pure tItIsOne)-compHCompU _ psi _ u0 _ _ = __IMPOSSIBLE__---primTransHComp :: TranspOrHComp -> [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term)-primTransHComp cmd ts nelims = do-  (l,bA,phi,u,u0) <- case (cmd,ts) of-        (DoTransp, [l,bA,phi,  u0]) -> do-          -- u <- runNamesT [] $ do-          --       u0 <- open $ unArg u0-          --       defaultArg <$> (ilam "o" $ \ _ -> u0)-          return $ (IsFam l,IsFam bA,phi,Nothing,u0)-        (DoHComp, [l,bA,phi,u,u0]) -> do-          -- [l,bA] <- runNamesT [] $ do-          --   forM [l,bA] $ \ a -> do-          --     let info = argInfo a-          --     a <- open $ unArg a-          --     Arg info <$> (lam "i" $ \ _ -> a)-          return $ (IsNot l,IsNot bA,phi,Just u,u0)-        _                          -> __IMPOSSIBLE__-  sphi <- reduceB' phi-  vphi <- intervalView $ unArg $ ignoreBlocking sphi-  let clP s = getTerm (cmdToName cmd) s--  -- WORK-  case vphi of-     IOne -> redReturn =<< case u of-                            -- cmd == DoComp-                            Just u -> runNamesT [] $ do-                                       u <- open (unArg u)-                                       u <@> clP builtinIOne <..> clP builtinItIsOne-                            -- cmd == DoTransp-                            Nothing -> return $ unArg u0-     _    -> do-       let fallback' sc = do-             u' <- case u of-                            -- cmd == DoComp-                     Just u ->-                              (:[]) <$> case vphi of-                                          IZero -> fmap (reduced . notBlocked . argN) . runNamesT [] $ do-                                            [l,c] <- mapM (open . unArg) [famThing l, ignoreBlocking sc]-                                            lam "i" $ \ i -> clP builtinIsOneEmpty <#> l-                                                                   <#> ilam "o" (\ _ -> c)-                                          _     -> return (notReduced u)-                            -- cmd == DoTransp-                     Nothing -> return []-             return $ NoReduction $ [notReduced (famThing l), reduced sc, reduced sphi] ++ u' ++ [notReduced u0]-       sbA <- reduceB' bA-       t <- case unArg <$> ignoreBlocking sbA of-              IsFam (Lam _info t) -> Just . fmap IsFam <$> reduceB' (absBody t)-              IsFam _             -> return Nothing-              IsNot t             -> return . Just . fmap IsNot $ (t <$ sbA)-       case t of-         Nothing -> fallback' (famThing <$> sbA)-         Just st  -> do-               let-                   fallback = fallback' (fmap famThing $ st *> sbA)-                   t = ignoreBlocking st-               mHComp <- getPrimitiveName' builtinHComp-               mGlue <- getPrimitiveName' builtinGlue-               mId   <- getBuiltinName' builtinId-               pathV <- pathView'-               case famThing t of-                 MetaV m _ -> fallback' (fmap famThing $ blocked_ m *> sbA)-                 -- absName t instead of "i"-                 Pi a b | nelims > 0  -> maybe fallback redReturn =<< compPi cmd "i" ((a,b) <$ t) (ignoreBlocking sphi) u u0-                        | otherwise -> fallback--                 Sort (Type l) | DoTransp <- cmd -> compSort cmd fallback phi u u0 (l <$ t)--                 Def q [Apply la, Apply lb, Apply bA, Apply phi', Apply bT, Apply e] | Just q == mGlue -> do-                   maybe fallback redReturn =<< compGlue cmd phi u u0 ((la, lb, bA, phi', bT, e) <$ t) Head--                 Def q [Apply _, Apply s, Apply phi', Apply bT, Apply bA]-                   | Just q == mHComp, Sort (Type la) <- unArg s  -> do-                   maybe fallback redReturn =<< compHCompU cmd phi u u0 ((Level la <$ s, phi', bT, bA) <$ t) Head--                 -- Path/PathP-                 d | PathType _ _ _ bA x y <- pathV (El __DUMMY_SORT__ d) -> do-                   if nelims > 0 then compPathP cmd sphi u u0 l ((bA, x, y) <$ t) else fallback--                 Def q [Apply _ , Apply bA , Apply x , Apply y] | Just q == mId -> do-                   maybe fallback return =<< compId cmd sphi u u0 l ((bA, x, y) <$ t)--                 Def q es -> do-                   info <- getConstInfo q-                   let   lam_i = Lam defaultArgInfo . Abs "i"--                   case theDef info of-                     r@Record{recComp = kit} | nelims > 0, Just as <- allApplyElims es, DoTransp <- cmd, Just transpR <- nameOfTransp kit-                                -> if recPars r == 0-                                   then redReturn $ unArg u0-                                   else redReturn $ (Def transpR []) `apply`-                                               (map (fmap lam_i) as ++ [ignoreBlocking sphi,u0])-                         | nelims > 0, Just as <- allApplyElims es, DoHComp <- cmd, Just hCompR <- nameOfHComp kit-                                -> redReturn $ (Def hCompR []) `apply`-                                               (as ++ [ignoreBlocking sphi,fromMaybe __IMPOSSIBLE__ u,u0])--                         | Just as <- allApplyElims es, [] <- recFields r -> compData False (recPars r) cmd l (as <$ t) sbA sphi u u0-                     Datatype{dataPars = pars, dataIxs = ixs, dataPathCons = pcons}-                       | and [null pcons | DoHComp  <- [cmd]], Just as <- allApplyElims es -> compData (not $ null $ pcons) (pars+ixs) cmd l (as <$ t) sbA sphi u u0-                     Axiom constTransp | constTransp, [] <- es, DoTransp <- cmd -> redReturn $ unArg u0-                     _          -> fallback--                 _ -> fallback-  where-    compSort DoTransp fallback phi Nothing u0 (IsFam l) = do-      -- TODO should check l is constant-      redReturn $ unArg u0-    -- compSort DoHComp fallback phi (Just u) u0 (IsNot l) = -- hcomp for Set is a whnf, handled above.-    compSort _ fallback phi u u0 _ = __IMPOSSIBLE__-    compPi :: TranspOrHComp -> ArgName -> FamilyOrNot (Dom Type, Abs Type) -- Γ , i : I-            -> Arg Term -- Γ-            -> Maybe (Arg Term) -- Γ-            -> Arg Term -- Γ-            -> ReduceM (Maybe Term)-    compPi cmd t ab phi u u0 = do-     let getTermLocal = getTerm $ cmdToName cmd ++ " for function types"--     tTrans <- getTermLocal builtinTrans-     tHComp <- getTermLocal builtinHComp-     tINeg <- getTermLocal builtinINeg-     tIMax <- getTermLocal builtinIMax-     iz    <- getTermLocal builtinIZero-     let-      toLevel' t = do-        s <- reduce $ getSort t-        case s of-          (Type l) -> return (Just l)-          _        -> return Nothing-      toLevel t = fromMaybe __IMPOSSIBLE__ <$> toLevel' t-     -- make sure the codomain has a level.-     caseMaybeM (toLevel' . absBody . snd . famThing $ ab) (return Nothing) $ \ _ -> do-     runNamesT [] $ do-      labA <- do-        let (x,f) = case ab of-              IsFam (a,_) -> (a, \ a -> runNames [] $ lam "i" (const (pure a)))-              IsNot (a,_) -> (a, id)-        s <- reduce $ getSort x-        case s of-          Type lx -> do-            [la,bA] <- mapM (open . f) [Level lx, unEl . unDom $ x]-            pure $ Just $ \ iOrNot phi a0 -> pure tTrans <#> lam "j" (\ j -> la <@> iOrNot j)-                                                         <@> lam "j" (\ j -> bA <@> iOrNot j)-                                                         <@> phi-                                                         <@> a0-          LockUniv -> return $ Just $ \ _ _ a0 -> a0-          _       -> return Nothing-      caseMaybe labA (return Nothing) $ \ trA -> Just <$> do-      [phi, u0] <- mapM (open . unArg) [phi, u0]-      u <- traverse open (unArg <$> u)--      glam (getArgInfo (fst $ famThing ab)) (absName $ snd $ famThing ab) $ \ u1 -> do-        case (cmd, ab, u) of-          (DoHComp, IsNot (a , b), Just u) -> do-            bT <- (raise 1 b `absApp`) <$> u1-            let v = u1-            pure tHComp <#> (Level <$> toLevel bT)-                        <#> pure (unEl                      $ bT)-                        <#> phi-                        <@> lam "i" (\ i -> ilam "o" $ \ o -> gApply (getHiding a) (u <@> i <..> o) v)-                        <@> (gApply (getHiding a) u0 v)-          (DoTransp, IsFam (a , b), Nothing) -> do-            let v i = do-                       let-                         iOrNot j = pure tIMax <@> i <@> (pure tINeg <@> j)-                       trA iOrNot (pure tIMax <@> phi <@> i)-                                  u1-                -- Γ , u1 : A[i1] , i : I-                bB v = consS v (liftS 1 $ raiseS 1) `applySubst` (absBody b {- Γ , i : I , x : A[i] -})-                tLam = Lam defaultArgInfo-            bT <- bind "i" $ fmap bB . v-            -- Γ , u1 : A[i1]-            (pure tTrans <#> (tLam <$> traverse (fmap Level . toLevel) bT)-                         <@> (pure . tLam $ unEl                      <$> bT)-                         <@> phi-                         <@> gApply (getHiding a) u0 (v (pure iz)))-          (_,_,_) -> __IMPOSSIBLE__-    compPathP cmd@DoHComp sphi (Just u) u0 (IsNot l) (IsNot (bA,x,y)) = do-      let getTermLocal = getTerm $ cmdToName cmd ++ " for path types"-      tHComp <- getTermLocal builtinHComp-      tINeg <- getTermLocal builtinINeg-      tIMax <- getTermLocal builtinIMax-      tOr   <- getTermLocal "primPOr"-      let-        ineg j = pure tINeg <@> j-        imax i j = pure tIMax <@> i <@> j--      redReturn . runNames [] $ do-         [l,u,u0] <- mapM (open . unArg) [l,u,u0]-         phi      <- open . unArg . ignoreBlocking $ sphi-         [bA, x, y] <- mapM (open . unArg) [bA, x, y]-         lam "j" $ \ j ->-           pure tHComp <#> l-                       <#> (bA <@> j)-                       <#> (phi `imax` (ineg j `imax` j))-                       <@> lam "i'" (\ i ->-                            let or f1 f2 = pure tOr <#> l <@> f1 <@> f2 <#> lam "_" (\ _ -> bA <@> i)-                            in or phi (ineg j `imax` j)-                                          <@> ilam "o" (\ o -> u <@> i <..> o <@@> (x, y, j)) -- a0 <@@> (x <@> i, y <@> i, j)-                                          <@> (or (ineg j) j <@> ilam "_" (const x)-                                                                  <@> ilam "_" (const y)))-                       <@> (u0 <@@> (x, y, j))-    compPathP cmd@DoTransp sphi Nothing u0 (IsFam l) (IsFam (bA,x,y)) = do-      -- Γ    ⊢ l-      -- Γ, i ⊢ bA, x, y-      let getTermLocal = getTerm $ cmdToName cmd ++ " for path types"-      tINeg <- getTermLocal builtinINeg-      tIMax <- getTermLocal builtinIMax-      tOr   <- getTermLocal "primPOr"-      iz <- getTermLocal builtinIZero-      io <- getTermLocal builtinIOne-      let-        ineg j = pure tINeg <@> j-        imax i j = pure tIMax <@> i <@> j-      comp <- do-        tHComp <- getTermLocal builtinHComp-        tTrans <- getTermLocal builtinTrans-        let forward la bA r u = pure tTrans <#> lam "i" (\ i -> la <@> (i `imax` r))-                                            <@> lam "i" (\ i -> bA <@> (i `imax` r))-                                            <@> r-                                            <@> u-        return $ \ la bA phi u u0 ->-          pure tHComp <#> (la <@> pure io)-                      <#> (bA <@> pure io)-                      <#> phi-                      <@> lam "i" (\ i -> ilam "o" $ \ o ->-                              forward la bA i (u <@> i <..> o))-                      <@> forward la bA (pure iz) u0-      redReturn . runNames [] $ do-        [l,u0] <- mapM (open . unArg) [l,u0]-        phi      <- open . unArg . ignoreBlocking $ sphi-        [bA, x, y] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [bA, x, y]-        lam "j" $ \ j ->-          comp l (lam "i" $ \ i -> bA <@> i <@> j) (phi `imax` (ineg j `imax` j))-                      (lam "i'" $ \ i ->-                            let or f1 f2 = pure tOr <#> l <@> f1 <@> f2 <#> lam "_" (\ _ -> bA <@> i <@> j) in-                                       or phi (ineg j `imax` j)-                                          <@> ilam "o" (\ o -> u0 <@@> (x <@> pure iz, y <@> pure iz, j))-                                          <@> (or (ineg j) j <@> ilam "_" (const (x <@> i))-                                                                  <@> ilam "_" (const (y <@> i))))-                      (u0 <@@> (x <@> pure iz, y <@> pure iz, j))-    compPathP _ sphi u a0 _ _ = __IMPOSSIBLE__-    compId cmd sphi u a0 l bA_x_y = do-      let getTermLocal = getTerm $ cmdToName cmd ++ " for " ++ builtinId-      unview <- intervalUnview'-      mConId <- getBuiltinName' builtinConId-      let isConId (Def q _) = Just q == mConId-          isConId _         = False-      sa0 <- reduceB' a0-      -- wasteful to compute b even when cheaper checks might fail-      b <- case u of-             Nothing -> return True-             Just u  -> allComponents unview (unArg . ignoreBlocking $ sphi) (unArg u) isConId-      case mConId of-        Just conid | isConId (unArg . ignoreBlocking $ sa0) , b -> (Just <$>) . (redReturn =<<) $ do-          tHComp <- getTermLocal builtinHComp-          tTrans <- getTermLocal builtinTrans-          tIMin <- getTermLocal "primDepIMin"-          tFace <- getTermLocal "primIdFace"-          tPath <- getTermLocal "primIdPath"-          tPathType <- getTermLocal builtinPath-          runNamesT [] $ do-            let io = pure $ unview IOne-                iz = pure $ unview IZero-                conId = pure $ Def conid []-            l <- case l of-                   IsFam l -> open . unArg $ l-                   IsNot l -> do-                     open (Lam defaultArgInfo $ NoAbs "_" $ unArg l)-            [p0] <- mapM (open . unArg) [a0]-            p <- case u of-                   Just u -> do-                     u <- open . unArg $ u-                     return $ \ i o -> u <@> i <..> o-                   Nothing -> do-                     return $ \ i o -> p0-            phi      <- open . unArg . ignoreBlocking $ sphi-            [bA, x, y] <--              case bA_x_y of-                IsFam (bA,x,y) -> mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [bA, x, y]-                IsNot (bA,x,y) -> forM [bA,x,y] $ \ a -> open (Lam defaultArgInfo $ NoAbs "_" $ unArg a)-            let-              eval DoTransp l bA phi _ u0 = pure tTrans <#> l <@> bA <@> phi <@> u0-              eval DoHComp l bA phi u u0 = pure tHComp <#> (l <@> io) <#> (bA <@> io) <#> phi-                                                       <@> u <@> u0-            conId <#> (l <@> io) <#> (bA <@> io) <#> (x <@> io) <#> (y <@> io)-                  <@> (pure tIMin <@> phi-                                  <@> ilam "o" (\ o -> pure tFace <#> (l <@> io) <#> (bA <@> io) <#> (x <@> io) <#> (y <@> io)-                                                                   <@> (p io o)))-                  <@> (eval cmd l-                                (lam "i" $ \ i -> pure tPathType <#> (l <@> i) <#> (bA <@> i) <@> (x <@> i) <@> (y <@> i))-                                phi-                                (lam "i" $ \ i -> ilam "o" $ \ o -> pure tPath <#> (l <@> i) <#> (bA <@> i)-                                                                                    <#> (x <@> i) <#> (y <@> i)-                                                                                    <@> (p i o)-                                      )-                                (pure tPath <#> (l <@> iz) <#> (bA <@> iz) <#> (x <@> iz) <#> (y <@> iz)-                                                  <@> p0)-                      )-        _ -> return $ Nothing-    allComponents unview phi u p = do-            let-              boolToI b = if b then unview IOne else unview IZero-            as <- decomposeInterval phi-            andM . for as $ \ (bs,ts) -> do-                 let u' = listS (Map.toAscList $ Map.map boolToI bs) `applySubst` u-                 t <- reduce2Lam u'-                 return $! p $ ignoreBlocking t-    reduce2Lam t = do-          t <- reduce' t-          case lam2Abs t of-            t -> underAbstraction_ t $ \ t -> do-               t <- reduce' t-               case lam2Abs t of-                 t -> underAbstraction_ t reduceB'-         where-           lam2Abs (Lam _ t) = absBody t <$ t-           lam2Abs t         = Abs "y" (raise 1 t `apply` [argN $ var 0])-    allComponentsBack unview phi u p = do-            let-              boolToI b = if b then unview IOne else unview IZero-              lamlam t = Lam defaultArgInfo (Abs "i" (Lam (setRelevance Irrelevant defaultArgInfo) (Abs "o" t)))-            as <- decomposeInterval phi-            (flags,t_alphas) <- fmap unzip . forM as $ \ (bs,ts) -> do-                 let u' = listS bs' `applySubst` u-                     bs' = (Map.toAscList $ Map.map boolToI bs)-                     -- Γ₁, i : I, Γ₂, j : I, Γ₃  ⊢ weaken : Γ₁, Γ₂, Γ₃   for bs' = [(j,_),(i,_)]-                     -- ordering of "j,i,.." matters.-                 let weaken = foldr (\ j s -> s `composeS` raiseFromS j 1) idS (map fst bs')-                 t <- reduce2Lam u'-                 return $ (p $ ignoreBlocking t, listToMaybe [ (weaken `applySubst` (lamlam <$> t),bs) | null ts ])-            return $ (flags,t_alphas)-    compData False _ cmd@DoHComp (IsNot l) (IsNot ps) fsc sphi (Just u) a0 = do-      let getTermLocal = getTerm $ cmdToName cmd ++ " for data types"--      let sc = famThing <$> fsc-      tEmpty <- getTermLocal builtinIsOneEmpty-      tPOr   <- getTermLocal builtinPOr-      iO   <- getTermLocal builtinIOne-      iZ   <- getTermLocal builtinIZero-      tMin <- getTermLocal builtinIMin-      tNeg <- getTermLocal builtinINeg-      let iNeg t = tNeg `apply` [argN t]-          iMin t u = tMin `apply` [argN t, argN u]-          iz = pure iZ-      constrForm <- do-        mz <- getTerm' builtinZero-        ms <- getTerm' builtinSuc-        return $ \ t -> fromMaybe t (constructorForm' mz ms t)-      su  <- reduceB' u-      sa0 <- reduceB' a0-      view   <- intervalView'-      unview <- intervalUnview'-      let f = unArg . ignoreBlocking-          phi = f sphi-          a0 = f sa0-          isLit t@(Lit lt) = Just t-          isLit _ = Nothing-          isCon (Con h _ _) = Just h-          isCon _           = Nothing-          combine l ty d [] = d-          combine l ty d [(psi,u)] = u-          combine l ty d ((psi,u):xs)-            = pure tPOr <#> l <@> psi <@> foldr (imax . fst) iz xs-                        <#> ilam "o" (\ _ -> ty) -- the type-                        <@> u <@> (combine l ty d xs)-          noRed' su = return $ NoReduction [notReduced l,reduced sc, reduced sphi, reduced su', reduced sa0]-            where-              su' = case view phi of-                     IZero -> notBlocked $ argN $ runNames [] $ do-                                 [l,c] <- mapM (open . unArg) [l,ignoreBlocking sc]-                                 lam "i" $ \ i -> pure tEmpty <#> l-                                                              <#> ilam "o" (\ _ -> c)-                     _     -> su-          sameConHeadBack Nothing Nothing su k = noRed' su-          sameConHeadBack lt h su k = do-            let u = unArg . ignoreBlocking $ su-            (b, ts) <- allComponentsBack unview phi u $ \ t ->-                        (isLit t == lt, isCon (constrForm t) == h)-            let-              (lit,hd) = unzip b--            if isJust lt && and lit then redReturn a0 else do-            su <- caseMaybe (sequence ts) (return su) $ \ ts -> do-              let (us,bools) = unzip ts-              fmap ((sequenceA_ us $>) . argN) $ do-              let-                phis :: [Term]-                phis = for bools $ \ m ->-                            foldr (iMin . (\(i,b) -> if b then var i else iNeg (var i))) iO (Map.toList m)-              runNamesT [] $ do-                u <- open u-                [l,c] <- mapM (open . unArg) [l,ignoreBlocking sc]-                phis <- mapM open phis-                us   <- mapM (open . ignoreBlocking) us-                lam "i" $ \ i -> do-                  combine l c (u <@> i) $ zip phis (map (\ t -> t <@> i) us)--            if isJust h && and hd then k (fromMaybe __IMPOSSIBLE__ h) su-                      else noRed' su--      sameConHeadBack (isLit a0) (isCon a0) su $ \ h su -> do-            let u = unArg . ignoreBlocking $ su-            Constructor{ conComp = cm } <- theDef <$> getConstInfo (conName h)-            case nameOfHComp cm of-              Just hcompD -> redReturn $ Def hcompD [] `apply`-                                          (ps ++ map argN [phi,u,a0])-              Nothing        -> noRed' su--    compData _     0 DoTransp (IsFam l) (IsFam ps) fsc sphi Nothing a0 = redReturn $ unArg a0-    compData isHIT _ cmd@DoTransp (IsFam l) (IsFam ps) fsc sphi Nothing a0 = do-      let getTermLocal = getTerm $ cmdToName cmd ++ " for data types"-      let sc = famThing <$> fsc-      mhcompName <- getName' builtinHComp-      constrForm <- do-        mz <- getTerm' builtinZero-        ms <- getTerm' builtinSuc-        return $ \ t -> fromMaybe t (constructorForm' mz ms t)-      sa0 <- reduceB' a0-      let f = unArg . ignoreBlocking-          phi = f sphi-          a0 = f sa0-          noRed = return $ NoReduction [notReduced l,reduced sc, reduced sphi, reduced sa0]-      let lam_i = Lam defaultArgInfo . Abs "i"-      case constrForm a0 of-        Con h _ args -> do-          Constructor{ conComp = cm } <- theDef <$> getConstInfo (conName h)-          case nameOfTransp cm of-              Just transpD -> redReturn $ Def transpD [] `apply`-                                          (map (fmap lam_i) ps ++ map argN [phi,a0])-              Nothing        -> noRed-        Def q es | isHIT, Just q == mhcompName, Just [_l0,_c0,psi,u,u0] <- allApplyElims es -> do-           let bC = ignoreBlocking sc-           hcomp <- getTermLocal builtinHComp-           transp <- getTermLocal builtinTrans-           io <- getTermLocal builtinIOne-           iz <- getTermLocal builtinIZero-           redReturn <=< runNamesT [] $ do-             [l,bC,phi,psi,u,u0] <- mapM (open . unArg) [l,bC,ignoreBlocking sphi,psi,u,u0]-             -- hcomp (sc 1) [psi |-> transp sc phi u] (transp sc phi u0)-             pure hcomp <#> (l <@> pure io) <#> (bC <@> pure io) <#> psi-                   <@> lam "j" (\ j -> ilam "o" $ \ o ->-                        pure transp <#> l <@> bC <@> phi <@> (u <@> j <..> o))-                   <@> (pure transp <#> l <@> bC <@> phi <@> u0)-        _ -> noRed-    compData _ _ _ _ _ _ _ _ _ = __IMPOSSIBLE__--primComp :: TCM PrimitiveImpl-primComp = do-  requireCubical CErased ""-  t    <- runNamesT [] $-          hPi' "a" (primIntervalType --> el (cl primLevel)) $ \ a ->-          nPi' "A" (nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA ->-          hPi' "φ" primIntervalType $ \ phi ->-          nPi' "i" primIntervalType (\ i -> pPi' "o" phi $ \ _ -> el' (a <@> i) (bA <@> i)) -->-          (el' (a <@> cl primIZero) (bA <@> cl primIZero) --> el' (a <@> cl primIOne) (bA <@> cl primIOne))-  one <- primItIsOne-  io  <- primIOne-  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 5 $ \ ts nelims -> do-    case ts of-      [l,c,phi,u,a0] -> do-        sphi <- reduceB' phi-        vphi <- intervalView $ unArg $ ignoreBlocking sphi-        case vphi of-          IOne -> redReturn (unArg u `apply` [argN io, argN one])-          _    -> do-            let getTermLocal = getTerm $ builtinComp-            tIMax <- getTermLocal builtinIMax-            tINeg <- getTermLocal builtinINeg-            tHComp <- getTermLocal builtinHComp-            tTrans <- getTermLocal builtinTrans-            iz      <- getTermLocal builtinIZero-            redReturn <=< runNamesT [] $ do-              comp <- do-                let imax i j = pure tIMax <@> i <@> j-                    forward la bA r u = pure tTrans <#> (lam "i" $ \ i -> la <@> (i `imax` r))-                                                    <@> (lam "i" $ \ i -> bA <@> (i `imax` r))-                                                    <@> r-                                                    <@> u-                return $ \ la bA phi u u0 ->-                  pure tHComp <#> (la <@> pure io) <#> (bA <@> pure io) <#> phi-                              <@> lam "i" (\ i -> ilam "o" $ \ o ->-                                      forward la bA i (u <@> i <..> o))-                              <@> forward la bA (pure iz) u0--              [l,c,phi,u,a0] <- mapM (open . unArg) [l,c,phi,u,a0]-              comp l c phi u a0--      _ -> __IMPOSSIBLE__---prim_glueU' :: TCM PrimitiveImpl-prim_glueU' = do-  requireCubical CErased ""-  t <- runNamesT [] $-       hPi' "la" (el $ cl primLevel) (\ la ->-       hPi' "φ" primIntervalType $ \ φ ->-       hPi' "T" (nPi' "i" primIntervalType $ \ _ -> pPi' "o" φ $ \ o -> sort . tmSort <$> la) $ \ t ->-       hPi' "A" (el's (cl primLevelSuc <@> la) $ cl primSub <#> (cl primLevelSuc <@> la) <@> (Sort . tmSort <$> la) <@> φ <@> (t <@> primIZero)) $ \ a -> do-       let bA = (cl primSubOut <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <#> (t <@> primIZero) <@> a)-       pPi' "o" φ (\ o -> el' la (t <@> cl primIOne <..> o))-         --> (el' la bA)-         --> el' la (cl primHComp <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <@> t <@> bA))-  view <- intervalView'-  one <- primItIsOne-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ts ->-    case ts of-      [la,phi,bT,bA,t,a] -> do-       sphi <- reduceB' phi-       case view $ unArg $ ignoreBlocking $ sphi of-         IOne -> redReturn $ unArg t `apply` [argN one]-         _    -> return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA,t,a])-      _ -> __IMPOSSIBLE__--prim_unglueU' :: TCM PrimitiveImpl-prim_unglueU' = do-  requireCubical CErased ""-  t <- runNamesT [] $-       hPi' "la" (el $ cl primLevel) (\ la ->-       hPi' "φ" primIntervalType $ \ φ ->-       hPi' "T" (nPi' "i" primIntervalType $ \ _ -> pPi' "o" φ $ \ o -> sort . tmSort <$> la) $ \ t ->-       hPi' "A" (el's (cl primLevelSuc <@> la) $ cl primSub <#> (cl primLevelSuc <@> la) <@> (Sort . tmSort <$> la) <@> φ <@> (t <@> primIZero)) $ \ a -> do-       let bA = (cl primSubOut <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <#> (t <@> primIZero) <@> a)-       el' la (cl primHComp <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <@> t <@> bA)-         --> el' la bA)-  view <- intervalView'-  one <- primItIsOne-  mglueU <- getPrimitiveName' builtin_glueU-  mtransp <- getPrimitiveName' builtinTrans-  mHCompU <- getPrimitiveName' builtinHComp-  let mhcomp = mHCompU-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ts ->-    case ts of-      [la,phi,bT,bA,b] -> do-       sphi <- reduceB' phi-       case view $ unArg $ ignoreBlocking $ sphi of-         IOne -> do-           tTransp <- getTerm builtin_unglueU builtinTrans-           iNeg    <- getTerm builtin_unglueU builtinINeg-           iZ      <- getTerm builtin_unglueU builtinIZero-           redReturn <=< runNamesT [] $ do-             [la,bT,b] <- mapM (open . unArg) [la,bT,b]-             pure tTransp <#> lam "i" (\ _ -> la)-                          <@> lam "i" (\ i -> bT <@> (pure iNeg <@> i) <..> pure one)-                          <@> pure iZ-                          <@> b-         _    -> do-            sb <- reduceB' b-            let fallback sbA = return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA] ++ [reduced sb])-            case unArg $ ignoreBlocking $ sb of-               Def q [Apply _,Apply _,Apply _,Apply _,Apply _,Apply a]-                     | Just q == mglueU -> redReturn $ unArg a-               Def q [Apply l,Apply bA,Apply r,Apply u0]-                     | Just q == mtransp -> do-                     sbA <- reduceB bA-                     case unArg $ ignoreBlocking sbA of-                       Lam _ t -> do-                         st <- reduceB' (absBody t)-                         case ignoreBlocking st of-                           Def h es | Just [la,_,phi,bT,bA] <- allApplyElims es, Just h == mHCompU -> do-                             redReturn . fromMaybe __IMPOSSIBLE__ =<< compHCompU DoTransp r Nothing u0 (IsFam (la,phi,bT,bA)) Eliminated-                           _ -> fallback (st *> sbA)-                       _  -> fallback sbA-               Def q [Apply l,Apply bA,Apply r,Apply u,Apply u0]-                     | Just q == mhcomp -> do-                     sbA <- reduceB bA-                     case unArg $ ignoreBlocking sbA of-                       Def h es | Just [la,_,phi,bT,bA] <- allApplyElims es, Just h == mHCompU -> do-                         redReturn . fromMaybe __IMPOSSIBLE__ =<< compHCompU DoHComp r (Just u) u0 (IsNot (la,phi,bT,bA)) Eliminated-                       _ -> fallback sbA-               _ -> return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA] ++ [reduced sb])-      _ -> __IMPOSSIBLE__---primGlue' :: TCM PrimitiveImpl-primGlue' = do-  requireCubical CFull ""-  -- Glue' : ∀ {l} (A : Set l) → ∀ φ → (T : Partial (Set a) φ) (f : (PartialP φ \ o → (T o) -> A))-  --            ([f] : PartialP φ \ o → isEquiv (T o) A (f o)) → Set l-  t <- runNamesT [] $-       hPi' "la" (el $ cl primLevel) (\ la ->-       hPi' "lb" (el $ cl primLevel) $ \ lb ->-       nPi' "A" (sort . tmSort <$> la) $ \ a ->-       hPi' "φ" primIntervalType $ \ φ ->-       nPi' "T" (pPi' "o" φ $ \ o -> el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t ->-       pPi' "o" φ (\ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a)-       --> (sort . tmSort <$> lb))-  view <- intervalView'-  one <- primItIsOne-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ts ->-    case ts of-     [la,lb,a,phi,t,e] -> do-       sphi <- reduceB' phi-       case view $ unArg $ ignoreBlocking $ sphi of-         IOne -> redReturn $ unArg t `apply` [argN one]-         _    -> return (NoReduction $ map notReduced [la,lb,a] ++ [reduced sphi] ++ map notReduced [t,e])-     _ -> __IMPOSSIBLE__--prim_glue' :: TCM PrimitiveImpl-prim_glue' = do-  requireCubical CFull ""-  t <- runNamesT [] $-       hPi' "la" (el $ cl primLevel) (\ la ->-       hPi' "lb" (el $ cl primLevel) $ \ lb ->-       hPi' "A" (sort . tmSort <$> la) $ \ a ->-       hPi' "φ" primIntervalType $ \ φ ->-       hPi' "T" (pPi' "o" φ $ \ o ->  el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t ->-       hPi' "e" (pPi' "o" φ $ \ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a) $ \ e ->-       pPi' "o" φ (\ o -> el' lb (t <@> o)) --> (el' la a --> el' lb (cl primGlue <#> la <#> lb <@> a <#> φ <@> t <@> e)))-  view <- intervalView'-  one <- primItIsOne-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 8 $ \ts ->-    case ts of-      [la,lb,bA,phi,bT,e,t,a] -> do-       sphi <- reduceB' phi-       case view $ unArg $ ignoreBlocking $ sphi of-         IOne -> redReturn $ unArg t `apply` [argN one]-         _    -> return (NoReduction $ map notReduced [la,lb,bA] ++ [reduced sphi] ++ map notReduced [bT,e,t,a])-      _ -> __IMPOSSIBLE__--prim_unglue' :: TCM PrimitiveImpl-prim_unglue' = do-  requireCubical CFull ""-  t <- runNamesT [] $-       hPi' "la" (el $ cl primLevel) (\ la ->-       hPi' "lb" (el $ cl primLevel) $ \ lb ->-       hPi' "A" (sort . tmSort <$> la) $ \ a ->-       hPi' "φ" primIntervalType $ \ φ ->-       hPi' "T" (pPi' "o" φ $ \ o ->  el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t ->-       hPi' "e" (pPi' "o" φ $ \ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a) $ \ e ->-       (el' lb (cl primGlue <#> la <#> lb <@> a <#> φ <@> t <@> e)) --> el' la a)-  view <- intervalView'-  one <- primItIsOne-  mGlue <- getPrimitiveName' builtinGlue-  mglue <- getPrimitiveName' builtin_glue-  mtransp <- getPrimitiveName' builtinTrans-  mhcomp <- getPrimitiveName' builtinHComp-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 7 $ \ts ->-    case ts of-      [la,lb,bA,phi,bT,e,b] -> do-       sphi <- reduceB' phi-       case view $ unArg $ ignoreBlocking $ sphi of-         IOne -> do-           let argOne = setRelevance Irrelevant $ argN one-           tEFun <- getTerm builtin_unglue builtinEquivFun-           redReturn $ tEFun `apply` [lb,la,argH $ unArg bT `apply` [argOne],bA, argN $ unArg e `apply` [argOne],b]-         _    -> do-            sb <- reduceB' b-            let fallback sbA = return (NoReduction $ map notReduced [la,lb] ++ map reduced [sbA, sphi] ++ map notReduced [bT,e] ++ [reduced sb])-            case unArg $ ignoreBlocking $ sb of-               Def q [Apply _,Apply _,Apply _,Apply _,Apply _,Apply _,Apply _,Apply a]-                     | Just q == mglue -> redReturn $ unArg a-               Def q [Apply l,Apply bA,Apply r,Apply u0]-                     | Just q == mtransp -> do-                 sbA <- reduceB' bA-                 case unArg $ ignoreBlocking sbA of-                   Lam _ t -> do-                     st <- reduceB' (absBody t)-                     case ignoreBlocking st of-                       Def g es | Just [la',lb',bA',phi',bT',e'] <- allApplyElims es, Just g == mGlue -> do-                           redReturn . fromMaybe __IMPOSSIBLE__ =<< compGlue DoTransp r Nothing u0 (IsFam (la',lb',bA',phi',bT',e')) Eliminated-                       _ -> fallback (st *> sbA)-                   _ -> fallback sbA-               Def q [Apply l,Apply bA,Apply r,Apply u,Apply u0]-                     | Just q == mhcomp -> do-                 sbA <- reduceB' bA-                 case unArg $ ignoreBlocking sbA of-                   Def g es | Just [la',lb',bA',phi',bT',e'] <- allApplyElims es, Just g == mGlue -> do-                       redReturn . fromMaybe __IMPOSSIBLE__ =<< compGlue DoHComp r (Just u) u0 (IsNot (la',lb',bA',phi',bT',e')) Eliminated-                   _ -> fallback sbA-               _ -> return (NoReduction $ map notReduced [la,lb,bA] ++ [reduced sphi] ++ map notReduced [bT,e] ++ [reduced sb])-      _ -> __IMPOSSIBLE__----- TODO Andrea: keep reductions that happen under foralls?-primFaceForall' :: TCM PrimitiveImpl-primFaceForall' = do-  requireCubical CErased ""-  t <- (primIntervalType --> primIntervalType) --> primIntervalType-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \ts -> case ts of-    [phi] -> do-      sphi <- reduceB' phi-      case unArg $ ignoreBlocking $ sphi of-        Lam _ t -> do-          t <- reduce' t-          case t of-            NoAbs _ t -> redReturn t-            Abs _ t ->-              maybe (return $ NoReduction [reduced sphi]) redReturn-                =<< toFaceMapsPrim t-        _ -> return (NoReduction [reduced sphi])-    _ -> __IMPOSSIBLE__-  where-    toFaceMapsPrim t = do-      view <- intervalView'-      unview <- intervalUnview'-      us' <- decomposeInterval t-      fr <- getTerm builtinFaceForall builtinFaceForall-      let v = view t-          us =-            [ map Left (Map.toList bsm) ++ map Right ts-              | (bsm, ts) <- us',-                0 `Map.notMember` bsm-            ]-          fm (i, b) = if b then var (i - 1) else unview (INeg (argN (var $ i - 1)))-          ffr t = fr `apply` [argN $ Lam defaultArgInfo $ Abs "i" t]-          r =-            Just $-              foldr-                ( (\x r -> unview (IMax (argN x) (argN r)))-                    . foldr-                      (\x r -> unview (IMin (argN (either fm ffr x)) (argN r)))-                      (unview IOne)-                )-                (unview IZero)-                us-      --   traceSLn "cube.forall" 20 (unlines [show v, show us', show us, show r]) $-      return $ case us' of-        [(m, [_])] | Map.null m -> Nothing-        v -> r--decomposeInterval :: HasBuiltins m => Term -> m [(Map Int Bool,[Term])]-decomposeInterval t = do-  xs <- decomposeInterval' t-  let isConsistent xs = all (\ xs -> Set.size xs == 1) . Map.elems $ xs  -- optimize by not doing generate + filter-  return [ (Map.map (head . Set.toList) bsm,ts)-            | (bsm,ts) <- xs-            , isConsistent bsm-            ]--decomposeInterval' :: HasBuiltins m => Term -> m [(Map Int (Set Bool),[Term])]-decomposeInterval' t = do-     view   <- intervalView'-     unview <- intervalUnview'-     let f :: IntervalView -> [[Either (Int,Bool) Term]]-         -- TODO handle primIMinDep-         -- TODO? handle forall-         f IZero = mzero-         f IOne  = return []-         f (IMin x y) = do xs <- (f . view . unArg) x; ys <- (f . view . unArg) y; return (xs ++ ys)-         f (IMax x y) = msum $ map (f . view . unArg) [x,y]-         f (INeg x)   = map (either (\ (x,y) -> Left (x,not y)) (Right . unview . INeg . argN)) <$> (f . view . unArg) x-         f (OTerm (Var i [])) = return [Left (i,True)]-         f (OTerm t)          = return [Right t]-         v = view t-     return [ (bsm,ts)-            | xs <- f v-            , let (bs,ts) = partitionEithers xs-            , let bsm     = (Map.fromListWith Set.union . map (id -*- Set.singleton)) bs-            ]----- | Tries to @primTransp@ a whole telescope of arguments, following the rule for Σ types.---   If a type in the telescope does not support transp, @transpTel@ throws it as an exception.-transpTel :: Abs Telescope -- Γ ⊢ i.Δ-          -> Term          -- Γ ⊢ φ : F  -- i.Δ const on φ-          -> Args          -- Γ ⊢ δ : Δ[0]-          -> ExceptT (Closure (Abs Type)) TCM Args      -- Γ ⊢ Δ[1]-transpTel delta phi args = do-  tTransp <- liftTCM primTrans-  imin <- liftTCM primIMin-  imax <- liftTCM primIMax-  ineg <- liftTCM primINeg-  let-    noTranspError t = lift . throwError =<< liftTCM (buildClosure t)-    bapp :: (Applicative m, Subst a) => m (Abs a) -> m (SubstArg a) -> m a-    bapp t u = lazyAbsApp <$> t <*> u-    gTransp (Just l) t phi a = pure tTransp <#> l <@> (Lam defaultArgInfo . fmap unEl <$> t) <@> phi <@> a-    gTransp Nothing  t phi a = do-      -- Γ ⊢ i.Ξ-      xi <- (open =<<) $ do-        bind "i" $ \ i -> do-          TelV xi _ <- (liftTCM . telView =<<) $ t `bapp` i-          return xi-      argnames <- do-        teleArgNames . unAbs <$> xi-      glamN argnames $ \ xi_args -> do-        b' <- bind "i" $ \ i -> do-          ti <- t `bapp` i-          xin <- bind "i" $ \ i -> xi `bapp` (pure ineg <@> i)-          xi_args <- xi_args-          ni <- pure ineg <@> i-          phi <- phi-          lift $ piApplyM ti =<< trFillTel xin phi xi_args ni-        axi <- do-          a <- a-          xif <- bind "i" $ \ i -> xi `bapp` (pure ineg <@> i)-          phi <- phi-          xi_args <- xi_args-          lift $ apply a <$> transpTel xif phi xi_args-        s <- reduce $ getSort (absBody b')-        case s of-          Type l -> do-            l <- open $ lam_i (Level l)-            b' <- open b'-            axi <- open axi-            gTransp (Just l) b' phi axi-          Inf _ n  ->-            if 0 `freeIn` (raise 1 b' `lazyAbsApp` var 0) then noTranspError b' else return axi-          SSet _  ->-            if 0 `freeIn` (raise 1 b' `lazyAbsApp` var 0) then noTranspError b' else return axi-          _ -> noTranspError b'-    lam_i = Lam defaultArgInfo . Abs "i"-    go :: Telescope -> Term -> Args -> ExceptT (Closure (Abs Type)) TCM Args-    go EmptyTel            _   []       = return []-    go (ExtendTel t delta) phi (a:args) = do-      -- Γ,i ⊢ t-      -- Γ,i ⊢ (x : t). delta-      -- Γ ⊢ a : t[0]-      s <- reduce $ getSort t-      -- Γ ⊢ b : t[1], Γ,i ⊢ b : t[i]-      (b,bf) <- runNamesT [] $ do-        l <- case s of-               SSet _ -> return Nothing-               Inf _ n -> return Nothing-               Type l -> Just <$> open (lam_i (Level l))-               _ -> noTranspError (Abs "i" (unDom t))-        t <- open $ Abs "i" (unDom t)-        [phi,a] <- mapM open [phi, unArg a]-        b <- gTransp l t phi a-        bf <- bind "i" $ \ i -> do-                            gTransp ((<$> l) $ \ l -> lam "j" $ \ j -> l <@> (pure imin <@> i <@> j))-                                    (bind "j" $ \ j -> t `bapp` (pure imin <@> i <@> j))-                                    (pure imax <@> (pure ineg <@> i) <@> phi)-                                    a-        return (b, absBody bf)-      (:) (b <$ a) <$> go (lazyAbsApp delta bf) phi args-    go (ExtendTel t delta) phi []    = __IMPOSSIBLE__-    go EmptyTel            _   (_:_) = __IMPOSSIBLE__-  go (absBody delta) phi args---- | Like @transpTel@ but performing a transpFill.-trFillTel :: Abs Telescope -- Γ ⊢ i.Δ-          -> Term-          -> Args          -- Γ ⊢ δ : Δ[0]-          -> Term          -- Γ ⊢ r : I-          -> ExceptT (Closure (Abs Type)) TCM Args      -- Γ ⊢ Δ[r]-trFillTel delta phi args r = do-  imin <- liftTCM primIMin-  imax <- liftTCM primIMax-  ineg <- liftTCM primINeg-  transpTel (Abs "j" $ raise 1 delta `lazyAbsApp` (imin `apply` (map argN [var 0, raise 1 r])))-            (imax `apply` [argN $ ineg `apply` [argN r], argN phi])-            args+module Agda.TypeChecking.Primitive.Cubical+  ( module Agda.TypeChecking.Primitive.Cubical+  , module Agda.TypeChecking.Primitive.Cubical.Base+  , module Agda.TypeChecking.Primitive.Cubical.Glue+  , module Agda.TypeChecking.Primitive.Cubical.HCompU+  )+  where++import Prelude hiding (null, (!!))++import Control.Monad+import Control.Monad.Except+import Control.Monad.Trans ( lift )+import Control.Exception++import Data.String ()++import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import qualified Data.List as List+import Data.Foldable hiding (null)++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.Syntax.Internal.Pattern+import qualified Agda.Syntax.Common.Pretty as P++import Agda.TypeChecking.Names+import Agda.TypeChecking.Positivity.Occurrence+import Agda.TypeChecking.Primitive.Base+import Agda.TypeChecking.Monad++import Agda.TypeChecking.Free+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Telescope++import Agda.Utils.Either+import Agda.Utils.Function+import Agda.Utils.Functor++import Agda.Utils.Impossible+import Agda.Utils.Maybe+import Agda.Utils.Null+import Agda.Utils.Tuple+import Agda.Utils.Size+import Agda.Utils.BoolSet (BoolSet)+import qualified Agda.Utils.BoolSet as BoolSet++import Agda.TypeChecking.Primitive.Cubical.HCompU+import Agda.TypeChecking.Primitive.Cubical.Glue+import Agda.TypeChecking.Primitive.Cubical.Base++primPOr :: TCM PrimitiveImpl+primPOr = do+  requireCubical CErased+  t    <- runNamesT [] $+          hPi' "a" (els (pure LevelUniv) (cl primLevel))    $ \ a  ->+          nPi' "i" primIntervalType $ \ i  ->+          nPi' "j" primIntervalType $ \ j  ->+          hPi' "A" (pPi' "o" (imax i j) $ \o -> el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->+          ((pPi' "i1" i $ \ i1 -> el' a $ bA <..> (cl primIsOne1 <@> i <@> j <@> i1))) -->+          ((pPi' "j1" j $ \ j1 -> el' a $ bA <..> (cl primIsOne2 <@> i <@> j <@> j1))) -->+          pPi' "o" (imax i j) (\ o -> el' a $ bA <..> o)+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ ts -> do+    case ts of+     [l,i,j,a,u,v] -> do+       si <- reduceB' i+       vi <- intervalView $ unArg $ ignoreBlocking si+       case vi of+        IOne -> redReturn (unArg u)+        IZero -> redReturn (unArg v)+        _ -> do+          sj <- reduceB' j+          vj <- intervalView $ unArg $ ignoreBlocking sj+          case vj of+            IOne -> redReturn (unArg v)+            IZero -> redReturn (unArg u)+            _ -> return $ NoReduction [notReduced l,reduced si,reduced sj,notReduced a,notReduced u,notReduced v]+++     _ -> __IMPOSSIBLE__++primPartial' :: TCM PrimitiveImpl+primPartial' = do+  requireCubical CErased+  t <- runNamesT [] $+       hPi' "a" (els (pure LevelUniv) (cl primLevel)) (\ a ->+        nPi' "φ" primIntervalType $ \ _ ->+        nPi' "A" (sort . tmSort <$> a) $ \ bA ->+        (sort . tmSSort <$> a))+  isOne <- primIsOne+  v <- runNamesT [] $+        lam "a" $ \ l ->+        lam "φ" $ \ phi ->+        lam "A" $ \ a ->+        unEl <$> pPi' "p" phi (\_ -> el' l a)+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \ _ -> redReturn v++primPartialP' :: TCM PrimitiveImpl+primPartialP' = do+  requireCubical CErased+  t <- runNamesT [] $+       hPi' "a" (els (pure LevelUniv) (cl primLevel)) (\ a ->+        nPi' "φ" primIntervalType $ \ phi ->+        nPi' "A" (pPi' "o" phi $ \ _ -> el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->+        (sort . tmSSort <$> a))+  v <- runNamesT [] $+        lam "a" $ \ l ->+        lam "φ" $ \ phi ->+        lam "A" $ \ a ->+        unEl <$> pPi' "p" phi (\ p -> el' l (a <@> p))+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \ _ -> redReturn v++primSubOut' :: TCM PrimitiveImpl+primSubOut' = do+  requireCubical CErased+  t    <- runNamesT [] $+          hPi' "a" (els (pure LevelUniv) (cl primLevel)) $ \ a ->+          hPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->+          hPi' "φ" primIntervalType $ \ phi ->+          hPi' "u" (el's a $ cl primPartial <#> a <@> phi <@> bA) $ \ u ->+          el's a (cl primSub <#> a <@> bA <@> phi <@> u) --> el' a bA+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ ts -> do+    case ts of+      [a,bA,phi,u,x] -> do+        view <- intervalView'+        sphi <- reduceB' phi+        case view $ unArg $ ignoreBlocking sphi of+          IOne -> redReturn =<< (return (unArg u) <..> getTerm (getBuiltinId PrimSubOut) BuiltinItIsOne)+          _ -> do+            sx <- reduceB' x+            mSubIn <- getBuiltinName' builtinSubIn+            case unArg $ ignoreBlocking $ sx of+              Def q [_,_,_, Apply t] | Just q == mSubIn -> redReturn (unArg t)+              _ -> return $ NoReduction $ map notReduced [a,bA] ++ [reduced sphi, notReduced u, reduced sx]+      _ -> __IMPOSSIBLE__++primTrans' :: TCM PrimitiveImpl+primTrans' = do+  requireCubical CErased+  t    <- runNamesT [] $+          hPi' "a" (primIntervalType --> els (pure LevelUniv) (cl primLevel)) $ \ a ->+          nPi' "A" (nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA ->+          nPi' "φ" primIntervalType $ \ phi ->+          (el' (a <@> cl primIZero) (bA <@> cl primIZero) --> el' (a <@> cl primIOne) (bA <@> cl primIOne))+  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 4 [] $ \ts nelims -> do+    primTransHComp DoTransp ts nelims++primHComp' :: TCM PrimitiveImpl+primHComp' = do+  requireCubical CErased+  t    <- runNamesT [] $+          hPi' "a" (els (pure LevelUniv) (cl primLevel)) $ \ a ->+          hPi' "A" (sort . tmSort <$> a) $ \ bA ->+          hPi' "φ" primIntervalType $ \ phi ->+          nPi' "i" primIntervalType (\ i -> pPi' "o" phi $ \ _ -> el' a bA) -->+          (el' a bA --> el' a bA)+  let occs = [Mixed, StrictPos, Mixed, StrictPos, StrictPos]+  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 5 occs $ \ts nelims -> do+    primTransHComp DoHComp ts nelims++-- | Construct a helper for CCHM composition, with a string indicating+-- what function uses it.+mkComp :: forall m. HasBuiltins m+       => String+       -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term)+mkComp s = do+  let getTermLocal :: IsBuiltin a => a -> NamesT m Term+      getTermLocal = getTerm s+  tIMax  <- getTermLocal builtinIMax+  tINeg  <- getTermLocal builtinINeg+  tHComp <- getTermLocal builtinHComp+  tTrans <- getTermLocal builtinTrans+  iz     <- getTermLocal builtinIZero+  io     <- getTermLocal builtinIOne++  let+    forward la bA r u = pure tTrans+      <#> lam "i" (\i -> la <@> (i `imax` r))+      <@> lam "i" (\i -> bA <@> (i `imax` r))+      <@> r+      <@> u++  pure $ \la bA phi u u0 ->+    pure tHComp <#> (la <@> pure io) <#> (bA <@> pure io) <#> phi+                <@> lam "i" (\i -> ilam "o" $ \o ->+                        forward la bA i (u <@> i <..> o))+                <@> forward la bA (pure iz) u0++-- | Construct an application of buitlinComp. Use instead of 'mkComp' if+-- reducing directly to hcomp + transport would be problematic.+mkCompLazy+  :: HasBuiltins m+  => String+  -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term)+mkCompLazy s = do+  let getTermLocal = getTerm s+  tComp <- getTermLocal builtinComp+  pure $ \la bA phi u u0 -> pure tComp <#> la <#> bA <#> phi <@> u <@> u0++-- | Implementation of Kan operations for Pi types. The implementation+-- of @transp@ and @hcomp@ for Pi types has many commonalities, so most+-- of it is shared between the two cases.+doPiKanOp+  :: KanOperation -- ^ Are we composing or transporting?+  -> ArgName      -- ^ Name of the binder+  -> FamilyOrNot (Dom Type, Abs Type)+  -- ^ The domain and codomain of the Pi type.+  -> ReduceM (Maybe Term)+doPiKanOp cmd t ab = do+  let getTermLocal :: IsBuiltin a => a -> ReduceM Term+      getTermLocal = getTerm $ kanOpName cmd ++ " for function types"+  tTrans <- getTermLocal builtinTrans+  tHComp <- getTermLocal builtinHComp+  tINeg <- getTermLocal builtinINeg+  tIMax <- getTermLocal builtinIMax+  iz    <- getTermLocal builtinIZero++  -- We must guarantee that the codomain is a fibrant type, i.e. one+  -- that supports hcomp and transp. Otherwise, what are we even doing!+  let+    toLevel' t = do+      s <- reduce $ getSort t+      case s of+        Type l -> return (Just l)+        _      -> return Nothing+    -- But this case is actually impossible:+    toLevel t = fromMaybe __IMPOSSIBLE__ <$> toLevel' t++  caseMaybeM (toLevel' . absBody . snd . famThing $ ab) (return Nothing) $ \ _ -> do+  runNamesT [] $ do++    -- When doing transport in Pi types, we need to distinguish a couple+    -- of different cases depending on the sort of the domain, since+    -- there are a couple of different possibilities for how we end up+    -- with a fibrant Pi type:+    trFibrantDomain <- do+      let+        (x, f) = case ab of+          IsFam (a, _) -> (a, \ a -> runNames [] $ lam "i" (const (pure a)))+          IsNot (a, _) -> (a, id)+      s <- reduce $ getSort x+      case s of+        -- We're looking at a fibrant Pi with fibrant domain: Transport+        -- backwards along the domain.+        Type lx -> do+          la <- open . f $ Level lx+          bA <- open . f . unEl . unDom $ x+          pure $ Just $ \iOrNot phi a0 ->+            pure tTrans <#> lam "j" (\j -> la <@> iOrNot j)+              <@> lam "j" (\ j -> bA <@> iOrNot j)+              <@> phi+              <@> a0++        -- We're looking a fibrant Pi whose domain is a lock: No need to do anything.+        LockUniv -> return $ Just $ \_ _ a0 -> a0++        -- We're looking at an unmarked path type. Make sure that the+        -- domain is actually the interval before continuing without an+        -- adjustment, though!+        IntervalUniv -> do+          x' <- reduceB $ unDom x+          mInterval <- getBuiltinName' builtinInterval+          case unEl $ ignoreBlocking x' of+            Def q [] | Just q == mInterval -> return $ Just $ \_ _ a0 -> a0+            _ -> return Nothing++        Prop _     -> pure Nothing+        SSet _     -> pure Nothing+        Inf _ _    -> pure Nothing+        LevelUniv  -> pure Nothing+        SizeUniv   -> pure Nothing+        PiSort{}   -> pure Nothing+        FunSort{}  -> pure Nothing+        UnivSort{} -> pure Nothing+        MetaS{}    -> pure Nothing+        DefS{}     -> pure Nothing+        DummyS{}   -> pure Nothing++    caseMaybe trFibrantDomain (return Nothing) $ \trA -> Just <$> do+    phi <- open . unArg $ ignoreBlocking $ kanOpCofib cmd+    u0  <- open . unArg $ kanOpBase cmd++    glam (getArgInfo (fst $ famThing ab)) (absName $ snd $ famThing ab) $ \u1 -> do+      case (cmd, ab) of++        -- hcomp u u0 x = hcomp (λ i o → u i o x) (u0 x). Short and sweet :)+        (HCompOp _ u _, IsNot (a , b)) -> do+          bT <- (raise 1 b `absApp`) <$> u1+          u <- open (raise 1 (unArg u))+          pure tHComp+            <#> (Level <$> toLevel bT)+            <#> pure (unEl bT)+            <#> phi+            <@> lam "i" (\ i -> ilam "o" $ \ o -> gApply (getHiding a) (u <@> i <..> o) u1)+            <@> gApply (getHiding a) u0 u1++        -- transp (λ i → (a : A i) → B i x) φ f u1 =+        --  transp (λ i → B i (transp (λ j → A (i ∨ ~ j)) (φ ∨ i) x)) φ+        --    (f (transp (λ j → A (~ j) φ x)))+        (TranspOp _ _, IsFam (a , b)) -> do+          -- trA is a function of three arguments which builds the+          -- transport fillers in the opposite direction, hence its+          -- first argument is called "iOrNot" where it's relevant.+          let+            -- Γ , u1 : A[i1] , i : I+            v i = trA (imax i . ineg) (imax phi i) u1+            bB v = consS v (liftS 1 $ raiseS 1) `applySubst`+              (absBody b {- Γ , i : I , x : A[i] -})++            -- Compute B @0 v, in the right scope+            tLam = Lam defaultArgInfo++          -- We know how to substitute v into B, but it's open in a+          -- variable, so we close over it here:+          bT <- bind "i" $ \ x -> fmap bB . v $ x++          pure tTrans+            <#> (tLam <$> traverse (fmap Level . toLevel) bT)+            <@> (pure . tLam $ unEl <$> bT)+            <@> phi+            <@> gApply (getHiding a) u0 (v (pure iz))++        (_, _) -> __IMPOSSIBLE_VERBOSE__ "Invalid Kan operation in doPiKanOp"++-- | Compute Kan operations in a type of dependent paths.+doPathPKanOp+  :: KanOperation+  -> FamilyOrNot (Arg Term)+  -> FamilyOrNot (Arg Term, Arg Term, Arg Term)+  -> ReduceM (Reduced MaybeReducedArgs Term)+doPathPKanOp (HCompOp phi u u0) (IsNot l) (IsNot (bA,x,y)) = do+  let getTermLocal = getTerm "primHComp for path types"+  tHComp <- getTermLocal builtinHComp++  redReturn <=< runNamesT [] $ do+    l   <- open . unArg $ l+    u   <- open . unArg $ u+    u0  <- open . unArg $ u0+    phi <- open . unArg $ ignoreBlocking phi+    bA  <- open . unArg $ bA+    x   <- open . unArg $ x+    y   <- open . unArg $ y++    -- hcomp in path spaces is simply hcomp in the underlying space, but+    -- fixing the endpoints at (j ∨ ~ j) in the new direction to those+    -- in the Path type.+    lam "j" $ \ j ->+      pure tHComp <#> l <#> (bA <@> j) <#> (phi `imax` (ineg j `imax` j))+        <@> lam "i'" (\i -> combineSys l (bA <@> i)+          [ (phi,    ilam "o" (\ o -> u <@> i <..> o <@@> (x, y, j)))+          , (j,      ilam "o" (const y))+          , (ineg j, ilam "o" (const x)) ])+        <@> (u0 <@@> (x, y, j))++doPathPKanOp (TranspOp phi u0) (IsFam l) (IsFam (bA,x,y)) = do+  let getTermLocal = getTerm "transport for path types"+  iz <- getTermLocal builtinIZero+  io <- getTermLocal builtinIOne++  -- Transport in path types becomes /CCHM/ composition in the+  -- underlying line of spaces. The intuition is that not only do we+  -- have to fix the endpoints (using composition) but also actually+  -- transport. CCHM composition conveniently does that for us!+  --+  -- Γ ⊢ l : I → Level+  --     l is already a function "coming in"+  -- Γ, i ⊢ bA   : Type (l i)+  -- Γ, i ⊢ x, y : bA+  -- Γ ⊢ u0 : PathP (A/i0) (x/i0) (y/i0)+  -- Γ, φ ⊢ bA constant+  --+  --   transp {l} (λ i → PathP A x y) φ p = λ j →+  --      comp {λ i → l j} (λ i → A i j) (φ ∨ j ∨ ~ j) λ i where+  --        (φ = i1 ∨ i = i0) → p j+  --        (j = i0)          → x i+  --        (j = i1)          → y i+  --   : PathP A/i1 x/i1 y/i1++  redReturn <=< runNamesT [] $ do+    -- In reality to avoid a round-trip between primComp we use mkComp+    -- here.+    comp <- mkComp $ "transport for path types"+    l   <- open . unArg $ l+    u0  <- open . unArg $ u0+    phi <- open . unArg $ ignoreBlocking phi+    let lami = open . runNames [] . lam "i" . const . pure . unArg+    bA  <- lami bA+    x   <- lami x+    y   <- lami y+    -- Γ ⊢ bA : (i : I) → Type (l i)+    -- Γ ⊢ x, y : (i : I) → bA i++    lam "j" $ \ j ->+      comp l (lam "i" $ \ i -> bA <@> i <@> j) (phi `imax` (ineg j `imax` j))+        (lam "i'" $ \i -> combineSys (l <@> i) (bA <@> i <@> j)+          [ (phi, ilam "o" (\o -> u0 <@@> (x <@> pure iz, y <@> pure iz, j)))+          -- Note that here we have lines of endpoints, which we must+          -- apply to fix the endpoints:+          , (j,      ilam "_" (const (y <@> i)))+          , (ineg j, ilam "_" (const (x <@> i)))+          ])+        (u0 <@@> (x <@> pure iz, y <@> pure iz, j))+doPathPKanOp a0 _ _ = __IMPOSSIBLE__++redReturnNoSimpl :: a -> ReduceM (Reduced a' a)+redReturnNoSimpl = pure . YesReduction NoSimplification++primTransHComp :: Command -> [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term)+primTransHComp cmd ts nelims = do+  (l,bA,phi,u,u0) <- pure $ case (cmd,ts) of+    (DoTransp, [l, bA, phi, u0]) -> (IsFam l, IsFam bA, phi, Nothing, u0)+    (DoHComp, [l, bA, phi, u, u0]) -> (IsNot l, IsNot bA, phi, Just u, u0)+    _ -> __IMPOSSIBLE__+  sphi <- reduceB' phi+  vphi <- intervalView $ unArg $ ignoreBlocking sphi+  let clP s = getTerm "primTransHComp" s++  -- WORK+  case vphi of+    -- When φ = i1, we know what to do! These cases are counted as+    -- simplifications.+    IOne -> redReturn =<< case cmd of+      DoHComp -> runNamesT [] $ do+        -- If we're composing, then we definitely had a partial element+        -- to extend. But now it's just a total element, so we can+        -- just.. return it:+        u <- open $ unArg $ fromMaybe __IMPOSSIBLE__ u+        u <@> clP builtinIOne <..> clP builtinItIsOne+      DoTransp ->+        -- Otherwise we're in the constant part of the line to transport+        -- over, so we must return the argument unchanged.+        pure $ unArg u0++    _ -> do+    let+      fallback' sc = do+        -- Possibly optimise the partial element to reduce the size of+        -- hcomps:+        u' <- case cmd of+          DoHComp -> (:[]) <$> case vphi of+            -- If φ=i0 then tabulating equality for Partial φ A+            -- guarantees that u = is constantly isOneEmpty,+            -- regardless of how big the original term is, and+            -- isOneEmpty is *tiny*, so let's use that:+            IZero -> fmap (reduced . notBlocked . argN) . runNamesT [] $ do+                l <- open . unArg . famThing $ l+                c <- open . unArg . ignoreBlocking $ sc+                lam "i" $ \ i -> clP builtinIsOneEmpty <#> l <#> ilam "o" (\ _ -> c)++            -- Otherwise we have some interesting formula (though+            -- definitely not IOne!) and we have to keep the partial+            -- element as-is.+            _ -> pure $ notReduced $ fromMaybe __IMPOSSIBLE__ u+          DoTransp -> return []++        pure . NoReduction $ [notReduced (famThing l), reduced sc, reduced sphi] ++ u' ++ [notReduced u0]++    -- Reduce the type whose Kan operations we're composing over:+    sbA <- reduceB' bA+    t <- case unArg <$> ignoreBlocking sbA of+      IsFam (Lam _ t) -> Just . fmap IsFam <$> reduceB' (absBody t)+      IsFam _         -> pure Nothing+      IsNot t         -> pure . Just . fmap IsNot $ (t <$ sbA)++    case t of+      -- If we don't have a grasp of the Kan operations then at least we+      -- can reuse the work we did for reducing the type later.+      Nothing -> fallback' (famThing <$> sbA)+      Just st  -> do+        -- Similarly, if we're stuck for another reason, we can reuse+        -- the work for reducing the family.+        let+          fallback = fallback' (fmap famThing $ st *> sbA)+          t = ignoreBlocking st+          operation = case cmd of+            DoTransp -> TranspOp { kanOpCofib = sphi, kanOpBase = u0 }+            DoHComp -> HCompOp+              { kanOpCofib = sphi, kanOpSides = fromMaybe __IMPOSSIBLE__ u, kanOpBase = u0 }++        mHComp <- getPrimitiveName' builtinHComp+        mGlue <- getPrimitiveName' builtinGlue+        pathV <- pathView'++        -- By cases on the family, determine what Kan operation we defer+        -- to:+        case famThing t of+          -- Metavariables are stuck+          MetaV m _ -> fallback' (fmap famThing $ blocked_ m *> sbA)++          -- TODO: absName t instead of "i"+          Pi a b+            -- For Π types, we prefer to keep the Kan operations around,+            -- so only actually reduce if we applied them to a nonzero+            -- positive of eliminations+            | nelims > 0 -> maybe fallback redReturn =<< doPiKanOp operation "i" ((a, b) <$ t)+            | otherwise -> fallback++          -- For Type, we have two possibilities:+          Sort (Type l)+            -- transp (λ i → Type _) φ is always the identity function.+            | DoTransp <- cmd -> redReturn $ unArg u0+            -- hcomp {Type} is actually a normal form! This is the+            -- "HCompU" optimisation; We do not use Glue for hcomp in+            -- the universe.+            | DoHComp <- cmd -> fallback++          -- Glue types have their own implementation of Kan operations+          -- which are implemented in a different module:+          Def q [Apply la, Apply lb, Apply bA, Apply phi', Apply bT, Apply e] | Just q == mGlue -> do+            maybe fallback redReturn =<< doGlueKanOp+              operation ((la, lb, bA, phi', bT, e) <$ t) Head++          -- Formal homogeneous compositions in the universe: Our family+          -- is @hcomp {A = Type l}@, so we defer to the implementation+          -- of Kan operations for HCompU implemented above.+          Def q [Apply _, Apply s, Apply phi', Apply bT, Apply bA]+            | Just q == mHComp, Sort (Type la) <- unArg s  -> do+            maybe fallback redReturn =<< doHCompUKanOp+              operation ((Level la <$ s, phi', bT, bA) <$ t) Head++          -- PathP types have the same optimisation as for Pi types:+          -- Only compute the Kan operation if there's >0 eliminations.+          d | PathType _ _ _ bA x y <- pathV (El __DUMMY_SORT__ d) -> do+            if nelims > 0 then doPathPKanOp operation l ((bA, x, y) <$ t) else fallback++          Def q es -> do+            info <- getConstInfo q+            let+              lam_i = Lam defaultArgInfo . Abs "i"++              -- When should Kan operations on a record value reduce?+              doR r@Record{recEtaEquality' = eta} = case theEtaEquality eta of+                -- If it's a no-eta, pattern-matching record, then the+                -- Kan operations behave as they do for data types; Only+                -- reduce when the base is a constructor+                NoEta PatternMatching -> case unArg u0 of+                  Con{} -> True+                  _ -> False+                -- For every other case, we can reduce into a value+                -- defined by copatterns; However, this would expose the+                -- internal name of transp/hcomp when printed, so hold+                -- off until there are projections.+                _ -> nelims > 0+              doR _ = False++            -- Record and data types have their own implementations of+            -- the Kan operations, which get generated as part of their+            -- definition.+            case theDef info of+              r@Record{recComp = kit, recEtaEquality' = eta}+                | doR r, Just as <- allApplyElims es, DoTransp <- cmd, Just transpR <- nameOfTransp kit ->+                  -- Optimisation: If the record has no parameters then we can ditch the transport.+                  if recPars r == 0+                     then redReturn $ unArg u0+                     else redReturn $ Def transpR [] `apply` (map (fmap lam_i) as ++ [ignoreBlocking sphi, u0])++                -- Records know how to hcomp themselves:+                | doR r, Just as <- allApplyElims es, DoHComp <- cmd, Just hCompR <- nameOfHComp kit ->+                  redReturn $ Def hCompR [] `apply` (as ++ [ignoreBlocking sphi, fromMaybe __IMPOSSIBLE__ u,u0])++                -- If this is a record with no fields, then compData+                -- will know what to do with it:+                | Just as <- allApplyElims es, [] <- recFields r -> compData Nothing False (recPars r) cmd l (as <$ t) sbA sphi u u0++              -- For data types, if this data type is indexed and/or a+              -- higher inductive type, then hcomp is normal; But+              -- compData knows what to do for the general cases.+              Datatype{dataPars = pars, dataIxs = ixs, dataPathCons = pcons, dataTransp = mtrD}+                | and [null pcons && ixs == 0 | DoHComp  <- [cmd]], Just as <- allApplyElims es ->+                  compData mtrD (not (null pcons) || ixs > 0) (pars + ixs) cmd l (as <$ t) sbA sphi u u0++              -- Is this an axiom with constrant transport? Then. Well. Transport is constant.+              Axiom constTransp | constTransp, [] <- es, DoTransp <- cmd -> redReturn $ unArg u0++              _          -> fallback++          _ -> fallback+  where+    allComponentsBack unview phi u p = do+            let+              boolToI b = if b then unview IOne else unview IZero+              lamlam t = Lam defaultArgInfo (Abs "i" (Lam defaultIrrelevantArgInfo (Abs "o" t)))+            as <- decomposeInterval phi+            (flags,t_alphas) <- fmap unzip . forM as $ \ (bs,ts) -> do+                 let u' = listS bs' `applySubst` u+                     bs' = IntMap.toAscList $ IntMap.map boolToI bs+                     -- Γ₁, i : I, Γ₂, j : I, Γ₃  ⊢ weaken : Γ₁, Γ₂, Γ₃   for bs' = [(j,_),(i,_)]+                     -- ordering of "j,i,.." matters.+                 let weaken = foldr (\ j s -> s `composeS` raiseFromS j 1) idS (map fst bs')+                 t <- reduce2Lam u'+                 return $ (p $ ignoreBlocking t, listToMaybe [ (weaken `applySubst` (lamlam <$> t),bs) | null ts ])+            return $ (flags,t_alphas)+    compData mtrD False _ cmd@DoHComp (IsNot l) (IsNot ps) fsc sphi (Just u) a0 = do+      let getTermLocal :: IsBuiltin a => a -> ReduceM Term+          getTermLocal = getTerm $ "builtinHComp for data types"++      let sc = famThing <$> fsc+      tEmpty <- getTermLocal builtinIsOneEmpty+      tPOr   <- getTermLocal builtinPOr+      iO   <- getTermLocal builtinIOne+      iZ   <- getTermLocal builtinIZero+      tMin <- getTermLocal builtinIMin+      tNeg <- getTermLocal builtinINeg+      let iNeg t = tNeg `apply` [argN t]+          iMin t u = tMin `apply` [argN t, argN u]+          iz = pure iZ+      constrForm <- do+        mz <- getTerm' builtinZero+        ms <- getTerm' builtinSuc+        return $ \ t -> fromMaybe t (constructorForm' mz ms t)+      su  <- reduceB' u+      sa0 <- reduceB' a0+      view   <- intervalView'+      unview <- intervalUnview'+      let f = unArg . ignoreBlocking+          phi = f sphi+          a0 = f sa0+          isLit t@(Lit lt) = Just t+          isLit _ = Nothing+          isCon (Con h _ _) = Just h+          isCon _           = Nothing+          combine l ty d [] = d+          combine l ty d [(psi,u)] = u+          combine l ty d ((psi,u):xs)+            = pure tPOr <#> l <@> psi <@> foldr (imax . fst) iz xs+                        <#> ilam "o" (\ _ -> ty) -- the type+                        <@> u <@> (combine l ty d xs)+          noRed' su = return $ NoReduction [notReduced l,reduced sc, reduced sphi, reduced su', reduced sa0]+            where+              su' = case view phi of+                     IZero -> notBlocked $ argN $ runNames [] $ do+                                 l <- open . unArg $ l+                                 c <- open . unArg . ignoreBlocking $ sc+                                 lam "i" $ \ i -> pure tEmpty <#> l+                                                              <#> ilam "o" (\ _ -> c)+                     _     -> su+          sameConHeadBack Nothing Nothing su k = noRed' su+          sameConHeadBack lt h su k = do+            let u = unArg . ignoreBlocking $ su+            (b, ts) <- allComponentsBack unview phi u $ \ t ->+                        (isLit t == lt, isCon (constrForm t) == h)+            let+              (lit,hd) = unzip b++            if isJust lt && and lit then redReturn a0 else do+            su <- caseMaybe (sequence ts) (return su) $ \ ts -> do+              let (us,bools) = unzip ts+              fmap ((sequenceA_ us $>) . argN) $ do+              let+                phis :: [Term]+                phis = for bools $ \ m ->+                            foldr (iMin . (\(i,b) -> applyUnless b iNeg $ var i)) iO (IntMap.toList m)+              runNamesT [] $ do+                u <- open u+                l <- open . unArg $ l+                c <- open . unArg $ ignoreBlocking sc+                phis <- mapM open phis+                us   <- mapM (open . ignoreBlocking) us+                lam "i" $ \ i -> do+                  combine l c (u <@> i) $ zip phis (map (\ t -> t <@> i) us)++            if isJust h && and hd then k (fromMaybe __IMPOSSIBLE__ h) su+                      else noRed' su++      sameConHeadBack (isLit a0) (isCon a0) su $ \ h su -> do+            let u = unArg . ignoreBlocking $ su+            Constructor{ conComp = cm } <- theDef <$> getConstInfo (conName h)+            case nameOfHComp cm of+              Just hcompD -> redReturn $ Def hcompD [] `apply`+                                          (ps ++ map argN [phi,u,a0])+              Nothing        -> noRed' su++    compData mtrD        _     0     DoTransp (IsFam l) (IsFam ps) fsc sphi Nothing a0 = redReturn $ unArg a0+    compData (Just trD) isHIT _ cmd@DoTransp (IsFam l) (IsFam ps) fsc sphi Nothing a0 = do+      let sc = famThing <$> fsc+      let f = unArg . ignoreBlocking+          phi :: Term+          phi = f $ sphi+      let lam_i = Lam defaultArgInfo . Abs "i"+      redReturn $ Def trD [] `apply` (map (fmap lam_i) ps ++ map argN [phi,unArg a0])++    compData mtrD isHIT _ cmd@DoTransp (IsFam l) (IsFam ps) fsc sphi Nothing a0 = do+      let getTermLocal :: IsBuiltin a => a -> ReduceM Term+          getTermLocal = getTerm $ getBuiltinId builtinTrans ++ " for data types"+      let sc = famThing <$> fsc+      mhcompName <- getName' builtinHComp+      constrForm <- do+        mz <- getTerm' builtinZero+        ms <- getTerm' builtinSuc+        return $ \ t -> fromMaybe t (constructorForm' mz ms t)+      sa0 <- reduceB' a0+      let f = unArg . ignoreBlocking+          phi = f sphi+          a0 = f sa0+          noRed = return $ NoReduction [notReduced l,reduced sc, reduced sphi, reduced sa0]+      let lam_i = Lam defaultArgInfo . Abs "i"+      case constrForm a0 of+        Con h _ args -> do+          Constructor{ conComp = cm } <- theDef <$> getConstInfo (conName h)+          case nameOfTransp cm of+              Just transpD -> redReturn $ Def transpD [] `apply`+                                          (map (fmap lam_i) ps ++ map argN [phi,a0])+              Nothing        -> noRed+        Def q es | isHIT, Just q == mhcompName, Just [_l0,_c0,psi,u,u0] <- allApplyElims es -> do+           let bC = ignoreBlocking sc+           hcomp <- getTermLocal builtinHComp+           transp <- getTermLocal builtinTrans+           io <- getTermLocal builtinIOne+           iz <- getTermLocal builtinIZero+           redReturn <=< runNamesT [] $ do+             l   <- open . unArg $ l+             bC  <- open . unArg $ bC+             phi <- open . unArg $ ignoreBlocking sphi+             psi <- open . unArg $ psi+             u   <- open . unArg $ u+             u0  <- open . unArg $ u0+             -- hcomp (sc 1) [psi |-> transp sc phi u] (transp sc phi u0)+             pure hcomp <#> (l <@> pure io) <#> (bC <@> pure io) <#> psi+                   <@> lam "j" (\ j -> ilam "o" $ \ o ->+                        pure transp <#> l <@> bC <@> phi <@> (u <@> j <..> o))+                   <@> (pure transp <#> l <@> bC <@> phi <@> u0)+        _ -> noRed+    compData mtrX isHITorIx nargs cmd l t sbA sphi u u0 = do+      () <- reportSDoc "impossible" 10 $ "compData" <+> (nest 2 . vcat)+       [ "mtrX:       " <+> pretty mtrX+       , "isHITorIx:  " <+> pretty isHITorIx+       , "nargs:      " <+> pretty nargs+       , "cmd:        " <+> text (show cmd)+       , "l:          " <+> familyOrNot l+       , "t:          " <+> familyOrNot t <+> pretty (famThing t)+       , "sbA:          " <+> familyOrNot (ignoreBlocking $ sbA)+       , "sphi:       " <+> pretty (ignoreBlocking sphi)+       , "isJust u:   " <+> pretty (isJust u)+       , "u0:         " <+> pretty u0+       ]+      __IMPOSSIBLE__++--    compData _ _ _ _ _ _ _ _ _ _ = __IMPOSSIBLE__++-- | CCHM 'primComp' is implemented in terms of 'hcomp' and 'transport'.+-- The definition of it comes from 'mkComp'.+primComp :: TCM PrimitiveImpl+primComp = do+  requireCubical CErased+  t    <- runNamesT [] $+          hPi' "a" (primIntervalType --> els (pure LevelUniv) (cl primLevel)) $ \ a ->+          nPi' "A" (nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA ->+          hPi' "φ" primIntervalType $ \ phi ->+          nPi' "i" primIntervalType (\ i -> pPi' "o" phi $ \ _ -> el' (a <@> i) (bA <@> i)) -->+          (el' (a <@> cl primIZero) (bA <@> cl primIZero) --> el' (a <@> cl primIOne) (bA <@> cl primIOne))+  one <- primItIsOne+  io  <- primIOne+  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 5 [] $ \ts nelims -> do+    case ts of+      [l,c,phi,u,a0] -> do+        sphi <- reduceB' phi+        vphi <- intervalView $ unArg $ ignoreBlocking sphi+        case vphi of+          -- Though we short-circuit evaluation for the rule+          --    comp A i1 (λ _ .1=1 → u) u ==> u+          -- rather than going through the motions of hcomp and transp.+          IOne -> redReturn (unArg u `apply` [argN io, argN one])+          _    -> do+            redReturnNoSimpl <=< runNamesT [] $ do+              comp <- mkComp (getBuiltinId PrimComp)+              l   <- open . unArg $ l+              c   <- open . unArg $ c+              phi <- open . unArg $ phi+              u   <- open . unArg $ u+              a0  <- open . unArg $ a0+              comp l c phi u a0++      _ -> __IMPOSSIBLE__+++-- TODO Andrea: keep reductions that happen under foralls?+primFaceForall' :: TCM PrimitiveImpl+primFaceForall' = do+  requireCubical CErased+  t <- (primIntervalType --> primIntervalType) --> primIntervalType+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \case+    [phi] -> do+      sphi <- reduceB' phi+      case unArg $ ignoreBlocking $ sphi of+        Lam _ t -> do+          t <- reduce' t+          case t of+            NoAbs _ t -> redReturn t+            Abs _ t ->+              maybe (return $ NoReduction [reduced sphi]) redReturn+                =<< toFaceMapsPrim t+        _ -> return (NoReduction [reduced sphi])+    _ -> __IMPOSSIBLE__+  where+    toFaceMapsPrim t = do+      view <- intervalView'+      unview <- intervalUnview'+      us' <- decomposeInterval t+      fr <- getTerm (getBuiltinId PrimFaceForall) PrimFaceForall+      let+        v = view t+        -- We decomposed the interval expression, without regard for+        -- inconsistent mappings, and now we keep only those which are+        -- stuck (the ts) and those which do not mention the 0th variable.+        us :: [[Either (Int, Bool) Term]]+        us = [ map Left (IntMap.toList bsm) ++ map Right ts+             | (bsm, ts) <- us', 0 `IntMap.notMember` bsm+             ]++        -- Turn a face mapping back into an interval expression:+        fm (i, b) = if b then var (i - 1) else unview (INeg (argN (var $ i - 1)))+        -- Apply ∀ to any indecomposable expressions we have encountered+        ffr t = fr `apply` [argN $ Lam defaultArgInfo $ Abs "i" t]++        -- Unfold one step of the foldr to avoid generation of the last+        -- ∧ i1. Marginal savings at best but it's cleaner.+        conjuncts :: [Either (Int, Bool) Term] -> Term+        conjuncts [] = unview IOne+        conjuncts [x] = either fm ffr x+        conjuncts (x:xs) =+          foldr (\x r -> unview (IMin (argN (either fm ffr x)) (argN r)))+            (either fm ffr x)+            xs++        disjuncts = foldr+          (\conj rest -> unview (IMax (argN (conjuncts conj)) (argN rest)))+          (unview IZero)+          us+      --   traceSLn "cube.forall" 20 (unlines [show v, show us', show us, show r]) $+      return $ case us' of+        [(m, [_])] | null m -> Nothing+        _ -> Just disjuncts++-- | Tries to @primTransp@ a whole telescope of arguments, following the rule for Σ types.+--   If a type in the telescope does not support transp, @transpTel@ throws it as an exception.+transpTel :: Abs Telescope -- Γ ⊢ i.Δ+          -> Term          -- Γ ⊢ φ : F  -- i.Δ const on φ+          -> Args          -- Γ ⊢ δ : Δ[0]+          -> ExceptT (Closure (Abs Type)) TCM Args      -- Γ ⊢ Δ[1]+transpTel = transpTel' False+++transpTel' :: (PureTCM m, MonadError TCErr m) =>+          Bool -> Abs Telescope -- Γ ⊢ i.Δ+          -> Term          -- Γ ⊢ φ : F  -- i.Δ const on φ+          -> Args          -- Γ ⊢ δ : Δ[0]+          -> ExceptT (Closure (Abs Type)) m Args      -- Γ ⊢ Δ[1]+transpTel' flag delta phi args = transpSysTel' flag delta [] phi args++type LM m a = NamesT (ExceptT (Closure (Abs Type)) m) a+-- transporting with an extra system/partial element+-- or composing when some of the system is known to be constant.+transpSysTel' :: forall m. (PureTCM m, MonadError TCErr m) =>+          Bool+          -> Abs Telescope -- Γ ⊢ i.Δ+          -> [(Term,Abs [Term])] -- [(ψ,i.δ)] with  Γ,ψ ⊢ i.δ : [i : I]. Δ[i]  -- the proof of [ψ] is not in scope.+          -> Term          -- Γ ⊢ φ : F  -- i.Δ const on φ and all i.δ const on φ ∧ ψ+          -> Args          -- Γ ⊢ δ : Δ[0]+          -> ExceptT (Closure (Abs Type)) m Args      -- Γ ⊢ Δ[1]+transpSysTel' flag delta us phi args = do+  reportSDoc "cubical.prim.transpTel" 20 $+      sep [ text "transpSysTel'"+          , (text "delta  =" <+>) $ nest 2 $ addContext ("i" :: String, __DUMMY_DOM__) $ prettyTCM (unAbs delta)+--          , (text "us =" <+>) $ nest 2 $ prettyList $ map prettyTCM us+          , (text "phi    =" <+>) $ nest 2 $ prettyTCM phi+          , (text "args   =" <+>) $ nest 2 $ prettyList $ map prettyTCM args+          ]+  let getTermLocal :: IsBuiltin a => a -> ExceptT e m Term+      getTermLocal = getTerm "transpSys"+  tTransp <- lift primTrans+  tComp <- getTermLocal builtinComp+  tPOr <- getTermLocal builtinPOr+  iz <- lift primIZero+  imin <- lift primIMin+  imax <- lift primIMax+  ineg <- lift primINeg+  let+    noTranspError t = do+      reportSDoc "cubical.prim.transpTel.error" 20 $ nest 2 $ (text "error type =" <+>) $+        addContext ("i" :: String, __DUMMY_DOM__) $ prettyTCM $ unAbs t+      lift . throwError =<< buildClosure t+    bapp :: forall m a. (Applicative m, Subst a) => m (Abs a) -> m (SubstArg a) -> m a+    bapp t u = lazyAbsApp <$> t <*> u+    doGTransp l t us phi a | null us = pure tTransp <#> l <@> (Lam defaultArgInfo . fmap unEl <$> t) <@> phi <@> a+                           | otherwise = pure tComp <#> l <@> (Lam defaultArgInfo . fmap unEl <$> t) <#> face <@> uphi <@> a+      where+        -- [phi -> a; us]+        face = foldr (\ x y -> pure imax <@> x <@> y) (pure iz) (phi : map fst us)+        uphi = lam "i" $ \ i -> ilam "o" $ \ o -> do+          let sys' = (phi , a) : map (mapSnd (`bapp` i)) us+              sys = map (mapSnd $ ilam "o" . const) sys'+          combine (l <@> i) (unEl <$> bapp t i) __IMPOSSIBLE__ sys <..> o+    combine l ty d [] = d+    combine l ty d [(psi,u)] = u+    combine l ty d ((psi,u):xs)+            = pure tPOr <#> l <@> psi <@> (foldr (\ x y -> pure imax <@> x <@> y) (pure iz) (map fst xs))+                        <#> ilam "o" (\ _ -> ty) -- the type+                        <@> u <@> (combine l ty d xs)++    gTransp :: Maybe (LM m Term) -> LM m (Abs Type) -> [(LM m Term,LM m (Abs Term))] -> LM m Term -> LM m Term -> LM m Term+    gTransp (Just l) t u phi a+     | flag = do+      t' <- t+      us' <- mapM snd u+      case ( 0 `freeIn` (raise 1 t' `lazyAbsApp` var 0)+           , 0 `freeIn` map (\ u -> raise 1 u `lazyAbsApp` var 0) us'+           ) of+        (False,False) -> a+        (False,True)  -> doGTransp l t u phi a -- TODO? optimize to "hcomp (l <@> io) (bapp t io) ((phi,NoAbs a):u) a" ?+        (True,_) -> doGTransp l t u phi a+     | otherwise = doGTransp l t u phi a++    gTransp Nothing t sys phi a = do+      let (psis,us) = unzip sys+      -- Γ ⊢ i.Ξ+      xi <- (open =<<) $ do+        bind "i" $ \ i -> do+          TelV xi _ <- (lift . telView =<<) $ t `bapp` i+          return xi+      argnames <- do+        teleArgNames . unAbs <$> xi+      glamN argnames $ \ xi_args -> do+        b' <- bind "i" $ \ i -> do+          ti <- t `bapp` i+          xin <- bind "i" $ \ i -> xi `bapp` (pure ineg <@> i)+          xi_args <- xi_args+          ni <- pure ineg <@> i+          phi <- phi+          lift $ piApplyM ti =<< trFillTel' flag xin phi xi_args ni+        usxi <- forM us $ \ u -> bind "i" $ \ i -> do+          ui <- u `bapp` i+          xin <- bind "i" $ \ i -> xi `bapp` (pure ineg <@> i)+          xi_args <- xi_args+          ni <- pure ineg <@> i+          phi <- phi+          lift $ apply ui <$> trFillTel' flag xin phi xi_args ni+        axi <- do+          a <- a+          xif <- bind "i" $ \ i -> xi `bapp` (pure ineg <@> i)+          phi <- phi+          xi_args <- xi_args+          lift $ apply a <$> transpTel' flag xif phi xi_args+        s <- reduce $ getSort (absBody b')+        reportSDoc "cubical.transp" 20 $ pretty (raise 1 b' `lazyAbsApp` var 0)+        let noTranspSort = if 0 `freeIn` (raise 1 b' `lazyAbsApp` var 0) || 0 `freeIn` (map (`lazyAbsApp` var 0) (raise 1 usxi))+              then noTranspError b'+              else return axi++        case s of+          Univ UType l -> do+            l <- open $ lam_i $ Level l+            b' <- open b'+            axi <- open axi+            usxi <- mapM open usxi+            gTransp (Just l) b' (zip psis usxi) phi axi+          Univ _ _     -> noTranspSort+          Inf _ _      -> noTranspSort+          IntervalUniv -> noTranspSort+          LevelUniv    -> noTranspSort+          LockUniv     -> noTranspSort+          SizeUniv     -> noTranspSort+          PiSort{}     -> noTranspError b'+          FunSort{}    -> noTranspError b'+          UnivSort{}   -> noTranspError b'+          MetaS{}      -> noTranspError b'+          DefS{}       -> noTranspError b'+          DummyS{}     -> noTranspError b'++    lam_i = Lam defaultArgInfo . Abs "i"+    go :: Telescope -> [[(Term,Term)]] -> Term -> Args -> ExceptT (Closure (Abs Type)) m Args+    go EmptyTel            [] _  []       = return []+    go (ExtendTel t delta) (u:us) phi (a:args) = do+      -- Γ,i ⊢ t+      -- Γ,i ⊢ (x : t). delta+      -- Γ ⊢ a : t[0]+      s <- reduce $ getSort t+      -- Γ ⊢ b : t[1]    Γ, i ⊢ bf : t[i]+      (b,bf) <- runNamesT [] $ do+        let b' = Abs "i" $ unDom t+        l <- case s of+          Univ UType l -> Just <$> open (lam_i (Level l))+          Univ USSet _ -> pure Nothing+          Univ UProp _ -> noTranspError b'  -- Issue #6060+          Inf  UType _ -> pure Nothing+          Inf  USSet _ -> pure Nothing+          Inf  UProp _ -> noTranspError b'  -- Issue #7535+          IntervalUniv -> pure Nothing+          LevelUniv    -> pure Nothing+          LockUniv     -> pure Nothing+          SizeUniv     -> pure Nothing+          PiSort{}     -> noTranspError b'+          FunSort{}    -> noTranspError b'+          UnivSort{}   -> noTranspError b'+          MetaS{}      -> noTranspError b'+          DefS{}       -> noTranspError b'+          DummyS{}     -> noTranspError b'+        t <- open b'+        u <- forM u $ \ (psi,upsi) -> do+              (,) <$> open psi <*> open (Abs "i" upsi)+        phi <- open phi+        a   <- open $ unArg a+        b <- gTransp l t u phi a+        bf <- bind "i" $ \ i -> do+                            gTransp ((<$> l) $ \ l -> lam "j" $ \ j -> l <@> (pure imin <@> i <@> j))+                                    (bind "j" $ \ j -> t `bapp` (pure imin <@> i <@> j))+                                    u+                                    (pure imax <@> (pure ineg <@> i) <@> phi)+                                    a+        return (b, absBody bf)+      (:) (b <$ a) <$> go (lazyAbsApp delta bf) us phi args+    go EmptyTel            _ _ _ = __IMPOSSIBLE__+    go (ExtendTel t delta) _ _ _ = __IMPOSSIBLE__+  let (psis,uss) = unzip us+      us' | null us = replicate (length args) []+          | otherwise = map (zip psis) $ List.transpose (map absBody uss)+  go (absBody delta) us' phi args++-- | Like @transpTel@ but performing a transpFill.+trFillTel :: Abs Telescope -- Γ ⊢ i.Δ+          -> Term+          -> Args          -- Γ ⊢ δ : Δ[0]+          -> Term          -- Γ ⊢ r : I+          -> ExceptT (Closure (Abs Type)) TCM Args      -- Γ ⊢ Δ[r]+trFillTel = trFillTel' False++trFillTel' :: (PureTCM m, MonadError TCErr m) =>+          Bool+          -> Abs Telescope -- Γ ⊢ i.Δ+          -> Term+          -> Args          -- Γ ⊢ δ : Δ[0]+          -> Term          -- Γ ⊢ r : I+          -> ExceptT (Closure (Abs Type)) m Args      -- Γ ⊢ Δ[r]+trFillTel' flag delta phi args r = do+  imin <- lift primIMin+  imax <- lift primIMax+  ineg <- lift primINeg+  transpTel' flag (Abs "j" $ raise 1 delta `lazyAbsApp` (imin `apply` (map argN [var 0, raise 1 r])))+            (imax `apply` [argN $ ineg `apply` [argN r], argN phi])+            args++++-- hcompTel' :: Bool -> Telescope -> [(Term,Abs [Term])] -> [Term] -> ExceptT (Closure (Abs Type)) TCM [Term]+-- hcompTel' b delta sides base = undefined++-- hFillTel' :: Bool -> Telescope -- Γ ⊢ Δ+--           -> [(Term,Abs [Term])]  -- [(φ,i.δ)] with  Γ,φ ⊢ i.δ : I → Δ+--           -> [Term]            -- Γ ⊢ δ0 : Δ, matching the [(φ,i.δ)]+--           -> Term -- Γ ⊢ r : I+--           -> ExceptT (Closure (Abs Type)) TCM [Term]+-- hFillTel' b delta sides base = undefined++pathTelescope :: forall m. (PureTCM m, MonadError TCErr m)+  => Telescope  -- ^ Δ+  -> [Arg Term] -- ^ lhs : Δ+  -> [Arg Term] -- ^ rhs : Δ+  -> m Telescope+pathTelescope tel lhs rhs = do+  runExceptT (pathTelescope' tel lhs rhs) >>= \case+    Left t -> do+      enterClosure t $ \ t ->+                 typeError . GenericDocError =<<+                    (text "The sort of" <+> pretty t <+> text "should be of the form \"Set l\"")+    Right tel -> return tel++pathTelescope' :: forall m. (PureTCM m, MonadError (Closure Type) m)+  => Telescope  -- ^ Δ+  -> [Arg Term] -- ^ lhs : Δ+  -> [Arg Term] -- ^ rhs : Δ+  -> m Telescope+pathTelescope' tel lhs rhs = do+  pathp <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPathP+  go pathp (raise 1 tel) lhs rhs+ where+  -- Γ,i ⊢ Δ, Γ ⊢ lhs : Δ[0], Γ ⊢ rhs : Δ[1]+  go :: Term -> Telescope -> [Arg Term] -> [Arg Term] -> m Telescope+  go pathp (ExtendTel a tel) (u : lhs) (v : rhs) = do+    let t = unDom a+    l <- subst 0 __DUMMY_TERM__ <$> getLevel t+    let a' = El (Type l) (apply pathp $ [argH $ Level l] ++ map argN [Lam defaultArgInfo (Abs "i" $ unEl t), unArg u, unArg v])+        -- Γ,eq : u ≡ v, i : I ⊢ m = eq i : t[i]+        -- m  = runNames [] $ do+        --        [u,v] <- mapM (open . unArg) [u,v]+        --        bind "eq" $ \ eq -> bind "i" $ \ i ->+    (ExtendTel (a' <$ a) <$>) . runNamesT [] $ do+      let nm = (absName tel)+      tel <- open $ Abs "i" tel+      u   <- open $ unArg u+      v   <- open $ unArg v+      lhs <- open lhs+      rhs <- open rhs+      bind nm $ \ eq -> do+        lhs <- lhs+        rhs <- rhs+        tel' <- bind "i" $ \ i ->+                  lazyAbsApp <$> (lazyAbsApp <$> tel <*> i) <*> (eq <@@> (u, v, i))+        lift $ go pathp (absBody tel') lhs rhs+  go _ EmptyTel [] [] = return EmptyTel+  go _ _ _ _ = __IMPOSSIBLE__+  getLevel :: Type -> m Level+  getLevel t = do+    s <- reduce $ getSort t+    case s of+      Type l -> pure l+      s      -> throwError =<< buildClosure t++data TranspError = CannotTransp {errorType :: (Closure (Abs Type)) }++instance Exception TranspError+instance Show TranspError where+  show _ = "TranspError"++tryTranspError :: TCM a -> TCM (Either (Closure (Abs Type)) a)+tryTranspError (TCM m) = TCM $ \ s env -> do+  mapLeft errorType <$> (try (m s env))++transpPathPTel' ::+             NamesT TCM (Abs (Abs Telescope)) -- ^ j.i.Δ                 const on φ+             -> [NamesT TCM Term]          -- ^ x : (i : I) → Δ[0,i]  const on φ+             -> [NamesT TCM Term]          -- ^ y : (i : I) → Δ[1,i]  const on φ+             -> NamesT TCM Term            -- ^ φ+             -> [NamesT TCM Term]          -- ^ p : PathP (λ j → Δ[j,0]) (x 0) (y 0)+             -> NamesT TCM [Arg Term] -- PathP (λ j → Δ[j,0]) (x 1) (y 1) [ φ ↦ q ]+transpPathPTel' theTel x y phi p = do+ let neg j = cl primINeg <@> j+ -- is the open overkill?+ qs <- (open =<<) $ fmap (fmap (\ (Abs n (Arg i t)) -> Arg i (Lam defaultArgInfo $ Abs n t)) . sequenceA)+                  $ bind "j" $ \ j -> do+   theTel <- absApp <$> theTel <*> j+   faces <- sequence [neg j, j]+   us <- forM [x,y] $ \ z -> do+           bind "i" $ \ i -> forM z (<@> i)+   let sys = zip faces us+   -- [(neg j, bind "i" $ \ i -> flip map x (<@> i))+   -- ,(j , bind "i" $ \ i -> flip map y (<@> i))]+   phi <- phi+   p0 <- mapM (<@> j) p+   let toArgs = zipWith (\ a t -> t <$ a) (teleArgNames (unAbs $ theTel))+   eq <- lift . runExceptT $ transpSysTel' False theTel sys phi (toArgs p0)+   either (lift . lift . throw . CannotTransp) pure eq+ qs++transpPathTel' ::+             NamesT TCM (Abs Telescope) -- ^ i.Δ                 const on φ+             -> [NamesT TCM Term]          -- ^ x : (i : I) → Δ[i]  const on φ+             -> [NamesT TCM Term]          -- ^ y : (i : I) → Δ[i]  const on φ+             -> NamesT TCM Term            -- ^ φ+             -> [NamesT TCM Term]          -- ^ p : Path (Δ[0]) (x 0) (y 0)+             -> NamesT TCM [Arg Term] -- Path (Δ[1]) (x 1) (y 1) [ φ ↦ q ]+transpPathTel' theTel x y phi p = do+ let neg j = cl primINeg <@> j+ -- is the open overkill?+ qs <- (open =<<) $ fmap (fmap (\ (Abs n (Arg i t)) -> Arg i (Lam defaultArgInfo $ Abs n t)) . sequenceA)+                  $ bind "j" $ \ j -> do+   theTel <- theTel+   faces <- sequence $ [neg j, j]+   us <- forM [x,y] $ \ z -> do+           bind "i" $ \ i -> forM z (<@> i)+   let sys = zip faces us+   -- [(neg j, bind "i" $ \ i -> flip map x (<@> i))+   -- ,(j , bind "i" $ \ i -> flip map y (<@> i))]+   phi <- phi+   p0 <- mapM (<@> j) p+   let toArgs = zipWith (\ a t -> t <$ a) (teleArgNames (unAbs theTel))+   eq <- lift . runExceptT $ transpSysTel' False theTel sys phi (toArgs p0)+   either (lift . lift . throw . CannotTransp) pure eq+ qs++trFillPathTel' ::+               NamesT TCM (Abs Telescope) -- ^ i.Δ                 const on φ+             -> [NamesT TCM Term]          -- ^ x : (i : I) → Δ[i]  const on φ+             -> [NamesT TCM Term]          -- ^ y : (i : I) → Δ[i]  const on φ+             -> NamesT TCM Term            -- ^ φ+             -> [NamesT TCM Term]          -- ^ p : Path (Δ[0]) (x 0) (y 0)+             -> NamesT TCM Term            -- ^ r+             -> NamesT TCM [Arg Term] -- Path (Δ[r]) (x r) (y r) [ φ ↦ q; (r = 0) ↦ q ]+trFillPathTel' tel x y phi p r = do+  let max i j = cl primIMin <@> i <@> j+  let min i j = cl primIMin <@> i <@> j+  let neg i = cl primINeg <@> i+  x' <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> forM x (<@> (min r i))+  y' <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> forM y (<@> (min r i))+  transpPathTel' (bind "i" $ \ i -> absApp <$> tel <*> min r i)+                 x'+                 y'+                 (max phi (neg r))+                 p++trFillPathPTel' ::+               NamesT TCM (Abs (Abs Telescope)) -- ^ j.i.Δ                 const on φ+             -> [NamesT TCM Term]          -- ^ x : (i : I) → Δ[0,i]  const on φ+             -> [NamesT TCM Term]          -- ^ y : (i : I) → Δ[1,i]  const on φ+             -> NamesT TCM Term            -- ^ φ+             -> [NamesT TCM Term]          -- ^ p : Path (\ j -> Δ[j,0]) (x 0) (y 0)+             -> NamesT TCM Term            -- ^ r+             -> NamesT TCM [Arg Term] -- Path (\ j → Δ[j,r]) (x r) (y r) [ φ ↦ q; (r = 0) ↦ q ]+trFillPathPTel' tel x y phi p r = do+  let max i j = cl primIMin <@> i <@> j+  let min i j = cl primIMin <@> i <@> j+  let neg i = cl primINeg <@> i+  x' <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> forM x (<@> (min r i))+  y' <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> forM y (<@> (min r i))+  transpPathPTel' (bind "j" $ \ j -> bind "i" $ \ i -> absApp <$> (absApp <$> tel <*> j) <*> min r i)+                 x'+                 y'+                 (max phi (neg r))+                 p++++-- given Γ ⊢ I type, and Γ ⊢ Δ telescope, build Δ^I such that+-- Γ ⊢ (x : A, y : B x, ...)^I = (x : I → A, y : (i : I) → B (x i), ...)+expTelescope :: Type -> Telescope -> Telescope+expTelescope int tel = unflattenTel names ys+  where+    stel = size tel+    xs = flattenTel tel+    names = teleNames tel+    t = ExtendTel (defaultDom $ raise stel int) (Abs "i" EmptyTel)+    s = expS stel+    ys = map (fmap (abstract t) . applySubst s) xs+++-- | Γ, Δ^I, i : I |- expS |Δ| : Γ, Δ+expS :: Nat -> Substitution+expS stel = prependS __IMPOSSIBLE__+  [ Just (var n `apply` [Arg defaultArgInfo $ var 0]) | n <- [1..stel] ]+  (raiseS (stel + 1))+++-- * Special cases of Type+-----------------------------------------------------------++-- | A @Type@ with sort @Type l@+--   Such a type supports both hcomp and transp.+data LType = LEl Level Term deriving (Eq,Show)++fromLType :: LType -> Type+fromLType (LEl l t) = El (Type l) t++lTypeLevel :: LType -> Level+lTypeLevel (LEl l t) = l++toLType :: MonadReduce m => Type -> m (Maybe LType)+toLType ty = do+  sort <- reduce $ getSort ty+  case sort of+    Type l -> return $ Just $ LEl l (unEl ty)+    _      -> return $ Nothing++instance Subst LType where+  type SubstArg LType = Term+  applySubst rho (LEl l t) = LEl (applySubst rho l) (applySubst rho t)++-- | A @Type@ that either has sort @Type l@ or is a closed definition.+--   Such a type supports some version of transp.+--   In particular we want to allow the Interval as a @ClosedType@.+data CType = ClosedType Sort QName | LType LType deriving (Eq,Show)++instance P.Pretty CType where+  pretty = P.pretty . fromCType++fromCType :: CType -> Type+fromCType (ClosedType s q) = El s (Def q [])+fromCType (LType t) = fromLType t++toCType :: MonadReduce m => Type -> m (Maybe CType)+toCType ty = do+  sort <- reduce $ getSort ty+  case sort of+    Type l -> return $ Just $ LType (LEl l (unEl ty))+    SSet _ -> do+      t <- reduce (unEl ty)+      case t of+        Def q [] -> return $ Just $ ClosedType sort q+        _        -> return $ Nothing+    Prop _       -> pure Nothing+    Inf _ _      -> pure Nothing+    IntervalUniv -> pure Nothing  -- ClosedType?  (See comment on CType.)+    LevelUniv    -> pure Nothing  -- TODO: Or some ClosedType?+    LockUniv     -> pure Nothing+    SizeUniv     -> pure Nothing+    PiSort{}     -> pure Nothing+    FunSort{}    -> pure Nothing+    UnivSort{}   -> pure Nothing+    MetaS{}      -> pure Nothing+    DefS{}       -> pure Nothing+    DummyS{}     -> pure Nothing+++instance Subst CType where+  type SubstArg CType = Term+  applySubst rho (ClosedType s q) = ClosedType (applySubst rho s) q+  applySubst rho (LType t) = LType $ applySubst rho t++hcomp :: (HasBuiltins m, MonadError TCErr m, MonadReduce m, MonadPretty m)+  => NamesT m Type+  -> [(NamesT m Term, NamesT m Term)]+  -> NamesT m Term+  -> NamesT m Term+hcomp ty sys u0 = do+  iz <- primIZero+  tHComp <- primHComp+  let max i j = cl primIMax <@> i <@> j+  ty <- ty+  (l, ty) <- toLType ty >>= \case+    Just (LEl l ty) -> return (l, ty)+    Nothing -> -- TODO: support Setω properly+      typeError $ CannotGenerateHCompClause ty+  l <- open $ Level l+  ty <- open $ ty+  face <- (foldr max (pure iz) $ map fst $ sys)+  sys <- lam "i'" $ \ i -> combineSys l ty [(phi, u <@> i) | (phi,u) <- sys]+  pure tHComp <#> l <#> ty <#> pure face <@> pure sys <@> u0++transpSys :: (HasBuiltins m, MonadError TCErr m, MonadReduce m) =>+               NamesT m (Abs Type) -- ty+               -> [(NamesT m Term, NamesT m Term)] -- sys+               -> NamesT m Term -- φ+               -> NamesT m Term+               -> NamesT m Term+transpSys ty sys phi u = do+  let max i j = cl primIMax <@> i <@> j+  iz <- primIZero+  tTransp <- primTrans+  tComp <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinComp+  l_ty <- bind "i" $ \ i -> do+      ty <- absApp <$> ty <*> i+      toLType ty >>= \case+        Just (LEl l ty) -> return (l,ty)+        Nothing -> return (__DUMMY_LEVEL__, unEl ty) -- TODO: properly support Setω+  l <- open $ Lam defaultArgInfo . fmap (Level . fst) $ l_ty+  ty <- open $ Lam defaultArgInfo . fmap snd $ l_ty++  if null sys then pure tTransp <#> l <@> ty <@> phi <@> u else do++  let face = max phi (foldr max (pure iz) $ map fst $ sys)+  sys <- (open =<<) $ lam "i'" $ \ i -> do+    let base = (phi, ilam "o" $ \ _ -> u)+    combineSys l ty $ base : [(phi, u <@> i) | (phi,u) <- sys]++  pure tComp <#> l <@> ty <#> face <@> sys <@> u++debugClause :: String -> Clause -> TCM ()+debugClause s c = do+      reportSDoc s 20 $+        "gamma:" <+> prettyTCM gamma+      reportSDoc s 20 $ addContext gamma $+        "ps   :" <+> prettyTCM (patternsToElims ps)+      reportSDoc s 20 $ addContext gamma $+        "type :" <+> maybe "nothing" prettyTCM rhsTy+      reportSDoc s 20 $ addContext gamma $+        "body :" <+> maybe "nothing" prettyTCM rhs++      reportSDoc s 30 $+        addContext gamma $ "c:" <+> pretty c+  where+    gamma = clauseTel c+    ps = namedClausePats c+    rhsTy = clauseType c+    rhs = clauseBody c
+ src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs view
@@ -0,0 +1,406 @@+-- | Implementations of the basic primitives of Cubical Agda: The+-- interval and its operations.++module Agda.TypeChecking.Primitive.Cubical.Base+  ( requireCubical+  , primIntervalType+  , primIMin', primIMax', primINeg'+  , imax, imin, ineg++  , Command(..), KanOperation(..), kanOpName, TermPosition(..), headStop+  , FamilyOrNot(..), familyOrNot++    -- * Helper functions for building terms+  , combineSys, combineSys'+  , fiber, hfill+  , decomposeInterval', decomposeInterval+  , reduce2Lam+  , isCubicalSubtype+  )+  where++import Control.Monad        ( msum, mzero )+import Control.Monad.Except ( MonadError )++import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)+import Data.String (IsString (fromString))+import Data.Bifunctor (second)+import Data.Either (partitionEithers)+import Data.Maybe (fromMaybe, maybeToList)++import qualified Agda.Utils.BoolSet as BoolSet+import Agda.Utils.Impossible (__IMPOSSIBLE__)+import Agda.Utils.BoolSet (BoolSet)+import Agda.Utils.Functor++import Agda.TypeChecking.Monad.Signature (HasConstInfo)+import Agda.TypeChecking.Monad.Debug (__IMPOSSIBLE_VERBOSE__)+import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Monad.Context+import Agda.TypeChecking.Monad.Pure+import Agda.TypeChecking.Monad.Base++import Agda.TypeChecking.Substitute.Class (absBody, raise, apply)++import Agda.TypeChecking.Reduce (Reduce(..), reduceB', reduce', reduce)+import Agda.TypeChecking.Names (NamesT, runNamesT, ilam, lam)++import Agda.Syntax.Common+  (Cubical(..), Arg(..), relevant, irrelevant, setRelevance, defaultArgInfo, hasQuantity0)++import Agda.TypeChecking.Primitive.Base+  (SigmaKit(..), (-->), nPi', pPi', (<@>), (<#>), (<..>), argN, getSigmaKit)++import Agda.Syntax.Internal+++-- | Checks that the correct variant of Cubical Agda is activated.+-- Note that @--erased-cubical@ \"counts as\" @--cubical@ in erased+-- contexts.+requireCubical+  :: Cubical -- ^ Which variant of Cubical Agda is required?+  -> TCM ()+requireCubical wanted = requireCubical' wanted ""++-- | Generalization of 'requireCubical' supplying a reason.+requireCubical'+  :: Cubical -- ^ Which variant of Cubical Agda is required?+  -> String  -- ^ Why, exactly, do we need Cubical to be enabled?+  -> TCM ()+requireCubical' wanted reason = do+  cubical         <- cubicalOption+  inErasedContext <- hasQuantity0 <$> viewTC eQuantity+  case cubical of+    Just CFull -> return ()+    Just CErased | wanted == CErased || inErasedContext -> return ()+    _ -> typeError $ NeedOptionCubical wanted reason++-- | Our good friend the interval type.+primIntervalType :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Type+primIntervalType = El intervalSort <$> primInterval++-- | Negation on the interval. Negation satisfies De Morgan's laws, and+-- their implementation is handled here.+primINeg' :: TCM PrimitiveImpl+primINeg' = do+  requireCubical CErased+  t <- primIntervalType --> primIntervalType+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \case+    [x] -> do+      unview <- intervalUnview'+      view <- intervalView'+      sx <- reduceB' x+      ix <- intervalView (unArg $ ignoreBlocking sx)++      -- Apply De Morgan's laws.+      let+        ineg :: Arg Term -> Arg Term+        ineg = fmap (unview . f . view)++        f ix = case ix of+          IZero    -> IOne+          IOne     -> IZero+          IMin x y -> IMax (ineg x) (ineg y)+          IMax x y -> IMin (ineg x) (ineg y)+          INeg x   -> OTerm (unArg x)+          OTerm t  -> INeg (Arg defaultArgInfo t)++      -- We force the argument in case it happens to be an interval+      -- expression, but it's quite possible that it's _not_. In those+      -- cases, negation is stuck.+      case ix of+        OTerm t -> return $ NoReduction [reduced sx]+        _       -> redReturn (unview $ f ix)+    _ -> __IMPOSSIBLE_VERBOSE__ "implementation of primINeg called with wrong arity"++-- | Internal helper for constructing binary operations on the interval,+-- parameterised by their unit and absorbing elements.+primIBin :: IntervalView -> IntervalView -> TCM PrimitiveImpl+primIBin unit absorber = do+  requireCubical CErased+  t <- primIntervalType --> primIntervalType --> primIntervalType+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 2 $ \case+    [x,y] -> do+      -- Evaluation here is short-circuiting: If the LHS is either the+      -- absorbing or unit element, then the RHS does not matter.+      sx <- reduceB' x+      ix <- intervalView (unArg $ ignoreBlocking sx)+      case ix of+        ix | ix ==% absorber -> redReturn =<< intervalUnview absorber+        ix | ix ==% unit     -> return $ YesReduction YesSimplification (unArg y)+        _ -> do+          -- And in the case where the LHS is stuck, we can make+          -- progress by comparing the LHS to the absorbing/unit+          -- elements.+          sy <- reduceB' y+          iy <- intervalView (unArg $ ignoreBlocking sy)+          case iy of+            iy | iy ==% absorber -> redReturn =<< intervalUnview absorber+            iy | iy ==% unit     -> return $ YesReduction YesSimplification (unArg x)+            _                    -> return $ NoReduction [reduced sx,reduced sy]+    _ -> __IMPOSSIBLE_VERBOSE__ "binary operation on the interval called with incorrect arity"+  where+    (==%) IZero IZero = True+    (==%) IOne IOne = True+    (==%) _ _ = False+{-# INLINE primIBin #-}++-- | Implements both the @min@ connection /and/ conjunction on the+-- cofibration classifier.+primIMin' :: TCM PrimitiveImpl+primIMin' = do+  requireCubical CErased+  primIBin IOne IZero++-- | Implements both the @max@ connection /and/ disjunction on the+-- cofibration classifier.+primIMax' :: TCM PrimitiveImpl+primIMax' = do+  requireCubical CErased+  primIBin IZero IOne++-- | A helper for evaluating @max@ on the interval in TCM&co.+imax :: HasBuiltins m => m Term -> m Term -> m Term+imax x y = do+  x' <- x+  y' <- y+  intervalUnview (IMax (argN x') (argN y'))++-- | A helper for evaluating @min@ on the interval in TCM&co.+imin :: HasBuiltins m => m Term -> m Term -> m Term+imin x y = do+  x' <- x+  y' <- y+  intervalUnview (IMin (argN x') (argN y'))++-- | A helper for evaluating @neg@ on the interval in TCM&co.+ineg :: HasBuiltins m => m Term -> m Term+ineg x = do+  x' <- x+  intervalUnview (INeg (argN x'))++data Command = DoTransp | DoHComp+  deriving (Eq, Show)++-- | The built-in name associated with a particular Kan operation.+kanOpName :: KanOperation -> String+kanOpName TranspOp{} = getBuiltinId PrimTrans+kanOpName HCompOp{}  = getBuiltinId PrimHComp++-- | Our Kan operations are @transp@ and @hcomp@. The KanOperation+-- record stores the data associated with a Kan operation on arbitrary+-- types: A cofibration and an element of that type.+data KanOperation+  -- | A transport problem consists of a cofibration, marking where the+  -- transport is constant, and a term to move from the fibre over i0 to+  -- the fibre over i1.+  = TranspOp+    { kanOpCofib :: Blocked (Arg Term)+      -- ^ When this cofibration holds, the transport must+      -- definitionally be the identity. This is handled generically by+      -- 'primTransHComp' but specific Kan operations may still need it.+    , kanOpBase :: Arg Term+      -- ^ This is the term in @A i0@ which we are transporting.+    }+  -- | A composition problem consists of a partial element and a base.+  -- Semantically, this is justified by the types being Kan fibrations,+  -- i.e., having the lifting property against trivial cofibrations.+  -- While the specified cofibration may not be trivial, (φ ∨ ~ r) for r+  -- ∉ φ is *always* a trivial cofibration.+  | HCompOp+    { kanOpCofib :: Blocked (Arg Term)+      -- ^ Extent of definition of the partial element we are lifting+      -- against.+    , kanOpSides :: Arg Term+      -- ^ The partial element itself+    , kanOpBase  :: Arg Term+      -- ^ The base.+    }++-- | Are we looking at a family of things, or at a single thing?+data FamilyOrNot a+  = IsFam { famThing :: a }+  | IsNot { famThing :: a }+  deriving (Eq,Show,Functor,Foldable,Traversable)++familyOrNot :: IsString p => FamilyOrNot a -> p+familyOrNot (IsFam x) = "IsFam"+familyOrNot (IsNot x) = "IsNot"++instance Reduce a => Reduce (FamilyOrNot a) where+  reduceB' x = traverse id <$> traverse reduceB' x+  reduce' x = traverse reduce' x++-- | For the Kan operations in @Glue@ and @hcomp {Type}@, we optimise+-- evaluation a tiny bit by differentiating the term produced when+-- evaluating a Kan operation by itself vs evaluating it under @unglue@.+-- (See @headStop@ below.)+data TermPosition+  = Head+  | Eliminated+  deriving (Eq,Show)++-- | Kan operations for the "unstable" type formers (@Glue@, @hcomp {Type}@) are+-- computed "negatively": they never actually produce a @glue φ t a@ term. Instead,+-- we block the computation unless such a term would reduce further, which happens+-- in two cases:+--+-- * when the formula @φ@ is i1, in which case we reduce to @t@;+-- * when we're under an @unglue@, i.e. in 'Eliminated' 'TermPosition', in which case+--   we reduce to @a@.+headStop :: PureTCM m => TermPosition -> m Term -> m Bool+headStop tpos phi+  | Head <- tpos = do+    phi <- intervalView =<< (reduce =<< phi)+    return $ not $ isIOne phi+  | otherwise = return False++-- | Build a partial element. The type of the resulting partial element+-- can depend on the computed extent, which we denote by @φ@ here. Note+-- that @φ@ is the n-ary disjunction of all the @ψ@s.+combineSys+  :: HasBuiltins m+  => NamesT m Term -- The level @l : Level@+  -> NamesT m Term -- The type @A : Partial φ (Type l)@.+  -> [(NamesT m Term, NamesT m Term)]+  -- ^ A list of @(ψ, PartialP ψ λ o → A (... o ...))@ mappings. Note+  -- that by definitional proof-irrelevance of @IsOne@, the actual+  -- injection can not matter here.+  -> NamesT m Term+combineSys l ty xs = snd <$> combineSys' l ty xs++-- | Build a partial element, and compute its extent. See 'combineSys'+-- for the details.+combineSys'+  :: forall m. HasBuiltins m+  => NamesT m Term -- The level @l@+  -> NamesT m Term -- The type @A@+  -> [(NamesT m Term, NamesT m Term)]+  -> NamesT m (Term,Term)+combineSys' l ty xs = do+  tPOr <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPOr+  tMax <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIMax+  iz <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIZero+  tEmpty <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIsOneEmpty++  let+    pOr l ty phi psi u0 u1 = pure tPOr+      <#> l <@> phi <@> psi <#> ilam "o" (\ _ -> ty)+      <@> u0 <@> u1++    -- In one pass, compute the disjunction of all the cofibrations and+    -- compute the primPOr expression.+    combine :: [(NamesT m Term, NamesT m Term)] -> NamesT m (Term, Term)+    combine [] = (iz,) <$> (pure tEmpty <#> l <#> ilam "o" (\ _ -> ty))+    combine [(psi, u)] = (,) <$> psi <*> u+    combine ((psi, u):xs) = do+      (phi, c) <- combine xs+      (,) <$> imax psi (pure phi) <*> pOr l ty psi (pure phi) u (pure c)+  combine xs++-- | Helper function for constructing the type of fibres of a function+-- over a given point.+fiber+  :: (HasBuiltins m, HasConstInfo m)+  => NamesT m Term -- @la : Level@+  -> NamesT m Term -- @lb : Level@+  -> NamesT m Term -- @A : Type la@+  -> NamesT m Term -- @B : Type lb@+  -> NamesT m Term -- @f : A → B@+  -> NamesT m Term -- @x : B@+  -> NamesT m Term -- @Σ[ x ∈ A ] (f a ≡ x)@+fiber la lb bA bB f b = do+  tPath <- getTerm "fiber" builtinPath+  kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit+  pure (Def (sigmaName kit) [])+    <#> la <#> lb+    <@> bA+    <@> lam "a" (\ a -> pure tPath <#> lb <#> bB <@> (f <@> a) <@> b)++-- | Helper function for constructing the filler of a given composition+-- problem.+hfill+  :: (HasBuiltins m, HasConstInfo m)+  => NamesT m Term -- @la : Level@+  -> NamesT m Term -- @A : Type la@+  -> NamesT m Term -- @φ : I@. Cofibration+  -> NamesT m Term -- @u : Partial φ A@.+  -> NamesT m Term -- @u0 : A@. Must agree with @u@ on @φ@+  -> NamesT m Term -- @i : I@. Position along the cube.+  -> NamesT m Term+hfill la bA phi u u0 i = do+  tHComp <- getTerm "hfill" builtinHComp+  pure tHComp <#> la <#> bA <#> (imax phi (ineg i))+    <@> lam "j" (\ j -> combineSys la bA+        [ (phi,    ilam "o" (\o -> u <@> (imin i j) <..> o))+        , (ineg i, ilam "o" (\_ -> u0))+        ])+    <@> u0++{-# SPECIALIZE decomposeInterval :: Term -> TCM [(IntMap Bool, [Term])] #-}+-- | Decompose an interval expression @i : I@ as in+-- 'decomposeInterval'', but discard any inconsistent mappings.+decomposeInterval :: HasBuiltins m => Term -> m [(IntMap Bool, [Term])]+decomposeInterval t = do+  decomposeInterval' t <&> \xs ->+    [ (bm, ts) | (bsm, ts) <- xs, bm <- maybeToList $ traverse BoolSet.toSingleton bsm ]++{-# SPECIALIZE decomposeInterval' :: Term -> TCM [(IntMap BoolSet, [Term])] #-}+-- | Decompose an interval expression @φ : I@ into a set of possible+-- assignments for the variables mentioned in @φ@, together any leftover+-- neutral terms that could not be put into 'IntervalView' form.+decomposeInterval' :: HasBuiltins m => Term -> m [(IntMap BoolSet, [Term])]+decomposeInterval' t = do+  view   <- intervalView'+  unview <- intervalUnview'+  let+    f :: IntervalView -> [[Either (Int,Bool) Term]]+    -- TODO handle primIMinDep+    -- TODO? handle forall+    f IZero = mzero     -- No assignments are possible+    f IOne  = return [] -- No assignments are necessary+    -- Take the cartesian product+    f (IMin x y) = do+      xs <- (f . view . unArg) x+      ys <- (f . view . unArg) y+      return (xs ++ ys)+    -- Take the union+    f (IMax x y) = msum $ map (f . view . unArg) [x,y]+    -- Invert the possible assignments and negate the neutrals+    f (INeg x) =+      map (either (\ (x,y) -> Left (x,not y)) (Right . unview . INeg . argN))+        <$> (f . view . unArg) x+    f (OTerm (Var i [])) = return [Left (i,True)]+    f (OTerm t)          = return [Right t]++  return [ (bsm, ts)+         | xs <- f (view t)+         , let (bs,ts) = partitionEithers xs+         , let bsm     = IntMap.fromListWith BoolSet.union $ map (second BoolSet.singleton) bs+         ]++reduce2Lam :: Term -> ReduceM (Blocked Term)+reduce2Lam t = do+  t <- reduce' t+  case lam2Abs relevant t of+    t -> underAbstraction_ t $ \ t -> do+      t <- reduce' t+      case lam2Abs irrelevant t of+        t -> underAbstraction_ t reduceB'+  where+    lam2Abs rel (Lam _ t) = absBody t <$ t+    lam2Abs rel t         = Abs "y" (raise 1 t `apply` [setRelevance rel $ argN $ var 0])++-- | Are we looking at an application of the 'Sub' type? If so, return:+-- * The type we're an extension of+-- * The extent+-- * The partial element.+isCubicalSubtype :: PureTCM m => Type -> m (Maybe (Term, Term, Term, Term))+isCubicalSubtype t = do+  t <- reduce t+  msub <- getBuiltinName' builtinSub+  case unEl t of+    Def q es | Just q == msub, Just (level:typ:phi:ext:_) <- allApplyElims es -> do+      pure (pure (unArg level, unArg typ, unArg phi, unArg ext))+    _ -> pure Nothing
+ src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs-boot view
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Primitive.Cubical.Base where++import Agda.TypeChecking.Monad.Pure+import Agda.Syntax.Internal++isCubicalSubtype :: PureTCM m => Type -> m (Maybe (Term, Term, Term, Term))
+ src/full/Agda/TypeChecking/Primitive/Cubical/Glue.hs view
@@ -0,0 +1,412 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.Primitive.Cubical.Glue+  ( mkGComp+  , doGlueKanOp++  , primGlue'+  , prim_glue'+  , prim_unglue'+  )+  where++import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Pure++import Agda.TypeChecking.Names+  ( NamesT, runNamesT, runNames, cl, lam, open, ilam )+import Agda.TypeChecking.Primitive.Cubical.Base+import Agda.TypeChecking.Reduce+  ( reduceB' )+import Agda.TypeChecking.Substitute+  ( absBody, apply, sort, applyE )++import Agda.Syntax.Common+  ( Cubical(..), Arg(..)+  , ConOrigin(..), ProjOrigin(..)+  , irrelevant, setRelevance+  )+import Agda.Syntax.Internal++import Agda.TypeChecking.Primitive.Base+  ( (-->), nPi', pPi', hPi', el, el', (<@>), (<@@>), (<#>), argN, argH, (<..>)+  , SigmaKit(..), getSigmaKit+  )++import Agda.Utils.Functor+import Agda.Utils.Maybe+import Agda.Utils.Monad++import Agda.Utils.Impossible+  ( __IMPOSSIBLE__ )++-- | Define a "ghcomp" version of gcomp. Normal comp looks like:+--+-- comp^i A [ phi -> u ] u0 = hcomp^i A(1/i) [ phi -> forward A i u ] (forward A 0 u0)+--+-- So for "gcomp" we compute:+--+-- gcomp^i A [ phi -> u ] u0 = hcomp^i A(1/i) [ phi -> forward A i u, ~ phi -> forward A 0 u0 ] (forward A 0 u0)+--+-- The point of this is that gcomp does not produce any empty+-- systems (if phi = 0 it will reduce to "forward A 0 u".+mkGComp :: forall m. HasBuiltins m+        => String+        -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term)+mkGComp s = do+  let getTermLocal :: IsBuiltin a => a -> NamesT m Term+      getTermLocal = getTerm s+  tPOr <- getTermLocal builtinPOr+  tIMax <- getTermLocal builtinIMax+  tIMin <- getTermLocal builtinIMin+  tINeg <- getTermLocal builtinINeg+  tHComp <- getTermLocal builtinHComp+  tTrans <- getTermLocal builtinTrans+  io      <- getTermLocal builtinIOne+  iz      <- getTermLocal builtinIZero+  let forward la bA r u = pure tTrans <#> lam "i" (\ i -> la <@> (i `imax` r))+                                      <@> lam "i" (\ i -> bA <@> (i `imax` r))+                                      <@> r+                                      <@> u+  return $ \ la bA phi u u0 ->+    pure tHComp <#> (la <@> pure io)+                <#> (bA <@> pure io)+                <#> imax phi (ineg phi)+                <@> lam "i" (\ i -> combineSys (la <@> i) (bA <@> i)+                                      [ (phi,      ilam "o" $ \o -> forward la bA i (u <@> i <..> o))+                                      , (ineg phi, ilam "o" $ \o -> forward la bA (pure iz) u0)+                                      ])+                <@> forward la bA (pure iz) u0++-- | Perform the Kan operations for a @Glue φ A (T , e)@ type.+doGlueKanOp+  :: forall m. PureTCM m+  => KanOperation -- ^ Are we composing or transporting?+  -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)+  -- ^ The data of the Glue operation: The levels of @A@ and @T@, @A@+  -- itself, the extent of @T@, @T@ itself, and the family of+  -- equivalences.+  -> TermPosition+  -- ^ Are we computing a plain hcomp/transp or are we computing under+  -- @unglue@?+  -> m (Maybe Term)++doGlueKanOp (HCompOp psi u u0) (IsNot (la, lb, bA, phi, bT, e)) tpos = do+-- hcomp {psi} u u0 : Glue {la} {lb} bA {φ} (bT, e)+-- ... |- la, lb : Level+-- ... |- bA : Type la+-- ... |- bT : Partial φ (Type lB)+-- ... |- e : PartialP φ λ o → bT o ≃ bA+  let getTermLocal :: IsBuiltin a => a -> m Term+      getTermLocal = getTerm $ getBuiltinId builtinHComp ++ " for " ++ getBuiltinId builtinGlue+  tHComp   <- getTermLocal builtinHComp+  tEFun    <- getTermLocal builtinEquivFun+  tunglue  <- getTermLocal builtin_unglue+  io       <- getTermLocal builtinIOne+  tItIsOne <- getTermLocal builtinItIsOne+  view     <- intervalView'++  runNamesT [] $ do+    psi <- open . unArg $ ignoreBlocking psi+    u   <- open . unArg $ u+    u0  <- open . unArg $ u0+    la  <- open . unArg $ la+    lb  <- open . unArg $ lb+    bA  <- open . unArg $ bA+    phi <- open . unArg $ phi+    bT  <- open . unArg $ bT+    e   <- open . unArg $ e++    ifM (headStop tpos phi) (return Nothing) $ Just <$> do+    let+      tf i o   = hfill lb (bT <..> o) psi u u0 i+      unglue g = pure tunglue <#> la <#> lb <#> bA <#> phi <#> bT <#> e <@> g++      a1 = pure tHComp <#> la <#> bA <#> (imax psi phi)+        <@> lam "i" (\i -> combineSys la bA+            [ (psi, ilam "o" (\o -> unglue (u <@> i <..> o)))+            , (phi, ilam "o" (\o -> pure tEFun <#> lb <#> la <#> (bT <..> o) <#> bA <@> (e <..> o) <@> tf i o))+            ])+        <@> unglue u0++      t1 = tf (pure io)++    case tpos of+      Head       -> t1 (pure tItIsOne)+      Eliminated -> a1++-- ...    |- psi, u0+-- ..., i |- la, lb, bA, phi, bT, e+doGlueKanOp (TranspOp psi u0) (IsFam (la, lb, bA, phi, bT, e)) tpos = do+-- transp (λ i → Glue {la} {lb} bA {φ} (bT , e)) ψ u0+  let+    localUse = getBuiltinId builtinTrans ++ " for " ++ getBuiltinId builtinGlue+    getTermLocal :: IsBuiltin a => a -> m Term+    getTermLocal = getTerm localUse+  tHComp <- getTermLocal builtinHComp+  tTrans <- getTermLocal builtinTrans+  tForall <- getTermLocal builtinFaceForall+  tEFun   <- getTermLocal builtinEquivFun+  tEProof <- getTermLocal builtinEquivProof+  toutS   <- getTermLocal builtinSubOut+  tunglue <- getTermLocal builtin_unglue+  io      <- getTermLocal builtinIOne+  iz      <- getTermLocal builtinIZero+  tLMax   <- getTermLocal builtinLevelMax+  tTransp <- getTermLocal builtinTranspProof+  tItIsOne <- getTermLocal builtinItIsOne+  kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit+  runNamesT [] $ do++    gcomp <- mkGComp localUse++    -- transpFill: transp (λ j → bA (i ∧ j)) (φ ∨ ~ i) u0+    -- connects u0 and transp bA i0 u0+    let transpFill la bA phi u0 i =+          pure tTrans <#> lam "j" (\ j -> la <@> imin i j)+                      <@> lam "j" (\ j -> bA <@> imin i j)+                      <@> (imax phi (ineg i))+                      <@> u0+    psi <- open . unArg $ ignoreBlocking psi+    u0  <- open . unArg $ u0+    let lami = open . runNames [] . lam "i" . const . pure . unArg+    la  <- lami la+    lb  <- lami lb+    bA  <- lami bA+    phi <- lami phi+    bT  <- lami bT+    e   <- lami e++    -- Andreas, 2022-03-24, fixing #5838+    -- Following the updated note+    --+    --   Simon Huber, A Cubical Type Theory for Higher Inductive Types+    --   https://simhu.github.io/misc/hcomp.pdf (February 2022)+    --+    -- See: https://github.com/agda/agda/issues/5755#issuecomment-1043797776++    -- unglue_u0 i = unglue la[i/i] lb[i/i] bA[i/i] phi[i/i] bT[i/i] e[i/e] u0+    let unglue_u0 i = foldl (<#>) (pure tunglue) (map (<@> i) [la, lb, bA, phi, bT, e]) <@> u0++    view <- intervalView'++    ifM (headStop tpos (phi <@> pure io)) (return Nothing) $ Just <$> do+    let+      tf i o = transpFill lb (lam "i" $ \ i -> bT <@> i <..> o) psi u0 i+      t1 o = tf (pure io) o++      -- compute "forall. phi"+      forallphi = pure tForall <@> phi++      -- a1 with gcomp+      -- a1 = gcomp (ψ ∨ (∀ i. φ)) (λ { i (ψ = i1) → unglue_u0 i ; i ((∀ i. φ) = i1) → equivFun ... })+      --        (unglue_u0 i0)+      a1 = gcomp la bA (imax psi forallphi)+        (lam "i" $ \ i -> combineSys (la <@> i) (bA <@> i)+          [ (psi,       ilam "o" $ \_ -> unglue_u0 i)+          , (forallphi, ilam "o" $ \o -> w i o <@> (tf i o))+          ])+        (unglue_u0 (pure iz))++      max l l' = pure tLMax <@> l <@> l'+      sigCon x y = pure (Con (sigmaCon kit) ConOSystem []) <@> x <@> y++      -- The underlying function of our partial equivalence at the given+      -- endpoint of the interval, together with proof (o : IsOne φ).+      w i o = pure tEFun <#> (lb <@> i)+                         <#> (la <@> i)+                         <#> (bT <@> i <..> o)+                         <#> (bA <@> i)+                         <@> (e <@> i <..> o)++      -- Type of fibres of the partial equivalence over a1.+      fiberT o = fiber (lb <@> pure io) (la <@> pure io)+        (bT <@> (pure io) <..> o) (bA <@> pure io)+        (w (pure io) o)+        a1++      -- We don't have to do anything special for "~ forall. phi"+      -- here (to implement "ghcomp") as it is taken care off by+      -- tEProof in t1'alpha below+      pe o = -- o : IsOne φ+        combineSys (max (la <@> pure io) (lb <@> pure io)) (fiberT o)+          [ (psi       , ilam "o" $ \_ -> sigCon u0     (lam "_" $ \_ -> a1))+          , (forallphi , ilam "o" $ \o -> sigCon (t1 o) (lam "_" $ \_ -> a1))+          ]+      -- pe is a partial fibre of the equivalence with extent (ψ ∨ ∀ i. φ)+      -- over a1++      -- "ghcomp" is implemented in the proof of tEProof+      -- (see src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda)+      t1'alpha o = -- o : IsOne φ+         -- Because @e i1 1=1@ is an equivalence, we can extend the+         -- partial fibre @pe@ to an actual fibre of (e i1 1=1) over a1.+         pure toutS <#> (max (la <@> pure io) (lb <@> pure io)) <#> fiberT o+          <#> imax psi forallphi+          <#> pe o+          <@> (pure tEProof+                <#> (lb <@> pure io)        <#> (la <@> pure io)+                <@> (bT <@> pure io <..> o) <@> (bA <@> pure io)+                <@> (e <@> pure io <..> o)  <@> a1+                <@> (imax psi forallphi)+                <@> pe o)++      -- TODO: optimize?+      t1' o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaFst kit)])+      alpha o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaSnd kit)])+      a1' = pure tHComp <#> (la <@> pure io) <#> (bA <@> pure io)+        <#> imax (phi <@> pure io) psi+        <@> lam "j" (\j -> combineSys (la <@> pure io) (bA <@> pure io)+          [ (phi <@> pure io, ilam "o" $ \o -> alpha o <@@> (w (pure io) o <@> t1' o, a1, j))+          , (psi,             ilam "o" $ \o -> a1)+          ])+        <@> a1++    -- glue1 (ilam "o" t1') a1'+    case tpos of+      Head -> t1' (pure tItIsOne)+      Eliminated -> a1'+doGlueKanOp _ _ _ = __IMPOSSIBLE__++-- The implementation of 'primGlue'. Handles reduction where the partial+-- element is defined.+primGlue' :: TCM PrimitiveImpl+primGlue' = do+  requireCubical CFull+  -- primGlue+  --   : {la lb : Level} (A : Type la) {φ : I}+  --   → (T : Partial φ (Type lb)+  --   → (e : PartialP φ λ o → A ≃ T o)+  --   → Type lb+  t <- runNamesT [] $+       hPi' "la" (el $ cl primLevel) (\ la ->+       hPi' "lb" (el $ cl primLevel) $ \ lb ->+       nPi' "A" (sort . tmSort <$> la) $ \ a ->+       hPi' "φ" primIntervalType $ \ φ ->+       nPi' "T" (pPi' "o" φ $ \ o -> el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t ->+       pPi' "o" φ (\ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a)+       --> (sort . tmSort <$> lb))+  view <- intervalView'+  one <- primItIsOne+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ts ->+    case ts of+     [la,lb,a,phi,t,e] -> do+       sphi <- reduceB' phi+       -- If @φ = i1@ then we reduce to @T 1=1@, since @Glue@ is also a Kan operation.+       case view $ unArg $ ignoreBlocking $ sphi of+         IOne -> redReturn $ unArg t `apply` [argN one]+         -- Otherwise we're a regular ol' type.+         _    -> return (NoReduction $ map notReduced [la,lb,a] ++ [reduced sphi] ++ map notReduced [t,e])+     _ -> __IMPOSSIBLE__++-- | The implementation of 'prim_glue', the introduction form for @Glue@+-- types.+prim_glue' :: TCM PrimitiveImpl+prim_glue' = do+  requireCubical CFull+  t <- runNamesT [] $+       hPi' "la" (el $ cl primLevel) (\ la ->+       hPi' "lb" (el $ cl primLevel) $ \ lb ->+       hPi' "A" (sort . tmSort <$> la) $ \ a ->+       hPi' "φ" primIntervalType $ \ φ ->+       hPi' "T" (pPi' "o" φ $ \ o ->  el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t ->+       hPi' "e" (pPi' "o" φ $ \ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a) $ \ e ->+       pPi' "o" φ (\ o -> el' lb (t <@> o)) --> (el' la a --> el' lb (cl primGlue <#> la <#> lb <@> a <#> φ <@> t <@> e)))++  -- Takes a partial element of @t : T@ and an element of the base type @A@+  -- which extends @e t@, and makes it into a Glue.+  view <- intervalView'+  one <- primItIsOne+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 8 $ \case+    [la, lb, bA, phi, bT, e, t, a] -> do+      sphi <- reduceB' phi+      -- When @φ = 1@ then @t : T@ is totally defined.+      case view $ unArg $ ignoreBlocking $ sphi of+        IOne -> redReturn $ unArg t `apply` [argN one]+        -- Otherwise we'll just wait to get unglued.+        _    -> return (NoReduction $ map notReduced [la,lb,bA] ++ [reduced sphi] ++ map notReduced [bT,e,t,a])+    _ -> __IMPOSSIBLE__++-- | The implementation of 'prim_unglue', the elimination form for+-- @Glue@ types.+prim_unglue' :: TCM PrimitiveImpl+prim_unglue' = do+  requireCubical CFull+  t <- runNamesT [] $+       hPi' "la" (el $ cl primLevel) (\ la ->+       hPi' "lb" (el $ cl primLevel) $ \ lb ->+       hPi' "A" (sort . tmSort <$> la) $ \ a ->+       hPi' "φ" primIntervalType $ \ φ ->+       hPi' "T" (pPi' "o" φ $ \ o ->  el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t ->+       hPi' "e" (pPi' "o" φ $ \ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a) $ \ e ->+       (el' lb (cl primGlue <#> la <#> lb <@> a <#> φ <@> t <@> e)) --> el' la a)++  -- Takes an element @b : Glue φ A (T, e)@ to an element of @A@ which,+  -- under @φ@, agrees with @e b@. Recall that @φ ⊢ e : A → T@ and @φ ⊢+  -- Glue φ A (T, e) = T@ so this is well-typed.+  view <- intervalView'+  one <- primItIsOne+  mGlue <- getPrimitiveName' builtinGlue+  mglue <- getPrimitiveName' builtin_glue+  mtransp <- getPrimitiveName' builtinTrans+  mhcomp <- getPrimitiveName' builtinHComp+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 7 $ \case+    [la, lb, bA, phi, bT, e, b] -> do+      sphi <- reduceB' phi+      case view $ unArg $ ignoreBlocking $ sphi of+        -- When @φ = i1@ we have @Glue i1 A (T , e) = T@ so @b : T@,+        -- and we must produce @unglue b : A [ i1 → e b ]@. But that's+        -- just @e b@!+        IOne -> do+          let argOne = setRelevance irrelevant $ argN one+          tEFun <- getTerm (getBuiltinId builtin_unglue) builtinEquivFun+          redReturn $ tEFun `apply` [lb,la,argH $ unArg bT `apply` [argOne],bA, argN $ unArg e `apply` [argOne],b]++        -- Otherwise we're dealing with a proper glued thing.+        -- Definitely a sticky situation!+        _    -> do+          sb <- reduceB' b+          let fallback sbA = return (NoReduction $ map notReduced [la,lb] ++ map reduced [sbA, sphi] ++ map notReduced [bT,e] ++ [reduced sb])+          case unArg $ ignoreBlocking $ sb of+            -- Case 1: unglue (glue a) = a. This agrees with the @φ =+            -- i1@ reduction because under @φ@, the argument to+            -- @glue@ must be in the image of the equivalence.+            Def q es+              | Just [_, _, _, _, _, _, _, a] <- allApplyElims es+              , Just q == mglue -> redReturn $ unArg a++            -- Case 2: unglue (transp (λ i → Glue ...) r u0).+            -- Defer to the implementation of @doGlueKanOp DoTransp ... Eliminated@: It knows how to unglue itself.+            Def q [Apply l, Apply bA, Apply r, Apply u0] | Just q == mtransp -> do+              sbA <- reduceB' bA+              -- Require that bA be a lambda abstraction...+              case unArg $ ignoreBlocking sbA of+                Lam _ t -> do+                  -- And that its body reduces to a Glue type.+                  st <- reduceB' (absBody t)+                  case ignoreBlocking st of+                    -- In this case, we use the Glue data extracted from+                    -- the family we're transporting over.+                    Def g es | Just [la', lb', bA', phi', bT', e'] <- allApplyElims es, Just g == mGlue -> do+                        redReturn . fromMaybe __IMPOSSIBLE__ =<<+                          doGlueKanOp (TranspOp (notBlocked r) u0) (IsFam (la',lb',bA',phi',bT',e')) Eliminated+                    _ -> fallback (st *> sbA)+                _ -> fallback sbA++            -- Case 3: unglue (hcomp u u0).+            -- Defer to the implementation of @doGlueKanOp DoHComp ... Eliminated@: It knows how to unglue itself.+            Def q [Apply l,Apply bA,Apply r,Apply u,Apply u0] | Just q == mhcomp -> do+              sbA <- reduceB' bA+              case unArg $ ignoreBlocking sbA of+                -- Idem: use the Glue data from the type we're doing+                -- hcomp in.+                Def g es | Just [la', lb', bA', phi', bT', e'] <- allApplyElims es, Just g == mGlue -> do+                  redReturn . fromMaybe __IMPOSSIBLE__ =<<+                    doGlueKanOp (HCompOp (notBlocked r) u u0) (IsNot (la',lb',bA',phi',bT',e')) Eliminated+                _ -> fallback sbA++            _ -> return (NoReduction $ map notReduced [la,lb,bA] ++ [reduced sphi] ++ map notReduced [bT,e] ++ [reduced sb])+    _ -> __IMPOSSIBLE__
+ src/full/Agda/TypeChecking/Primitive/Cubical/HCompU.hs view
@@ -0,0 +1,304 @@+{-# OPTIONS_GHC -Wunused-imports #-}++{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.Primitive.Cubical.HCompU+  ( doHCompUKanOp+  , prim_glueU'+  , prim_unglueU'+  )+  where++import Control.Monad++import Agda.Syntax.Common+  ( Cubical(..), Arg(..)+  , ProjOrigin(..)+  )+import Agda.Syntax.Internal++import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Monad.Pure++import Agda.TypeChecking.Names+  ( runNamesT, runNames, cl, lam, open, ilam )+import Agda.TypeChecking.Primitive.Base+  ( (-->), nPi', pPi', hPi', el, el', el's, (<@>), (<@@>), (<#>), argN, (<..>)+  , SigmaKit(..), getSigmaKit+  )+import Agda.TypeChecking.Primitive.Cubical.Glue+import Agda.TypeChecking.Primitive.Cubical.Base+import Agda.TypeChecking.Reduce+  ( reduceB', reduceB )+import Agda.TypeChecking.Substitute+  ( absBody, apply, sort, applyE )++import Agda.Utils.Functor+import Agda.Utils.Maybe+import Agda.Utils.Monad++import Agda.Utils.Impossible (__IMPOSSIBLE__)++-- | Perform the Kan operations for an @hcomp {A = Type} {φ} u u0@ type.+doHCompUKanOp+  :: forall m. PureTCM m+  => KanOperation+  -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)+  -> TermPosition+  -> m (Maybe Term)++-- TODO (Amy, 2022-08-17): This is literally the same algorithm as+-- doGlueKanOp, but specialised for using transport as the equivalence.+-- Can we deduplicate them?+doHCompUKanOp (HCompOp psi u u0) (IsNot (la, phi, bT, bA)) tpos = do+  let getTermLocal :: IsBuiltin a => a -> m Term+      getTermLocal = getTerm $ getBuiltinId builtinHComp ++ " for " ++ getBuiltinId builtinHComp ++ " of Set"+  io       <- getTermLocal builtinIOne+  iz       <- getTermLocal builtinIZero+  tHComp   <- getTermLocal builtinHComp+  tTransp  <- getTermLocal builtinTrans+  tunglue  <- getTermLocal builtin_unglueU+  tLSuc    <- getTermLocal builtinLevelSuc+  tSubIn   <- getTermLocal builtinSubIn+  tItIsOne <- getTermLocal builtinItIsOne+  runNamesT [] $ do+    psi <- open . unArg $ ignoreBlocking psi+    u   <- open . unArg $ u+    u0  <- open . unArg $ u0+    la  <- open . unArg $ la+    phi <- open . unArg $ phi+    bT  <- open . unArg $ bT+    bA  <- open . unArg $ bA++    ifM (headStop tpos phi) (return Nothing) $ Just <$> do++    let+      transp la bA a0 = pure tTransp <#> lam "i" (const la) <@> lam "i" bA <@> pure iz <@> a0+      tf i o = hfill la (bT <@> pure io <..> o) psi u u0 i++      bAS = pure tSubIn <#> (pure tLSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <@> bA+      unglue g = pure tunglue <#> la <#> phi <#> bT <#> bAS <@> g++      a1 = pure tHComp <#> la <#> bA <#> (imax psi phi)+        <@> lam "i" (\i -> combineSys la bA+            [ (psi, ilam "o" (\o -> unglue (u <@> i <..> o)))+            , (phi, ilam "o" (\ o -> transp la (\i -> bT <@> (ineg i) <..> o) (tf i o)))+            ])+        <@> unglue u0++      t1 = tf (pure io)++    -- pure tglue <#> la <#> phi <#> bT <#> bAS <@> (ilam "o" $ \ o -> t1 o) <@> a1+    case tpos of+      Eliminated -> a1+      Head       -> t1 (pure tItIsOne)+++doHCompUKanOp (TranspOp psi u0) (IsFam (la, phi, bT, bA)) tpos = do+  let+    localUse = getBuiltinId builtinTrans ++ " for " ++ getBuiltinId builtinHComp ++ " of Set"+    getTermLocal :: IsBuiltin a => a -> m Term+    getTermLocal = getTerm localUse+  tPOr <- getTermLocal builtinPOr+  tIMax <- getTermLocal builtinIMax+  tIMin <- getTermLocal builtinIMin+  tINeg <- getTermLocal builtinINeg+  tHComp <- getTermLocal builtinHComp+  tTrans <- getTermLocal builtinTrans+  tTranspProof <- getTermLocal builtinTranspProof+  tSubIn <- getTermLocal builtinSubIn+  tForall  <- getTermLocal builtinFaceForall+  io      <- getTermLocal builtinIOne+  iz      <- getTermLocal builtinIZero+  tLSuc   <- getTermLocal builtinLevelSuc+  tPath   <- getTermLocal builtinPath+  tItIsOne   <- getTermLocal builtinItIsOne+  kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit+  runNamesT [] $ do+    -- Helper definitions we'll use:+    gcomp <- mkGComp localUse++    let+      transp la bA a0 = pure tTrans <#> lam "i" (const la) <@> lam "i" bA <@> pure iz <@> a0+      transpFill la bA phi u0 i = pure tTrans+        <#> ilam "j" (\ j -> la <@> imin i j)+        <@> ilam "j" (\ j -> bA <@> imin i j)+        <@> (imax phi (ineg i))+        <@> u0++    psi <- open . unArg . ignoreBlocking $ psi+    u0  <- open . unArg $ u0++    let lami = open . runNames [] . lam "i" . const . pure . unArg+    la  <- lami la+    phi <- lami phi+    bT  <- lami bT+    bA  <- lami bA++    -- Andreas, 2022-03-25, issue #5838.+    -- Port the fix of @unglueTranspGlue@ and @doGlueKanOp DoTransp@+    -- also to @doHCompUKanOp DoTransp@, as suggested by Tom Jack and Anders Mörtberg.+    -- We define @unglue_u0 i@ that is first used with @i@ and then with @i0@.+    -- The original code used it only with @i0@.+    tunglue <- cl $ getTermLocal builtin_unglueU+    let+      bAS i = pure tSubIn+        <#> (pure tLSuc <@> (la <@> i)) <#> (Sort . tmSort <$> (la <@> i)) <#> (phi <@> i)+        <@> (bA <@> i)+      unglue_u0 i = pure tunglue+        <#> (la <@> i) <#> (phi <@> i) <#> (bT <@> i)+        <#> bAS i <@> u0++    ifM (headStop tpos (phi <@> pure io)) (return Nothing) $ Just <$> do++    let+      tf i o = transpFill la (lam "i" $ \ i -> bT <@> i <@> pure io <..> o) psi u0 i+      t1 o   = tf (pure io) o++      -- compute "forall. phi"+      forallphi = pure tForall <@> phi++      -- a1 with gcomp+      a1 = gcomp la bA (imax psi forallphi)+        (lam "i" $ \ i -> combineSys (la <@> i) (bA <@> i)+          [ (psi,       ilam "o" $ \_ -> unglue_u0 i)+          , (forallphi, ilam "o" (\o -> transp (la <@> i) (\j -> bT <@> i <@> ineg j <..> o) (tf i o)))+          ])+          (unglue_u0 (pure iz))++      w i o = lam "x" $ transp (la <@> i) (\j -> bT <@> i <@> ineg j <..> o)++      pt o = -- o : [ φ 1 ]+        combineSys (la <@> pure io) (bT <@> pure io <@> pure io <..> o)+          [ (psi       , ilam "o" $ \_ -> u0)+          , (forallphi , ilam "o" $ \o -> t1 o)+          ]++      -- "ghcomp" is implemented in the proof of tTranspProof+      -- (see src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda)+      t1'alpha o = -- o : [ φ 1 ]+         pure tTranspProof+          <#> (la <@> pure io) <@> lam "i" (\i -> bT <@> pure io <@> ineg i <..> o)+          <@> imax psi forallphi+          <@> pt o+          <@> (pure tSubIn <#> (la <@> pure io) <#> (bA <@> pure io) <#> imax psi forallphi+                <@> a1)++      -- TODO: optimize?+      t1' o   = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaFst kit)])+      alpha o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaSnd kit)])+      a1' = pure tHComp <#> (la <@> pure io) <#> (bA <@> pure io)+        <#> imax (phi <@> pure io) psi+        <@> lam "j" (\j -> combineSys (la <@> pure io) (bA <@> pure io)+          [ (phi <@> pure io, ilam "o" $ \o -> alpha o <@@> (w (pure io) o <@> t1' o, a1, j))+          , (psi,             ilam "o" $ \o -> a1)+          ])+        <@> a1++    -- glue1 (ilam "o" t1') a1'+    case tpos of+      Eliminated -> a1'+      Head       -> t1' (pure tItIsOne)+doHCompUKanOp _ _ _ = __IMPOSSIBLE__++-- | The implementation of 'prim_glueU', the introduction form for+-- @hcomp@ types.+prim_glueU' :: TCM PrimitiveImpl+prim_glueU' = do+-- TODO (Amy, 2022-08-17): Same thing about duplicated code with Glue+-- applies here.+  requireCubical CErased+  t <- runNamesT [] $+       hPi' "la" (el $ cl primLevel) (\ la ->+       hPi' "φ" primIntervalType $ \ φ ->+       hPi' "T" (nPi' "i" primIntervalType $ \ _ -> pPi' "o" φ $ \ o -> sort . tmSort <$> la) $ \ t ->+       hPi' "A" (el's (cl primLevelSuc <@> la) $ cl primSub <#> (cl primLevelSuc <@> la) <@> (Sort . tmSort <$> la) <@> φ <@> (t <@> primIZero)) $ \ a -> do+       let bA = (cl primSubOut <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <#> (t <@> primIZero) <@> a)+       pPi' "o" φ (\ o -> el' la (t <@> cl primIOne <..> o))+         --> (el' la bA)+         --> el' la (cl primHComp <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <@> t <@> bA))+  view <- intervalView'+  one <- primItIsOne+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ts ->+    case ts of+      [la,phi,bT,bA,t,a] -> do+       sphi <- reduceB' phi+       case view $ unArg $ ignoreBlocking $ sphi of+         IOne -> redReturn $ unArg t `apply` [argN one]+         _    -> return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA,t,a])+      _ -> __IMPOSSIBLE__++-- | The implementation of 'prim_unglueU', the elimination form for+-- @hcomp@ types.+prim_unglueU' :: TCM PrimitiveImpl+prim_unglueU' = do+-- TODO (Amy, 2022-08-17): Same thing about duplicated code with Glue+-- applies here.+  requireCubical CErased+  t <- runNamesT [] $+       hPi' "la" (el $ cl primLevel) (\ la ->+       hPi' "φ" primIntervalType $ \ φ ->+       hPi' "T" (nPi' "i" primIntervalType $ \ _ -> pPi' "o" φ $ \ o -> sort . tmSort <$> la) $ \ t ->+       hPi' "A" (el's (cl primLevelSuc <@> la) $ cl primSub <#> (cl primLevelSuc <@> la) <@> (Sort . tmSort <$> la) <@> φ <@> (t <@> primIZero)) $ \ a -> do+       let bA = (cl primSubOut <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <#> (t <@> primIZero) <@> a)+       el' la (cl primHComp <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <@> t <@> bA)+         --> el' la bA)++  view <- intervalView'+  one <- primItIsOne+  mglueU <- getPrimitiveName' builtin_glueU+  mtransp <- getPrimitiveName' builtinTrans+  mHCompU <- getPrimitiveName' builtinHComp+  let mhcomp = mHCompU++  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \case+    [la,phi,bT,bA,b] -> do+      sphi <- reduceB' phi+      case view $ unArg $ ignoreBlocking $ sphi of+        -- Case where the hcomp has reduced away: Transport backwards+        -- along the partial element we've glued.+        IOne -> do+          tTransp <- getTerm (getBuiltinId builtin_unglueU) builtinTrans+          iNeg    <- getTerm (getBuiltinId builtin_unglueU) builtinINeg+          iZ      <- getTerm (getBuiltinId builtin_unglueU) builtinIZero+          redReturn <=< runNamesT [] $ do+            la <- open . unArg $ la+            bT <- open . unArg $ bT+            b  <- open . unArg $ b+            pure tTransp <#> lam "i" (\ _ -> la) <@> lam "i" (\ i -> bT <@> ineg i <..> pure one)+              <@> pure iZ <@> b++        -- Otherwise, we're dealing with a proper glu- didn't I already+        -- make this joke? Oh, yeah, in prim_unglue, right.+        _ -> do+          sb <- reduceB' b+          let fallback sbA = return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA] ++ [reduced sb])+          case unArg $ ignoreBlocking $ sb of+            -- Project:+            Def q es | Just [_,_,_,_,_, a] <- allApplyElims es, Just q == mglueU -> redReturn $ unArg a++            -- Transport:+            Def q [Apply l, Apply bA, Apply r, Apply u0] | Just q == mtransp -> do+              sbA <- reduceB bA+              case unArg $ ignoreBlocking sbA of+                Lam _ t -> do+                  st <- reduceB' (absBody t)+                  case ignoreBlocking st of+                    Def h es | Just [la,_,phi,bT,bA] <- allApplyElims es, Just h == mHCompU -> do+                      redReturn . fromMaybe __IMPOSSIBLE__ =<<+                        doHCompUKanOp (TranspOp (notBlocked r) u0) (IsFam (la,phi,bT,bA)) Eliminated+                    _ -> fallback (st *> sbA)+                _  -> fallback sbA++            -- Compose:+            Def q [Apply l,Apply bA,Apply r,Apply u,Apply u0] | Just q == mhcomp -> do+              sbA <- reduceB bA+              case unArg $ ignoreBlocking sbA of+                Def h es | Just [la,_,phi,bT,bA] <- allApplyElims es, Just h == mHCompU -> do+                  redReturn . fromMaybe __IMPOSSIBLE__ =<<+                    doHCompUKanOp (HCompOp (notBlocked r) u u0) (IsNot (la,phi,bT,bA)) Eliminated+                _ -> fallback sbA+            _ -> return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA] ++ [reduced sb])++    _ -> __IMPOSSIBLE__
src/full/Agda/TypeChecking/ProjectionLike.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Dropping initial arguments (``parameters'') from a function which can be --   easily reconstructed from its principal argument.@@ -57,8 +58,6 @@  module Agda.TypeChecking.ProjectionLike where -import Control.Monad- import qualified Data.Map as Map import Data.Monoid (Any(..), getAny) @@ -74,15 +73,18 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Positivity import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Reduce (reduce)+import Agda.TypeChecking.Records+import Agda.TypeChecking.Reduce (reduce, abortIfBlocked)+import Agda.TypeChecking.Telescope  import Agda.TypeChecking.DropArgs +import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Permutation-import Agda.Utils.Pretty ( prettyShow )+import Agda.Syntax.Common.Pretty ( prettyShow ) import Agda.Utils.Size  import Agda.Utils.Impossible@@ -129,6 +131,7 @@      _ -> fallback +{-# SPECIALIZE reduceProjectionLike :: Term -> TCM Term #-} -- | Reduce away top-level projection like functions. --   (Also reduces projections, but they should not be there, --   since Internal is in lambda- and projection-beta-normal form.)@@ -146,6 +149,7 @@ data ProjEliminator = EvenLone | ButLone | NoPostfix   deriving Eq +{-# SPECIALIZE elimView :: ProjEliminator -> Term -> TCM Term #-} -- | Turn prefix projection-like function application into postfix ones. --   This does just one layer, such that the top spine contains --   the projection-like functions as projections.@@ -161,9 +165,9 @@ --   on (applications of) projection-like functions. elimView :: PureTCM m => ProjEliminator -> Term -> m Term elimView pe v = do-  reportSDoc "tc.conv.elim" 30 $ "elimView of " <+> prettyTCM v+  reportSDoc "tc.conv.elim" 60 $ "elimView of " <+> prettyTCM v   v <- reduceProjectionLike v-  reportSDoc "tc.conv.elim" 40 $+  reportSDoc "tc.conv.elim" 65 $     "elimView (projections reduced) of " <+> prettyTCM v   case pe of     NoPostfix -> return v@@ -172,10 +176,11 @@       case pv of         NoProjection{}        -> return v         LoneProjectionLike f ai-          | pe==EvenLone  -> return $ Lam ai $ Abs "r" $ Var 0 [Proj ProjPrefix f]+          | pe == EvenLone  -> return $ Lam ai $ Abs "r" $ Var 0 [Proj ProjPrefix f]           | otherwise     -> return v         ProjectionView f a es -> (`applyE` (Proj ProjPrefix f : es)) <$> elimView pe (unArg a) +{-# SPECIALIZE eligibleForProjectionLike :: QName -> TCM Bool #-} -- | Which @Def@types are eligible for the principle argument --   of a projection-like function? eligibleForProjectionLike :: (HasConstInfo m) => QName -> m Bool@@ -262,10 +267,10 @@     -- the dropped arguments.     -- Nor can abstract definitions be projection-like since they won't reduce     -- outside the abstract block.-    def@Function{funProjection = Nothing, funClauses = cls,+    def@Function{funProjection = Left MaybeProjection, funClauses = cls,                  funSplitTree = st0, funCompiled = cc0, funInv = NotInjective,                  funMutual = Just [], -- Andreas, 2012-09-28: only consider non-mutual funs-                 funAbstr = ConcreteDef} -> do+                 funOpaque = TransparentDef} | not (def ^. funAbstract) -> do       ps0 <- filterM validProj $ candidateArgs [] t       reportSLn "tc.proj.like" 30 $ if null ps0 then "  no candidates found"                                                 else "  candidates: " ++ prettyShow ps0@@ -307,7 +312,7 @@                     , projLams     = ProjLams $ map (argFromDom . fmap fst) tel                     }               let newDef = def-                           { funProjection     = Just projection+                           { funProjection     = Right projection                            , funClauses        = cls'                            , funSplitTree      = st                            , funCompiled       = cc@@ -320,14 +325,19 @@                                    }     Function{funInv = Inverse{}} ->       reportSLn "tc.proj.like" 30 $ "  injective functions can't be projections"-    Function{funAbstr = AbstractDef} ->+    d@Function{} | d ^. funAbstract ->       reportSLn "tc.proj.like" 30 $ "  abstract functions can't be projections"-    Function{funProjection = Just{}} ->+    Function{funOpaque = OpaqueDef _} ->+      reportSLn "tc.proj.like" 30 $ "  opaque functions can't be projections"+    Function{funProjection = Right{}} ->       reportSLn "tc.proj.like" 30 $ "  already projection like"+    Function{funProjection = Left NeverProjection} ->+      reportSLn "tc.proj.like" 30 $ "  the user has asked for it not to be projection-like"     Function{funMutual = Just (_:_)} ->       reportSLn "tc.proj.like" 30 $ "  mutual functions can't be projections"     Function{funMutual = Nothing} ->       reportSLn "tc.proj.like" 30 $ "  mutuality check has not run yet"+    Function{} -> __IMPOSSIBLE__ -- match is complete, but GHC does not see this (because of d^.funAbstract)     Axiom{}        -> reportSLn "tc.proj.like" 30 $ "  not a function, but Axiom"     DataOrRecSig{} -> reportSLn "tc.proj.like" 30 $ "  not a function, but DataOrRecSig"     GeneralizableVar{} -> reportSLn "tc.proj.like" 30 $ "  not a function, but GeneralizableVar"@@ -419,3 +429,72 @@       where         candidateRec NoAbs{}   = []         candidateRec (Abs x t) = candidateArgs (var (size vs) : vs) t++{-# SPECIALIZE inferNeutral :: Term -> TCM Type #-}+-- | Infer type of a neutral term.+--   See also @infer@ in @Agda.TypeChecking.CheckInternal@, which has a very similar+--   logic but also type checks all arguments.+inferNeutral :: (PureTCM m, MonadBlock m) => Term -> m Type+inferNeutral u = do+  reportSDoc "tc.infer" 20 $ "inferNeutral" <+> prettyTCM u+  case u of+    Var i es -> do+      a <- typeOfBV i+      loop a (Var i) es+    Def f es -> do+      whenJustM (isRelevantProjection f) $ \_ -> nonInferable+      a <- defType <$> getConstInfo f+      loop a (Def f) es+    MetaV x es -> do -- we assume meta instantiations to be well-typed+      a <- metaType x+      loop a (MetaV x) es+    _ -> nonInferable+  where+    nonInferable :: MonadDebug m => m a+    nonInferable = __IMPOSSIBLE_VERBOSE__ $ unlines+      [ "inferNeutral: non-inferable term:"+      , "  " ++ prettyShow u+      ]+    loop :: (PureTCM m, MonadBlock m) => Type -> (Elims -> Term) -> Elims -> m Type+    loop t hd [] = return t+    loop t hd (e:es) = do+      t' <- case e of+        Apply (Arg ai v) ->+          ifPiType t (\_ b -> return $ b `absApp` v) __IMPOSSIBLE__+        IApply x y r ->+          ifPath t (\_ b -> return $ b `absApp` r) __IMPOSSIBLE__+        Proj o f -> do+          -- @projectTyped@ expects the type to be reduced.+          t <- reduce t+          ifJustM (projectTyped (hd []) t o f) (\(_,_,t') -> return t') __IMPOSSIBLE__+      loop t' (hd . (e:)) es++{-# SPECIALIZE computeDefType :: QName -> Elims -> TCM Type #-}+-- | Compute the head type of a Def application. For projection-like functions+--   this requires inferring the type of the principal argument.+computeDefType :: (PureTCM m, MonadBlock m) => QName -> Elims -> m Type+computeDefType f es = do+  def <- getConstInfo f+  -- To compute the type @a@ of a projection-like @f@,+  -- we have to infer the type of its first argument.+  let defaultResult = return $ defType def+  -- Find a first argument to @f@.+  case es of+    _ | projectionArgs def <= 0 -> defaultResult+    (Apply arg : _) -> do+      -- Infer its type.+      reportSDoc "tc.infer" 30 $+        "inferring type of internal arg: " <+> prettyTCM arg+      -- Jesper, 2023-02-06: infer crashes on non-inferable terms,+      -- e.g. applications of projection-like functions. Hence we bring them+      -- into postfix form.+      targ <- inferNeutral =<< elimView EvenLone (unArg arg)+      reportSDoc "tc.infer" 30 $+        "inferred type: " <+> prettyTCM targ+      -- getDefType wants the argument type reduced.+      -- Andreas, 2016-02-09, Issue 1825: The type of arg might be+      -- a meta-variable, e.g. in interactive development.+      -- In this case, we postpone.+      targ <- abortIfBlocked targ+      fromMaybeM __IMPOSSIBLE__ $ getDefType f targ+    _ -> defaultResult
src/full/Agda/TypeChecking/ProjectionLike.hs-boot view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.ProjectionLike where  import Agda.Syntax.Abstract.Name (QName)
src/full/Agda/TypeChecking/Quote.hs view
@@ -1,7 +1,7 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Quote where -import Control.Arrow ((&&&)) import Control.Monad  import Data.Maybe (fromMaybe)@@ -10,11 +10,11 @@ import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common import Agda.Syntax.Internal as I+import Agda.Syntax.Internal.Pattern ( hasDefP ) import Agda.Syntax.Literal-import Agda.Syntax.Position+import Agda.Syntax.TopLevelModuleName  import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.DropArgs import Agda.TypeChecking.Level import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty@@ -23,28 +23,28 @@ import Agda.TypeChecking.Substitute  import Agda.Utils.Impossible-import Agda.Utils.FileName import Agda.Utils.Functor import Agda.Utils.List-import Agda.Utils.Pretty (prettyShow)+import Agda.Utils.List1 ( pattern (:|) )+import Agda.Utils.List2 ( pattern List2 ) import Agda.Utils.Size+import qualified Agda.Utils.Maybe.Strict as Strict  -- | Parse @quote@. quotedName :: (MonadTCError m, MonadAbsToCon m) => A.Expr -> m QName quotedName = \case-  A.Var x          -> genericError $ "Cannot quote a variable " ++ prettyShow x-  A.Def x          -> return x-  A.Macro x        -> return x-  A.Proj _o p      -> unambiguous p-  A.Con c          -> unambiguous c-  A.ScopedExpr _ e -> quotedName e-  e -> genericDocError =<< do-    text "Can only quote defined names, but encountered" <+> prettyA e+  -- Andreas, 2024-09-27, issue #7514+  -- Is it intended to be able to quote Set but not Set1?+  A.Def' x NoSuffix -> return x+  A.Macro x         -> return x+  A.Proj _o p       -> unambiguous p+  A.Con c           -> unambiguous c+  A.ScopedExpr _ e  -> quotedName e+  e -> typeError $ CannotQuote $ CannotQuoteExpression e   where-  unambiguous xs-    | Just x <- getUnambiguous xs = return x-    | otherwise =-        genericError $ "quote: Ambigous name: " ++ prettyShow (unAmbQ xs)+    unambiguous (AmbQ (x :| xs)) = case xs of+      []   -> return x+      y:ys -> typeError $ CannotQuote $ CannotQuoteAmbiguous $ List2 x y ys   data QuotingKit = QuotingKit@@ -57,7 +57,7 @@  quotingKit :: TCM QuotingKit quotingKit = do-  currentFile     <- fromMaybe __IMPOSSIBLE__ <$> asksTC envCurrentPath+  currentModule   <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule   hidden          <- primHidden   instanceH       <- primInstance   visible         <- primVisible@@ -130,9 +130,10 @@       quoteHiding NotHidden  = pure visible        quoteRelevance :: Relevance -> ReduceM Term-      quoteRelevance Relevant   = pure relevant-      quoteRelevance Irrelevant = pure irrelevant-      quoteRelevance NonStrict  = pure relevant+      quoteRelevance = \case+        Relevant        {} -> pure relevant+        Irrelevant      {} -> pure irrelevant+        ShapeIrrelevant {} -> pure relevant        quoteQuantity :: Quantity -> ReduceM Term       quoteQuantity (Quantity0 _) = pure quantity0@@ -168,17 +169,20 @@       quoteSort :: Sort -> ReduceM Term       quoteSort (Type t) = quoteSortLevelTerm setLit set t       quoteSort (Prop t) = quoteSortLevelTerm propLit prop t-      quoteSort (Inf f n) = case f of-        IsFibrant -> inf !@! Lit (LitNat n)-        IsStrict  -> pure unsupportedSort+      quoteSort (Inf u n) = case u of+        UType -> inf !@! Lit (LitNat n)+        UProp -> pure unsupportedSort+        USSet -> pure unsupportedSort       quoteSort SSet{}   = pure unsupportedSort       quoteSort SizeUniv = pure unsupportedSort       quoteSort LockUniv = pure unsupportedSort+      quoteSort LevelUniv = pure unsupportedSort+      quoteSort IntervalUniv = pure unsupportedSort       quoteSort PiSort{} = pure unsupportedSort       quoteSort FunSort{} = pure unsupportedSort       quoteSort UnivSort{}   = pure unsupportedSort-      quoteSort (MetaS x es) = quoteTerm $ MetaV x es-      quoteSort (DefS d es)  = quoteTerm $ Def d es+      quoteSort (MetaS x es) = pure unsupportedSort+      quoteSort (DefS d es)  = pure unsupportedSort       quoteSort (DummyS s)   =__IMPOSSIBLE_VERBOSE__ s        quoteType :: Type -> ReduceM Term@@ -198,10 +202,11 @@       quotePat (ConP c _ ps)     = conP !@ quoteQName (conName c) @@ quotePats ps       quotePat (LitP _ l)        = litP !@ quoteLit l       quotePat (ProjP _ x)       = projP !@ quoteQName x-      quotePat (IApplyP o t u x) = pure unsupported+      -- #4763: quote IApply co/patterns as though they were variables+      quotePat (IApplyP _ _ _ x) = varP !@! quoteNat (toInteger $ dbPatVarIndex x)       quotePat DefP{}            = pure unsupported -      quoteClause :: Maybe Projection -> Clause -> ReduceM Term+      quoteClause :: Either a Projection -> Clause -> ReduceM Term       quoteClause proj cl@Clause{ clauseTel = tel, namedClausePats = ps, clauseBody = body} =         case body of           Nothing -> absurdClause !@ quoteTelescope tel @@ quotePats ps'@@ -210,8 +215,8 @@           -- #5128: restore dropped parameters if projection-like           ps' =             case proj of-              Nothing -> ps-              Just p  -> pars ++ ps+              Left _ -> ps+              Right p  -> pars ++ ps                 where                   n    = projIndex p - 1                   pars = map toVar $ take n $ zip (downFrom $ size tel) (telToList tel)@@ -219,12 +224,12 @@        quoteTelescope :: Telescope -> ReduceM Term       quoteTelescope tel = quoteList quoteTelEntry $ telToList tel-        where-          quoteTelEntry :: Dom (ArgName, Type) -> ReduceM Term-          quoteTelEntry dom@Dom{ unDom = (x , t) } = do-            SigmaKit{..} <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit-            Con sigmaCon ConOSystem [] !@! quoteString x @@ quoteDom quoteType (fmap snd dom) +      quoteTelEntry :: Dom (ArgName, Type) -> ReduceM Term+      quoteTelEntry dom@Dom{ unDom = (x , t) } = do+        SigmaKit{..} <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit+        Con sigmaCon ConOSystem [] !@! quoteString x @@ quoteDom quoteType (fmap snd dom)+       list :: [ReduceM Term] -> ReduceM Term       list = foldr (\ a as -> cons !@ a @@ as) (pure nil) @@ -244,6 +249,11 @@       quoteArgs :: Args -> ReduceM Term       quoteArgs ts = list (map (quoteArg quoteTerm) ts) +      -- has the clause been generated (in particular by --cubical)?+      -- TODO: have an explicit clause origin field?+      generatedClause :: Clause -> Bool+      generatedClause cl = hasDefP (namedClausePats cl)+       quoteTerm :: Term -> ReduceM Term       quoteTerm v = do         v <- instantiate' v@@ -254,23 +264,29 @@           Lam info t -> lam !@ quoteHiding (getHiding info) @@ quoteAbs quoteTerm t           Def x es   -> do             defn <- getConstInfo x+            patlams <- viewTC ePrintingPatternLambdas+            let isSeenPatLam = elem x patlams             r <- isReconstructed             -- #2220: remember to restore dropped parameters             let               conOrProjPars = defParameters defn r               ts = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-              qx Function{ funExtLam = Just (ExtLamInfo m False _), funClauses = cs } = do+              qx Function{ funExtLam = Just (ExtLamInfo m False Strict.Nothing), funClauses = cs }+                | not isSeenPatLam = locallyTC ePrintingPatternLambdas (x :) $ do+                     -- An extended lambda should not have any extra parameters!                     unless (null conOrProjPars) __IMPOSSIBLE__+                    cs <- return $ filter (not . generatedClause) cs                     n <- size <$> lookupSection m                     let (pars, args) = splitAt n ts-                    extlam !@ list (map (quoteClause Nothing . (`apply` pars)) cs)+                    extlam !@ list (map (quoteClause (Left ()) . (`apply` pars)) cs)                            @@ list (map (quoteArg quoteTerm) args)-              qx df@Function{ funExtLam = Just (ExtLamInfo _ True _), funCompiled = Just Fail{}, funClauses = [cl] } = do+              qx df@Function{ funExtLam = Just (ExtLamInfo _ True Strict.Nothing), funCompiled = Just Fail{}, funClauses = [cl] }+                | not isSeenPatLam = locallyTC ePrintingPatternLambdas (x :) $ do                     -- See also corresponding code in InternalToAbstract                     let n = length (namedClausePats cl) - 1                         pars = take n ts-                    extlam !@ list [quoteClause Nothing $ cl `apply` pars ]+                    extlam !@ list [quoteClause (Left ()) $ cl `apply` pars ]                            @@ list (drop n $ map (quoteArg quoteTerm) ts)               qx _ = do                 n <- getDefFreeVars x@@ -289,7 +305,8 @@           Level l    -> quoteTerm (unlevelWithKit lkit l)           Lit l      -> lit !@ quoteLit l           Sort s     -> sort !@ quoteSort s-          MetaV x es -> meta !@! quoteMeta currentFile x @@ quoteArgs vs+          MetaV x es -> meta !@! quoteMeta currentModule x+                              @@ quoteArgs vs             where vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es           DontCare u -> quoteTerm u           Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s@@ -298,10 +315,7 @@       defParameters def True  = []       defParameters def False = map par hiding         where-          np = case theDef def of-                 Constructor{ conPars = np }        -> np-                 Function{ funProjection = Just p } -> projIndex p - 1-                 _                                  -> 0+          np         = droppedPars def           TelV tel _ = telView' (defType def)           hiding     = take np $ telToList tel           par d      = arg !@ quoteArgInfo (domInfo d)@@ -311,6 +325,9 @@       quoteDefn def =         case theDef def of           Function{funClauses = cs, funProjection = proj} ->+           do+            -- re #3733: maybe these should be quoted but marked as generated?+            cs <- return $ filter (not . generatedClause) cs             agdaDefinitionFunDef !@ quoteList (quoteClause proj) cs           Datatype{dataPars = np, dataCons = cs} ->             agdaDefinitionDataDef !@! quoteNat (fromIntegral np) @@ quoteList (pure . quoteName) cs@@ -323,11 +340,12 @@           GeneralizableVar{} -> pure agdaDefinitionPostulate  -- TODO: reflect generalizable vars           AbstractDefn{}-> pure agdaDefinitionPostulate           Primitive{primClauses = cs} | not $ null cs ->-            agdaDefinitionFunDef !@ quoteList (quoteClause Nothing) cs+            agdaDefinitionFunDef !@ quoteList (quoteClause (Left ())) cs           Primitive{}   -> pure agdaDefinitionPrimitive           PrimitiveSort{} -> pure agdaDefinitionPrimitive-          Constructor{conData = d} ->-            agdaDefinitionDataConstructor !@! quoteName d+          Constructor{conData = d, conSrcCon = c} -> do+            q <- getQuantity <$> getConstInfo (conName c)+            agdaDefinitionDataConstructor !@! quoteName d @@ quoteQuantity q    return $ QuotingKit quoteTerm quoteType (quoteDom quoteType) quoteDefn quoteList @@ -345,8 +363,8 @@ quoteConName :: ConHead -> Term quoteConName = quoteName . conName -quoteMeta :: AbsolutePath -> MetaId -> Term-quoteMeta file = Lit . LitMeta file+quoteMeta :: TopLevelModuleName -> MetaId -> Term+quoteMeta m = Lit . LitMeta m  quoteTerm :: Term -> TCM Term quoteTerm v = do
src/full/Agda/TypeChecking/ReconstructParameters.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  -- | Reconstruct dropped parameters from constructors.  Used by --   with-abstraction to avoid ill-typed abstractions (#745). Note that the@@ -6,14 +7,14 @@  module Agda.TypeChecking.ReconstructParameters where -import Data.Maybe+import Data.Functor ( ($>) )+ import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Generic  import Agda.TypeChecking.Monad import Agda.TypeChecking.CheckInternal-import Agda.TypeChecking.Irrelevance import Agda.TypeChecking.ProjectionLike import Agda.TypeChecking.Substitute import Agda.TypeChecking.Reduce@@ -22,9 +23,10 @@ import Agda.TypeChecking.Records import Agda.TypeChecking.Datatypes -import Agda.Utils.Size import Agda.Utils.Either import Agda.Utils.Function (applyWhen)+import Agda.Utils.Lens+import Agda.Utils.Size  import Agda.Utils.Impossible @@ -43,8 +45,8 @@     ExtendTel (ar <$ a) <$> traverse reconstructParametersInTel tel  reconstructParametersInEqView :: EqualityView -> TCM EqualityView-reconstructParametersInEqView (EqualityType s eq l a u v) =-  EqualityType s eq l <$> traverse (reconstructParameters $ sort s) a+reconstructParametersInEqView (EqualityType r s eq l a u v) =+  EqualityType r s eq l <$> traverse (reconstructParameters $ sort s) a                       <*> traverse (reconstructParameters $ El s $ unArg a) u                       <*> traverse (reconstructParameters $ El s $ unArg a) v reconstructParametersInEqView (OtherType a) = OtherType <$> reconstructParametersInType a@@ -55,116 +57,114 @@  reconstructParameters' :: Action TCM -> Type -> Term -> TCM Term reconstructParameters' act a v = do-  reportSDoc "tc.with.reconstruct" 30 $+  reportSDoc "tc.reconstruct" 30 $     sep [ "reconstructing parameters in"         , nest 2 $ sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM a ] ]-  v <- checkInternal' reconstructAction v CmpLeq a+  v <- checkInternal' (reconstructAction' act) v CmpLeq a -  reportSDoc "tc.with.reconstruct" 30 $+  reportSDoc "tc.reconstruct" 30 $     nest 2 $ "-->" <+> prettyTCM v   return v-  where-    reconstructAction = defaultAction{ postAction = reconstruct } -    reconstruct a v = do-      reportSDoc "tc.with.reconstruct" 30 $-        sep [ "reconstructing in"-        , nest 2 $ sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM a ] ]-      case unSpine v of-        Con h ci vs -> do-          hh <- fromRight __IMPOSSIBLE__ <$> getConHead (conName h)-          TelV tel a <- telView a-          let under = size tel  -- under-applied when under > 0-          reportSDoc "tc.reconstruct" 50 $-            sep [ "reconstructing"-                , nest 2 $ sep [ prettyTCM v <+> ":"-                               , nest 2 $ prettyTCM a ] ]-          case (unEl a) of-            Def d es -> do-              Just n <- defParameters <$> getConstInfo d-              let prePs = applySubst (strengthenS impossible under) . take n $ es-              let hiddenPs = map (Apply . hideAndRelParams) $ fromMaybe __IMPOSSIBLE__ $-                               allApplyElims prePs-              reportSDoc "tc.reconstruct" 50 $ "The hiddenPs are" <+> pretty hiddenPs-              tyCon <- defType <$> getConstInfo (conName hh)-              reportSDoc "tc.reconstruct" 50 $ "Here we start infering spine"-              ((_,Con hh ci psAfterAct),_) <- inferSpine' act tyCon (Con hh ci []) (Con hh ci []) hiddenPs-              ((_,conWithPars),_) <- inferSpine' reconstructAction tyCon (Con hh ci []) (Con hh ci []) psAfterAct-              reportSDoc "tc.reconstruct" 50 $ "The spine has been inferred:" <+> pretty conWithPars-              return $ applyWithoutReversing conWithPars vs-            _ -> __IMPOSSIBLE__-        _  -> do-          vv <- elimView EvenLone v-          unSpineAndReconstruct a vv-    unSpineAndReconstruct :: Type -> Term -> TCM Term-    unSpineAndReconstruct a v =-      case v of-        Var i vs -> do-          ty <- typeOfBV i-          ctx <- getContextTelescope-          reportSDoc "tc.reconstruct" 50 $ (text ("Var case "++(show i)++" with context")) <+> prettyTCM ctx-          loop ty (Var i) vs-        Def nam vs -> do-          reportSDoc "tc.reconstruct" 50 $ "Def case"-          ty <- defType <$> getConstInfo nam-          loop ty (Def nam) vs-        MetaV id vs -> do-          reportSDoc "tc.reconstruct" 50 $ "MetaVar case"-          ty <- getMetaType id-          loop ty (MetaV id) vs-        _ -> do-          reportSDoc "tc.reconstruct" 50 $ "Another case" <+> pretty v-          return v+reconstructAction :: Action TCM+reconstructAction = reconstructAction' defaultAction++reconstructAction' :: Action TCM -> Action TCM+reconstructAction' act = act{ postAction = \ty tm -> postAction act ty tm >>= reconstruct ty }++reconstruct :: Type -> Term -> TCM Term+reconstruct ty v = do+    reportSDoc "tc.reconstruct" 30 $+      sep [ "reconstructing in"+      , nest 2 $ sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM ty ] ]+    case v of+      Con h ci vs -> do+        hh <- fromRight __IMPOSSIBLE__ <$> getConHead (conName h)+        TelV tel dataTy <- telView ty+        reportSDoc "tc.reconstruct" 50 $+          sep [ "reconstructing"+              , nest 2 $ sep [ prettyTCM v <+> ":"+                             , nest 2 $ prettyTCM dataTy ] ]+        pars <- addContext tel $ extractParameters (conName h) dataTy+        -- If the constructor is underapplied, we need to escape from the telescope.+        let escape = applySubst $ strengthenS __IMPOSSIBLE__ $ size tel+        return $ Con hh ci $ map Apply (escape pars) ++ vs+      Def f es -> projView v >>= \case+        ProjectionView _f a es -> do+          recTy <- infer =<< dropParameters (unArg a)+          pars <- extractParameters f recTy+          loop ty (Def f . (map Apply pars ++) . (Apply a:)) es+        LoneProjectionLike _f i -> reduce (unEl ty) >>= \case+          Pi recTy _ -> do+            pars <- extractParameters f (unDom recTy)+            return $ Def f $ map Apply pars+          _ -> __IMPOSSIBLE__+        NoProjection{} -> do+          ty <- defType <$> getConstInfo f+          loop ty (Def f) es+      Var i es -> do+        ty <- typeOfBV i+        loop ty (Var i) es+      MetaV m es -> do+        ty <- getMetaType m+        loop ty (MetaV m) es+      _ -> return v++  where     -- @loop ty f vs@ where @ty@ is the type of @f []@ and vs are valid     -- arguments to something of type @ty@     loop :: Type -> (Elims -> Term) -> Elims -> TCM Term-    loop ty f = loop' ty f f-    -- We duplicate @f@ because we don't want the parameters to be reconstructed in-    -- type, since it would cause type-checking error when running @checkInternal'@.-    -- The first one @fTe@ is for term, the other one @fTy@ for type.-    loop' ty fTe _   []           = do-      reportSDoc "tc.reconstruct" 50 $ "Loop ended" <+> (pretty $ fTe [])-      return $ fTe []-    loop' ty fTe fTy (Apply u:es) = do+    loop ty f []           = do+      reportSDoc "tc.reconstruct" 50 $ "Loop ended" <+> pretty (f [])+      return $ f []+    loop ty f (Apply u:es) = do       reportSDoc "tc.reconstruct" 50 $ "The type before app is:" <+> pretty ty-      reportSDoc "tc.reconstruct" 50 $ "The term before app is:" <+> prettyTCM (fTe [])+      reportSDoc "tc.reconstruct" 50 $ "The term before app is:" <+> prettyTCM (f [])       uu <- dropParameters u       reportSDoc "tc.reconstruct" 50 $ "The app is:" <+> pretty uu       ty' <- piApplyM ty uu       reportSDoc "tc.reconstruct" 50 $ "The type after app is:" <+> pretty ty'-      loop' ty' (fTe . (Apply u :)) (fTy . (Apply uu :)) es-    loop' ty fTe fTy (Proj o p:es) = do+      loop ty' (f . (Apply u :)) es+    loop ty f (Proj o p:es) = do       reportSDoc "tc.reconstruct" 50 $ "The type is:" <+> pretty ty-      reportSDoc "tc.reconstruct" 50 $ "The term is:" <+> pretty (fTe [])+      reportSDoc "tc.reconstruct" 50 $ "The term is:" <+> pretty (f [])       reportSDoc "tc.reconstruct" 50 $ "The proj is:" <+> prettyTCM p-      ty' <- reduce ty-      case unEl ty' of-        Def r pars -> do-          ~(Just (El _ (Pi _ b))) <- getDefType p ty'-          tyProj <- defType <$> getConstInfo p-          let reconstructWithoutPostFixing = reconstructAction { elimViewAction = elimView NoPostfix }-          let hiddenPs = map Apply $ mapHide tyProj $ fromMaybe __IMPOSSIBLE__ $-                               allApplyElims pars-          reportSDoc "tc.reconstruct" 50 $ "The params are" <+> pretty hiddenPs-          ((_,Def p psAfterAct),_) <- inferSpine' act tyProj (Def p []) (Def p []) hiddenPs-          ((_,projWithPars),_) <- inferSpine' reconstructWithoutPostFixing tyProj (Def p []) (Def p []) psAfterAct-          reportSDoc "tc.reconstruct" 50 $ "Spine infered" <+> pretty projWithPars-          let fTe' x = applyWithoutReversing projWithPars ((Apply $ defaultArg $ fTe []):x)-          loop' (absApp b (fTy [])) fTe' (fTy . (Proj o p:)) es-        _ -> __IMPOSSIBLE__-    loop' ty _   _   (IApply {}:vs) = __IMPOSSIBLE__--    applyWithoutReversing :: Term -> Elims -> Term-    applyWithoutReversing (Var i es)   ess = Var i (es++ess)-    applyWithoutReversing (Def n es)   ess = Def n (es++ess)-    applyWithoutReversing (Con h i es) ess = Con h i (es++ess)-    applyWithoutReversing (MetaV i es) ess = MetaV i (es++ess)-    applyWithoutReversing (Dummy s es) ess = Dummy s (es++ess)-    applyWithoutReversing _            _   = __IMPOSSIBLE__+      pars <- extractParameters p ty+      ~(Just (El _ (Pi _ b))) <- getDefType p =<< reduce ty+      let fTm = f []+      fe <- dropParameters fTm+      loop (absApp b fe) (Def p . (map Apply pars ++) . (Apply (defaultArg fTm) :)) es+    loop ty _ (IApply {}:vs) = __IMPOSSIBLE__ -    mapHide (El _ (Pi a b)) (p:tl) =-      applyWhen (getHiding a == Hidden) hideAndRelParams p : mapHide (unAbs b) tl-    mapHide t l = l+-- Extract the parameters from the type of a constructor+-- application or the type of the principal argument of a+-- projection.+extractParameters :: QName -> Type -> TCM Args+extractParameters q ty = reduce (unEl ty) >>= \case+  Def d prePs -> do+    dt <- defType <$> getConstInfo d+    reportSDoc "tc.reconstruct" 50 $ "Start traversing parameters: " <+> pretty prePs+    postPs <- checkInternal' reconstructAction prePs CmpEq (dt , Def d)+    reportSDoc "tc.reconstruct" 50 $ "Traversed parameters:" <+> pretty postPs+    info <- getConstInfo q+    let mkParam erasure =+            applyWhen erasure (applyQuantity zeroQuantity)+          . hideAndRelParams+          . isApplyElim' __IMPOSSIBLE__+    if -- Case: data or record constructor+       | Constructor{ conPars = n, conErasure = e } <- theDef info ->+           return $ map (mkParam e) $ take n postPs+       -- Case: regular projection+       | isProperProjection (theDef info) ->+         case theDef info of+           d@Function{} ->+             return $ map (mkParam (d ^. funErasure)) postPs+           _ -> __IMPOSSIBLE__+       -- Case: projection-like function+       | otherwise -> do+           TelV tel _ <- telViewUpTo (size postPs) $ defType info+           return $ zipWith ($>) (teleArgs tel :: Args) $ map (unArg . isApplyElim' __IMPOSSIBLE__) postPs+  _ -> __IMPOSSIBLE__  dropParameters :: TermLike a => a -> TCM a dropParameters = traverseTermM $
src/full/Agda/TypeChecking/RecordPatterns.hs view
@@ -3,31 +3,32 @@ -- uses of projection functions.  module Agda.TypeChecking.RecordPatterns-  ( translateRecordPatterns-  , translateCompiledClauses+  ( translateCompiledClauses   , translateSplitTree   , recordPatternToProjections+  , recordRHSToCopatterns   ) where  import Control.Arrow          ( first, second )-import Control.Monad          ( forM, unless, when, zipWithM )-import Control.Monad.Fix      ( mfix ) import Control.Monad.IO.Class ( MonadIO(..) ) import Control.Monad.Reader   ( MonadReader(..), ReaderT(..), runReaderT ) import Control.Monad.State    ( MonadState(..), StateT(..), runStateT )-import Control.Monad.Trans    ( lift )  import qualified Data.List as List import Data.Maybe import qualified Data.Map as Map +import qualified Agda.Syntax.Common.Pretty as P+import Agda.Syntax.Common.Pretty (Pretty(..), prettyShow) import Agda.Syntax.Common import Agda.Syntax.Internal as I import Agda.Syntax.Internal.Pattern as I+import Agda.Syntax.Info  import Agda.TypeChecking.CompiledClause import Agda.TypeChecking.Coverage.SplitTree import Agda.TypeChecking.Datatypes+import Agda.TypeChecking.Functions ( etaExpandClause ) import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty hiding (pretty) import Agda.TypeChecking.Records@@ -37,12 +38,14 @@  import Agda.Interaction.Options +import qualified Agda.Utils.SmallSet as SmallSet import Agda.Utils.Either+import Agda.Utils.Function import Agda.Utils.Functor+import Agda.Utils.Monad import Agda.Utils.Permutation hiding (dropFrom)-import Agda.Utils.Pretty (Pretty(..))-import qualified Agda.Utils.Pretty as P import Agda.Utils.Size+import Agda.Utils.Tuple import Agda.Utils.Update (MonadChange, tellDirty)  import Agda.Utils.Impossible@@ -122,33 +125,43 @@  getEtaAndArity :: SplitTag -> TCM (Bool, Nat) getEtaAndArity (SplitCon c) =-  for (getConstructorInfo c) $ \case-    DataCon n        -> (False, n)-    RecordCon _ eta fs -> (eta == YesEta, size fs)+  getConstructorInfo c <&> \case+    DataCon n           -> (False, n)+    RecordCon _ eta n _ -> (eta == YesEta, n) getEtaAndArity (SplitLit l) = return (False, 0) getEtaAndArity SplitCatchall = return (False, 1)  translateCompiledClauses   :: forall m. (HasConstInfo m, MonadChange m)-  => CompiledClauses -> m CompiledClauses-translateCompiledClauses cc = ignoreAbstractMode $ do+  => QName+  -> CompiledClauses+  -> m CompiledClauses+translateCompiledClauses defn cc = ignoreAbstractMode $ do   reportSDoc "tc.cc.record" 20 $ vcat     [ "translate record patterns in compiled clauses"     , nest 2 $ return $ pretty cc     ]+   cc <- loop cc   reportSDoc "tc.cc.record" 20 $ vcat     [ "translated compiled clauses (no eta record patterns):"     , nest 2 $ return $ pretty cc     ]-  cc <- recordExpressionsToCopatterns cc-  reportSDoc "tc.cc.record" 20 $ vcat-    [ "translated compiled clauses (record expressions to copatterns):"-    , nest 2 $ return $ pretty cc-    ]-  return cc-  where +  -- If the function these clauses belong to is marked INLINE then we do+  -- not perform record expression to copattern translation.+  isinl <- isInlineFun . theDef <$> getConstInfo defn+  if+    | isinl -> cc <$ do+      reportSDoc "tc.cc.record" 20 $ "record expressions to copatterns skipped because" <+> prettyTCM defn <+> "is inline"+    | otherwise -> do+      cc <- recordExpressionsToCopatterns cc+      reportSDoc "tc.cc.record" 20 $ vcat+        [ "translated compiled clauses (record expressions to copatterns):"+        , nest 2 $ return $ pretty cc+        ]+      pure cc+  where     loop :: CompiledClauses -> m (CompiledClauses)     loop cc = case cc of       Fail{}    -> return cc@@ -163,10 +176,10 @@                        , etaBranch      = eta                        , litBranches    = litMap                        , fallThrough    = fT-                       , catchAllBranch = catchAll+                       , catchallBranch = catchall                        , lazyMatch      = lazy } = do -      catchAll <- traverse loop catchAll+      catchall <- traverse loop catchall       litMap   <- traverse loop litMap       (conMap, eta) <- do         let noEtaCase = (, Nothing) <$> (traverse . traverse) loop conMap@@ -178,8 +191,8 @@               -- inferred eta.           _ | Just (ch, b) <- eta -> yesEtaCase b ch           [(c, b)] | not comatch -> -- possible eta-match-            getConstructorInfo c >>= \ case-              RecordCon pm YesEta fs -> yesEtaCase b $+            getConstructorInfo' c >>= \ case+              Just (RecordCon pm YesEta _ar fs) -> yesEtaCase b $                 ConHead c (IsRecord pm) Inductive (map argFromDom fs)               _ -> noEtaCase           _ -> noEtaCase@@ -187,25 +200,107 @@                         , etaBranch      = eta                         , litBranches    = litMap                         , fallThrough    = fT-                        , catchAllBranch = catchAll+                        , catchallBranch = catchall                         } -{- UNUSED-instance Monoid CompiledClauses where-  mempty = __IMPOSSIBLE__-  mappend (Case n c) (Case n' c') | n == n' = Case n $ mappend c c'-  mappend _ _ = __IMPOSSIBLE__ -mergeCatchAll :: CompiledClauses -> Maybe CompiledClauses -> CompiledClauses-mergeCatchAll cc ca = maybe cc (mappend cc) ca-{--  case (cc, ca) of-    (_       , Nothing) -> cc-    (Case n c, Just (Case n' c')) | n == n' -> Case n $ mappend c c'-    _                   -> __IMPOSSIBLE__ -- this would mean non-determinism--}--}+-- | Transform definitions returning record values to use copatterns instead.+--   This allows e.g. termination-checking constructor-style coinduction.+--+--   For example:+--+--   @+--     nats : Nat → Stream Nat+--     nats n = n ∷ nats (1 + n)+--   @+--+--   The clause is translated to:+--+--   @+--     nats n .head = n+--     nats n .tail = nats (1 + n)+--   @+--+--   A change is signalled if definitional equalities might not hold after the+--   translation, e.g. if a non-eta constructor was turned to copattern matching.+recordRHSsToCopatterns ::+     forall m. (MonadChange m, PureTCM m)+  => [Clause]+  -> m [Clause]+recordRHSsToCopatterns cls = do+  reportSLn "tc.inline.con" 40 $ "enter recordRHSsToCopatterns with " ++ show (length cls) ++ " clauses"+  concatMapM recordRHSToCopatterns cls +recordRHSToCopatterns ::+     forall m. (MonadChange m, PureTCM m)+  => Clause+  -> m [Clause]+recordRHSToCopatterns cl0 = do+  reportSLn "tc.inline.con" 40 $ "enter recordRHSToCopatterns"++  etaExpandClause cl0 >>= \case++    -- RHS must be fully applied coinductive constructor/record expression.+    cl@Clause{ namedClausePats = ps+             , clauseBody      = Just v0@(Con con@(ConHead c _ _ind fs) _ci es)+             , clauseType      = mt+             }+      | not (null fs)           -- at least one field+      , length fs == length es  -- fully applied+      , Just vs <- allApplyElims es++          -- Only expand constructors labelled @{-# INLINE c #-}@.+      -> inlineConstructor c >>= \case+        Nothing  -> return [cl0]+        Just eta -> do++          mt <- traverse reduce mt++          -- If it may change definitional equality,+          -- announce that the translation actually fired.+          unless eta tellDirty++          -- Iterate the translation for nested constructor rhss.+          recordRHSsToCopatterns =<< do++            -- Create one clause per projection.+            forM (zip fs vs) $ \ (f, v) -> do++              -- Get the type of the field.+              let inst :: Type -> m (Maybe Type)+                  inst t = fmap thd3 <$> projectTyped v0 t ProjSystem (unArg f)++              let fuse :: Maybe (Arg (Maybe a)) -> Maybe (Arg a)+                  fuse = join . fmap distributeF++              mt' :: Maybe (Arg Type) <- fuse <$> traverse (traverse inst) mt++              reportSDoc "tc.inline.con" 50 $ vcat+                [ "for field" <+> prettyTCM (unArg f) <+> ": "+                , "  mt  =" <+> prettyTCM mt+                , "  mt' =" <+> prettyTCM mt'+                ]++              -- Make clause ... .f = v+              return cl+                { namedClausePats = ps ++ [ unnamed . ProjP ProjSystem <$> f ]+                , clauseBody      = Just $ unArg v+                , clauseType      = mt'+                }++    -- Otherwise: no change.+    _ -> return [cl0]++  where+    -- @Nothing@ means do not inline, @Just eta@ means inline.+    inlineConstructor :: QName -> m (Maybe Bool)+    inlineConstructor c = getConstInfo c <&> theDef >>= \case+      Constructor { conData, conInline } -> do+        reportSLn "tc.inline.con" 80 $+          ("can" ++) $ applyUnless conInline ("not" ++) $ " inline constructor " ++ prettyShow c+        if not conInline then return Nothing else Just <$> isEtaRecord conData+      _ -> return Nothing+ -- | Transform definitions returning record expressions to use copatterns --   instead. This prevents terms from blowing up when reduced. recordExpressionsToCopatterns@@ -217,13 +312,12 @@     cc@Fail{} -> return cc     cc@(Done xs (Con c ConORec es)) -> do  -- don't translate if using the record /constructor/       let vs = map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es-      Constructor{ conArity = ar } <- theDef <$> getConstInfo (conName c)       irrProj <- optIrrelevantProjections <$> pragmaOptions       getConstructorInfo (conName c) >>= \ case-        RecordCon CopatternMatching YesEta fs-          | ar <- length fs, ar > 0,                   -- only for eta-records with at least one field-            length vs == ar,                           -- where the constructor application is saturated-            irrProj || not (any isIrrelevant fs) -> do -- and irrelevant projections (if any) are allowed+        RecordCon CopatternMatching YesEta ar fs+          | ar > 0                                     -- only for eta-records with at least one field+          , length vs == ar                            -- where the constructor application is saturated+          , irrProj || not (any isIrrelevant fs) -> do -- and irrelevant projections (if any) are allowed               tellDirty               Case (defaultArg $ length xs) <$> do                 -- translate new cases recursively (there might be nested record expressions)@@ -233,121 +327,17 @@                       zipWith (\ f v -> (unDom f, WithArity 0 $ Done xs v)) fs vs                   , etaBranch      = Nothing                   , litBranches    = Map.empty-                  , catchAllBranch = Nothing+                  , catchallBranch = Nothing                   , fallThrough    = Nothing                   , lazyMatch      = False                   }         _ -> return cc     cc@Done{} -> return cc --- UNUSED Liang-Ting Chen 2019-07-16----- | @replaceByProjections i projs cc@ replaces variables @i..i+n-1@-----   (counted from left) by projections @projs_1 i .. projs_n i@.----------   If @n==0@, we matched on a zero-field record, which means that-----   we are actually introduce a new variable, increasing split-----   positions greater or equal to @i@ by one.-----   Otherwise, we have to lower--------replaceByProjections :: Arg Int -> [QName] -> CompiledClauses -> CompiledClauses---replaceByProjections (Arg ai i) projs cc =---  let n = length projs------      loop :: Int -> CompiledClauses -> CompiledClauses---      loop i cc = case cc of---        Case j cs------        -- if j < i, we leave j untouched, but we increase i by the number---        -- of variables replacing j in the branches---          | unArg j < i -> Case j $ loops i cs------        -- if j >= i then we shrink j by (n-1)---          | otherwise   -> Case (j <&> \ k -> k - (n-1)) $ fmap (loop i) cs------        Done xs v ->---        -- we have to delete (n-1) variables from xs---        -- and instantiate v suitably with the projections---          let (xs0,xs1,xs2)     = cutSublist i n xs---              names | null xs1  = ["r"]---                    | otherwise = map unArg xs1---              x                 = Arg ai $ foldr1 appendArgNames names---              xs'               = xs0 ++ x : xs2---              us                = map (\ p -> Var 0 [Proj ProjSystem p]) (reverse projs)---              -- go from level (i + n - 1) to index (subtract from |xs|-1)---              index             = length xs - (i + n)---          in  Done xs' $ applySubst (liftS (length xs2) $ us ++# raiseS 1) v---          -- The body is NOT guarded by lambdas!---          -- WRONG: underLambdas i (flip apply) (map defaultArg us) v------        Fail -> Fail------      loops :: Int -> Case CompiledClauses -> Case CompiledClauses---      loops i bs@Branches{ conBranches    = conMap---                         , litBranches    = litMap---                         , catchAllBranch = catchAll } =---        bs{ conBranches    = fmap (\ (WithArity n c) -> WithArity n $ loop (i + n - 1) c) conMap---          , litBranches    = fmap (loop (i - 1)) litMap---          , catchAllBranch = fmap (loop i) catchAll---          }---  in  loop i cc---- UNUSED Liang-Ting 2019-07-16----- | Check if a split is on a record constructor, and return the projections-----   if yes.---isRecordCase :: Case c -> TCM (Maybe ([QName], c))---isRecordCase (Branches { conBranches = conMap---                       , litBranches = litMap---                       , catchAllBranch = Nothing })---  | Map.null litMap---  , [(con, WithArity _ br)] <- Map.toList conMap = do---    isRC <- isRecordConstructor con---    case isRC of---      Just (r, Record { recFields = fs }) -> return $ Just (map unArg fs, br)---      Just (r, _) -> __IMPOSSIBLE__---      Nothing -> return Nothing---isRecordCase _ = return Nothing- --------------------------------------------------------------------------- -- * Record pattern translation for split trees ------------------------------------------------------------------------------UNUSED Liang-Ting Chen 2019-07-16----- | Split tree annotation.---data RecordSplitNode = RecordSplitNode---  { _splitTag           :: SplitTag -- ^ Constructor name/literal for this branch.---  , _splitArity         :: Int      -- ^ Arity of the constructor.---  , _splitRecordPattern :: Bool     -- ^ Should we translate this split away?---  } --- | Split tree annotated for record pattern translation.---type RecordSplitTree  = SplitTree' RecordSplitNode---type RecordSplitTrees = SplitTrees' RecordSplitNode----UNUSED Liang-Ting Chen 2019-07-16----- | Bottom-up procedure to annotate split tree.---recordSplitTree :: SplitTree -> TCM RecordSplitTree---recordSplitTree = snd <.> loop---  where------    loop :: SplitTree -> TCM ([Bool], RecordSplitTree)---    loop = \case---      SplittingDone n -> return (replicate n True, SplittingDone n)---      SplitAt i ts    -> do---        (xs, ts) <- loops (unArg i) ts---        return (xs, SplitAt i ts)------    loops :: Int -> SplitTrees -> TCM ([Bool], RecordSplitTrees)---    loops i ts = do---      (xss, ts) <- unzip <$> do---        forM ts $ \ (c, t) -> do---          (xs, t) <- loop t---          (isRC, n) <- getEtaAndArity c---          let (xs0, rest) = splitAt i xs---              (xs1, xs2)  = splitAt n rest---              x           = isRC && and xs1---              xs'         = xs0 ++ x : xs2---          return (xs, (RecordSplitNode c n x, t))---      return (foldl1 (zipWith (&&)) xss, ts)- -- | Bottom-up procedure to record-pattern-translate split tree. translateSplitTree :: SplitTree -> TCM SplitTree translateSplitTree = snd <.> loop@@ -374,7 +364,7 @@         return (xs, t')      -- @loops i ts = return (x, xs, ts')@ cf. @loop@-    -- @x@ says wether at arg @i@ we have a record pattern split+    -- @x@ says whether at arg @i@ we have a record pattern split     -- that can be removed     loops :: Int -> SplitTrees -> TCM (Bool, [Bool], SplitTrees)     loops i ts = do@@ -421,385 +411,3 @@  instance DropFrom a => DropFrom [a] where   dropFrom i n ts = map (dropFrom i n) ts--{---- | Check if a split is on a record constructor, and return the projections---   if yes.-isRecordSplit :: SplitTrees -> TCM (Maybe ([QName], c))-isRecordSplit (Branches { conBranches = conMap-                       , litBranches = litMap-                       , catchAllBranch = Nothing })-  | Map.null litBranches-  , [(con,br)] <- Map.toList conMap = do-    isRC <- isRecordConstructor con-    case isRC of-      Just (r, Record { recFields = fs }) -> return $ Just (map unArg fs, br)-      Just (r, _) -> __IMPOSSIBLE__-      Nothing -> return Nothing-isRecordSplit _ = return Nothing---}--------------------------------------------------------------------------------- * Record pattern translation for function definitions-------------------------------------------------------------------------------- | Replaces pattern matching on record constructors with uses of--- projection functions. Does not remove record constructor patterns--- which have sub-patterns containing non-record constructor or--- literal patterns.--translateRecordPatterns :: Clause -> TCM Clause-translateRecordPatterns clause = do-  -- ps: New patterns, in left-to-right order, in the context of the-  -- old RHS.--  -- s: Partial substitution taking the old pattern variables-  -- (including dot patterns; listed from left to right) to terms in-  -- the context of the new RHS.--  -- cs: List of changes, with types in the context of the old-  -- telescope.--  (ps, s, cs) <- runRecPatM $ translatePatterns $ unnumberPatVars $ namedClausePats clause--  let -- Number of variables + dot patterns in new clause.-      noNewPatternVars = size cs--      s'   = reverse s-      mkSub s = s ++# raiseS noNewPatternVars--      -- Substitution used to convert terms in the old RHS's-      -- context to terms in the new RHS's context.-      rhsSubst = mkSub s' -- NB:: Defined but not used--      -- Substitution used to convert terms in the old telescope's-      -- context to terms in the new RHS's context.-      perm = fromMaybe __IMPOSSIBLE__ $ clausePerm clause-      rhsSubst' = mkSub $ permute (reverseP perm) s'-      -- TODO: Is it OK to replace the definition above with the-      -- following one?-      ---      --   rhsSubst' = mkSub $ permute (clausePerm clause) s--      -- The old telescope, flattened and in textual left-to-right-      -- order (i.e. the type signature for the variable which occurs-      -- first in the list of patterns comes first).-      flattenedOldTel =-        permute (invertP __IMPOSSIBLE__ $ compactP perm) $-        zip (teleNames $ clauseTel clause) $-        flattenTel $-        clauseTel clause--      -- The new telescope, still flattened, with types in the context-      -- of the new RHS, in textual left-to-right order, and with-      -- Nothing in place of dot patterns.-      substTel = map . fmap . second . applySubst-      newTel' =-        substTel rhsSubst' $-        translateTel cs $-        flattenedOldTel--      -- Permutation taking the new variable and dot patterns to the-      -- new telescope.-      newPerm = adjustForDotPatterns $-                  reorderTel_ $ map (maybe __DUMMY_DOM__ snd) newTel'-        -- It is important that __DUMMY_DOM__ does not mention any variable-        -- (see the definition of reorderTel).-        where-        isDotP n = case List.genericIndex cs n of-                     Left DotP{} -> True-                     _           -> False--        adjustForDotPatterns (Perm n is) =-          Perm n (filter (not . isDotP) is)--      -- Substitution used to convert terms in the new RHS's context-      -- to terms in the new telescope's context.-      lhsSubst' = renaming impossible (reverseP newPerm)--      -- Substitution used to convert terms in the old telescope's-      -- context to terms in the new telescope's context.-      lhsSubst = applySubst lhsSubst' rhsSubst'--      -- The new telescope.-      newTel =-        uncurry unflattenTel . unzip $-        map (fromMaybe __IMPOSSIBLE__) $-        permute newPerm $-        substTel lhsSubst' $-        newTel'--      -- New clause.-      c = clause-            { clauseTel       = newTel-            , namedClausePats = numberPatVars __IMPOSSIBLE__ newPerm $ applySubst lhsSubst ps-            , clauseBody      = applySubst lhsSubst $ clauseBody clause-            }--  reportSDoc "tc.lhs.recpat" 20 $ vcat-      [ "Original clause:"-      , nest 2 $ inTopContext $ vcat-        [ "delta =" <+> prettyTCM (clauseTel clause)-        , "pats  =" <+> text (show $ clausePats clause)-        ]-      , "Intermediate results:"-      , nest 2 $ vcat-        [ "ps        =" <+> text (show ps)-        , "s         =" <+> prettyTCM s-        , "cs        =" <+> prettyTCM cs-        , "flattenedOldTel =" <+> (text . show) flattenedOldTel-        , "newTel'   =" <+> (text . show) newTel'-        , "newPerm   =" <+> prettyTCM newPerm-        ]-      ]--  reportSDoc "tc.lhs.recpat" 20 $ vcat-        [ "lhsSubst' =" <+> (text . show) lhsSubst'-        , "lhsSubst  =" <+> (text . show) lhsSubst-        , "newTel  =" <+> prettyTCM newTel-        ]--  reportSDoc "tc.lhs.recpat" 10 $-    escapeContext impossible (size $ clauseTel clause) $ vcat-      [ "Translated clause:"-      , nest 2 $ vcat-        [ "delta =" <+> prettyTCM (clauseTel c)-        , "ps    =" <+> text (show $ clausePats c)-        , "body  =" <+> text (show $ clauseBody c)-        , "body  =" <+> addContext (clauseTel c) (maybe "_|_" prettyTCM (clauseBody c))-        ]-      ]--  return c----------------------------------------------------------------------------- Record pattern monad---- | A monad used to translate record patterns.------ The state records the number of variables produced so far, the--- reader records the total number of variables produced by the entire--- computation. Functions using this monad need to be sufficiently--- lazy in the reader component.--newtype RecPatM a = RecPatM (TCMT (ReaderT Nat (StateT Nat IO)) a)-  deriving (Functor, Applicative, Monad,-            MonadIO, MonadTCM, HasOptions,-            MonadTCEnv, MonadTCState)---- | Runs a computation in the 'RecPatM' monad.--runRecPatM :: RecPatM a -> TCM a-runRecPatM (RecPatM m) =-  mapTCMT (\m -> do-             (x, noVars) <- mfix $ \ ~(_, noVars) ->-                              runStateT (runReaderT m noVars) 0-             return x)-          m---- | Returns the next pattern variable, and the corresponding term.--nextVar :: RecPatM (Pattern, Term)-nextVar = RecPatM $ do-  n <- lift get-  lift $ put $ succ n-  noVars <- lift ask-  return (varP "r", var $ noVars - n - 1)----------------------------------------------------------------------------- Types used to record changes to a clause---- | @VarPat@ stands for variable patterns, and @DotPat@ for dot--- patterns.--data Kind = VarPat | DotPat-  deriving Eq---- | @'Left' p@ means that a variable (corresponding to the pattern--- @p@, a variable or dot pattern) should be kept unchanged. @'Right'--- (n, x, t)@ means that @n 'VarPat'@ variables, and @n 'DotPat'@ dot--- patterns, should be removed, and a new variable, with the name @x@,--- inserted instead. The type of the new variable is @t@.--type Change  = Either Pattern (Kind -> Nat, ArgName, Dom Type)-type Changes = [Change]--instance Pretty (Kind -> Nat) where-  pretty f =-    ("(VarPat:" P.<+> P.text (show $ f VarPat) P.<+>-    "DotPat:"  P.<+> P.text (show $ f DotPat)) <> ")"--instance PrettyTCM (Kind -> Nat) where-  prettyTCM = return . pretty--instance PrettyTCM Change where-  prettyTCM (Left  p) = prettyTCM p-  prettyTCM (Right (f, x, t)) = "Change" <+> prettyTCM f <+> text x <+> prettyTCM t---- | Record pattern trees.--data RecordTree-  = Leaf Pattern-    -- ^ Corresponds to variable and dot patterns; contains the-    -- original pattern.-  | RecCon (Arg Type) [(Term -> Term, RecordTree)]-    -- ^ @RecCon t args@ stands for a record constructor application:-    -- @t@ is the type of the application, and the list contains a-    -- projection function and a tree for every argument.----------------------------------------------------------------------------- Record pattern trees---- | @projections t@ returns a projection for every non-dot leaf--- pattern in @t@. The term is the composition of the projection--- functions from the leaf to the root.------ Every term is tagged with its origin: a variable pattern or a dot--- pattern.--projections :: RecordTree -> [(Term -> Term, Kind)]-projections (Leaf (DotP{})) = [(id, DotPat)]-projections (Leaf (VarP{})) = [(id, VarPat)]-projections (Leaf _)        = __IMPOSSIBLE__-projections (RecCon _ args) =-  concatMap (\ (p, t) -> map (first (. p)) $ projections t)-            args---- | Converts a record tree to a single pattern along with information--- about the deleted pattern variables.--removeTree :: RecordTree -> RecPatM (Pattern, [Term], Changes)-removeTree tree = do-  (pat, x) <- nextVar-  let ps = projections tree-      s  = map (\(p, _) -> p x) ps--      count k = length $ filter ((== k) . snd) ps--  return $ case tree of-    Leaf p     -> (p,   s, [Left p])-    RecCon t _ -> (pat, s, [Right (count, "r", domFromArg t)])----------------------------------------------------------------------------- Translation of patterns---- | Removes record constructors from patterns.------ Returns the following things:------ * The new pattern.------ * A substitution which maps the /old/ pattern variables (in the---   order they occurred in the pattern; not including dot patterns)---   to terms (either the new name of the variable, or a projection---   applied to a new pattern variable).------ * A list explaining the changes to the variables bound in the---   pattern.------ Record patterns containing non-record constructor patterns are not--- translated (though their sub-patterns may be).------ Example: The pattern @rec1 (con1 a) (rec2 b c) (rec3 d)@ should--- yield the pattern @rec1 (con1 x) y z@, along with a substitution--- similar to @[x, proj2-1 y, proj2-2 y, proj3-1 z]@.------ This function assumes that literals are never of record type.--translatePattern :: Pattern -> RecPatM (Pattern, [Term], Changes)-translatePattern p@(ConP c ci ps)-  -- Andreas, 2015-05-28 only translate implicit record patterns-  | conPRecord ci , PatOSystem <- patOrigin (conPInfo ci) = do-      r <- recordTree p-      case r of-        Left  r -> r-        Right t -> removeTree t-  | otherwise = do-      (ps, s, cs) <- translatePatterns ps-      return (ConP c ci ps, s, cs)-translatePattern p@(DefP o q ps) = do-      (ps, s, cs) <- translatePatterns ps-      return (DefP o q ps, s, cs)-translatePattern p@VarP{} = removeTree (Leaf p)-translatePattern p@DotP{} = removeTree (Leaf p)-translatePattern p@LitP{} = return (p, [], [])-translatePattern p@ProjP{}= return (p, [], [])-translatePattern p@IApplyP{}= return (p, [], [])--translatePatterns :: [NamedArg Pattern] -> RecPatM ([NamedArg Pattern], [Term], Changes)-translatePatterns ps = do-  (ps', ss, cs) <- unzip3 <$> mapM (translatePattern . namedArg) ps-  return (zipWith (\p -> fmap (p <$)) ps' ps, concat ss, concat cs)---- | Traverses a pattern and returns one of two things:------ * If there is no non-record constructor in the pattern, then---   @'Right' ps@ is returned, where @ps@ contains one projection for---   every variable in the input pattern (in the order they are---   encountered).------ * Otherwise the output is a computation returning the same kind of---   result as that coming from 'translatePattern'. (Computations are---   returned rather than values to ensure that variable numbers are---   allocated in the right order.)------ Assumes that literals are never of record type.--recordTree ::-  Pattern ->-  RecPatM (Either (RecPatM (Pattern, [Term], Changes)) RecordTree)--- Andreas, 2015-05-28 only translate implicit record patterns-recordTree p@(ConP c ci ps) | conPRecord ci , PatOSystem <- patOrigin (conPInfo ci) = do-  let t = fromMaybe __IMPOSSIBLE__ $ conPType ci-  rs <- mapM (recordTree . namedArg) ps-  case allRight rs of-    Nothing ->-      return $ Left $ do-        (ps', ss, cs) <- unzip3 <$> mapM (either id removeTree) rs-        return (ConP c ci (ps' `withNamedArgsFrom` ps),-                concat ss, concat cs)-    Just ts -> liftTCM $ do-      t <- reduce t-      reportSDoc "tc.rec" 45 $ vcat-        [ "recordTree: "-        , nest 2 $ "constructor pattern " <+> prettyTCM p <+> " has type " <+> prettyTCM t-        ]-      -- Andreas, 2018-03-03, see #2989:-      -- The content of an @Arg@ might not be reduced (if @Arg@ is @Irrelevant@).-      fields <- getRecordTypeFields =<< reduce (unArg t)---      let proj p = \x -> Def (unArg p) [defaultArg x]-      let proj p = (`applyE` [Proj ProjSystem $ unDom p])-      return $ Right $ RecCon t $ zip (map proj fields) ts-recordTree p@(ConP _ ci _) = return $ Left $ translatePattern p-recordTree p@DefP{} = return $ Left $ translatePattern p-recordTree p@VarP{} = return (Right (Leaf p))-recordTree p@DotP{} = return (Right (Leaf p))-recordTree p@LitP{} = return $ Left $ translatePattern p-recordTree p@ProjP{}= return $ Left $ translatePattern p-recordTree p@IApplyP{}= return $ Left $ translatePattern p----------------------------------------------------------------------------- Translation of the clause telescope and body---- | Translates the telescope.--translateTel-  :: Changes-     -- ^ Explanation of how the telescope should be changed. Types-     -- should be in the context of the old telescope.-  -> [(ArgName, Dom Type)]-     -- ^ Old telescope, flattened, in textual left-to-right-     -- order.-  -> [Maybe (ArgName, Dom Type)]-     -- ^ New telescope, flattened, in textual left-to-right order.-     -- 'Nothing' is used to indicate the locations of dot patterns.-translateTel (Left (DotP{}) : rest)   tel = Nothing : translateTel rest tel-translateTel (Right (n, x, t) : rest) tel = Just (x, t) :-                                              translateTel rest-                                                (drop (n VarPat) tel)-translateTel (Left _ : rest) (t : tel)    = Just t : translateTel rest tel-translateTel []              []           = []-translateTel (Left _ : _)    []           = __IMPOSSIBLE__-translateTel []              (_ : _)      = __IMPOSSIBLE__
src/full/Agda/TypeChecking/Records.hs view
@@ -2,14 +2,17 @@  module Agda.TypeChecking.Records where -import Control.Monad-import Control.Monad.Except-import Control.Monad.Trans.Maybe-import Control.Monad.Writer+import Prelude hiding (null) +import Control.Applicative        ( (<|>) )+import Control.Monad.Except       ( MonadError )+import Control.Monad.Trans.Maybe  ( MaybeT(MaybeT), runMaybeT )+import Control.Monad.Writer       ( Writer, runWriter, tell )+ import Data.Bifunctor import qualified Data.List as List import Data.Maybe+import Data.Set (Set) import qualified Data.Set as Set import qualified Data.HashMap.Strict as HMap @@ -17,33 +20,41 @@ import qualified Agda.Syntax.Concrete.Name as C import Agda.Syntax.Concrete (FieldAssignment'(..)) import Agda.Syntax.Abstract.Name+import Agda.Syntax.Internal.MetaVars (unblockOnAnyMetaIn) import Agda.Syntax.Internal as I import Agda.Syntax.Position import Agda.Syntax.Scope.Base (isNameInScope)  import Agda.TypeChecking.Irrelevance import Agda.TypeChecking.Monad+import qualified Agda.TypeChecking.Monad.Base.Warning as W import Agda.TypeChecking.Pretty as TCM import Agda.TypeChecking.Reduce import Agda.TypeChecking.Reduce.Monad () --instance only import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope import Agda.TypeChecking.Warnings-+import {-# SOURCE #-} Agda.TypeChecking.Primitive.Cubical.Base (isCubicalSubtype) import {-# SOURCE #-} Agda.TypeChecking.ProjectionLike (eligibleForProjectionLike) -import Agda.Utils.Either-import Agda.Utils.Functor (for, ($>))+import Agda.Utils.Empty+import Agda.Utils.Function (applyWhen)+import Agda.Utils.Functor (for, ($>), (<&>))+import Agda.Utils.Lens import Agda.Utils.List+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Pretty (prettyShow)+import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Utils.Singleton import Agda.Utils.Size  import Agda.Utils.Impossible +---------------------------------------------------------------------------+-- * Tools to build record values+ mkCon :: ConHead -> ConInfo -> Args -> Term mkCon h info args = Con h info (map Apply args) @@ -61,15 +72,15 @@   --   , "  official fields: " <+> sep (map pretty xs)   --   , "  provided fields: " <+> sep (map pretty ys)   --   ]-  unlessNull alien     $ warn $ TooManyFieldsWarning r missing-  unlessNull duplicate $ warn $ DuplicateFieldsWarning+  List1.unlessNull alien     $ warn $ W.TooManyFields r missing+  List1.unlessNull duplicate $ warn $ W.DuplicateFields   return $ for axs $ \ ax -> fromMaybe (fill ax) $ lookup (unArg ax) uniq   where     (uniq, duplicate) = nubAndDuplicatesOn fst fs   -- separating duplicate fields     xs        = map unArg axs                       -- official fields (accord. record type)     missing   = filter (not . hasElem (map fst fs)) xs  -- missing  fields     alien     = filter (not . hasElem xs . fst) fs      -- spurious fields-    warn w    = tell . singleton . w . map (second getRange)+    warn w    = tell . singleton . w . fmap (second getRange)  -- | Raise generated 'RecordFieldWarning's as warnings. warnOnRecordFieldWarnings :: Writer [RecordFieldWarning] a -> TCM a@@ -171,10 +182,23 @@ insertMissingFieldsFail r placeholder fs axs =   failOnRecordFieldWarnings $ insertMissingFields r placeholder fs axs +---------------------------------------------------------------------------+-- * Query information about records from signature++-- | Check if a name refers to a record.+--   If yes, return record definition.+{-# SPECIALIZE isRecord :: QName -> TCM (Maybe RecordData) #-}+{-# SPECIALIZE isRecord :: QName -> ReduceM (Maybe RecordData) #-}+isRecord :: HasConstInfo m => QName -> m (Maybe RecordData)+isRecord r = do+  getConstInfo r <&> theDef <&> \case+    RecordDefn rd -> Just rd+    _ -> Nothing+ -- | Get the definition for a record. Throws an exception if the name --   does not refer to a record or the record is abstract.-getRecordDef :: (HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m Defn-getRecordDef r = maybe err return =<< isRecord r+getRecordDef :: (HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m RecordData+getRecordDef r = fromMaybeM err $ isRecord r   where err = typeError $ ShouldBeRecordType (El __DUMMY_SORT__ $ Def r [])  -- | Get the record name belonging to a field name.@@ -185,15 +209,12 @@  -- | Get the field names of a record. getRecordFieldNames :: (HasConstInfo m, ReadTCState m, MonadError TCErr m)-                    => QName -> m [Dom C.Name]+  => QName+  -> m [Dom C.Name] getRecordFieldNames r = recordFieldNames <$> getRecordDef r -getRecordFieldNames_ :: (HasConstInfo m, ReadTCState m)-                     => QName -> m (Maybe [Dom C.Name])-getRecordFieldNames_ r = fmap recordFieldNames <$> isRecord r--recordFieldNames :: Defn -> [Dom C.Name]-recordFieldNames = map (fmap (nameConcrete . qnameName)) . recFields+recordFieldNames :: RecordData -> [Dom C.Name]+recordFieldNames = map (fmap (nameConcrete . qnameName)) . _recFields  -- | Find all records with at least the given fields. findPossibleRecords :: [C.Name] -> TCM [QName]@@ -213,10 +234,6 @@         _ -> False     given = Set.fromList fields --- | Get the field types of a record.-getRecordFieldTypes :: QName -> TCM Telescope-getRecordFieldTypes r = recTel <$> getRecordDef r- -- | Get the field names belonging to a record type. getRecordTypeFields   :: Type  -- ^ Record type.  Need not be reduced.@@ -234,30 +251,19 @@ -- | Returns the given record type's constructor name (with an empty -- range). getRecordConstructor :: (HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m ConHead-getRecordConstructor r = killRange . recConHead <$> getRecordDef r---- | Check if a name refers to a record.---   If yes, return record definition.-{-# SPECIALIZE isRecord :: QName -> TCM (Maybe Defn) #-}-{-# SPECIALIZE isRecord :: QName -> ReduceM (Maybe Defn) #-}-isRecord :: HasConstInfo m => QName -> m (Maybe Defn)-isRecord r = do-  def <- theDef <$> getConstInfo r-  return $ case def of-    Record{} -> Just def-    _        -> Nothing+getRecordConstructor r = killRange . _recConHead <$> getRecordDef r  -- | Reduce a type and check whether it is a record type. --   Succeeds only if type is not blocked by a meta var. --   If yes, return its name, parameters, and definition.-isRecordType :: PureTCM m => Type -> m (Maybe (QName, Args, Defn))+isRecordType :: PureTCM m => Type -> m (Maybe (QName, Args, RecordData)) isRecordType t = either (const Nothing) Just <$> tryRecordType t  -- | Reduce a type and check whether it is a record type. --   Succeeds only if type is not blocked by a meta var. --   If yes, return its name, parameters, and definition. --   If no, return the reduced type (unless it is blocked).-tryRecordType :: PureTCM m => Type -> m (Either (Blocked Type) (QName, Args, Defn))+tryRecordType :: PureTCM m => Type -> m (Either (Blocked Type) (QName, Args, RecordData)) tryRecordType t = ifBlocked t (\ m a -> return $ Left $ Blocked m a) $ \ nb t -> do   let no = return $ Left $ NotBlocked nb t   case unEl t of@@ -326,7 +332,7 @@               [ text $ "head d     = " ++ prettyShow d               , "parameters =" <+> sep (map prettyTCM pars)               ]-            reportSLn "tc.deftype" 60 $ "parameters = " ++ show pars+            reportSDoc "tc.deftype" 60 $ "parameters = " <+> pretty pars             if length pars < npars then failure "does not supply enough parameters"             else Just <$> a `piApplyM` pars         _ -> failNotDef@@ -340,8 +346,27 @@         , prettyTCM t         , text $ "of its argument " ++ reason         ]-      return Nothing+      reportSDoc "tc.deftype" 60 $ "raw type: " <+> pretty t+      return $ case unEl t of+        Dummy{} -> Just __DUMMY_TYPE__+        _       -> Nothing +-- | Apply a projection to an expression with a known type, returning+--   the type of the projected value.+--   The given type should either be a record type or a type eligible for+--   the principal argument of a projection-like function.+shouldBeProjectible :: (PureTCM m, MonadTCError m, MonadBlock m)+                    => Term -> Type -> ProjOrigin -> QName -> m Type+-- shouldBeProjectible t f = maybe failure return =<< projectionType t f+shouldBeProjectible v t o f = do+  t <- abortIfBlocked t+  projectTyped v t o f >>= \case+    Just (_ , _ , ft) -> return ft+    Nothing -> case t of+      El _ Dummy{} -> return __DUMMY_TYPE__+      _ -> typeError $ ShouldBeRecordType t+    -- TODO: more accurate error that makes sense also for proj.-like funs.+ -- | The analogue of 'piApply'.  If @v@ is a value of record type @t@ --   with field @f@, then @projectTyped v t f@ returns the type of @f v@. --   And also the record type (as first result).@@ -375,7 +400,7 @@ instance PrettyTCM ElimType where   prettyTCM (ArgT a)    = prettyTCM a   prettyTCM (ProjT a b) =-    "." TCM.<> parens (prettyTCM a <+> "->" <+> prettyTCM b)+    "." <> parens (prettyTCM a <+> "->" <+> prettyTCM b)  -- | Given a head and its type, compute the types of the eliminations. @@ -394,34 +419,63 @@       (ProjT dom a :) <$> typeElims a self es     IApply{} -> __IMPOSSIBLE__ +-- | Given a term with a given type and a list of eliminations, returning the+--   type of the term applied to the eliminations.+eliminateType :: (PureTCM m) => m Empty -> Term -> Type -> Elims -> m Type+eliminateType err = eliminateType' err . applyE++eliminateType' :: (PureTCM m) => m Empty -> (Elims -> Term) -> Type -> Elims -> m Type+eliminateType' err hd t [] = return t+eliminateType' err hd t (e : es) = case e of+  Apply v -> do+    t' <- piApplyM' err t v+    eliminateType' err (hd . (e:)) t' es+  Proj o f -> reduce t >>= getDefType f >>= \case+    Just a -> ifNotPiType a (\_ -> absurd <$> err) $ \_ c ->+      eliminateType' err (hd . (e:)) (c `absApp` (hd [])) es+    Nothing -> absurd <$> err+  IApply _ _ r -> do+    t' <- piApplyM' err t r+    eliminateType' err (hd . (e:)) t' es+ -- | Check if a name refers to an eta expandable record.+--+-- The answer is no for a record type with an erased constructor+-- unless the current quantity is \"erased\". {-# SPECIALIZE isEtaRecord :: QName -> TCM Bool #-} {-# SPECIALIZE isEtaRecord :: QName -> ReduceM Bool #-} isEtaRecord :: HasConstInfo m => QName -> m Bool-isEtaRecord r = maybe False ((YesEta ==) . recEtaEquality) <$> isRecord r+isEtaRecord r = do+  isRecord r >>= \case+    Just r | isEtaRecordDef r -> do+     constructorQ <- getQuantity <$> getConstInfo (conName (_recConHead r))+     currentQ     <- viewTC eQuantity+     return $ constructorQ `moreQuantity` currentQ+    _ -> return False +isEtaRecordDef :: RecordData -> Bool+isEtaRecordDef r = _recEtaEquality r == YesEta++{-# SPECIALIZE isEtaCon :: QName -> TCM Bool #-} isEtaCon :: HasConstInfo m => QName -> m Bool-isEtaCon c = getConstInfo' c >>= \case-  Left (SigUnknown err) -> __IMPOSSIBLE__-  Left SigAbstract -> return False-  Right def -> case theDef def of-    Constructor {conData = r} -> isEtaRecord r-    _ -> return False+isEtaCon c = isJust <$> isEtaRecordConstructor c  -- | Going under one of these does not count as a decrease in size for the termination checker. isEtaOrCoinductiveRecordConstructor :: HasConstInfo m => QName -> m Bool isEtaOrCoinductiveRecordConstructor c =-  caseMaybeM (isRecordConstructor c) (return False) $ \ (_, def) -> return $-    recEtaEquality def == YesEta || recInduction def /= Just Inductive+  caseMaybeM (isRecordConstructor c) (return False) $ \ (_, def) ->+    pure (isEtaRecordDef def) `or2M`+      return (_recInduction def /= Just Inductive)       -- If in doubt about coinductivity, then yes.  -- | Check if a name refers to a record which is not coinductive.  (Projections are then size-preserving)-isInductiveRecord :: QName -> TCM Bool-isInductiveRecord r = maybe False ((Just CoInductive /=) . recInduction) <$> isRecord r+isInductiveRecord :: HasConstInfo m => QName -> m Bool+isInductiveRecord r = maybe False ((Just CoInductive /=) . _recInduction) <$> isRecord r  -- | Check if a type is an eta expandable record and return the record identifier and the parameters. isEtaRecordType :: (HasConstInfo m)-                => Type -> m (Maybe (QName, Args))+  => Type+  -> m (Maybe (QName, Args)) isEtaRecordType a = case unEl a of   Def d es -> do     let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es@@ -430,63 +484,58 @@  -- | Check if a name refers to a record constructor. --   If yes, return record definition.-isRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, Defn))+--+isRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, RecordData)) isRecordConstructor c = getConstInfo' c >>= \case-  Left (SigUnknown err)        -> __IMPOSSIBLE__-  Left SigAbstract             -> return Nothing-  Right def -> case theDef $ def of+  Left (SigUnknown err)     -> __IMPOSSIBLE__+  Left SigCubicalNotErasure -> __IMPOSSIBLE__+  Left SigAbstract          -> return Nothing+  Right def                 -> case theDef $ def of     Constructor{ conData = r } -> fmap (r,) <$> isRecord r     _                          -> return Nothing --- | Check if a constructor name is the internally generated record constructor.------   Works also for abstract constructors.-isGeneratedRecordConstructor :: (MonadTCEnv m, HasConstInfo m)-                             => QName -> m Bool-isGeneratedRecordConstructor c = ignoreAbstractMode $ do-  caseMaybeM (isRecordConstructor c) (return False) $ \ (_, def) ->-    case def of-      Record{ recNamedCon = False } -> return True-      _ -> return False-+isEtaRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, RecordData))+isEtaRecordConstructor c = isRecordConstructor c >>= \case+  Nothing -> return Nothing+  Just (d, def) -> if isEtaRecordDef def then return $ Just (d, def) else return Nothing  -- | Turn off eta for unguarded recursive records. --   Projections do not preserve guardedness. unguardedRecord :: QName -> PatternOrCopattern -> TCM ()-unguardedRecord q pat = modifySignature $ updateDefinition q $ updateTheDef $ \case-  r@Record{} -> r { recEtaEquality' = setEtaEquality (recEtaEquality' r) $ NoEta pat }-  _ -> __IMPOSSIBLE__+unguardedRecord q pat = modifyRecEta q \ eta -> setEtaEquality eta $ NoEta pat +-- | Turn on eta for non-recursive and inductive guarded recursive records,+--   unless user declared otherwise.+--   Projections do not preserve guardedness.+updateEtaForRecord :: QName -> TCM ()+updateEtaForRecord q = whenM etaEnabled $ do++  -- Do we need to switch on eta for record q?+  switchEta <- getConstInfo q <&> theDef <&> \case+    Record{ recInduction = ind, recEtaEquality' = eta }+      | Inferred NoEta{} <- eta, ind /= Just CoInductive -> True+      | otherwise -> False+    _ -> __IMPOSSIBLE__++  when switchEta $ modifyRecEta q $ const $ Inferred YesEta+ -- | Turn on eta for inductive guarded recursive records. --   Projections do not preserve guardedness. recursiveRecord :: QName -> TCM ()-recursiveRecord q = do-  ok <- etaEnabled-  modifySignature $ updateDefinition q $ updateTheDef $ \case-    r@Record{ recInduction = ind, recEtaEquality' = eta } ->-      r { recEtaEquality' = eta' }-      where-      eta' | ok, Inferred NoEta{} <- eta, ind /= Just CoInductive = Inferred YesEta-           | otherwise = eta-    _ -> __IMPOSSIBLE__+recursiveRecord = updateEtaForRecord  -- | Turn on eta for non-recursive record, unless user declared otherwise. nonRecursiveRecord :: QName -> TCM ()-nonRecursiveRecord q = whenM etaEnabled $ do-  -- Do nothing if eta is disabled by option.-  modifySignature $ updateDefinition q $ updateTheDef $ \case-    r@Record{ recInduction = ind, recEtaEquality' = Inferred (NoEta _) }-      | ind /= Just CoInductive ->-      r { recEtaEquality' = Inferred YesEta }-    r@Record{} -> r-    _          -> __IMPOSSIBLE__-+nonRecursiveRecord = updateEtaForRecord  -- | Check whether record type is marked as recursive. -- --   Precondition: record type identifier exists in signature. isRecursiveRecord :: QName -> TCM Bool-isRecursiveRecord q = recRecursive . theDef . fromMaybe __IMPOSSIBLE__ . lookupDefinition q <$> getSignature+isRecursiveRecord q =+  getSignature <&> lookupDefinition q <&> fmap theDef <&> \case+    Just (RecordDefn r) -> recRecursive_ r+    _ -> __IMPOSSIBLE__  {- | @etaExpandBoundVar i = (Δ, σ, τ)@ @@ -508,7 +557,7 @@ -- --   Postcondition: @Δ = Γ₁, Γ', Γ₂[c Γ']@ and @Γ ⊢ σ : Δ@ and @Δ ⊢ τ : Γ@. -expandRecordVar :: Int -> Telescope -> TCM (Maybe (Telescope, Substitution, Substitution, Telescope))+expandRecordVar :: PureTCM m => Int -> Telescope -> m (Maybe (Telescope, Substitution, Substitution, Telescope)) expandRecordVar i gamma0 = do   -- Get the context with last variable added last in list.   let gamma = telToList gamma0@@ -524,17 +573,17 @@           " since its type " <+> prettyTCM a <+>           " is not a record type"         return Nothing-  caseMaybeM (isRecordType a) failure $ \ (r, pars, def) -> case recEtaEquality def of-    NoEta{} -> return Nothing-    YesEta  -> Just <$> do+  caseMaybeM (isRecordType a) failure $ \ (r, pars, def) -> case isEtaRecordDef def of+    False -> return Nothing+    True  -> Just <$> do       -- Get the record fields @Γ₁ ⊢ tel@ (@tel = Γ'@).       -- TODO: compose argInfo ai with tel.-      let tel = recTel def `apply` pars+      let tel = _recTel def `apply` pars           m   = size tel-          fs  = map argFromDom $ recFields def+          fs  = map argFromDom $ _recFields def       -- Construct the record pattern @Γ₁, Γ' ⊢ u := c ys@.           ys  = zipWith (\ f i -> f $> var i) fs $ downFrom m-          u   = mkCon (recConHead def) ConOSystem ys+          u   = mkCon (_recConHead def) ConOSystem ys       -- @Γ₁, Γ' ⊢ τ₀ : Γ₁, x:_@           tau0 = consS u $ raiseS m       -- @Γ₁, Γ', Γ₂ ⊢ τ₀ : Γ₁, x:_, Γ₂@@@ -594,20 +643,20 @@       -- This might trigger another call to @etaExpandProjectedVar@ later.       -- A more efficient version does all the eta-expansions at once here.       (r, pars, def) <- fromMaybe __IMPOSSIBLE__ <$> isRecordType a-      if | NoEta _ <- recEtaEquality def -> __IMPOSSIBLE__+      if | NoEta _ <- _recEtaEquality def -> __IMPOSSIBLE__          | otherwise -> return ()       -- TODO: compose argInfo ai with tel.-      let tel = recTel def `apply` pars+      let tel = _recTel def `apply` pars           m   = size tel-          fs  = map argFromDom $ recFields def+          fs  = map argFromDom $ _recFields def           ys  = zipWith (\ f i -> f $> var i) fs $ downFrom m-          u   = mkCon (recConHead def) ConOSystem ys+          u   = mkCon (killRange $ _recConHead def) ConOSystem ys           b'  = raise m b `absApp` u           t'  = gamma `telePi` (tel `telePi` b')           gammai = map domInfo $ telToList gamma           xs  = reverse $ zipWith (\ ai i -> Arg ai $ var i) gammai [m..]           curry v = teleLam gamma $ teleLam tel $-                      raise (n+m) v `apply` (xs ++ [Arg ai u])+                      raise (n + m) v `apply` (xs ++ [Arg ai u])           zs  = for fs $ fmap $ \ f -> Var 0 [Proj ProjSystem f]           atel = sgTel $ (,) (absName b) <$> dom           uncurry v = teleLam gamma $ teleLam atel $@@ -630,35 +679,60 @@     where @tel@ is the record telescope instantiated at the parameters @pars@. -} etaExpandRecord :: (HasConstInfo m, MonadDebug m, ReadTCState m)-                => QName -> Args -> Term -> m (Telescope, Args)+  => QName       -- ^ Name of record type.+  -> Args        -- ^ Parameters applied to record type.+  -> Term        -- ^ Term to eta-expand.+  -> m (Telescope, Args)+     -- ^ Field types instantiated to parameters, field values. etaExpandRecord = etaExpandRecord' False  -- | Eta expand a record regardless of whether it's an eta-record or not. forceEtaExpandRecord :: (HasConstInfo m, MonadDebug m, ReadTCState m, MonadError TCErr m)-                     => QName -> Args -> Term -> m (Telescope, Args)+  => QName       -- ^ Name of record type.+  -> Args        -- ^ Parameters applied to record type.+  -> Term        -- ^ Term to eta-expand.+  -> m (Telescope, Args)+     -- ^ Field types instantiated to parameters, field values. forceEtaExpandRecord = etaExpandRecord' True +-- | Eta-expand a value at the given record type (must match). etaExpandRecord' :: (HasConstInfo m, MonadDebug m, ReadTCState m)-                 => Bool -> QName -> Args -> Term -> m (Telescope, Args)+  => Bool        -- ^ Force expansion, overriding '_recEtaEquality'?+  -> QName       -- ^ Name of record type.+  -> Args        -- ^ Parameters applied to record type.+  -> Term        -- ^ Term to eta-expand.+  -> m (Telescope, Args)+     -- ^ Field types instantiated to parameters, field values. etaExpandRecord' forceEta r pars u = do   def <- fromMaybe __IMPOSSIBLE__ <$> isRecord r   (tel, _, _, args) <- etaExpandRecord'_ forceEta r pars def u   return (tel, args) +-- | Eta-expand a value at the given eta record type (must match). etaExpandRecord_ :: HasConstInfo m-                 => QName -> Args -> Defn -> Term -> m (Telescope, ConHead, ConInfo, Args)+  => QName       -- ^ Name of record type.+  -> Args        -- ^ Parameters applied to record type.+  -> RecordData  -- ^ Definition of record type.+  -> Term        -- ^ Term to eta-expand.+  -> m (Telescope, ConHead, ConInfo, Args)+     -- ^ Field types instantiated to parameters, disassembled constructor term. etaExpandRecord_ = etaExpandRecord'_ False +-- | Eta-expand a value at the given record type (must match). etaExpandRecord'_ :: HasConstInfo m-                  => Bool -> QName -> Args -> Defn -> Term -> m (Telescope, ConHead, ConInfo, Args)-etaExpandRecord'_ forceEta r pars def u = do-  let Record{ recConHead     = con-            , recFields      = xs-            , recTel         = tel-            } = def-      tel' = apply tel pars+  => Bool        -- ^ Force expansion, overriding '_recEtaEquality'?+  -> QName       -- ^ Name of record type.+  -> Args        -- ^ Parameters applied to record type.+  -> RecordData  -- ^ Definition of record type.+  -> Term        -- ^ Term to eta-expand.+  -> m (Telescope, ConHead, ConInfo, Args)+     -- ^ Field types instantiated to parameters, disassembled constructor term.+etaExpandRecord'_ forceEta r pars+    def@RecordData{ _recConHead = con, _recFields = xs, _recTel = tel }+    u = do+  let tel' = apply tel pars   -- Make sure we do not expand non-eta records (unless forced to):-  unless (recEtaEquality def == YesEta || forceEta) __IMPOSSIBLE__+  unless (_recEtaEquality def == YesEta || forceEta) __IMPOSSIBLE__   case u of      -- Already expanded.@@ -715,7 +789,7 @@ {-# SPECIALIZE etaContractRecord :: QName -> ConHead -> ConInfo -> Args -> ReduceM Term #-} etaContractRecord :: HasConstInfo m => QName -> ConHead -> ConInfo -> Args -> m Term etaContractRecord r c ci args = if all (not . usableModality) args then fallBack else do-  Just Record{ recFields = xs } <- isRecord r+  RecordData{ _recFields = xs } <- fromMaybe __IMPOSSIBLE__ <$> isRecord r   reportSDoc "tc.record.eta.contract" 20 $ vcat     [ "eta contracting record"     , nest 2 $ vcat@@ -744,7 +818,7 @@   -- @a@ is the constructor argument, @ax@ the corr. record field name     -- skip irrelevant record fields by returning DontCare     case (getRelevance a, hasElims $ unArg a) of-      (Irrelevant, _)   -> Just Nothing+      (Irrelevant{}, _)   -> Just Nothing       -- if @a@ is the record field name applied to a single argument       -- then it passes the check       (_, Just (_, [])) -> Nothing  -- not a projection@@ -753,66 +827,131 @@         , unDom ax == f -> Just $ Just $ h es       _                 -> Nothing +{-# SPECIALIZE isSingletonRecord :: QName -> Args -> TCM Bool #-} -- | Is the type a hereditarily singleton record type? May return a -- blocking metavariable. -- -- Precondition: The name should refer to a record type, and the -- arguments should be the parameters to the type.-isSingletonRecord :: (PureTCM m, MonadBlock m) => QName -> Args -> m Bool-isSingletonRecord r ps = isJust <$> isSingletonRecord' False r ps+isSingletonRecord :: (PureTCM m, MonadBlock m)+  => QName   -- ^ Name of record type to check.+  -> Args    -- ^ Parameters given to the record type.+  -> m Bool+isSingletonRecord r ps = isJust <$> isSingletonRecord' False r ps mempty  isSingletonRecordModuloRelevance :: (PureTCM m, MonadBlock m)-                                 => QName -> Args -> m Bool-isSingletonRecordModuloRelevance r ps = isJust <$> isSingletonRecord' True r ps+  => QName   -- ^ Name of record type to check.+  -> Args    -- ^ Parameters given to the record type.+  -> m Bool+isSingletonRecordModuloRelevance r ps = isJust <$> isSingletonRecord' True r ps mempty  -- | Return the unique (closed) inhabitant if exists. --   In case of counting irrelevance in, the returned inhabitant --   contains dummy terms.-isSingletonRecord' :: forall m. (PureTCM m, MonadBlock m)-                   => Bool -> QName -> Args -> m (Maybe Term)-isSingletonRecord' regardIrrelevance r ps = do-  reportSDoc "tc.meta.eta" 30 $ "Is" <+> prettyTCM (Def r $ map Apply ps) <+> "a singleton record type?"-  isRecord r >>= \case-    Nothing  -> return Nothing-    Just def -> do-      fmap (mkCon (recConHead def) ConOSystem) <$> check (recTel def `apply` ps)+isSingletonRecord'+  :: forall m. (PureTCM m, MonadBlock m)+  => Bool            -- ^ Should disregard irrelevant fields?+  -> QName           -- ^ Name of record type to check.+  -> Args            -- ^ Parameters given to the record type.+  -> Set QName       -- ^ Non-terminating record types we already encountered.+                     --   These are considered as non-singletons,+                     --   otherwise we would construct an infinite inhabitant (in an infinite time...).+  -> m (Maybe Term)  -- ^ The unique inhabitant, if any.  May contain dummy terms in irrelevant positions.+isSingletonRecord' regardIrrelevance r ps rs = do+  reportSDoc "tc.meta.eta" 30 $ vcat+    [ "Is" <+> prettyTCM (Def r $ map Apply ps) <+> "a singleton record type?"+    , "  already visited:" <+> hsep (map prettyTCM $ Set.toList rs)+    ]+  -- Andreas, 2022-03-10, issue #5823+  -- We need to make sure we are not infinitely unfolding records, so we only expand each once,+  -- and keep track of the recursive ones we have already seen.+  if r `Set.member` rs then no else do+    caseMaybeM (isRecord r) no $ \ def -> do+      -- We might not know yet whether a record type is recursive because the positivity checker hasn't run yet.+      -- In this case, we pessimistically consider the record type to be recursive (@True@).+      let recursive = maybe True (not . null) $ _recMutual def+      -- Andreas, 2022-03-23, issue #5823+      -- We may pass through terminating record types as often as we want.+      -- If the termination checker has not run yet, we pessimistically consider the record type+      -- to be non-terminating.+      let nonTerminating = maybe True not $ _recTerminates def+      reportSDoc "tc.meta.eta" 30 $ vcat+        [ hsep [ prettyTCM r, "is recursive      :", prettyTCM recursive      ]+        , hsep [ prettyTCM r, "is non-terminating:", prettyTCM nonTerminating ]+        ]+      fmap (mkCon (_recConHead def) ConOSystem) <$> do+        check (applyWhen (recursive && nonTerminating) (Set.insert r) rs) $ _recTel def `apply` ps   where-  check :: Telescope -> m (Maybe [Arg Term])-  check tel = do+  -- Check that all entries of the constructor telescope are singletons.+  check :: Set QName -> Telescope -> m (Maybe [Arg Term])+  check rs tel = do     reportSDoc "tc.meta.eta" 30 $       "isSingletonRecord' checking telescope " <+> prettyTCM tel     case tel of-      EmptyTel -> return $ Just []+      EmptyTel -> yes       ExtendTel dom tel -> ifM (return regardIrrelevance `and2M` isIrrelevantOrPropM dom)         {-then-}-          (underAbstraction dom tel $ fmap (fmap (Arg (domInfo dom) __DUMMY_TERM__ :)) . check)+          (underAbstraction dom tel $ fmap (fmap (Arg (domInfo dom) __DUMMY_TERM__ :)) . check rs)         {-else-} $ do-          isSing <- isSingletonType' regardIrrelevance $ unDom dom-          case isSing of-            Nothing  -> return Nothing-            (Just v) -> underAbstraction dom tel $ fmap (fmap (Arg (domInfo dom) v :)) . check+          caseMaybeM (isSingletonType' regardIrrelevance (unDom dom) rs) no $ \ v -> do+            underAbstraction dom tel $ fmap (fmap (Arg (domInfo dom) v :)) . check rs+  no  = return Nothing+  yes = return $ Just []  -- | Check whether a type has a unique inhabitant and return it. --   Can be blocked by a metavar. isSingletonType :: (PureTCM m, MonadBlock m) => Type -> m (Maybe Term)-isSingletonType = isSingletonType' False+isSingletonType t = isSingletonType' False t mempty  -- | Check whether a type has a unique inhabitant (irrelevant parts ignored). --   Can be blocked by a metavar. isSingletonTypeModuloRelevance :: (PureTCM m, MonadBlock m) => Type -> m Bool-isSingletonTypeModuloRelevance t = isJust <$> isSingletonType' True t+isSingletonTypeModuloRelevance t = isJust <$> isSingletonType' True t mempty -isSingletonType' :: (PureTCM m, MonadBlock m) => Bool -> Type -> m (Maybe Term)-isSingletonType' regardIrrelevance t = do+isSingletonType'+  :: forall m. (PureTCM m, MonadBlock m)+  => Bool            -- ^ Should disregard irrelevant fields?+  -> Type            -- ^ Type to check.+  -> Set QName       -- ^ Non-terminating record typess we already encountered.+                     --   These are considered as non-singletons,+                     --   otherwise we would construct an infinite inhabitant (in an infinite time...).+  -> m (Maybe Term)  -- ^ The unique inhabitant, if any.  May contain dummy terms in irrelevant positions.+isSingletonType' regardIrrelevance t rs = do     TelV tel t <- telView t     t <- abortIfBlocked t     addContext tel $ do-      res <- isRecordType t-      case res of-        Just (r, ps, def) | YesEta <- recEtaEquality def -> do-          fmap (abstract tel) <$> isSingletonRecord' regardIrrelevance r ps-        _ -> return Nothing+      let+        -- Easy case: η for records.+        record :: m (Maybe Term)+        record = runMaybeT $ do+          (r, ps, def) <- MaybeT $ isRecordType t+          guard $ isEtaRecordDef def+          abstract tel <$> MaybeT (isSingletonRecord' regardIrrelevance r ps rs) +        -- Slightly harder case: η for Sub {level} tA phi elt.+        -- tA : Type level, phi : I, elt : Partial phi tA.+        subtype :: m (Maybe Term)+        subtype = runMaybeT $ do+          (level, tA, phi, elt) <- MaybeT $ isCubicalSubtype t+          subin <- MaybeT $ getBuiltinName' builtinSubIn+          itIsOne <- MaybeT $ getBuiltinName' builtinIsOne+          phiV <- intervalView phi+          case phiV of+            -- If phi = i1, then inS (elt 1=1) is the only inhabitant.+            IOne -> do+              let+                argH = Arg $ setHiding Hidden defaultArgInfo+                it = elt `apply` [defaultArg (Def itIsOne [])]+              pure (Def subin [] `apply` [argH level, argH tA, argH phi, defaultArg it])+            -- Otherwise we're blocked+            OTerm phi' -> patternViolation (unblockOnAnyMetaIn phi')+            -- This fails the MaybeT: we're not looking at a+            -- definitional singleton.+            _ -> fail ""++      (<|>) <$> record <*> subtype++{-# SPECIALIZE isEtaVar :: Term -> Type -> TCM (Maybe Int) #-} -- | Checks whether the given term (of the given type) is beta-eta-equivalent --   to a variable. Returns just the de Bruijn-index of the variable if it is, --   or nothing otherwise.@@ -847,13 +986,13 @@           case (mi, is) of             (Just i, _)     -> return i             (Nothing, [])   -> mzero-            (Nothing, i:is) -> guard (all (==i) is) >> return i+            (Nothing, i:is) -> guard (all (== i) is) >> return i         (_, Pi dom cod) -> addContext dom $ do           let u'  = raise 1 u `apply` [argFromDom dom $> var 0]               a'  = absBody cod-              mi' = fmap (+1) mi-              es' = (fmap . fmap) (+1) es ++ [Apply $ argFromDom dom $> 0]-          (-1+) <$> isEtaVarG u' a' mi' es'+              mi' = fmap (+ 1) mi+              es' = (fmap . fmap) (+ 1) es ++ [Apply $ argFromDom dom $> 0]+          (-1 +) <$> isEtaVarG u' a' mi' es'         _ -> mzero      -- `areEtaVarElims u a es es'` checks whether the given elims es (as applied
src/full/Agda/TypeChecking/Records.hs-boot view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Records where @@ -5,9 +6,10 @@ import qualified Agda.Syntax.Concrete.Name as C import Agda.TypeChecking.Monad -isRecord :: HasConstInfo m => QName -> m (Maybe Defn)-isEtaRecord :: HasConstInfo m => QName -> m Bool-getRecordFieldNames_ :: (HasConstInfo m, ReadTCState m) => QName -> m (Maybe [Dom C.Name]) etaContractRecord :: HasConstInfo m => QName -> ConHead -> ConInfo -> Args -> m Term-isGeneratedRecordConstructor :: (MonadTCEnv m, HasConstInfo m) => QName -> m Bool-isRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, Defn))++isRecord :: HasConstInfo m => QName -> m (Maybe RecordData)+isEtaRecord :: HasConstInfo m => QName -> m Bool+isRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, RecordData))++recordFieldNames :: RecordData -> [Dom C.Name]
src/full/Agda/TypeChecking/Reduce.hs view
@@ -1,13 +1,35 @@ {-# LANGUAGE NondecreasingIndentation #-} -module Agda.TypeChecking.Reduce where+module Agda.TypeChecking.Reduce+ -- Meta instantiation+ ( Instantiate, instantiate', instantiate, instantiateWhen+ -- Recursive meta instantiation+ , InstantiateFull, instantiateFull', instantiateFull+ -- Check for meta (no reduction)+ , IsMeta, isMeta+ -- Reduction and blocking+ , Reduce, reduce', reduceB', reduce, reduceB, reduceWithBlocker, reduceIApply'+ , reduceDefCopy, reduceDefCopyTCM+ , reduceHead+ , slowReduceTerm+ , unfoldCorecursion, unfoldCorecursionE+ , unfoldDefinitionE, unfoldDefinitionStep+ , unfoldInlined+ , appDef', appDefE'+ , abortIfBlocked, ifBlocked, isBlocked, fromBlocked, blockOnError+ -- Simplification+ , Simplify, simplify, simplifyBlocked'+ -- Normalization+ , Normalise, normalise', normalise+ , slowNormaliseArgs+ ) where -import Control.Monad ( (>=>), void )+import Control.Monad.Except ( MonadError(..) ) +import Data.List ( intercalate ) import Data.Maybe import Data.Map (Map) import qualified Data.Map as Map-import qualified Data.IntMap as IntMap import Data.Foldable import Data.Traversable import Data.HashMap.Strict (HashMap)@@ -17,13 +39,13 @@  import Agda.Syntax.Position import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Syntax.Internal import Agda.Syntax.Internal.MetaVars import Agda.Syntax.Scope.Base (Scope) import Agda.Syntax.Literal -import {-# SOURCE #-} Agda.TypeChecking.Irrelevance (workOnTypes, isPropM)-import {-# SOURCE #-} Agda.TypeChecking.Level (reallyUnLevelView)+import {-# SOURCE #-} Agda.TypeChecking.Irrelevance (isPropM) import Agda.TypeChecking.Monad hiding ( enterClosure, constructorForm ) import Agda.TypeChecking.Substitute import Agda.TypeChecking.CompiledClause@@ -36,14 +58,14 @@ import {-# SOURCE #-} Agda.TypeChecking.Pretty import {-# SOURCE #-} Agda.TypeChecking.Rewriting import {-# SOURCE #-} Agda.TypeChecking.Reduce.Fast+import {-# SOURCE #-} Agda.TypeChecking.Opacity  import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List-import Agda.Utils.Maybe+import Agda.Utils.List1 (List1) import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad-import Agda.Utils.Pretty (prettyShow) import Agda.Utils.Size import Agda.Utils.Tuple import qualified Agda.Utils.SmallSet as SmallSet@@ -56,9 +78,23 @@ instantiateFull :: (InstantiateFull a, MonadReduce m) => a -> m a instantiateFull = liftReduce . instantiateFull' +-- | A variant of 'instantiateFull' that only instantiates those+-- meta-variables that satisfy the predicate.++instantiateWhen ::+  (InstantiateFull a, MonadReduce m) =>+  (MetaId -> ReduceM Bool) ->+  a -> m a+instantiateWhen p =+  liftReduce .+  localR (\env -> env { redPred = Just p }) .+  instantiateFull'++{-# INLINE reduce #-} reduce :: (Reduce a, MonadReduce m) => a -> m a reduce = liftReduce . reduce' +{-# INLINE reduceB #-} reduceB :: (Reduce a, MonadReduce m) => a -> m (Blocked a) reduceB = liftReduce . reduceB' @@ -69,33 +105,29 @@   (\b a' -> return (b, a'))   (\_ a' -> return (neverUnblock, a')) --- Reduce a term and call the continuation. If the continuation is--- blocked, the whole call is blocked either on what blocked the reduction--- or on what blocked the continuation (using `blockedOnEither`).-withReduced-  :: (Reduce a, IsMeta a, MonadReduce m, MonadBlock m)-  => a -> (a -> m b) -> m b-withReduced a cont = ifBlocked a (\b a' -> addOrUnblocker b $ cont a') (\_ a' -> cont a')-+{-# INLINE normalise #-} normalise :: (Normalise a, MonadReduce m) => a -> m a normalise = liftReduce . normalise' --- | Normalise the given term but also preserve blocking tags---   TODO: implement a more efficient version of this.-normaliseB :: (MonadReduce m, Reduce t, Normalise t) => t -> m (Blocked t)-normaliseB = normalise >=> reduceB+-- UNUSED+-- -- | Normalise the given term but also preserve blocking tags+-- --   TODO: implement a more efficient version of this.+-- normaliseB :: (MonadReduce m, Reduce t, Normalise t) => t -> m (Blocked t)+-- normaliseB = normalise >=> reduceB +{-# INLINE simplify #-} simplify :: (Simplify a, MonadReduce m) => a -> m a simplify = liftReduce . simplify'  -- | Meaning no metas left in the instantiation. isFullyInstantiatedMeta :: MetaId -> TCM Bool isFullyInstantiatedMeta m = do-  mv <- lookupMeta m-  case mvInstantiation mv of-    InstV _tel v -> noMetas <$> instantiateFull v+  inst <- lookupMetaInstantiation m+  case inst of+    InstV inst -> noMetas <$> instantiateFull (instBody inst)     _ -> return False +{-# INLINABLE blockAll #-} -- | Blocking on all blockers. blockAll :: (Functor f, Foldable f) => f (Blocked a) -> Blocked (f a) blockAll bs = blockedOn block $ fmap ignoreBlocking bs@@ -103,6 +135,7 @@         blocker NotBlocked{}  = alwaysUnblock         blocker (Blocked b _) = b +{-# INLINABLE blockAny #-} -- | Blocking on any blockers. blockAny :: (Functor f, Foldable f) => f (Blocked a) -> Blocked (f a) blockAny bs = blockedOn block $ fmap ignoreBlocking bs@@ -112,6 +145,18 @@         blocker NotBlocked{}  = []         blocker (Blocked b _) = [b] +{-# SPECIALIZE blockOnError :: Blocker -> TCM a -> TCM a #-}+-- | Run the given computation but turn any errors into blocked computations with the given blocker+blockOnError :: MonadError TCErr m => Blocker -> m a -> m a+blockOnError blocker f+  | blocker == neverUnblock = f+  | otherwise               = f `catchError` \case+    TypeError{}         -> throwError $ PatternErr blocker+    PatternErr blocker' -> throwError $ PatternErr $ unblockOnEither blocker blocker'+    GenericException{}  -> __IMPOSSIBLE__+    err@IOException{}   -> throwError err+    ParserError{}       -> __IMPOSSIBLE__+ -- | Instantiate something. --   Results in an open meta variable or a non meta. --   Doesn't do any reduction, and preserves blocking tags (when blocking meta@@ -123,6 +168,7 @@   instantiate' = traverse instantiate'  instance Instantiate t => Instantiate [t]+instance Instantiate t => Instantiate (List1 t) instance Instantiate t => Instantiate (Map k t) instance Instantiate t => Instantiate (Maybe t) instance Instantiate t => Instantiate (Strict.Maybe t)@@ -133,40 +179,71 @@ instance Instantiate t => Instantiate (Tele t) instance Instantiate t => Instantiate (IPBoundary' t) +instance Instantiate () where+    instantiate' () = pure ()+ instance (Instantiate a, Instantiate b) => Instantiate (a,b) where     instantiate' (x,y) = (,) <$> instantiate' x <*> instantiate' y  instance (Instantiate a, Instantiate b,Instantiate c) => Instantiate (a,b,c) where     instantiate' (x,y,z) = (,,) <$> instantiate' x <*> instantiate' y <*> instantiate' z +-- | Run the second computation if the 'redPred' predicate holds for+-- the given meta-variable (or if the predicate is not defined), and+-- otherwise the first computation.++ifPredicateDoesNotHoldFor ::+  MetaId -> ReduceM a -> ReduceM a -> ReduceM a+ifPredicateDoesNotHoldFor m doesNotHold holds = do+  pred <- redPred <$> askR+  case pred of+    Nothing -> holds+    Just p  -> ifM (p m) holds doesNotHold+ instance Instantiate Term where-  instantiate' t@(MetaV x es) = do+  instantiate' t@(MetaV x es) = ifPredicateDoesNotHoldFor x (return t) $ do     blocking <- view stInstantiateBlocking <$> getTCState -    mv <- lookupMeta x-    let mi = mvInstantiation mv+    m <- lookupMeta x+    case m of+      Just (Left rmv) -> cont (rmvInstantiation rmv) -    case mi of-      InstV tel v -> instantiate' inst-        where-          -- A slight complication here is that the meta might be underapplied,-          -- in which case we have to build the lambda abstraction before-          -- applying the substitution, or overapplied in which case we need to-          -- fall back to applyE.-          (es1, es2) = splitAt (length tel) es-          vs1 = reverse $ map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es1-          rho = vs1 ++# wkS (length vs1) idS-                -- really should be .. ++# emptyS but using wkS makes it reduce to idS-                -- when applicable-          -- specification: inst == foldr mkLam v tel `applyE` es-          inst = applySubst rho (foldr mkLam v $ drop (length es1) tel) `applyE` es2-      _ | Just m' <- mvTwin mv, blocking -> do-            instantiate' (MetaV m' es)-      Open                             -> return t-      OpenInstance                     -> return t-      BlockedConst u | blocking  -> instantiate' . unBrave $ BraveTerm u `applyE` es-                     | otherwise -> return t-      PostponedTypeCheckingProblem _ -> return t+      Just (Right mv) -> case mvInstantiation mv of+         InstV inst -> cont inst++         _ | Just m' <- mvTwin mv, blocking ->+           instantiate' (MetaV m' es)++         OpenMeta _ -> return t++         BlockedConst u+           | blocking  -> instantiate' . unBrave $+                          BraveTerm u `applyE` es+           | otherwise -> return t++         PostponedTypeCheckingProblem _ -> return t++      Nothing -> __IMPOSSIBLE_VERBOSE__+                   ("Meta-variable not found: " ++ prettyShow x)+    where+    cont i = instantiate' inst+      where+      -- A slight complication here is that the meta might be underapplied,+      -- in which case we have to build the lambda abstraction before+      -- applying the substitution, or overapplied in which case we need to+      -- fall back to applyE.+      (es1, es2) = splitAt (length (instTel i)) es+      vs1 = reverse $ map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es1+      rho = vs1 ++# wkS (length vs1) idS+            -- really should be .. ++# emptyS but using wkS makes it reduce to idS+            -- when applicable+      -- specification:+      -- inst == foldr mkLam (instBody i) (instTel i) `applyE` es+      inst =+        applySubst rho+          (foldr mkLam (instBody i) $ drop (length es1) (instTel i))+          `applyE` es2+   instantiate' (Level l) = levelTm <$> instantiate' l   instantiate' (Sort s) = Sort <$> instantiate' s   instantiate' t = return t@@ -191,7 +268,9 @@   instantiate' (UnblockOnAny bs) = unblockOnAny . Set.fromList <$> mapM instantiate' (Set.toList bs)   instantiate' b@(UnblockOnMeta x) =     ifM (isInstantiatedMeta x) (return alwaysUnblock) (return b)-  instantiate' b@UnblockOnProblem{} = return b+  instantiate' (UnblockOnProblem pi) =+    ifM (isProblemSolved pi) (return alwaysUnblock) (return $ UnblockOnProblem pi)+  instantiate' b@UnblockOnDef{} = return b  instance Instantiate Sort where   instantiate' = \case@@ -203,7 +282,7 @@     s -> return s  instance (Instantiate t, Instantiate e) => Instantiate (Dom' t e) where-    instantiate' (Dom i fin n tac x) = Dom i fin n <$> instantiate' tac <*> instantiate' x+    instantiate' (Dom i n b tac x) = Dom i n b <$> instantiate' tac <*> instantiate' x  instance Instantiate a => Instantiate (Closure a) where     instantiate' cl = do@@ -222,7 +301,8 @@   instantiate' (LevelCmp cmp u v)   = uncurry (LevelCmp cmp) <$> instantiate' (u,v)   instantiate' (SortCmp cmp a b)    = uncurry (SortCmp cmp) <$> instantiate' (a,b)   instantiate' (UnBlock m)          = return $ UnBlock m-  instantiate' (FindInstance m cs)  = FindInstance m <$> mapM instantiate' cs+  instantiate' (FindInstance r m cs)   = FindInstance r m <$> mapM instantiate' cs+  instantiate' (ResolveInstanceHead q) = return $ ResolveInstanceHead q   instantiate' (IsEmpty r t)        = IsEmpty r <$> instantiate' t   instantiate' (CheckSizeLtSat t)   = CheckSizeLtSat <$> instantiate' t   instantiate' c@CheckFunDef{}      = return c@@ -231,9 +311,10 @@   instantiate' (CheckLockedVars a b c d) =     CheckLockedVars <$> instantiate' a <*> instantiate' b <*> instantiate' c <*> instantiate' d   instantiate' (UnquoteTactic t h g) = UnquoteTactic <$> instantiate' t <*> instantiate' h <*> instantiate' g+  instantiate' (CheckDataSort q s)  = CheckDataSort q <$> instantiate' s   instantiate' c@CheckMetaInst{}    = return c   instantiate' (CheckType t)        = CheckType <$> instantiate' t-  instantiate' (UsableAtModality mod t) = UsableAtModality mod <$> instantiate' t+  instantiate' (UsableAtModality cc ms mod t) = flip (UsableAtModality cc) mod <$> instantiate' ms <*> instantiate' t  instance Instantiate CompareAs where   instantiate' (AsTermsOf a) = AsTermsOf <$> instantiate' a@@ -248,7 +329,7 @@     <$> instantiate' t   instantiate' (IdiomType t)            = IdiomType     <$> instantiate' t-  instantiate' (EqualityType s eq l t a b) = EqualityType+  instantiate' (EqualityType r s eq l t a b) = EqualityType r     <$> instantiate' s     <*> return eq     <*> mapM instantiate' l@@ -320,6 +401,12 @@   => t -> m (Maybe Blocker) isBlocked t = ifBlocked t (\m _ -> return $ Just m) (\_ _ -> return Nothing) +-- | Throw a pattern violation if the argument is @Blocked@,+--   otherwise return the value embedded in the @NotBlocked@.+fromBlocked :: MonadBlock m => Blocked a -> m a+fromBlocked (Blocked b _) = patternViolation b+fromBlocked (NotBlocked _ x) = return x+ class Reduce t where   reduce'  :: t -> ReduceM t   reduceB' :: t -> ReduceM (Blocked t)@@ -327,32 +414,54 @@   reduce'  t = ignoreBlocking <$> reduceB' t   reduceB' t = notBlocked <$> reduce' t +  {-# MINIMAL reduce' | reduceB' #-}+ instance Reduce Type where     reduce'  (El s t) = workOnTypes $ El s <$> reduce' t     reduceB' (El s t) = workOnTypes $ fmap (El s) <$> reduceB' t  instance Reduce Sort where-    reduce' s = do+    -- Does not return a 'NotBlocked' 'PiSort', 'FunSort', or 'UnivSort'.+    reduceB' s = do       s <- instantiate' s+      let done | MetaS x _ <- s = return $ blocked x s+               | otherwise      = return $ notBlocked s       case s of-        PiSort a s1 s2 -> do-          (s1' , s2') <- reduce' (s1 , s2)-          maybe (return $ PiSort a s1' s2') reduce' $ piSort' a s1' s2'-        FunSort s1 s2 -> do-          (s1' , s2') <- reduce (s1 , s2)-          maybe (return $ FunSort s1' s2') reduce' $ funSort' s1' s2'-        UnivSort s' -> do-          s' <- reduce' s'-          caseMaybe (univSort' s') (return $ UnivSort s') reduce'-        Prop s'    -> Prop <$> reduce' s'-        Type s'    -> Type <$> reduce' s'-        Inf f n    -> return $ Inf f n-        SSet s'    -> SSet <$> reduce' s'-        SizeUniv   -> return SizeUniv-        LockUniv   -> return LockUniv-        MetaS x es -> return s-        DefS d es  -> return s -- postulated sorts do not reduce-        DummyS{}   -> return s+        PiSort a s1 s2 -> reduceB' (s1 , s2) >>= \case+          Blocked b (s1',s2') -> return $ Blocked b $ PiSort a s1' s2'+          NotBlocked _ (s1',s2') -> do+            -- Jesper, 2022-10-12: do instantiateFull here because+            -- `piSort'` does checking of free variables, and if we+            -- don't instantiate we might end up blocking on a solved+            -- metavariable.+            s2' <- instantiateFull s2'+            case piSort' a s1' s2' of+              Left b -> return $ Blocked b $ PiSort a s1' s2'+              Right s -> reduceB' s+        FunSort s1 s2 -> reduceB' (s1 , s2) >>= \case+          Blocked b (s1',s2') -> return $ Blocked b $ FunSort s1' s2'+          NotBlocked _ (s1',s2') -> do+            case funSort' s1' s2' of+              Left b -> return $ Blocked b $ FunSort s1' s2'+              Right s -> reduceB' s+        UnivSort s1 -> reduceB' s1 >>= \case+          Blocked b s1' -> return $ Blocked b $ UnivSort s1'+          NotBlocked _ s1' -> case univSort' s1' of+            Left b -> return $ Blocked b $ UnivSort s1'+            Right s -> reduceB' s+        Univ u l   -> notBlocked . Univ u <$> reduce l+        Inf _ _    -> done+        SizeUniv   -> done+        LockUniv   -> done+        LevelUniv  -> do+          levelUniverseEnabled <- isLevelUniverseEnabled+          if levelUniverseEnabled+          then done+          else return $ notBlocked (mkType 0)+        IntervalUniv -> done+        MetaS x es -> done+        DefS d es  -> done -- postulated sorts do not reduce+        DummyS{}   -> done  instance Reduce Elim where   reduce' (Apply v) = Apply <$> reduce' v@@ -367,18 +476,22 @@   reduceB' (Plus n l) = fmap (Plus n) <$> reduceB' l  instance (Subst a, Reduce a) => Reduce (Abs a) where-  reduce' b@(Abs x _) = Abs x <$> underAbstraction_ b reduce'-  reduce' (NoAbs x v) = NoAbs x <$> reduce' v+  reduceB' b@(Abs x _) = fmap (Abs x) <$> underAbstraction_ b reduceB'+  reduceB' (NoAbs x v) = fmap (NoAbs x) <$> reduceB' v  -- Lists are never blocked instance Reduce t => Reduce [t] where     reduce' = traverse reduce' +-- Maybes are never blocked+instance Reduce t => Reduce (Maybe t) where+    reduce' = traverse reduce'+ instance Reduce t => Reduce (Arg t) where     reduce' a = case getRelevance a of-      Irrelevant -> return a             -- Don't reduce' irr. args!?-                                         -- Andreas, 2018-03-03, caused #2989.-      _          -> traverse reduce' a+      Irrelevant{} -> return a             -- Don't reduce' irr. args!?+                                           -- Andreas, 2018-03-03, caused #2989.+      _ -> traverse reduce' a      reduceB' t = traverse id <$> traverse reduceB' t @@ -429,11 +542,7 @@   reduceB' = {-# SCC "reduce'<Term>" #-} maybeFastReduceTerm  shouldTryFastReduce :: ReduceM Bool-shouldTryFastReduce = (optFastReduce <$> pragmaOptions) `and2M` do-  allowed <- asksTC envAllowedReductions-  let optionalReductions = SmallSet.fromList [NonTerminatingReductions, UnconfirmedReductions]-      requiredReductions = allReductions SmallSet.\\ optionalReductions-  return $ (allowed SmallSet.\\ optionalReductions) == requiredReductions+shouldTryFastReduce = optFastReduce <$> pragmaOptions  maybeFastReduceTerm :: Term -> ReduceM (Blocked Term) maybeFastReduceTerm v = do@@ -448,7 +557,7 @@       MetaV x _ -> ifM (isOpen x) (return $ blocked x v) (maybeFast v)       _         -> maybeFast v   where-    isOpen x = isOpenMeta . mvInstantiation <$> lookupMeta x+    isOpen x = isOpenMeta <$> lookupMetaInstantiation x     maybeFast v = ifM shouldTryFastReduce (fastReduce v) (slowReduceTerm v)  slowReduceTerm :: Term -> ReduceM (Blocked Term)@@ -462,15 +571,15 @@ --    and seems to save 2% sec on the standard library --      MetaV x args -> notBlocked . MetaV x <$> reduce' args       MetaV x es -> iapp es-      Def f es   -> flip reduceIApply es $ unfoldDefinitionE False reduceB' (Def f []) f es+      Def f es   -> flip reduceIApply es $ unfoldDefinitionE reduceB' (Def f []) f es       Con c ci es -> do           -- Constructors can reduce' when they come from an           -- instantiated module.           -- also reduce when they are path constructors           v <- flip reduceIApply es-                 $ unfoldDefinitionE False reduceB' (Con c ci []) (conName c) es+                 $ unfoldDefinitionE reduceB' (Con c ci []) (conName c) es           traverse reduceNat v-      Sort s   -> fmap Sort <$> reduceB' s+      Sort s   -> done       Level l  -> ifM (SmallSet.member LevelReductions <$> asksTC envAllowedReductions)                     {- then -} (fmap levelTm <$> reduceB' l)                     {- else -} done@@ -512,37 +621,37 @@ unfoldCorecursion v = do   v <- instantiate' v   case v of-    Def f es -> unfoldDefinitionE True unfoldCorecursion (Def f []) f es+    Def f es -> unfoldDefinitionE unfoldCorecursion (Def f []) f es     _ -> slowReduceTerm v  -- | If the first argument is 'True', then a single delayed clause may -- be unfolded. unfoldDefinition ::-  Bool -> (Term -> ReduceM (Blocked Term)) ->+  (Term -> ReduceM (Blocked Term)) ->   Term -> QName -> Args -> ReduceM (Blocked Term)-unfoldDefinition unfoldDelayed keepGoing v f args =-  unfoldDefinitionE unfoldDelayed keepGoing v f (map Apply args)+unfoldDefinition keepGoing v f args =+  unfoldDefinitionE keepGoing v f (map Apply args)  unfoldDefinitionE ::-  Bool -> (Term -> ReduceM (Blocked Term)) ->+  (Term -> ReduceM (Blocked Term)) ->   Term -> QName -> Elims -> ReduceM (Blocked Term)-unfoldDefinitionE unfoldDelayed keepGoing v f es = do-  r <- unfoldDefinitionStep unfoldDelayed v f es+unfoldDefinitionE keepGoing v f es = do+  r <- unfoldDefinitionStep v f es   case r of     NoReduction v    -> return v     YesReduction _ v -> keepGoing v  unfoldDefinition' ::-  Bool -> (Simplification -> Term -> ReduceM (Simplification, Blocked Term)) ->+  (Simplification -> Term -> ReduceM (Simplification, Blocked Term)) ->   Term -> QName -> Elims -> ReduceM (Simplification, Blocked Term)-unfoldDefinition' unfoldDelayed keepGoing v0 f es = do-  r <- unfoldDefinitionStep unfoldDelayed v0 f es+unfoldDefinition' keepGoing v0 f es = do+  r <- unfoldDefinitionStep v0 f es   case r of     NoReduction v       -> return (NoSimplification, v)     YesReduction simp v -> keepGoing simp v -unfoldDefinitionStep :: Bool -> Term -> QName -> Elims -> ReduceM (Reduced (Blocked Term) Term)-unfoldDefinitionStep unfoldDelayed v0 f es =+unfoldDefinitionStep :: Term -> QName -> Elims -> ReduceM (Reduced (Blocked Term) Term)+unfoldDefinitionStep v0 f es =   {-# SCC "reduceDef" #-} do   traceSDoc "tc.reduce" 90 ("unfoldDefinitionStep v0" <+> pretty v0) $ do   info <- getConstInfo f@@ -559,7 +668,6 @@       dontUnfold = or         [ defNonterminating info && SmallSet.notMember NonTerminatingReductions allowed         , defTerminationUnconfirmed info && SmallSet.notMember UnconfirmedReductions allowed-        , defDelayed info == Delayed && not unfoldDelayed         , prp == Right True         , isIrrelevant info         , not defOk@@ -575,7 +683,7 @@         then reducePrimitive x v0 f es pf dontUnfold                              cls (defCompiled info) rewr         else noReduction $ notBlocked v-    PrimitiveSort{ primSort = s } -> yesReduction NoSimplification $ Sort s `applyE` es+    PrimitiveSort{ primSortSort = s } -> yesReduction NoSimplification $ Sort s `applyE` es      _  -> do       if or@@ -629,8 +737,9 @@                           defaultResult -- non-terminating or delayed         ([],[])        -> traceSLn "tc.reduce" 90 "reduceNormalE: no clauses or rewrite rules" $ do           -- no definition for head-          blk <- defBlocked <$> getConstInfo f-          noReduction $ blk $> vfull+          (defBlocked <$> getConstInfo f) >>= \case+            Blocked{}    -> noReduction $ Blocked (UnblockOnDef f) vfull+            NotBlocked{} -> defaultResult         (cls,rewr)     -> do           ev <- appDefE_ f v0 cls mcc rewr es           debugReduce ev@@ -683,7 +792,7 @@                 xs  = etaArgs ps es                 n   = length xs                 newes = raise n es ++ [ Apply $ var i <$ x | (i, x) <- zip (downFrom n) xs ]-        if (defDelayed info == Delayed) || (defNonterminating info)+        if defNonterminating info          then return $ NoReduction ()          else do             ev <- liftReduce $ appDefE_ f v0 [cl] Nothing mempty $ map notReduced es'@@ -706,13 +815,13 @@     Def f es -> do        abstractMode <- envAbstractMode <$> askTC-      isAbstract <- treatAbstractly f+      isAbstract <- not <$> hasAccessibleDef f       traceSLn "tc.inj.reduce" 50 (-        "reduceHead: we are in " ++ show abstractMode++ "; " ++ prettyShow f +++        "reduceHead: we are in " ++ show abstractMode ++ "; " ++ prettyShow f ++         " is treated " ++ if isAbstract then "abstractly" else "concretely"         ) $ do       let v0  = Def f []-          red = liftReduce $ unfoldDefinitionE False reduceHead v0 f es+          red = liftReduce $ unfoldDefinitionE reduceHead v0 f es       def <- theDef <$> getConstInfo f       case def of         -- Andreas, 2012-11-06 unfold aliases (single clause terminating functions)@@ -720,7 +829,7 @@         -- We restrict this to terminating functions to not make the         -- type checker loop here on non-terminating functions.         -- see test/fail/TerminationInfiniteRecord-        Function{ funClauses = [ _ ], funDelayed = NotDelayed, funTerminates = Just True } -> do+        Function{ funClauses = [ _ ], funTerminates = Just True } -> do           traceSLn "tc.inj.reduce" 50 ("reduceHead: head " ++ prettyShow f ++ " is Function") $ do           red         Datatype{ dataClause = Just _ } -> red@@ -728,7 +837,8 @@         _                               -> return $ notBlocked v     _ -> return $ notBlocked v --- | Unfold a single inlined function.+-- | Unfold as many copies as possible, and then potentially a single+-- inline function. unfoldInlined :: PureTCM m => Term -> m Term unfoldInlined v = do   inTypes <- viewTC eWorkingOnTypes@@ -736,12 +846,31 @@     _ | inTypes -> return v -- Don't inline in types (to avoid unfolding of goals)     Def f es -> do       info <- getConstInfo f-      let def = theDef info-          irr = isIrrelevant $ defArgInfo info-      case def of   -- Only for simple definitions with no pattern matching (TODO: maybe copatterns?)-        Function{ funCompiled = Just Done{}, funDelayed = NotDelayed }-          | def ^. funInline , not irr -> liftReduce $-          ignoreBlocking <$> unfoldDefinitionE False (return . notBlocked) (Def f []) f es++      let+        def = theDef info+        irr = isIrrelevant $ defArgInfo info+        continue+          | defCopy info = fmap notBlocked . unfoldInlined+          | otherwise    = return . notBlocked++      case def of+        Function{} ->+          reportSLn "tc.inline" 90 $+            intercalate "\n"+            [ "considering to inline " ++ prettyShow f+            , "irr         = " ++ prettyShow irr+            , "funInline   = " ++ prettyShow (def ^. funInline)+            , "funCompiled = " ++ prettyShow (funCompiled def)+            ]+        _ -> pure ()++      case def of -- Only for simple definitions with no pattern matching (TODO: maybe copatterns?)+        Function{ funCompiled = Just Done{} }+          | (defCopy info || def ^. funInline), not irr -> do+            reportSLn "tc.inline" 70 $ "asking to inline " ++ prettyShow f+            liftReduce $+              ignoreBlocking <$> unfoldDefinitionE continue (Def f []) f es         _ -> return v     _ -> return v @@ -753,7 +882,7 @@ appDefE_ :: QName -> Term -> [Clause] -> Maybe CompiledClauses -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term) appDefE_ f v0 cls mcc rewr args =   localTC (\ e -> e { envAppDef = Just f }) $-  maybe (appDefE' v0 cls rewr args)+  maybe (appDefE'' v0 cls rewr args)         (\cc -> appDefE v0 cc rewr args) mcc  @@ -771,11 +900,17 @@     NoReduction es'      -> rewrite (void es') (applyE v) rewr (ignoreBlocking es')  -- | Apply a defined function to it's arguments, using the original clauses.-appDef' :: Term -> [Clause] -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)-appDef' v cls rewr args = appDefE' v cls rewr $ map (fmap Apply) args+appDef' :: QName -> Term -> [Clause] -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)+appDef' f v cls rewr args = appDefE' f v cls rewr $ map (fmap Apply) args -appDefE' :: Term -> [Clause] -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)-appDefE' v cls rewr es = traceSDoc "tc.reduce" 90 ("appDefE' v = " <+> pretty v) $ do+appDefE' :: QName -> Term -> [Clause] -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)+appDefE' f v cls rewr es =+  localTC (\ e -> e { envAppDef = Just f }) $+  appDefE'' v cls rewr es++-- | Expects @'envAppDef' = Just f@ in 'TCEnv' to be able to report @'MissingClauses' f@.+appDefE'' :: Term -> [Clause] -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)+appDefE'' v cls rewr es = traceSDoc "tc.reduce" 90 ("appDefE' v = " <+> pretty v) $ do   goCls cls $ map ignoreReduced es   where     goCls :: [Clause] -> [Elim] -> ReduceM (Reduced (Blocked Term) Term)@@ -787,7 +922,9 @@         -- the remaining clauses (see Issue 907).         -- Andrea(s), 2014-12-05:  We return 'MissingClauses' here, since this         -- is the most conservative reason.-        [] -> rewrite (NotBlocked MissingClauses ()) (applyE v) rewr es+        [] -> do+          f <- fromMaybe __IMPOSSIBLE__ <$> asksTC envAppDef+          rewrite (NotBlocked (MissingClauses f) ()) (applyE v) rewr es         cl : cls -> do           let pats = namedClausePats cl               body = clauseBody cl@@ -795,13 +932,23 @@               nvars = size $ clauseTel cl           -- if clause is underapplied, skip to next clause           if length es < npats then goCls cls es else do+            termCheck <- asksTC envTermCheckReducing             let (es0, es1) = splitAt npats es             (m, es0) <- matchCopatterns pats es0             let es = es0 ++ es1             case m of-              No         -> goCls cls es-              DontKnow b -> rewrite b (applyE v) rewr es+              No               -> goCls cls es+              -- Szumi, 2024-03-29, issue #7181:+              -- If a lazy match is stuck and all non-lazy matches are conclusive,+              -- then reduction should not be stuck on the current clause and it+              -- should be fine to continue matching on the next clause.+              -- This assumes it's impossible for a lazy match to be stuck if+              -- all non-lazy matches succeed.+              DontKnow OnlyLazy _ -> goCls cls es+              DontKnow NonLazy  b -> rewrite b (applyE v) rewr es               Yes simpl vs -- vs is the subst. for the variables bound in body+                | termCheck && fromMaybe True (clauseRecursive cl) ->+                    return $ NoReduction __IMPOSSIBLE__                 | Just w <- body -> do -- clause has body?                     -- TODO: let matchPatterns also return the reduced forms                     -- of the original arguments!@@ -814,6 +961,7 @@     reduce' cl = do         x <- enterClosure cl reduce'         return $ cl { clValue = x }+{-# SPECIALIZE reduce' :: Closure Constraint -> ReduceM (Closure Constraint) #-}  instance Reduce Telescope where   reduce' EmptyTel          = return EmptyTel@@ -831,7 +979,8 @@   reduce' (LevelCmp cmp u v)    = uncurry (LevelCmp cmp) <$> reduce' (u,v)   reduce' (SortCmp cmp a b)     = uncurry (SortCmp cmp) <$> reduce' (a,b)   reduce' (UnBlock m)           = return $ UnBlock m-  reduce' (FindInstance m cs)   = FindInstance m <$> mapM reduce' cs+  reduce' (FindInstance r m cs)   = FindInstance r m <$> mapM reduce' cs+  reduce' (ResolveInstanceHead q) = return $ ResolveInstanceHead q   reduce' (IsEmpty r t)         = IsEmpty r <$> reduce' t   reduce' (CheckSizeLtSat t)    = CheckSizeLtSat <$> reduce' t   reduce' c@CheckFunDef{}       = return c@@ -840,9 +989,10 @@   reduce' (UnquoteTactic t h g) = UnquoteTactic <$> reduce' t <*> reduce' h <*> reduce' g   reduce' (CheckLockedVars a b c d) =     CheckLockedVars <$> reduce' a <*> reduce' b <*> reduce' c <*> reduce' d+  reduce' (CheckDataSort q s)   = CheckDataSort q <$> reduce' s   reduce' c@CheckMetaInst{}     = return c   reduce' (CheckType t)         = CheckType <$> reduce' t-  reduce' (UsableAtModality mod t) = UsableAtModality mod <$> reduce' t+  reduce' (UsableAtModality cc ms mod t) = flip (UsableAtModality cc) mod <$> reduce' ms <*> reduce' t  instance Reduce CompareAs where   reduce' (AsTermsOf a) = AsTermsOf <$> reduce' a@@ -860,7 +1010,7 @@     <$> reduce' t   reduce' (IdiomType t)            = IdiomType     <$> reduce' t-  reduce' (EqualityType s eq l t a b) = EqualityType+  reduce' (EqualityType r s eq l t a b) = EqualityType r     <$> reduce' s     <*> return eq     <*> mapM reduce' l@@ -918,10 +1068,10 @@     case v of       Def f vs   -> iapp vs $ do         let keepGoing simp v = return (simp, notBlocked v)-        (simpl, v) <- unfoldDefinition' False keepGoing (Def f []) f vs-        traceSDoc "tc.simplify'" 90 (-          text ("simplify': unfolding definition returns " ++ show simpl)-            <+> pretty (ignoreBlocking v)) $ do+        (simpl, v) <- unfoldDefinition' keepGoing (Def f []) f vs+        when (simpl == YesSimplification) $+          reportSDoc "tc.simplify'" 90 $+            pretty f <+> text ("simplify': unfolding definition returns " ++ show simpl) <+> pretty (ignoreBlocking v)         case simpl of           YesSimplification -> simplifyBlocked' v -- Dangerous, but if @simpl@ then @v /= Def f vs@           NoSimplification  -> Def f <$> simplify' vs@@ -949,12 +1099,12 @@         PiSort a s1 s2 -> piSort <$> simplify' a <*> simplify' s1 <*> simplify' s2         FunSort s1 s2 -> funSort <$> simplify' s1 <*> simplify' s2         UnivSort s -> univSort <$> simplify' s-        Type s     -> Type <$> simplify' s-        Prop s     -> Prop <$> simplify' s+        Univ u s   -> Univ u <$> simplify' s         Inf _ _    -> return s-        SSet s     -> SSet <$> simplify' s         SizeUniv   -> return s         LockUniv   -> return s+        LevelUniv  -> return s+        IntervalUniv -> return s         MetaS x es -> MetaS x <$> simplify' es         DefS d es  -> DefS d <$> simplify' es         DummyS{}   -> return s@@ -996,7 +1146,8 @@   simplify' (LevelCmp cmp u v)    = uncurry (LevelCmp cmp) <$> simplify' (u,v)   simplify' (SortCmp cmp a b)     = uncurry (SortCmp cmp) <$> simplify' (a,b)   simplify' (UnBlock m)           = return $ UnBlock m-  simplify' (FindInstance m cs)   = FindInstance m <$> mapM simplify' cs+  simplify' (FindInstance r m cs)   = FindInstance r m <$> mapM simplify' cs+  simplify' (ResolveInstanceHead q) = return $ ResolveInstanceHead q   simplify' (IsEmpty r t)         = IsEmpty r <$> simplify' t   simplify' (CheckSizeLtSat t)    = CheckSizeLtSat <$> simplify' t   simplify' c@CheckFunDef{}       = return c@@ -1005,9 +1156,10 @@   simplify' (UnquoteTactic t h g) = UnquoteTactic <$> simplify' t <*> simplify' h <*> simplify' g   simplify' (CheckLockedVars a b c d) =     CheckLockedVars <$> simplify' a <*> simplify' b <*> simplify' c <*> simplify' d+  simplify' (CheckDataSort q s)   = CheckDataSort q <$> simplify' s   simplify' c@CheckMetaInst{}     = return c   simplify' (CheckType t)         = CheckType <$> simplify' t-  simplify' (UsableAtModality mod t) = UsableAtModality mod <$> simplify' t+  simplify' (UsableAtModality cc ms mod t) = flip (UsableAtModality cc) mod <$> simplify' ms <*> simplify' t  instance Simplify CompareAs where   simplify' (AsTermsOf a) = AsTermsOf <$> simplify' a@@ -1038,7 +1190,7 @@     <$> simplify' t   simplify' (IdiomType t)            = IdiomType     <$> simplify' t-  simplify' (EqualityType s eq l t a b) = EqualityType+  simplify' (EqualityType r s eq l t a b) = EqualityType r     <$> simplify' s     <*> return eq     <*> mapM simplify' l@@ -1056,9 +1208,10 @@   default normalise' :: (t ~ f a, Traversable f, Normalise a) => t -> ReduceM t   normalise' = traverse normalise' --- boring instances:+-- Functor instances:  instance Normalise t => Normalise [t]+instance Normalise t => Normalise (List1 t) instance Normalise t => Normalise (Map k t) instance Normalise t => Normalise (Maybe t) instance Normalise t => Normalise (Strict.Maybe t)@@ -1067,8 +1220,11 @@ -- Elim' not included since it contains Arg instance Normalise t => Normalise (Named name t) instance Normalise t => Normalise (IPBoundary' t)+instance Normalise t => Normalise (Ranged t) instance Normalise t => Normalise (WithHiding t) +-- more boring instances:+ instance (Normalise a, Normalise b) => Normalise (a,b) where     normalise' (x,y) = (,) <$> normalise' x <*> normalise' y @@ -1098,12 +1254,12 @@         PiSort a s1 s2 -> piSort <$> normalise' a <*> normalise' s1 <*> normalise' s2         FunSort s1 s2 -> funSort <$> normalise' s1 <*> normalise' s2         UnivSort s -> univSort <$> normalise' s-        Prop s     -> Prop <$> normalise' s-        Type s     -> Type <$> normalise' s+        Univ u s   -> Univ u <$> normalise' s         Inf _ _    -> return s-        SSet s     -> SSet <$> normalise' s         SizeUniv   -> return SizeUniv         LockUniv   -> return LockUniv+        LevelUniv  -> return LevelUniv+        IntervalUniv -> return IntervalUniv         MetaS x es -> return s         DefS d es  -> return s         DummyS{}   -> return s@@ -1176,7 +1332,8 @@   normalise' (LevelCmp cmp u v)    = uncurry (LevelCmp cmp) <$> normalise' (u,v)   normalise' (SortCmp cmp a b)     = uncurry (SortCmp cmp) <$> normalise' (a,b)   normalise' (UnBlock m)           = return $ UnBlock m-  normalise' (FindInstance m cs)   = FindInstance m <$> mapM normalise' cs+  normalise' (FindInstance r m cs)   = FindInstance r m <$> mapM normalise' cs+  normalise' (ResolveInstanceHead q) = return $ ResolveInstanceHead q   normalise' (IsEmpty r t)         = IsEmpty r <$> normalise' t   normalise' (CheckSizeLtSat t)    = CheckSizeLtSat <$> normalise' t   normalise' c@CheckFunDef{}       = return c@@ -1185,9 +1342,10 @@   normalise' (UnquoteTactic t h g) = UnquoteTactic <$> normalise' t <*> normalise' h <*> normalise' g   normalise' (CheckLockedVars a b c d) =     CheckLockedVars <$> normalise' a <*> normalise' b <*> normalise' c <*> normalise' d+  normalise' (CheckDataSort q s)   = CheckDataSort q <$> normalise' s   normalise' c@CheckMetaInst{}     = return c   normalise' (CheckType t)         = CheckType <$> normalise' t-  normalise' (UsableAtModality mod t) = UsableAtModality mod <$> normalise' t+  normalise' (UsableAtModality cc ms mod t) = flip (UsableAtModality cc) mod <$> normalise' ms <*> normalise' t  instance Normalise CompareAs where   normalise' (AsTermsOf a) = AsTermsOf <$> normalise' a@@ -1218,7 +1376,7 @@     <$> normalise' t   normalise' (IdiomType t)            = IdiomType     <$> normalise' t-  normalise' (EqualityType s eq l t a b) = EqualityType+  normalise' (EqualityType r s eq l t a b) = EqualityType r     <$> normalise' s     <*> return eq     <*> mapM normalise' l@@ -1241,6 +1399,7 @@ -- Traversables (doesn't include binders like Abs, Tele):  instance InstantiateFull t => InstantiateFull [t]+instance InstantiateFull t => InstantiateFull (List1 t) instance InstantiateFull t => InstantiateFull (HashMap k t) instance InstantiateFull t => InstantiateFull (Map k t) instance InstantiateFull t => InstantiateFull (Maybe t)@@ -1296,21 +1455,24 @@ instance InstantiateFull DBPatVar where     instantiateFull' = return +instance InstantiateFull PrimitiveId where+  instantiateFull' = return+ -- Rest:  instance InstantiateFull Sort where     instantiateFull' s = do         s <- instantiate' s         case s of-            Type n     -> Type <$> instantiateFull' n-            Prop n     -> Prop <$> instantiateFull' n-            SSet n     -> SSet <$> instantiateFull' n+            Univ u n   -> Univ u <$> instantiateFull' n             PiSort a s1 s2 -> piSort <$> instantiateFull' a <*> instantiateFull' s1 <*> instantiateFull' s2             FunSort s1 s2 -> funSort <$> instantiateFull' s1 <*> instantiateFull' s2             UnivSort s -> univSort <$> instantiateFull' s             Inf _ _    -> return s             SizeUniv   -> return s             LockUniv   -> return s+            LevelUniv  -> return s+            IntervalUniv -> return s             MetaS x es -> MetaS x <$> instantiateFull' es             DefS d es  -> DefS d <$> instantiateFull' es             DummyS{}   -> return s@@ -1346,13 +1508,13 @@ instance InstantiateFull Substitution where   instantiateFull' sigma =     case sigma of-      IdS                  -> return IdS-      EmptyS err           -> return $ EmptyS err-      Wk   n sigma         -> Wk   n         <$> instantiateFull' sigma-      Lift n sigma         -> Lift n         <$> instantiateFull' sigma-      Strengthen bot sigma -> Strengthen bot <$> instantiateFull' sigma-      t :# sigma           -> consS <$> instantiateFull' t-                                    <*> instantiateFull' sigma+      IdS                    -> return IdS+      EmptyS err             -> return $ EmptyS err+      Wk   n sigma           -> Wk   n           <$> instantiateFull' sigma+      Lift n sigma           -> Lift n           <$> instantiateFull' sigma+      Strengthen bot n sigma -> Strengthen bot n <$> instantiateFull' sigma+      t :# sigma             -> consS <$> instantiateFull' t+                                      <*> instantiateFull' sigma  instance InstantiateFull ConPatternInfo where     instantiateFull' i = instantiateFull' (conPType i) <&> \ t -> i { conPType = t }@@ -1371,8 +1533,14 @@     instantiateFull' (NoAbs x a) = NoAbs x <$> instantiateFull' a  instance (InstantiateFull t, InstantiateFull e) => InstantiateFull (Dom' t e) where-    instantiateFull' (Dom i fin n tac x) = Dom i fin n <$> instantiateFull' tac <*> instantiateFull' x+    instantiateFull' (Dom i n b tac x) = Dom i n b <$> instantiateFull' tac <*> instantiateFull' x +instance InstantiateFull ContextEntry where+  instantiateFull' (CtxVar x a) = CtxVar x <$> instantiateFull' a++instance InstantiateFull LetBinding where+  instantiateFull' (LetBinding o v t) = LetBinding o <$> instantiateFull' v <*> instantiateFull' t+ -- Andreas, 2021-09-13, issue #5544, need to traverse @checkpoints@ map instance InstantiateFull t => InstantiateFull (Open t) where   instantiateFull' (OpenThing checkpoint checkpoints modl t) =@@ -1409,7 +1577,8 @@     LevelCmp cmp u v    -> uncurry (LevelCmp cmp) <$> instantiateFull' (u,v)     SortCmp cmp a b     -> uncurry (SortCmp cmp) <$> instantiateFull' (a,b)     UnBlock m           -> return $ UnBlock m-    FindInstance m cs   -> FindInstance m <$> mapM instantiateFull' cs+    FindInstance r m cs -> FindInstance r m <$> mapM instantiateFull' cs+    ResolveInstanceHead q -> return $ ResolveInstanceHead q     IsEmpty r t         -> IsEmpty r <$> instantiateFull' t     CheckSizeLtSat t    -> CheckSizeLtSat <$> instantiateFull' t     c@CheckFunDef{}     -> return c@@ -1418,9 +1587,10 @@     UnquoteTactic t g h -> UnquoteTactic <$> instantiateFull' t <*> instantiateFull' g <*> instantiateFull' h     CheckLockedVars a b c d ->       CheckLockedVars <$> instantiateFull' a <*> instantiateFull' b <*> instantiateFull' c <*> instantiateFull' d+    CheckDataSort q s   -> CheckDataSort q <$> instantiateFull' s     c@CheckMetaInst{}   -> return c     CheckType t         -> CheckType <$> instantiateFull' t-    UsableAtModality mod t -> UsableAtModality mod <$> instantiateFull' t+    UsableAtModality cc ms mod t -> flip (UsableAtModality cc) mod <$> instantiateFull' ms <*> instantiateFull' t  instance InstantiateFull CompareAs where   instantiateFull' (AsTermsOf a) = AsTermsOf <$> instantiateFull' a@@ -1428,7 +1598,11 @@   instantiateFull' AsTypes       = return AsTypes  instance InstantiateFull Signature where-  instantiateFull' (Sig a b c) = uncurry3 Sig <$> instantiateFull' (a, b, c)+  instantiateFull' (Sig a b c d) = Sig+    <$> instantiateFull' a+    <*> instantiateFull' b+    <*> instantiateFull' c+    <*> pure d             -- The instance table only stores names  instance InstantiateFull Section where   instantiateFull' (Section tel) = Section <$> instantiateFull' tel@@ -1457,14 +1631,15 @@     <*> instantiateFull' a  instance InstantiateFull NLPSort where-  instantiateFull' (PType x) = PType <$> instantiateFull' x-  instantiateFull' (PProp x) = PProp <$> instantiateFull' x+  instantiateFull' (PUniv u x) = PUniv u <$> instantiateFull' x   instantiateFull' (PInf f n) = return $ PInf f n   instantiateFull' PSizeUniv = return PSizeUniv   instantiateFull' PLockUniv = return PLockUniv+  instantiateFull' PLevelUniv = return PLevelUniv+  instantiateFull' PIntervalUniv = return PIntervalUniv  instance InstantiateFull RewriteRule where-  instantiateFull' (RewriteRule q gamma f ps rhs t c) =+  instantiateFull' (RewriteRule q gamma f ps rhs t c top) =     RewriteRule q       <$> instantiateFull' gamma       <*> pure f@@ -1472,13 +1647,14 @@       <*> instantiateFull' rhs       <*> instantiateFull' t       <*> pure c+      <*> pure top  instance InstantiateFull DisplayForm where   instantiateFull' (Display n ps v) = uncurry (Display n) <$> instantiateFull' (ps, v)  instance InstantiateFull DisplayTerm where-  instantiateFull' (DTerm v)       = DTerm <$> instantiateFull' v-  instantiateFull' (DDot  v)       = DDot  <$> instantiateFull' v+  instantiateFull' (DTerm' v es)   = DTerm' <$> instantiateFull' v <*> instantiateFull' es+  instantiateFull' (DDot' v es)    = DDot'  <$> instantiateFull' v <*> instantiateFull' es   instantiateFull' (DCon c ci vs)  = DCon c ci <$> instantiateFull' vs   instantiateFull' (DDef c es)     = DDef c <$> instantiateFull' es   instantiateFull' (DWithApp v vs ws) = uncurry3 DWithApp <$> instantiateFull' (v, vs, ws)@@ -1535,60 +1711,60 @@   instantiateFull' (Case n bs) = Case n <$> instantiateFull' bs  instance InstantiateFull Clause where-    instantiateFull' (Clause rl rf tel ps b t catchall exact recursive unreachable ell) =+    instantiateFull' (Clause rl rf tel ps b t catchall recursive unreachable ell wm) =        Clause rl rf <$> instantiateFull' tel        <*> instantiateFull' ps        <*> instantiateFull' b        <*> instantiateFull' t        <*> return catchall-       <*> return exact        <*> return recursive        <*> return unreachable        <*> return ell--instance InstantiateFull Interface where-  instantiateFull' i = do-    defs <- instantiateFull' (i ^. intSignature . sigDefinitions)-    instantiateFullExceptForDefinitions'-      (set (intSignature . sigDefinitions) defs i)+       <*> return wm --- | Instantiates everything except for definitions in the signature.+instance InstantiateFull Instantiation where+  instantiateFull' (Instantiation a b) =+    Instantiation a <$> instantiateFull' b -instantiateFullExceptForDefinitions' :: Interface -> ReduceM Interface-instantiateFullExceptForDefinitions'-  (Interface h s ft ms mod scope inside sig display userwarn importwarn-     b foreignCode highlighting libPragmas filePragmas usedOpts patsyns-     warnings partialdefs) =-  Interface h s ft ms mod scope inside-    <$> ((\s r -> Sig { _sigSections     = s-                      , _sigDefinitions  = sig ^. sigDefinitions-                      , _sigRewriteRules = r-                      })-         <$> instantiateFull' (sig ^. sigSections)-         <*> instantiateFull' (sig ^. sigRewriteRules))-    <*> instantiateFull' display-    <*> return userwarn-    <*> return importwarn-    <*> instantiateFull' b-    <*> return foreignCode-    <*> return highlighting-    <*> return libPragmas-    <*> return filePragmas-    <*> return usedOpts-    <*> return patsyns-    <*> return warnings-    <*> return partialdefs+instance InstantiateFull (Judgement MetaId) where+  instantiateFull' (HasType a b c) =+    HasType a b <$> instantiateFull' c+  instantiateFull' (IsSort a b) =+    IsSort a <$> instantiateFull' b --- | Instantiates everything except for definitions in the signature.+instance InstantiateFull RemoteMetaVariable where+  instantiateFull' (RemoteMetaVariable a b c) = RemoteMetaVariable+    <$> instantiateFull' a+    <*> return b+    <*> instantiateFull' c -instantiateFullExceptForDefinitions ::-  MonadReduce m => Interface -> m Interface-instantiateFullExceptForDefinitions =-  liftReduce . instantiateFullExceptForDefinitions'+instance InstantiateFull Interface where+  instantiateFull'+    (Interface h s ft ms mod tlmod scope inside sig _ display userwarn+         importwarn b foreignCode highlighting libPragmas filePragmas+         usedOpts patsyns warnings partialdefs oblocks onames) = do+    Interface h s ft ms mod tlmod scope inside+      <$!> instantiateFull' sig+      <*!> pure mempty               -- remote metas are dropped+      <*!> instantiateFull' display+      <*!> return userwarn+      <*!> return importwarn+      <*!> instantiateFull' b+      <*!> return foreignCode+      <*!> return highlighting+      <*!> return libPragmas+      <*!> return filePragmas+      <*!> return usedOpts+      <*!> return patsyns+      <*!> return warnings+      <*!> return partialdefs+      <*!> return oblocks+      <*!> return onames  instance InstantiateFull a => InstantiateFull (Builtin a) where     instantiateFull' (Builtin t) = Builtin <$> instantiateFull' t     instantiateFull' (Prim x)   = Prim <$> instantiateFull' x+    instantiateFull' b@(BuiltinRewriteRelations xs) = pure b  instance InstantiateFull Candidate where   instantiateFull' (Candidate q u t ov) =@@ -1599,7 +1775,7 @@     <$> instantiateFull' t   instantiateFull' (IdiomType t)            = IdiomType     <$> instantiateFull' t-  instantiateFull' (EqualityType s eq l t a b) = EqualityType+  instantiateFull' (EqualityType r s eq l t a b) = EqualityType r     <$> instantiateFull' s     <*> return eq     <*> mapM instantiateFull' l
src/full/Agda/TypeChecking/Reduce.hs-boot view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.Reduce where  import Agda.Syntax.Internal (Term, Elims, QName)
src/full/Agda/TypeChecking/Reduce/Fast.hs view
@@ -35,13 +35,16 @@ module Agda.TypeChecking.Reduce.Fast   ( fastReduce, fastNormalise ) where +import Prelude hiding ((!!))+ import Control.Applicative hiding (empty) import Control.Monad.ST import Control.Monad.ST.Unsafe (unsafeSTToIO, unsafeInterleaveST) +import qualified Data.HashMap.Strict as HMap import Data.Map (Map) import qualified Data.Map as Map-import qualified Data.IntMap as IntMap+import qualified Data.Map.Strict as MapS import qualified Data.IntSet as IntSet import qualified Data.List as List import Data.Semigroup ((<>))@@ -53,9 +56,8 @@ import Data.STRef import Data.Char -import Agda.Syntax.Internal import Agda.Syntax.Common-import Agda.Syntax.Position+import Agda.Syntax.Internal import Agda.Syntax.Literal  import Agda.TypeChecking.CompiledClause@@ -75,7 +77,7 @@ import Agda.Utils.Monad import Agda.Utils.Null (empty) import Agda.Utils.Functor-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty import Agda.Utils.Size import Agda.Utils.Zipper import qualified Agda.Utils.SmallSet as SmallSet@@ -90,8 +92,7 @@ -- information needed for fast reduction from the definition.  data CompactDef =-  CompactDef { cdefDelayed        :: Bool-             , cdefNonterminating :: Bool+  CompactDef { cdefNonterminating :: Bool              , cdefUnconfirmed    :: Bool              , cdefDef            :: CompactDefn              , cdefRewriteRules   :: RewriteRules@@ -118,27 +119,46 @@    -- WARNING: don't use isPropM here because it relies on reduction,   -- which causes an infinite loop.-  let isPrp = case getSort (defType def) of-        Prop{} -> True-        _      -> False-  let irr = isPrp || isIrrelevant (defArgInfo def)+  let isPrp = isProp $ getSort $ defType def -  dontReduce <- not <$> shouldReduceDef (defName def)+  shouldReduce <- shouldReduceDef (defName def)+  allowed <- asksTC envAllowedReductions +  let isConOrProj = case theDef def of+        Constructor{} -> True+        Function { funProjection = Right{} } -> True+        _ -> False+  let allowReduce = and+        [ shouldReduce+        , or+          [ RecursiveReductions `SmallSet.member` allowed+          , isConOrProj && ProjectionReductions `SmallSet.member` allowed+          , isInlineFun (theDef def) && InlineReductions `SmallSet.member` allowed+          , definitelyNonRecursive_ (theDef def) && or+            [ defCopatternLHS def && CopatternReductions `SmallSet.member` allowed+            , FunctionReductions `SmallSet.member` allowed+            ]+          ]+        , not (defNonterminating def) || SmallSet.member NonTerminatingReductions allowed+        , not (defTerminationUnconfirmed def) || SmallSet.member UnconfirmedReductions allowed+        , not isPrp+        , not (isIrrelevant def)+        ]+   cdefn <-     case theDef def of-      _ | irr || dontReduce -> pure CAxiom+      _ | not allowReduce -> pure CAxiom       _ | Just (defName def) == bPrimForce bEnv   -> pure CForce       _ | Just (defName def) == bPrimErase bEnv ->           case telView' (defType def) of-            TelV tel _ | size tel == 5 -> pure CErase-                       | otherwise     -> pure COther+            TelV tel _ | natSize tel == 5 -> pure CErase+                       | otherwise        -> pure COther                           -- Non-standard equality. Fall back to slow reduce.       _ | defBlocked def /= notBlocked_ -> pure COther -- Blocked definition       Constructor{conSrcCon = c, conArity = n} -> pure CCon{cconSrcCon = c, cconArity = n}       Function{funCompiled = Just cc, funClauses = _:_, funProjection = proj} ->         pure CFun{ cfunCompiled   = fastCompiledClauses bEnv cc-                 , cfunProjection = projOrig <$> proj }+                 , cfunProjection = projOrig <$> either (const Nothing) Just proj }       Function{funClauses = []}      -> pure CAxiom       Function{}                     -> pure COther -- Incomplete definition       Datatype{dataClause = Nothing} -> pure CTyCon@@ -150,22 +170,25 @@       AbstractDefn{}                 -> pure CAxiom       GeneralizableVar{}             -> __IMPOSSIBLE__       PrimitiveSort{}                -> pure COther -- TODO+      Primitive{}+        | not (FunctionReductions `SmallSet.member` allowed)+        -> pure CAxiom       Primitive{ primName = name, primCompiled = cc } ->         case name of           -- "primShowInteger"            -- integers are not literals            -- Natural numbers-          "primNatPlus"                -> mkPrim 2 $ natOp (+)-          "primNatMinus"               -> mkPrim 2 $ natOp (\ x y -> max 0 (x - y))-          "primNatTimes"               -> mkPrim 2 $ natOp (*)-          "primNatDivSucAux"           -> mkPrim 4 $ natOp4 divAux-          "primNatModSucAux"           -> mkPrim 4 $ natOp4 modAux-          "primNatLess"                -> mkPrim 2 $ natRel (<)-          "primNatEquality"            -> mkPrim 2 $ natRel (==)+          PrimNatPlus                  -> mkPrim 2 $ natOp (+)+          PrimNatMinus                 -> mkPrim 2 $ natOp (\ x y -> max 0 (x - y))+          PrimNatTimes                 -> mkPrim 2 $ natOp (*)+          PrimNatDivSucAux             -> mkPrim 4 $ natOp4 divAux+          PrimNatModSucAux             -> mkPrim 4 $ natOp4 modAux+          PrimNatLess                  -> mkPrim 2 $ natRel (<)+          PrimNatEquality              -> mkPrim 2 $ natRel (==)            -- Word64-          "primWord64ToNat"            -> mkPrim 1 $ \ [LitWord64 a] -> nat (fromIntegral a)-          "primWord64FromNat"          -> mkPrim 1 $ \ [LitNat a]    -> word (fromIntegral a)+          PrimWord64ToNat              -> mkPrim 1 $ \ [LitWord64 a] -> nat (fromIntegral a)+          PrimWord64FromNat            -> mkPrim 1 $ \ [LitNat a]    -> word (fromIntegral a)            -- Levels           -- "primLevelZero"              -- levels are not literals@@ -173,17 +196,16 @@           -- "primLevelMax"               -- levels are not literals            -- Floats-          "primFloatInequality"        -> mkPrim 2 $ floatRel (<=)-          "primFloatEquality"          -> mkPrim 2 $ floatRel (==)-          "primFloatLess"              -> mkPrim 2 $ floatRel (<)-          "primFloatIsInfinite"        -> mkPrim 1 $ floatPred isInfinite-          "primFloatIsNaN"             -> mkPrim 1 $ floatPred isNaN-          "primFloatIsDenormalized"    -> mkPrim 1 $ floatPred isDenormalized-          "primFloatIsNegativeZero"    -> mkPrim 1 $ floatPred isNegativeZero-          "primFloatIsSafeInteger"     -> mkPrim 1 $ floatPred isSafeInteger-          "primFloatToWord64"          -> mkPrim 1 $ \ [LitFloat a] -> word (doubleToWord64 a)+          PrimFloatInequality          -> mkPrim 2 $ floatRel (<=)+          PrimFloatEquality            -> mkPrim 2 $ floatRel (==)+          PrimFloatLess                -> mkPrim 2 $ floatRel (<)+          PrimFloatIsInfinite          -> mkPrim 1 $ floatPred isInfinite+          PrimFloatIsNaN               -> mkPrim 1 $ floatPred isNaN+          PrimFloatIsNegativeZero      -> mkPrim 1 $ floatPred isNegativeZero+          PrimFloatIsSafeInteger       -> mkPrim 1 $ floatPred isSafeInteger+          -- "primFloatToWord64"          -- returns a maybe           -- "primFloatToWord64Injective" -- identities are not literals-          "primNatToFloat"             -> mkPrim 1 $ \ [LitNat a] -> float (fromIntegral a)+          PrimNatToFloat               -> mkPrim 1 $ \ [LitNat a] -> float (fromIntegral a)           -- "primIntToFloat"             -- integers are not literals           -- "primFloatRound"             -- integers and maybe are not literals           -- "primFloatFloor"             -- integers and maybe are not literals@@ -192,63 +214,63 @@           -- "primRatioToFloat"           -- integers are not literals           -- "primFloatDecode"            -- integers and sigma are not literals           -- "primFloatEncode"            -- integers are not literals-          "primFloatPlus"              -> mkPrim 2 $ floatOp (+)-          "primFloatMinus"             -> mkPrim 2 $ floatOp (-)-          "primFloatTimes"             -> mkPrim 2 $ floatOp (*)-          "primFloatNegate"            -> mkPrim 1 $ floatFun negate-          "primFloatDiv"               -> mkPrim 2 $ floatOp (/)-          "primFloatSqrt"              -> mkPrim 1 $ floatFun sqrt-          "primFloatExp"               -> mkPrim 1 $ floatFun exp-          "primFloatLog"               -> mkPrim 1 $ floatFun log-          "primFloatSin"               -> mkPrim 1 $ floatFun sin-          "primFloatCos"               -> mkPrim 1 $ floatFun cos-          "primFloatTan"               -> mkPrim 1 $ floatFun tan-          "primFloatASin"              -> mkPrim 1 $ floatFun asin-          "primFloatACos"              -> mkPrim 1 $ floatFun acos-          "primFloatATan"              -> mkPrim 1 $ floatFun atan-          "primFloatATan2"             -> mkPrim 2 $ floatOp atan2-          "primFloatSinh"              -> mkPrim 1 $ floatFun sinh-          "primFloatCosh"              -> mkPrim 1 $ floatFun cosh-          "primFloatTanh"              -> mkPrim 1 $ floatFun tanh-          "primFloatASinh"             -> mkPrim 1 $ floatFun asinh-          "primFloatACosh"             -> mkPrim 1 $ floatFun acosh-          "primFloatATanh"             -> mkPrim 1 $ floatFun atanh-          "primFloatPow"               -> mkPrim 2 $ floatOp (**)-          "primShowFloat"              -> mkPrim 1 $ \ [LitFloat a] -> string (show a)+          PrimFloatPlus                -> mkPrim 2 $ floatOp (+)+          PrimFloatMinus               -> mkPrim 2 $ floatOp (-)+          PrimFloatTimes               -> mkPrim 2 $ floatOp (*)+          PrimFloatNegate              -> mkPrim 1 $ floatFun negate+          PrimFloatDiv                 -> mkPrim 2 $ floatOp (/)+          PrimFloatSqrt                -> mkPrim 1 $ floatFun sqrt+          PrimFloatExp                 -> mkPrim 1 $ floatFun exp+          PrimFloatLog                 -> mkPrim 1 $ floatFun log+          PrimFloatSin                 -> mkPrim 1 $ floatFun sin+          PrimFloatCos                 -> mkPrim 1 $ floatFun cos+          PrimFloatTan                 -> mkPrim 1 $ floatFun tan+          PrimFloatASin                -> mkPrim 1 $ floatFun asin+          PrimFloatACos                -> mkPrim 1 $ floatFun acos+          PrimFloatATan                -> mkPrim 1 $ floatFun atan+          PrimFloatATan2               -> mkPrim 2 $ floatOp atan2+          PrimFloatSinh                -> mkPrim 1 $ floatFun sinh+          PrimFloatCosh                -> mkPrim 1 $ floatFun cosh+          PrimFloatTanh                -> mkPrim 1 $ floatFun tanh+          PrimFloatASinh               -> mkPrim 1 $ floatFun asinh+          PrimFloatACosh               -> mkPrim 1 $ floatFun acosh+          PrimFloatATanh               -> mkPrim 1 $ floatFun atanh+          PrimFloatPow                 -> mkPrim 2 $ floatOp (**)+          PrimShowFloat                -> mkPrim 1 $ \ [LitFloat a] -> string (show a)            -- Characters-          "primCharEquality"           -> mkPrim 2 $ charRel (==)-          "primIsLower"                -> mkPrim 1 $ charPred isLower-          "primIsDigit"                -> mkPrim 1 $ charPred isDigit-          "primIsAlpha"                -> mkPrim 1 $ charPred isAlpha-          "primIsSpace"                -> mkPrim 1 $ charPred isSpace-          "primIsAscii"                -> mkPrim 1 $ charPred isAscii-          "primIsLatin1"               -> mkPrim 1 $ charPred isLatin1-          "primIsPrint"                -> mkPrim 1 $ charPred isPrint-          "primIsHexDigit"             -> mkPrim 1 $ charPred isHexDigit-          "primToUpper"                -> mkPrim 1 $ charFun toUpper-          "primToLower"                -> mkPrim 1 $ charFun toLower-          "primCharToNat"              -> mkPrim 1 $ \ [LitChar a] -> nat (fromIntegral (fromEnum a))-          "primNatToChar"              -> mkPrim 1 $ \ [LitNat a] -> char (integerToChar a)-          "primShowChar"               -> mkPrim 1 $ \ [a] -> string (prettyShow a)+          PrimCharEquality             -> mkPrim 2 $ charRel (==)+          PrimIsLower                  -> mkPrim 1 $ charPred isLower+          PrimIsDigit                  -> mkPrim 1 $ charPred isDigit+          PrimIsAlpha                  -> mkPrim 1 $ charPred isAlpha+          PrimIsSpace                  -> mkPrim 1 $ charPred isSpace+          PrimIsAscii                  -> mkPrim 1 $ charPred isAscii+          PrimIsLatin1                 -> mkPrim 1 $ charPred isLatin1+          PrimIsPrint                  -> mkPrim 1 $ charPred isPrint+          PrimIsHexDigit               -> mkPrim 1 $ charPred isHexDigit+          PrimToUpper                  -> mkPrim 1 $ charFun toUpper+          PrimToLower                  -> mkPrim 1 $ charFun toLower+          PrimCharToNat                -> mkPrim 1 $ \ [LitChar a] -> nat (fromIntegral (fromEnum a))+          PrimNatToChar                -> mkPrim 1 $ \ [LitNat a] -> char (integerToChar a)+          PrimShowChar                 -> mkPrim 1 $ \ [a] -> string (prettyShow a)            -- Strings           -- "primStringToList"           -- lists are not literals (TODO)           -- "primStringFromList"         -- lists are not literals (TODO)-          "primStringAppend"           -> mkPrim 2 $ \ [LitString a, LitString b] -> text (b <> a)-          "primStringEquality"         -> mkPrim 2 $ \ [LitString a, LitString b] -> bool (b == a)-          "primShowString"             -> mkPrim 1 $ \ [a] -> string (prettyShow a)+          PrimStringAppend             -> mkPrim 2 $ \ [LitString a, LitString b] -> text (b <> a)+          PrimStringEquality           -> mkPrim 2 $ \ [LitString a, LitString b] -> bool (b == a)+          PrimShowString               -> mkPrim 1 $ \ [a] -> string (prettyShow a)            -- "primErase"           -- "primForce"           -- "primForceLemma"-          "primQNameEquality"          -> mkPrim 2 $ \ [LitQName a, LitQName b] -> bool (b == a)-          "primQNameLess"              -> mkPrim 2 $ \ [LitQName a, LitQName b] -> bool (b < a)-          "primShowQName"              -> mkPrim 1 $ \ [LitQName a] -> string (prettyShow a)+          PrimQNameEquality            -> mkPrim 2 $ \ [LitQName a, LitQName b] -> bool (b == a)+          PrimQNameLess                -> mkPrim 2 $ \ [LitQName a, LitQName b] -> bool (b < a)+          PrimShowQName                -> mkPrim 1 $ \ [LitQName a] -> string (prettyShow a)           -- "primQNameFixity"            -- fixities are not literals (TODO)-          "primMetaEquality"           -> mkPrim 2 $ \ [LitMeta _ a, LitMeta _ b] -> bool (b == a)-          "primMetaLess"               -> mkPrim 2 $ \ [LitMeta _ a, LitMeta _ b] -> bool (b < a)-          "primShowMeta"               -> mkPrim 1 $ \ [LitMeta _ a] -> string (prettyShow a)+          PrimMetaEquality             -> mkPrim 2 $ \ [LitMeta _ a, LitMeta _ b] -> bool (b == a)+          PrimMetaLess                 -> mkPrim 2 $ \ [LitMeta _ a, LitMeta _ b] -> bool (b < a)+          PrimShowMeta                 -> mkPrim 1 $ \ [LitMeta _ a] -> string (prettyShow a)            _                            -> pure COther         where@@ -302,11 +324,10 @@           charRel _ _ = __IMPOSSIBLE__    return $-    CompactDef { cdefDelayed        = defDelayed def == Delayed-               , cdefNonterminating = defNonterminating def+    CompactDef { cdefNonterminating = defNonterminating def                , cdefUnconfirmed    = defTerminationUnconfirmed def                , cdefDef            = cdefn-               , cdefRewriteRules   = rewr+               , cdefRewriteRules   = if allowReduce then rewr else []                }  -- Faster case trees ------------------------------------------------------@@ -321,10 +342,10 @@   , fsucBranch      :: Maybe c   , flitBranches    :: Map Literal c     -- ^ Map from literal to case subtree.-  , fcatchAllBranch :: Maybe c+  , fcatchallBranch :: Maybe c     -- ^ (Possibly additional) catch-all clause.   , ffallThrough    :: Bool-    -- ^ (if True) In case of non-canonical argument use catchAllBranch.+    -- ^ (if True) In case of non-canonical argument use catchallBranch.   }  --UNUSED Liang-Ting Chen 2019-07-16@@ -333,7 +354,7 @@ --                      , fconBranches    = Map.empty --                      , fsucBranch      = Nothing --                      , flitBranches    = Map.empty---                      , fcatchAllBranch = Nothing+--                      , fcatchallBranch = Nothing --                      , ffallThrough    = False }  -- | Case tree with bodies.@@ -360,7 +381,7 @@   case cc of     Fail{}            -> FFail     Done xs b         -> FDone xs b-    Case (Arg _ n) Branches{ etaBranch = Just (c, cc), catchAllBranch = ca } ->+    Case (Arg _ n) Branches{ etaBranch = Just (c, cc), catchallBranch = ca } ->       FEta n (conFields c) (fastCompiledClauses bEnv $ content cc) (fastCompiledClauses bEnv <$> ca)     Case (Arg _ n) bs -> FCase n (fastCase bEnv bs) @@ -371,8 +392,8 @@     , fconBranches    = Map.mapKeysMonotonic (nameId . qnameName) $ fmap (fastCompiledClauses env . content) (stripSuc con)     , fsucBranch      = fmap (fastCompiledClauses env . content) $ flip Map.lookup con . conName =<< bSuc env     , flitBranches    = fmap (fastCompiledClauses env) lit-    , ffallThrough    = (Just True ==) fT-    , fcatchAllBranch = fmap (fastCompiledClauses env) wild }+    , ffallThrough    = Just True == fT+    , fcatchallBranch = fmap (fastCompiledClauses env) wild }   where     stripSuc | Just c <- bSuc env = Map.delete (conName c)              | otherwise          = id@@ -405,11 +426,6 @@ data Normalisation = WHNF | NF   deriving (Eq) -data ReductionFlags = ReductionFlags-  { allowNonTerminating :: Bool-  , allowUnconfirmed    :: Bool-  , hasRewriting        :: Bool }- -- | The entry point to the reduction machine. fastReduce :: Term -> ReduceM (Blocked Term) fastReduce = fastReduce' WHNF@@ -419,16 +435,26 @@  fastReduce' :: Normalisation -> Term -> ReduceM (Blocked Term) fastReduce' norm v = do+  tcState <- getTCState   let name (Con c _ _) = c       name _         = __IMPOSSIBLE__-  zero  <- fmap name <$> getBuiltin' builtinZero-  suc   <- fmap name <$> getBuiltin' builtinSuc-  true  <- fmap name <$> getBuiltin' builtinTrue-  false <- fmap name <$> getBuiltin' builtinFalse-  refl  <- fmap name <$> getBuiltin' builtinRefl-  force <- fmap primFunName <$> getPrimitive' "primForce"-  erase <- fmap primFunName <$> getPrimitive' "primErase"-  let bEnv = BuiltinEnv { bZero = zero, bSuc = suc, bTrue = true, bFalse = false, bRefl = refl,++      -- Gather builtins using 'BuiltinAccess' rather than with the default+      -- 'HasBuiltins ReduceM' instance. This increases laziness, allowing us to+      -- avoid costly builtin lookups unless needed.+      builtinName   = fmap name . runBuiltinAccess tcState . getBuiltin'+      primitiveName = fmap primFunName . runBuiltinAccess tcState . getPrimitive'++      zero  = builtinName builtinZero+      suc   = builtinName builtinSuc+      true  = builtinName builtinTrue+      false = builtinName builtinFalse+      refl  = builtinName builtinRefl++      force = primitiveName PrimForce+      erase = primitiveName PrimErase++      bEnv = BuiltinEnv { bZero = zero, bSuc = suc, bTrue = true, bFalse = false, bRefl = refl,                           bPrimForce = force, bPrimErase = erase }   allowedReductions <- asksTC envAllowedReductions   rwr <- optRewriting <$> pragmaOptions@@ -437,13 +463,7 @@     rewr <- if rwr then instantiateRewriteRules =<< getRewriteRulesFor f                    else return []     compactDef bEnv info rewr-  let flags = ReductionFlags{ allowNonTerminating = NonTerminatingReductions `SmallSet.member` allowedReductions-                            , allowUnconfirmed    = UnconfirmedReductions `SmallSet.member` allowedReductions-                            , hasRewriting        = rwr }-  ReduceM $ \ redEnv -> reduceTm redEnv bEnv (memoQName constInfo) norm flags v--unKleisli :: (a -> ReduceM b) -> ReduceM (a -> b)-unKleisli f = ReduceM $ \ env x -> unReduceM (f x) env+  ReduceM $ \ redEnv -> reduceTm redEnv bEnv (memoQName constInfo) norm v  -- * Closures @@ -578,19 +598,19 @@             --   instance, long chains of 'suc' constructors.           | Match QName FastCompiledClauses (Spine s) (MatchStack s) (ControlStack s)             -- ^ @Match f cc spine stack ctrl@ Match the arguments @spine@ against the case tree-            --   @cc@. The match stack contains a (possibly empty) list of 'CatchAll' frames and a+            --   @cc@. The match stack contains a (possibly empty) list of 'Catchall' frames and a             --   closure to return in case of a stuck match.  -- | The control stack contains a list of continuations, i.e. what to do with --   the result of the current focus. type ControlStack s = [ControlFrame s] --- | The control stack for matching. Contains a list of CatchAllFrame's and the closure to return in+-- | The control stack for matching. Contains a list of CatchallFrame's and the closure to return in --   case of a stuck match.-data MatchStack s = [CatchAllFrame s] :> Closure s+data MatchStack s = [CatchallFrame s] :> Closure s infixr 2 :>, >: -(>:) :: CatchAllFrame s -> MatchStack s -> MatchStack s+(>:) :: CatchallFrame s -> MatchStack s -> MatchStack s (>:) c (cs :> cl) = c : cs :> cl -- Previously written as: --   c >: cs :> cl = c : cs :> cl@@ -603,11 +623,11 @@ -- -- See https://ghc.haskell.org/trac/ghc/ticket/10018 which may be related. -data CatchAllFrame s = CatchAll FastCompiledClauses (Spine s)-                        -- ^ @CatchAll cc spine@. Case trees are not fully expanded, that is,+data CatchallFrame s = Catchall FastCompiledClauses (Spine s)+                        -- ^ @Catchall cc spine@. Case trees are not fully expanded, that is,                         --   inner matches can be partial and covered by a catch-all at a higher                         --   level. This catch-all is represented on the match stack as a-                        --   @CatchAll@. @cc@ is the case tree in the catch-all case and @spine@ is+                        --   @Catchall@. @cc@ is the case tree in the catch-all case and @spine@ is                         --   the value of the pattern variables at the point of the catch-all.  -- An Elim' with a hole.@@ -799,16 +819,20 @@ --   'getConstInfo' function, a couple of flags (allow non-terminating function unfolding, and --   whether rewriting is enabled), and a term to reduce. The result is the weak-head normal form of --   the term with an attached blocking tag.-reduceTm :: ReduceEnv -> BuiltinEnv -> (QName -> CompactDef) -> Normalisation -> ReductionFlags -> Term -> Blocked Term-reduceTm rEnv bEnv !constInfo normalisation ReductionFlags{..} =+reduceTm :: ReduceEnv -> BuiltinEnv -> (QName -> CompactDef) -> Normalisation -> Term -> Blocked Term+reduceTm rEnv bEnv !constInfo normalisation =     compileAndRun . traceDoc "-- fast reduce --"   where     -- Helpers to get information from the ReduceEnv.-    metaStore      = redSt rEnv ^. stMetaStore+    localMetas     = redSt rEnv ^. stSolvedMetaStore+    remoteMetas    = redSt rEnv ^. stImportedMetaStore     -- Are we currently instance searching. In that case we don't fail hard on missing clauses. This     -- is a (very unsatisfactory) work-around for #3870.     speculative    = redSt rEnv ^. stConsideringInstance-    getMeta m      = maybe __IMPOSSIBLE__ mvInstantiation (IntMap.lookup (metaId m) metaStore)+    getMetaInst m  = case MapS.lookup m localMetas of+                       Just mv -> Just (mvInstantiation mv)+                       Nothing -> InstV . rmvInstantiation <$>+                                    HMap.lookup m remoteMetas     partialDefs    = runReduce getPartialDefs     rewriteRules f = cdefRewriteRules (constInfo f)     callByNeed     = envCallByNeed (redEnv rEnv) && not (optCallByName $ redSt rEnv ^. stPragmaOptions)@@ -860,7 +884,7 @@     --  - Look up in the environment if variable     --  - Perform a beta step if lambda and application elimination in the spine     --  - Perform a record beta step if record constructor and projection elimination in the spine-    runAM' s@(Eval cl@(Closure Unevaled t env spine) !ctrl) = {-# SCC "runAM.Eval" #-}+    runAM' s@(Eval cl@(Closure Unevaled t env spine) ctrl) = {-# SCC "runAM.Eval" #-}       case t of          -- Case: definition. Enter 'Match' state if defined function or shift to evaluating an@@ -868,17 +892,11 @@         -- slow reduce for unsupported definitions.         Def f [] ->           evalIApplyAM spine ctrl $-          let CompactDef{ cdefDelayed        = delayed-                        , cdefNonterminating = nonterm+          let CompactDef{ cdefNonterminating = nonterm                         , cdefUnconfirmed    = unconf                         , cdefDef            = def } = constInfo f-              dontUnfold = (nonterm && not allowNonTerminating) ||-                           (unconf  && not allowUnconfirmed)    ||-                           (delayed && not (unfoldDelayed ctrl))           in case def of-            CFun{ cfunCompiled = cc }-              | dontUnfold -> rewriteAM done-              | otherwise  -> runAM (Match f cc spine ([] :> cl) ctrl)+            CFun{ cfunCompiled = cc } -> runAM (Match f cc spine ([] :> cl) ctrl)             CAxiom         -> rewriteAM done             CTyCon         -> rewriteAM done             CCon{}         -> runAM done   -- Only happens for builtinSharp (which is a Def when you bind it)@@ -959,12 +977,16 @@         -- environment for the closure. Avoiding shifting spines for open metas         -- save a bit of performance.         MetaV m es -> evalIApplyAM spine ctrl $-          case getMeta m of-            InstV xs t -> do+          case getMetaInst m of+            Nothing ->+              runAM (Eval (mkValue (blocked m ()) cl) ctrl)+            Just (InstV i) -> do               spine' <- elimsToSpine env es-              let (zs, env, !spine'') = buildEnv xs (spine' <> spine)-              runAM (evalClosure (lams zs t) env spine'' ctrl)-            _ -> runAM (Eval (mkValue (blocked m ()) cl) ctrl)+              let (zs, env, !spine'') = buildEnv (instTel i) (spine' <> spine)+              runAM (evalClosure (lams zs (instBody i)) env spine'' ctrl)+            Just OpenMeta{}                     -> __IMPOSSIBLE__+            Just BlockedConst{}                 -> __IMPOSSIBLE__+            Just PostponedTypeCheckingProblem{} -> __IMPOSSIBLE__          -- Case: unsupported. These terms are not handled by the abstract machine, so we fall back         -- to slowReduceTerm for these.@@ -1108,8 +1130,8 @@     -- Case: CaseK. Pattern matching against a value. If it's a stuck value the pattern match is     -- stuck and we return the closure from the match stack (see stuckMatch). Otherwise we need to     -- find a matching branch switch to the Match state. If there is no matching branch we look for-    -- a CatchAll in the match stack, or fail if there isn't one (see failedMatch). If the current-    -- branches contain a catch-all case we need to push a CatchAll on the match stack if picking+    -- a Catchall in the match stack, or fail if there isn't one (see failedMatch). If the current+    -- branches contain a catch-all case we need to push a Catchall on the match stack if picking     -- one of the other branches.     runAM' (Eval cl@(Closure (Value blk) t env spine) ctrl0@(CaseK f i bs spine0 spine1 stack : ctrl)) =       {-# SCC "runAM.CaseK" #-}@@ -1162,9 +1184,9 @@          -- Push catch-all frame on the match stack if there is a catch-all (and we're not taking it         -- right now).-        catchallStack = case fcatchAllBranch bs of+        catchallStack = case fcatchallBranch bs of           Nothing -> stack-          Just cc -> CatchAll cc catchallSpine >: stack+          Just cc -> Catchall cc catchallSpine >: stack          -- The matchX functions below all take an extra argument which is what to do if there is no         -- appropriate branch in the case tree. ifJust is maybe with a different argument order@@ -1177,8 +1199,8 @@         matchCon' q ar = lookupCon q bs `ifJust` \ cc ->           runAM (Match f cc (spine0 <> spine <> spine1) catchallStack ctrl) -        -- Catch-all: Don't add a CatchAll to the match stack since this _is_ the catch-all.-        matchCatchall = fcatchAllBranch bs `ifJust` \ cc ->+        -- Catch-all: Don't add a Catchall to the match stack since this _is_ the catch-all.+        matchCatchall = fcatchallBranch bs `ifJust` \ cc ->           runAM (Match f cc catchallSpine stack ctrl)          -- Matching literal: Switch to the Match state. There are no arguments to add to the spine.@@ -1225,11 +1247,11 @@             (_, [])                    -> done Underapplied -- matter for equality, but might for             (spine0, Apply e : spine1) -> do                -- rewriting or 'with'.               -- Replace e by its projections in the spine. And don't forget a-              -- CatchAll frame if there's a catch-all.+              -- Catchall frame if there's a catch-all.               let projClosure (Arg ai f) = Closure Unevaled (Var 0 []) (extendEnv (unArg e) emptyEnv) [Proj ProjSystem f]               projs <- mapM (createThunk . projClosure) fs               let spine' = spine0 <> map (Apply . defaultArg) projs <> spine1-                  stack' = caseMaybe ca stack $ \ cc -> CatchAll cc spine >: stack+                  stack' = caseMaybe ca stack $ \ cc -> Catchall cc spine >: stack               runAM (Match f cc spine' stack' ctrl)             _ -> __IMPOSSIBLE__ @@ -1251,7 +1273,7 @@             (spine0, Proj o p : spine1) ->               case lookupCon p bs <|> ((`lookupCon` bs) =<< op) of                 Nothing-                  | f `elem` partialDefs -> stuckMatch (NotBlocked MissingClauses ()) stack ctrl+                  | f `elem` partialDefs -> stuckMatch (NotBlocked (MissingClauses f) ()) stack ctrl                   | otherwise          -> __IMPOSSIBLE__                 Just cc -> runAM (Match f cc (spine0 <> spine1) stack ctrl)               where CFun{ cfunProjection = op } = cdefDef (constInfo p)@@ -1314,17 +1336,11 @@               _                        -> (slowReduceTerm, ctrl)     fallbackAM _ = __IMPOSSIBLE__ -    -- If rewriting is enabled, try to apply rewrite rules to the current focus before considering-    -- it a value. The current state must be 'Eval' and the focus a value closure. Take care to only-    -- test the 'hasRewriting' flag once.-    rewriteAM :: AM s -> ST s (Blocked Term)-    rewriteAM = if hasRewriting then rewriteAM' else runAM-     -- Applying rewrite rules to the current focus. This needs to decode the current focus, call     -- rewriting and pack the result back up in a closure. In case some rewrite rules actually fired     -- the next state is an unevaluated closure, otherwise it's a value closure.-    rewriteAM' :: AM s -> ST s (Blocked Term)-    rewriteAM' s@(Eval (Closure (Value blk) t env spine) ctrl)+    rewriteAM :: AM s -> ST s (Blocked Term)+    rewriteAM s@(Eval (Closure (Value blk) t env spine) ctrl)       | null rewr = runAM s       | otherwise = traceDoc ("R" <+> pretty s) $ do         v0 <- decodeClosure_ (Closure Unevaled t env [])@@ -1336,7 +1352,7 @@                      Def f []   -> rewriteRules f                      Con c _ [] -> rewriteRules (conName c)                      _          -> __IMPOSSIBLE__-    rewriteAM' _ =+    rewriteAM _ =       __IMPOSSIBLE__      -- Add a NatSucK frame to the control stack. Pack consecutive suc's into a single frame.@@ -1349,37 +1365,21 @@     updateThunkCtrl p (UpdateThunk ps : ctrl) = UpdateThunk (p : ps) : ctrl     updateThunkCtrl p                   ctrl  = UpdateThunk [p] : ctrl -    -- Only unfold delayed (corecursive) definitions if the result is being cased on.-    unfoldDelayed :: ControlStack s -> Bool-    unfoldDelayed []                     = False-    unfoldDelayed (CaseK{}       : _)    = True-    unfoldDelayed (PrimOpK{}     : _)    = False-    unfoldDelayed (NatSucK{}     : _)    = False-    unfoldDelayed (NormaliseK{}  : _)    = False-    unfoldDelayed (ArgK{}        : _)    = False-    unfoldDelayed (UpdateThunk{} : ctrl) = unfoldDelayed ctrl-    unfoldDelayed (ApplyK{}      : ctrl) = unfoldDelayed ctrl-    unfoldDelayed (ForceK{}      : ctrl) = unfoldDelayed ctrl-    unfoldDelayed (EraseK{}      : ctrl) = unfoldDelayed ctrl-     -- When matching is stuck we return the closure from the 'MatchStack' with the appropriate     -- 'IsValue' set.     stuckMatch :: Blocked_ -> MatchStack s -> ControlStack s -> ST s (Blocked Term)     stuckMatch blk (_ :> cl) ctrl = rewriteAM (Eval (mkValue blk cl) ctrl) -    -- On a mismatch we find the next 'CatchAll' on the control stack and+    -- On a mismatch we find the next 'Catchall' on the control stack and     -- continue matching from there. If there isn't one we get an incomplete     -- matching error (or get stuck if the function is marked partial).     failedMatch :: QName -> MatchStack s -> ControlStack s -> ST s (Blocked Term)-    failedMatch f (CatchAll cc spine : stack :> cl) ctrl = runAM (Match f cc spine (stack :> cl) ctrl)+    failedMatch f (Catchall cc spine : stack :> cl) ctrl = runAM (Match f cc spine (stack :> cl) ctrl)     failedMatch f ([] :> cl) ctrl         -- Bad work-around for #3870: don't fail hard during instance search.-      | speculative          = rewriteAM (Eval (mkValue (NotBlocked MissingClauses ()) cl) ctrl)-      | f `elem` partialDefs = rewriteAM (Eval (mkValue (NotBlocked MissingClauses ()) cl) ctrl)-      | hasRewriting         = rewriteAM (Eval (mkValue (NotBlocked ReallyNotBlocked ()) cl) ctrl)  -- See #5396-      | otherwise            = runReduce $-          traceSLn "impossible" 10 ("Incomplete pattern matching when applying " ++ prettyShow f)-                   __IMPOSSIBLE__+      | speculative          = rewriteAM (Eval (mkValue (NotBlocked (MissingClauses f) ()) cl) ctrl)+      | f `elem` partialDefs = rewriteAM (Eval (mkValue (NotBlocked (MissingClauses f) ()) cl) ctrl)+      | otherwise            = rewriteAM (Eval (mkValue (NotBlocked ReallyNotBlocked ()) cl) ctrl)  -- See #5396      -- Some helper functions to build machine states and closures.     evalClosure t env spine = Eval (Closure Unevaled t env spine)@@ -1448,8 +1448,8 @@                           , nest 2 $ pretty stack                           , nest 2 $ prettyList ctrl ] -instance Pretty (CatchAllFrame s) where-  pretty CatchAll{} = "CatchAll"+instance Pretty (CatchallFrame s) where+  pretty Catchall{} = "Catchall"  instance Pretty (MatchStack s) where   pretty ([] :> _) = empty
src/full/Agda/TypeChecking/Reduce/Fast.hs-boot view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Reduce.Fast where
src/full/Agda/TypeChecking/Reduce/Monad.hs view
@@ -1,4 +1,5 @@-+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wunused-imports #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Agda.TypeChecking.Reduce.Monad@@ -10,26 +11,26 @@  import Prelude hiding (null) -import Control.Monad         ( liftM2 )- import qualified Data.Map as Map import Data.Maybe  import System.IO.Unsafe +import Agda.Syntax.Common.Pretty () --instance only import Agda.Syntax.Internal-import Agda.TypeChecking.Monad hiding-  ( enterClosure, isInstantiatedMeta, verboseS, typeOfConst, lookupMeta, lookupMeta', constructorForm )++import Agda.TypeChecking.Monad hiding (enterClosure, constructorForm) import Agda.TypeChecking.Substitute  import Agda.Utils.Lens+import Agda.Utils.Maybe import Agda.Utils.Monad-import Agda.Utils.Pretty () --instance only - instance HasBuiltins ReduceM where-  getBuiltinThing b = liftM2 mplus (Map.lookup b <$> useR stLocalBuiltins)-                                   (Map.lookup b <$> useR stImportedBuiltins)+  getBuiltinThing b =+    liftM2 (unionMaybeWith unionBuiltin)+      (Map.lookup b <$> useR stLocalBuiltins)+      (Map.lookup b <$> useR stImportedBuiltins)  constructorForm :: HasBuiltins m => Term -> m Term constructorForm v = do@@ -37,7 +38,7 @@   ms <- getBuiltin' builtinSuc   return $ fromMaybe v $ constructorForm' mz ms v -enterClosure :: LensClosure a c => c -> (a -> ReduceM b) -> ReduceM b+enterClosure :: LensClosure c a => c -> (a -> ReduceM b) -> ReduceM b enterClosure c | Closure _sig env scope cps x <- c ^. lensClosure = \case   -- The \case is a hack to correctly associate the where block to the rhs   -- rather than to the expression in the pattern guard.@@ -72,28 +73,34 @@ instance MonadDebug ReduceM where    traceDebugMessage k n s cont = do-    ReduceEnv env st <- askR+    ReduceEnv env st _ <- askR     unsafePerformIO $ do       _ <- runTCM env st $ displayDebugMessage k n s       return $ cont    formatDebugMessage k n d = do-    ReduceEnv env st <- askR+    ReduceEnv env st _ <- askR     unsafePerformIO $ do       (s , _) <- runTCM env st $ formatDebugMessage k n d       return $ return s +#ifdef DEBUG   verboseBracket k n s = applyWhenVerboseS k n $     bracket_ (openVerboseBracket k n s) (const $ closeVerboseBracket k n)+#else+  verboseBracket k n s ma = ma+  {-# INLINE verboseBracket #-}+#endif -  getVerbosity     = defaultGetVerbosity-  isDebugPrinting  = defaultIsDebugPrinting-  nowDebugPrinting = defaultNowDebugPrinting+  getVerbosity      = defaultGetVerbosity+  getProfileOptions = defaultGetProfileOptions+  isDebugPrinting   = defaultIsDebugPrinting+  nowDebugPrinting  = defaultNowDebugPrinting  instance HasConstInfo ReduceM where   getRewriteRulesFor = defaultGetRewriteRulesFor   getConstInfo' q = do-    ReduceEnv env st <- askR+    ReduceEnv env st _ <- askR     defaultGetConstInfo st env q  instance PureTCM ReduceM where
src/full/Agda/TypeChecking/Rewriting.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE GADTs #-}  {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -46,11 +45,15 @@  import Prelude hiding (null) -import Control.Monad+import Control.Monad.Trans.Maybe ( MaybeT(..), runMaybeT ) +import Data.Either (partitionEithers)+import Data.Foldable (toList) import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import qualified Data.List as List+import Data.Set (Set)+import qualified Data.Set as Set  import Agda.Interaction.Options @@ -58,6 +61,7 @@ import Agda.Syntax.Common import Agda.Syntax.Internal as I import Agda.Syntax.Internal.MetaVars+import Agda.Syntax.Internal.Pattern  import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Monad@@ -65,7 +69,6 @@ import Agda.TypeChecking.Conversion import qualified Agda.TypeChecking.Positivity.Occurrence as Pos import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Primitive ( getBuiltinName ) import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope@@ -79,10 +82,12 @@ import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null+import qualified Agda.Utils.Set1 as Set1 import Agda.Utils.Size import qualified Agda.Utils.SmallSet as SmallSet  import Agda.Utils.Impossible+import Agda.Utils.Either  requireOptionRewriting :: TCM () requireOptionRewriting =@@ -95,22 +100,17 @@ verifyBuiltinRewrite :: Term -> Type -> TCM () verifyBuiltinRewrite v t = do   requireOptionRewriting-  let failure reason = typeError . GenericDocError =<< sep-       [ prettyTCM v <+> " does not have the right type for a rewriting relation"-       , reason-       ]   caseMaybeM (relView t)-    (failure $ "because it should accept at least two arguments") $+    (typeError $ IncorrectTypeForRewriteRelation v ShouldAcceptAtLeastTwoArguments) $     \ (RelView tel delta a b core) -> do-    unless (visible a && visible b) $ failure $ "because its two final arguments are not both visible."+    unless (visible a && visible b) $ typeError $ IncorrectTypeForRewriteRelation v FinalTwoArgumentsNotVisible     case unEl core of       Sort{}   -> return ()       Con{}    -> __IMPOSSIBLE__       Level{}  -> __IMPOSSIBLE__       Lam{}    -> __IMPOSSIBLE__       Pi{}     -> __IMPOSSIBLE__-      _ -> failure $ "because its type does not end in a sort, but in "-             <+> do inTopContext $ addContext tel $ prettyTCM core+      _ -> typeError $ IncorrectTypeForRewriteRelation v (TypeDoesNotEndInSort core tel)  -- | Deconstructing a type into @Δ → t → t' → core@. data RelView = RelView@@ -137,7 +137,7 @@ addRewriteRules qs = do    -- Check the rewrite rules-  rews <- mapM checkRewriteRule qs+  rews <- mapMaybeM checkRewriteRule qs    -- Add rewrite rules to the signature   forM_ rews $ \rew -> do@@ -152,6 +152,8 @@   -- Run confluence check for the new rules   -- (should be done after adding all rules, see #3795)   whenJustM (optConfluenceCheck <$> pragmaOptions) $ \confChk -> do+    -- Warn if --cubical is enabled+    whenJustM cubicalOption $ \_ -> warning ConfluenceForCubicalNotSupported     -- Global confluence checker requires rules to be sorted     -- according to the generality of their lhs     when (confChk == GlobalConfluenceCheck) $@@ -160,6 +162,19 @@     reportSDoc "rewriting" 10 $       "done checking confluence of rules" <+> prettyList_ (map (prettyTCM . rewName) rews) +-- Auxiliary function for checkRewriteRule.+-- | Get domain of rewrite relation.+rewriteRelationDom :: QName -> TCM (ListTel, Dom Type)+rewriteRelationDom rel = do+  -- We know that the type of rel is that of a relation.+  relV <- relView =<< do defType <$> getConstInfo rel+  let RelView _tel delta a _a' _core = fromMaybe __IMPOSSIBLE__ relV+  reportSDoc "rewriting" 30 $ do+    "rewrite relation at type " <+> do+      inTopContext $ prettyTCM (telFromList delta) <+> " |- " <+> do+        addContext delta $ prettyTCM a+  return (delta, a)+ -- | Check the validity of @q : Γ → rel us lhs rhs@ as rewrite rule --   @ --       Γ ⊢ lhs ↦ rhs : B@@ -168,28 +183,28 @@ --   Remember that @rel : Δ → A → A → Set i@, so --   @rel us : (lhs rhs : A[us/Δ]) → Set i@. --   Returns the checked rewrite rule to be added to the signature.-checkRewriteRule :: QName -> TCM RewriteRule-checkRewriteRule q = do-  requireOptionRewriting-  let failNoBuiltin = typeError $ GenericError $-        "Cannot add rewrite rule without prior BUILTIN REWRITE"-  rel <- fromMaybeM failNoBuiltin $ getBuiltinName builtinRewrite+checkRewriteRule :: QName -> TCM (Maybe RewriteRule)+checkRewriteRule q = runMaybeT $ setCurrentRange q do+  lift requireOptionRewriting+  rels <- lift getBuiltinRewriteRelations+  reportSDoc "rewriting.relations" 40 $ vcat+    [ "Rewrite relations:"+    , prettyList $ map prettyTCM $ toList rels+    ]   def <- instantiateDef =<< getConstInfo q   -- Issue 1651: Check that we are not adding a rewrite rule   -- for a type signature whose body has not been type-checked yet.   when (isEmptyFunction $ theDef def) $-    typeError . GenericDocError =<< hsep-      [ "Rewrite rule from function "-      , prettyTCM q-      , " cannot be added before the function definition"-      ]-  -- We know that the type of rel is that of a relation.-  relV <- relView =<< do defType <$> getConstInfo rel-  let RelView _tel delta a _a' _core = fromMaybe __IMPOSSIBLE__ relV-  reportSDoc "rewriting" 30 $ do-    "rewrite relation at type " <+> do-      inTopContext $ prettyTCM (telFromList delta) <+> " |- " <+> do-        addContext delta $ prettyTCM a+    illegalRule BeforeFunctionDefinition+  -- Issue 6643: Also check that there are no mututal definitions+  -- that are not yet defined.+  whenJustM (asksTC envMutualBlock) \ mb -> do+    qs <- mutualNames <$> lookupMutualBlock mb+    when (Set.member q qs) $ forM_ qs $ \r -> do+      whenM (isEmptyFunction . theDef <$> getConstInfo r) $+        illegalRule $ BeforeMutualFunctionDefinition r++   -- Get rewrite rule (type of q).   TelV gamma1 core <- telView $ defType def   reportSDoc "rewriting" 30 $ vcat@@ -197,25 +212,21 @@     , prettyTCM gamma1     , " |- " <+> do addContext gamma1 $ prettyTCM core     ]-  let failureWrongTarget :: TCM a-      failureWrongTarget = typeError . GenericDocError =<< hsep-        [ prettyTCM q , " does not target rewrite relation" ]-  let failureMetas :: TCM a-      failureMetas       = typeError . GenericDocError =<< hsep-        [ prettyTCM q , " is not a legal rewrite rule, since it contains unsolved meta variables" ]-  let failureNotDefOrCon :: TCM a-      failureNotDefOrCon = typeError . GenericDocError =<< hsep-        [ prettyTCM q , " is not a legal rewrite rule, since the left-hand side is neither a defined symbol nor a constructor" ]-  let failureFreeVars :: IntSet -> TCM a-      failureFreeVars xs = typeError . GenericDocError =<< hsep-        [ prettyTCM q , " is not a legal rewrite rule, since the following variables are not bound by the left hand side: " , prettyList_ (map (prettyTCM . var) $ IntSet.toList xs) ]-  let failureIllegalRule :: TCM a -- TODO:: Defined but not used-      failureIllegalRule = typeError . GenericDocError =<< hsep-        [ prettyTCM q , " is not a legal rewrite rule" ]+  let failureBlocked :: Blocker -> MaybeT TCM a+      failureBlocked b+        | Set1.IsNonEmpty ms <- allBlockingMetas    b = illegalRule $ ContainsUnsolvedMetaVariables ms+        | Set1.IsNonEmpty ps <- allBlockingProblems b = illegalRule $ BlockedOnProblems ps+        | Set1.IsNonEmpty qs <- allBlockingDefs     b = illegalRule $ RequiresDefinitions qs+        | otherwise = __IMPOSSIBLE__+  let failureFreeVars :: IntSet -> MaybeT TCM a+      failureFreeVars xs = illegalRule $ VariablesNotBoundByLHS xs+  let failureNonLinearPars :: IntSet -> MaybeT TCM a+      failureNonLinearPars xs = illegalRule $ VariablesBoundMoreThanOnce xs    -- Check that type of q targets rel.   case unEl core of-    Def rel' es@(_:_:_) | rel == rel' -> do+    Def rel es@(_:_:_) | rel `elem` rels -> do+      (delta, a) <- lift $ rewriteRelationDom rel       -- Because of the type of rel (Γ → sort), all es are applications.       let vs = map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es       -- The last two arguments are lhs and rhs.@@ -230,10 +241,6 @@       gamma1 <- instantiateFull gamma1       let gamma = gamma0 `abstract` gamma1 -      unless (noMetas (telToList gamma1)) $ do-        reportSDoc "rewriting" 30 $ "metas in gamma1: " <+> text (show $ allMetasList $ telToList gamma1)-        failureMetas-       -- 2017-06-18, Jesper: Unfold inlined definitions on the LHS.       -- This is necessary to replace copies created by imports by their       -- original definition.@@ -250,7 +257,10 @@           ~(Just ((_ , _ , pars) , t)) <- getFullyAppliedConType c $ unDom b           pars <- addContext gamma1 $ checkParametersAreGeneral c pars           return (conName c , hd , t , pars , vs)-        _        -> failureNotDefOrCon+        _ -> do+          reportSDoc "rewriting.rule.check" 30 $ hsep+            [ "LHSNotDefinitionOrConstructor: ", prettyTCM lhs ]+          illegalRule LHSNotDefinitionOrConstructor        ifNotAlreadyAdded f $ do @@ -258,13 +268,10 @@          checkNoLhsReduction f hd es -        unless (noMetas (es, rhs, b)) $ do-          reportSDoc "rewriting" 30 $ "metas in lhs: " <+> text (show $ allMetasList es)-          reportSDoc "rewriting" 30 $ "metas in rhs: " <+> text (show $ allMetasList rhs)-          reportSDoc "rewriting" 30 $ "metas in b  : " <+> text (show $ allMetasList b)-          failureMetas+        ps <- fromRightM failureBlocked $ lift $+          catchPatternErr (pure . Left) $+            Right <$> patternFrom relevant 0 (t , Def f) es -        ps <- patternFrom Relevant 0 (t , Def f []) es         reportSDoc "rewriting" 30 $           "Pattern generated from lhs: " <+> prettyTCM (PDef f ps) @@ -282,10 +289,16 @@             freeVars  = allFreeVars (ps,rhs)             allVars   = IntSet.fromList $ downFrom $ size gamma             usedVars  = case theDef def of-              Function{}     -> usedArgs def-              Axiom{}        -> allVars-              AbstractDefn{} -> allVars-              _              -> __IMPOSSIBLE__+              Function{}         -> usedArgs def+              Axiom{}            -> allVars+              AbstractDefn{}     -> allVars+              Constructor{}      -> allVars+              Primitive{}        -> allVars+              DataOrRecSig{}     -> __IMPOSSIBLE__+              GeneralizableVar{} -> __IMPOSSIBLE__+              Datatype{}         -> __IMPOSSIBLE__+              Record{}           -> __IMPOSSIBLE__+              PrimitiveSort{}    -> __IMPOSSIBLE__         reportSDoc "rewriting" 70 $           "variables bound by the pattern: " <+> text (show boundVars)         reportSDoc "rewriting" 70 $@@ -295,8 +308,13 @@         unlessNull (freeVars IntSet.\\ boundVars) failureFreeVars         unlessNull (usedVars IntSet.\\ (boundVars `IntSet.union` IntSet.fromList pars)) failureFreeVars -        let rew = RewriteRule q gamma f ps rhs (unDom b) False+        reportSDoc "rewriting" 70 $+          "variables bound in (erased) parameter position: " <+> text (show pars)+        unlessNull (boundVars `IntSet.intersection` IntSet.fromList pars) failureNonLinearPars +        top <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule+        let rew = RewriteRule q gamma f ps rhs (unDom b) False top+         reportSDoc "rewriting" 10 $ vcat           [ "checked rewrite rule" , prettyTCM rew ]         reportSDoc "rewriting" 90 $ vcat@@ -304,55 +322,74 @@          return rew -    _ -> failureWrongTarget+    _ -> illegalRule DoesNotTargetRewriteRelation    where-    checkNoLhsReduction :: QName -> (Elims -> Term)  -> Elims -> TCM ()+    illegalRule :: IllegalRewriteRuleReason -> MaybeT TCM a+    illegalRule reason = do+      lift $ warning $ IllegalRewriteRule q reason+      mzero++    checkNoLhsReduction :: QName -> (Elims -> Term) -> Elims -> MaybeT TCM ()     checkNoLhsReduction f hd es = do       -- Skip this check when global confluence check is enabled, as       -- redundant rewrite rules may be required to prove confluence.       unlessM ((== Just GlobalConfluenceCheck) . optConfluenceCheck <$> pragmaOptions) $ do       let v = hd es       v' <- reduce v-      let fail :: TCM a+      let fail :: MaybeT TCM a           fail = do             reportSDoc "rewriting" 20 $ "v  = " <+> text (show v)             reportSDoc "rewriting" 20 $ "v' = " <+> text (show v')-            typeError . GenericDocError =<< fsep-              [ prettyTCM q <+> " is not a legal rewrite rule, since the left-hand side "-              , prettyTCM v <+> " reduces to " <+> prettyTCM v' ]+            illegalRule $ LHSReduces v v'       es' <- case v' of         Def f' es'   | f == f'         -> return es'         Con c' _ es' | f == conName c' -> return es'         _                              -> fail       unless (null es && null es') $ do-        a   <- computeElimHeadType f es es'+        a   <- lift $ computeElimHeadType f es es'         pol <- getPolarity' CmpEq f-        ok  <- dontAssignMetas $ tryConversion $+        ok  <- lift $ dontAssignMetas $ tryConversion $                  compareElims pol [] a (Def f []) es es'         unless ok fail -    checkAxFunOrCon :: QName -> Definition -> TCM ()+    checkAxFunOrCon :: QName -> Definition -> MaybeT TCM ()     checkAxFunOrCon f def = case theDef def of       Axiom{}        -> return ()-      Function{}     -> return ()+      def@Function{} -> do+        whenJust (maybeRight (funProjection def)) $ \proj -> case projProper proj of+          Nothing -> illegalRule $ HeadSymbolIsProjectionLikeFunction f+          Just{} -> __IMPOSSIBLE__+            -- Andreas, 2024-08-20+            -- A projection ought to be impossible in the head, since they are represented+            -- in post-fix in the internal syntax.+            -- Thus, a lone projection @p@ will be @λ x → x .p@+            -- and an applied projection @p t@ will be @t .p@.+        whenM (isJust . optConfluenceCheck <$> pragmaOptions) $ do+          let simpleClause cl = (patternsToElims (namedClausePats cl) , clauseBody cl)+          cls <- instantiateFull $ map simpleClause $ funClauses def+          unless (noMetas cls) $ illegalRule $ HeadSymbolContainsMetas f+       Constructor{}  -> return ()       AbstractDefn{} -> return ()       Primitive{}    -> return () -- TODO: is this fine?-      _              -> typeError . GenericDocError =<< hsep-        [ prettyTCM q , " is not a legal rewrite rule, since the head symbol"-        , prettyTCM f , "is not a postulate, a function, or a constructor"-        ]+      Datatype{}     -> illegalHead+      Record{}       -> illegalHead+      DatatypeDefn{} -> illegalHead+      RecordDefn{}   -> illegalHead+      DataOrRecSig{} -> illegalHead+      PrimitiveSort{}-> illegalHead+      GeneralizableVar{} -> __IMPOSSIBLE__ -    ifNotAlreadyAdded :: QName -> TCM RewriteRule -> TCM RewriteRule+      where+      illegalHead = illegalRule $ HeadSymbolIsTypeConstructor f++    ifNotAlreadyAdded :: QName -> MaybeT TCM RewriteRule -> MaybeT TCM RewriteRule     ifNotAlreadyAdded f cont = do       rews <- getRewriteRulesFor f       -- check if q is already an added rewrite rule       case List.find ((q ==) . rewName) rews of-        Just rew -> do-          genericWarning =<< do-            "Rewrite rule " <+> prettyTCM q <+> " has already been added"-          return rew+        Just rew -> illegalRule DuplicateRewriteRule         Nothing -> cont      usedArgs :: Definition -> IntSet@@ -364,7 +401,7 @@         used Pos.Unused = False         used _          = True -    checkParametersAreGeneral :: ConHead -> Args -> TCM [Int]+    checkParametersAreGeneral :: ConHead -> Args -> MaybeT TCM [Int]     checkParametersAreGeneral c vs = do         is <- loop vs         unless (fastDistinct is) $ errorNotGeneral@@ -375,12 +412,8 @@           Var i [] -> (i :) <$> loop vs           _        -> errorNotGeneral -        errorNotGeneral :: TCM a-        errorNotGeneral = typeError . GenericDocError =<< vcat-            [ prettyTCM q <+> text " is not a legal rewrite rule, since the constructor parameters are not fully general:"-            , nest 2 $ text "Constructor: " <+> prettyTCM c-            , nest 2 $ text "Parameters: " <+> prettyList (map prettyTCM vs)-            ]+        errorNotGeneral :: MaybeT TCM a+        errorNotGeneral = illegalRule $ ConstructorParametersNotGeneral c vs  -- | @rewriteWith t f es rew@ where @f : t@ --   tries to rewrite @f es@ with @rew@, returning the reduct if successful.@@ -389,7 +422,7 @@             -> RewriteRule             -> Elims             -> ReduceM (Either (Blocked Term) Term)-rewriteWith t hd rew@(RewriteRule q gamma _ ps rhs b isClause) es+rewriteWith t hd rew@(RewriteRule q gamma _ ps rhs b isClause _) es  | isClause = return $ Left $ NotBlocked ReallyNotBlocked $ hd es  | otherwise = do   traceSDoc "rewriting.rewrite" 50 (sep
src/full/Agda/TypeChecking/Rewriting.hs-boot view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.Rewriting where  import Agda.Syntax.Internal
src/full/Agda/TypeChecking/Rewriting/Clause.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Rewriting.Clause where @@ -5,6 +6,7 @@  import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.Internal.Pattern import Agda.Syntax.Position  import Agda.TypeChecking.Monad@@ -12,41 +14,49 @@ import Agda.Utils.Functor import Agda.Utils.Impossible import Agda.Utils.Monad-import Agda.Utils.Pretty+import Agda.Syntax.Common.Pretty  ------------------------------------------------------------------------ -- * Converting clauses to rewrite rules ------------------------------------------------------------------------ +{-# INLINABLE getClausesAsRewriteRules #-} -- | Get all the clauses of a definition and convert them to rewrite --   rules.-getClausesAsRewriteRules :: (HasConstInfo m, MonadFresh NameId m) => QName -> m [RewriteRule]+getClausesAsRewriteRules :: (HasConstInfo m, ReadTCState m, MonadFresh NameId m) => QName -> m [RewriteRule] getClausesAsRewriteRules f = do   cls <- defClauses <$> getConstInfo f   forMaybeM (zip [1..] cls) $ \(i,cl) -> do     clname <- clauseQName f i-    return $ clauseToRewriteRule f clname cl+    clauseToRewriteRule f clname cl +{-# INLINABLE clauseQName #-} -- | Generate a sensible name for the given clause clauseQName :: (HasConstInfo m, MonadFresh NameId m) => QName -> Int -> m QName clauseQName f i = QName (qnameModule f) <$> clauseName (qnameName f) i   where     clauseName n i = freshName noRange (prettyShow n ++ "-clause" ++ show i) +{-# INLINABLE clauseToRewriteRule #-} -- | @clauseToRewriteRule f q cl@ converts the clause @cl@ of the --   function @f@ to a rewrite rule with name @q@. Returns @Nothing@ --   if @clauseBody cl@ is @Nothing@. Precondition: @clauseType cl@ is --   not @Nothing@.-clauseToRewriteRule :: QName -> QName -> Clause -> Maybe RewriteRule-clauseToRewriteRule f q cl = clauseBody cl <&> \rhs -> RewriteRule-  { rewName    = q-  , rewContext = clauseTel cl-  , rewHead    = f-  , rewPats    = toNLPat $ namedClausePats cl-  , rewRHS     = rhs-  , rewType    = unArg $ fromMaybe __IMPOSSIBLE__  $ clauseType cl-  , rewFromClause = True-  }+clauseToRewriteRule :: (MonadTCEnv m, ReadTCState m)+  => QName -> QName -> Clause -> m (Maybe RewriteRule)+clauseToRewriteRule f q cl | hasDefP (namedClausePats cl) = return  Nothing+clauseToRewriteRule f q cl = do+  top <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule+  return $ clauseBody cl <&> \rhs -> RewriteRule+    { rewName    = q+    , rewContext = clauseTel cl+    , rewHead    = f+    , rewPats    = toNLPat $ namedClausePats cl+    , rewRHS     = rhs+    , rewType    = unArg $ fromMaybe __IMPOSSIBLE__  $ clauseType cl+    , rewFromClause = True+    , rewTopModule  = top+    }  class ToNLPat a b where   toNLPat :: a -> b
src/full/Agda/TypeChecking/Rewriting/Confluence.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NondecreasingIndentation #-}  -- | Checking local or global confluence of rewrite rules.@@ -7,13 +6,13 @@ -- we construct critical pairs involving this as the main rule by -- searching for: ----- 1. *Different* rules @f ps' ↦ v'@ where @ps@ and @ps'@ can be---    unified@.+-- 1. *Different* rules @f ps' ↦ ...@ where @ps@ and @ps'@ can be+--    unified. ----- 2. Subpatterns @g qs@ of @ps@ and rewrite rules @g qs' ↦ w@ where+-- 2. Subpatterns @g qs@ of @ps@ and rewrite rules @g qs' ↦ ...@ where --    @qs@ and @qs'@ can be unified. ----- Each of these leads to a *critical pair* @v₁ <-- u --> v₂@, which+-- Each of these leads to a *critical pair* @v₁ <-- f us --> v₂@, which -- should satisfy @v₁ = v₂@. -- -- For checking GLOBAL CONFLUENCE, we check the following two@@ -27,7 +26,7 @@ --    also be a rule @suc m + suc n = suc (suc (m + n))@. -- -- 2. Each rewrite rule should satisfy the *triangle property*: For---    any rewrite rule @u = w@ and any single-step parallel unfolding+--    any rewrite rule @u ↦ w@ and any single-step parallel unfolding --    @u => v@, we should have another single-step parallel unfolding --    @v => w@. @@ -40,9 +39,8 @@  import Control.Applicative import Control.Arrow ((***))-import Control.Monad-import Control.Monad.Except-import Control.Monad.Reader+import Control.Monad.Except ( MonadError(..) )+import Control.Monad.Reader ( MonadReader(..), asks, runReaderT )  import Data.Either import Data.Function ( on )@@ -63,12 +61,12 @@ import Agda.TypeChecking.Conversion.Pure import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Free-import Agda.TypeChecking.Irrelevance ( workOnTypes , isIrrelevantOrPropM )+import Agda.TypeChecking.Irrelevance ( isIrrelevantOrPropM ) import Agda.TypeChecking.Level import Agda.TypeChecking.MetaVars import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Pretty.Warning+import Agda.TypeChecking.Pretty.Warning    () import Agda.TypeChecking.Pretty.Constraint import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce@@ -80,7 +78,7 @@ import Agda.TypeChecking.Telescope import Agda.TypeChecking.Warnings -import Agda.Utils.Applicative+import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Impossible import Agda.Utils.Lens@@ -93,11 +91,15 @@ import Agda.Utils.Singleton import Agda.Utils.Size --- ^ Check confluence of the clauses of the given function wrt rewrite rules of the+-- | Check confluence of the clauses of the given function wrt rewrite rules of the -- constructors they match against checkConfluenceOfClauses :: ConfluenceCheck -> QName -> TCM () checkConfluenceOfClauses confChk f = do   rews <- getClausesAsRewriteRules f+  let noMetasInPats rew+        | noMetas (rewPats rew) = return True+        | otherwise             = False <$ do warning $ ConfluenceCheckingIncompleteBecauseOfMeta f+  rews <- filterM noMetasInPats rews   let matchables = map getMatchables rews   reportSDoc "rewriting.confluence" 30 $     "Function" <+> prettyTCM f <+> "has matchable symbols" <+> prettyList_ (map prettyTCM matchables)@@ -107,7 +109,7 @@     unlessNullM (filterM hasRules ms) $ \_ -> do       checkConfluenceOfRules confChk [rew] --- ^ Check confluence of the given rewrite rules wrt all other rewrite+-- | Check confluence of the given rewrite rules wrt all other rewrite --   rules (also amongst themselves). checkConfluenceOfRules :: ConfluenceCheck -> [RewriteRule] -> TCM () checkConfluenceOfRules confChk rews = inTopContext $ inAbstractMode $ do@@ -263,6 +265,11 @@             es0        = applySubst (liftS k sub1) $ ohElims hole0             qs2        = rewPats rew2 +        -- TODO: support IApply in forceEtaExpansion+        let isIApply IApply{} = True+            isIApply _        = False+        unless (any isIApply $ drop (size es0) qs2) $ do+         -- If the second rewrite rule has more eliminations than the         -- subpattern of the first rule, the only chance of overlap is         -- by eta-expanding the subpattern of the first rule.@@ -380,14 +387,15 @@           (f, t) <- fromMaybe __IMPOSSIBLE__ <$> getTypedHead (hd [])            let checkEqualLHS :: RewriteRule -> TCM Bool-              checkEqualLHS (RewriteRule q delta _ ps _ _ _) = do+              checkEqualLHS (RewriteRule q delta _ ps _ _ _ _) = do                 onlyReduceTypes (nonLinMatch delta (t , hd) ps es) >>= \case                   Left _    -> return False                   Right sub -> do                     let us = applySubst sub $ map var $ downFrom $ size delta                         as = applySubst sub $ flattenTel delta                     reportSDoc "rewriting.confluence.global" 35 $-                      prettyTCM (hd es) <+> "is an instance of the LHS of rule" <+> prettyTCM q <+> "with instantiation" <+> prettyList_ (map prettyTCM us)+                      applyUnless (null us) (<+> ("with instantiation" <+> prettyList_ (map prettyTCM us))) $+                        prettyTCM (hd es) <+> "is an instance of the LHS of rule" <+> prettyTCM q                     ok <- allDistinctVars $ zip us as                     when ok $ reportSDoc "rewriting.confluence.global" 30 $                       "It is equal to the LHS of rewrite rule" <+> prettyTCM q@@ -402,11 +410,11 @@            rews <- getAllRulesFor f           let sameRHS = onlyReduceTypes $ pureEqualTerm a rhs1 rhs2-          unlessM (sameRHS `or2M` anyM rews checkEqualLHS) $ addContext gamma $+          unlessM (sameRHS `or2M` anyM checkEqualLHS rews) $ addContext gamma $             warning $ RewriteAmbiguousRules (hd es) rhs1 rhs2      checkTrianglePropertyForRule :: RewriteRule -> TCM ()-    checkTrianglePropertyForRule (RewriteRule q gamma f ps rhs b c) = addContext gamma $ do+    checkTrianglePropertyForRule (RewriteRule q gamma f ps rhs b c _) = addContext gamma $ do       u  <- nlPatToTerm $ PDef f ps       -- First element in the list is the "best reduct" @ρ(u)@       (rhou,vs) <- fromMaybe __IMPOSSIBLE__ . uncons <$> allParallelReductions u@@ -436,7 +444,12 @@  sortRulesOfSymbol :: QName -> TCM () sortRulesOfSymbol f = do-    rules <- sortRules =<< getRewriteRulesFor f+    -- Andreas, 2025-06-28, PR #7934:+    -- By getting all rewrite rules regardless of scope,+    -- we replicate the old (unhygienic) approach to rewrite rule scoping+    -- here to avoid a regression.+    -- See also #7969 for a reason why the code below is questionable.+    rules <- sortRules =<< getFilteredRewriteRulesFor False f     modifySignature $ over sigRewriteRules $ HMap.insert f rules   where     sortRules :: PureTCM m => [RewriteRule] -> m [RewriteRule]@@ -474,7 +487,7 @@   -- For record projections @f : R Δ → A@, we rely on the invariant   -- that any clause is fully general in the parameters, i.e. it   -- is quantified over the parameter telescope @Δ@-  Function { funProjection = Just proj } -> do+  Function { funProjection = Right proj } -> do     let f          = projOrig proj         r          = unArg $ projFromType proj     rtype <- defType <$> getConstInfo r@@ -490,7 +503,7 @@ sameRuleName = (==) `on` rewName  -- | Get both clauses and rewrite rules for the given symbol-getAllRulesFor :: (HasConstInfo m, MonadFresh NameId m) => QName -> m [RewriteRule]+getAllRulesFor :: (HasConstInfo m, ReadTCState m, MonadFresh NameId m) => QName -> m [RewriteRule] getAllRulesFor f = (++) <$> getRewriteRulesFor f <*> getClausesAsRewriteRules f  -- | Build a substitution that replaces all variables in the given@@ -554,7 +567,7 @@   -- Get type of head symbol   (f , t) <- fromMaybe __IMPOSSIBLE__ <$> getTypedHead (hd [])   reportSDoc "rewriting.parreduce" 60 $ "topLevelReductions: head symbol" <+> prettyTCM (hd []) <+> ":" <+> prettyTCM t-  RewriteRule q gamma _ ps rhs b c <- scatterMP (getAllRulesFor f)+  RewriteRule q gamma _ ps rhs b c _ <- scatterMP (getAllRulesFor f)   reportSDoc "rewriting.parreduce" 60 $ "topLevelReductions: trying rule" <+> prettyTCM q   -- Don't reduce if underapplied   guard $ length es >= length ps@@ -604,7 +617,7 @@ instance ParallelReduce a => ParallelReduce (Elim' a) where   parReduce (Apply u)  = Apply <$> parReduce u   parReduce e@Proj{}   = pure e-  parReduce IApply{}   = __IMPOSSIBLE__ -- not yet supported+  parReduce e@IApply{} = pure e -- TODO  instance (Free a, Subst a, ParallelReduce a) => ParallelReduce (Abs a) where   parReduce = mapAbstraction __DUMMY_DOM__ parReduce@@ -625,14 +638,14 @@     ns <- forM ms' getMetaNameSuggestion      -- Construct telescope (still containing the metas)-    let gamma = unflattenTel ns $ map defaultDom as+    let n     = size ms'+        gamma = unflattenTel' n ns $ map defaultDom as      -- Replace metas by variables-    let n           = size ms'-        metaIndex x = (n-1-) <$> elemIndex x ms'+    let metaIndex x = (n-1-) <$> elemIndex x ms'     runReaderT (metasToVars (gamma, x)) metaIndex --- ^ A @OneHole p@ is a @p@ with a subpattern @f ps@ singled out.+-- | A @OneHole p@ is a @p@ with a subpattern @f ps@ singled out. data OneHole a = OneHole   { ohBoundVars :: Telescope     -- Telescope of bound variables at the hole   , ohType      :: Type          -- Type of the term in the hole@@ -670,20 +683,19 @@ ohAddBV :: ArgName -> Dom Type -> OneHole a -> OneHole a ohAddBV x a oh = oh { ohBoundVars = ExtendTel a $ Abs x $ ohBoundVars oh } --- ^ Given a @p : a@, @allHoles p@ lists all the possible+-- | Given a @p : a@, @allHoles p@ lists all the possible --   decompositions @p = p'[(f ps)/x]@. class (TermSubst p, Free p) => AllHoles p where-  type PType p-  allHoles :: (Alternative m, PureTCM m) => PType p -> p -> m (OneHole p)+  allHoles :: (Alternative m, PureTCM m) => TypeOf p -> p -> m (OneHole p)  allHoles_-  :: ( Alternative m , PureTCM m , AllHoles p , PType p ~ () )+  :: ( Alternative m , PureTCM m , AllHoles p , TypeOf p ~ () )   => p -> m (OneHole p) allHoles_ = allHoles ()  allHolesList   :: ( PureTCM m , AllHoles p)-  => PType p -> p -> m [OneHole p]+  => TypeOf p -> p -> m [OneHole p] allHolesList a = sequenceListT . allHoles a  -- | Given a term @v : a@ and eliminations @es@, force eta-expansion@@ -724,15 +736,14 @@     reportSDoc "rewriting.confluence.eta" 40 $ fsep       [ "Forcing" , prettyTCM v , ":" , prettyTCM a , "to be projectible by" , prettyTCM f ]     r <- fromMaybe __IMPOSSIBLE__ <$> getRecordOfField f-    rdef <- getConstInfo r-    let ra = defType rdef+    Defn{ defType = ra, theDef = RecordDefn rdef } <- getConstInfo r     pars <- newArgsMeta ra     s <- ra `piApplyM` pars >>= \s -> ifIsSort s return __IMPOSSIBLE__     equalType a $ El s (Def r $ map Apply pars)      -- Eta-expand v at record type r, and get field corresponding to f-    (_ , c , ci , fields) <- etaExpandRecord_ r pars (theDef rdef) v-    let fs        = map argFromDom $ recFields $ theDef rdef+    (_ , c , ci , fields) <- etaExpandRecord_ r pars rdef v+    let fs        = map argFromDom $ _recFields rdef         i         = fromMaybe __IMPOSSIBLE__ $ elemIndex f $ map unArg fs         fContent  = unArg $ fromMaybe __IMPOSSIBLE__ $ fields !!! i         fUpdate w = Con c ci $ map Apply $ updateAt i (w <$) fields@@ -746,30 +757,25 @@    IApply{} -> __IMPOSSIBLE__ -- Not yet implemented --- ^ Instances for @AllHoles@+-- Instances for @AllHoles@  instance AllHoles p => AllHoles (Arg p) where-  type PType (Arg p) = Dom (PType p)   allHoles a x = fmap (x $>) <$> allHoles (unDom a) (unArg x)  instance AllHoles p => AllHoles (Dom p) where-  type PType (Dom p) = PType p   allHoles a x = fmap (x $>) <$> allHoles a (unDom x)  instance AllHoles (Abs Term) where-  type PType (Abs Term) = (Dom Type , Abs Type)   allHoles (dom , a) x = addContext (absName x , dom) $     ohAddBV (absName a) dom . fmap (mkAbs $ absName x) <$>       allHoles (absBody a) (absBody x)  instance AllHoles (Abs Type) where-  type PType (Abs Type) = Dom Type   allHoles dom a = addContext (absName a , dom) $     ohAddBV (absName a) dom . fmap (mkAbs $ absName a) <$>       allHoles_ (absBody a)  instance AllHoles Elims where-  type PType Elims = (Type , Elims -> Term)   allHoles (a,hd) [] = empty   allHoles (a,hd) (e:es) = do     reportSDoc "rewriting.confluence.hole" 65 $ fsep@@ -788,15 +794,13 @@         let a' = c `absApp` hd []         hd' <- applyE <$> applyDef o f (argFromDom b $> hd [])         fmap (e:) <$> allHoles (a' , hd') es-      IApply x y u -> __IMPOSSIBLE__ -- Not yet implemented+      IApply x y u -> empty -- TODO: support --confluence-check + --cubical  instance AllHoles Type where-  type PType Type = ()   allHoles _ (El s a) = workOnTypes $     fmap (El s) <$> allHoles (sort s) a  instance AllHoles Term where-  type PType Term = Type   allHoles a u = do     reportSDoc "rewriting.confluence.hole" 60 $ fsep       [ "Getting holes of term" , prettyTCM u , ":" , prettyTCM a ]@@ -827,14 +831,13 @@       Dummy{}        -> empty  instance AllHoles Sort where-  type PType Sort = ()   allHoles _ = \case-    Type l       -> fmap Type <$> allHoles_ l-    Prop l       -> fmap Prop <$> allHoles_ l-    Inf f n      -> empty-    SSet l       -> fmap SSet <$> allHoles_ l+    Univ u l     -> fmap (Univ u) <$> allHoles_ l+    Inf _ _      -> empty     SizeUniv     -> empty     LockUniv     -> empty+    LevelUniv    -> empty+    IntervalUniv -> empty     PiSort{}     -> __IMPOSSIBLE__     FunSort{}    -> __IMPOSSIBLE__     UnivSort{}   -> __IMPOSSIBLE__@@ -845,20 +848,17 @@     DummyS{}     -> empty  instance AllHoles Level where-  type PType Level = ()   allHoles _ (Max n ls) = fmap (Max n) <$> allHoles_ ls  instance AllHoles [PlusLevel] where-  type PType [PlusLevel] = ()   allHoles _ []     = empty   allHoles _ (l:ls) =     (fmap (:ls) <$> allHoles_ l)     <|> (fmap (l:) <$> allHoles_ ls)  instance AllHoles PlusLevel where-  type PType PlusLevel = ()   allHoles _ (Plus n l) = do-    la <- levelType+    la <- levelType'     fmap (Plus n) <$> allHoles la l  @@ -905,12 +905,12 @@  instance MetasToVars Sort where   metasToVars = \case-    Type l     -> Type     <$> metasToVars l-    Prop l     -> Prop     <$> metasToVars l-    Inf f n    -> pure $ Inf f n-    SSet l     -> SSet     <$> metasToVars l+    Univ u l   -> Univ u <$> metasToVars l+    Inf u n    -> pure $ Inf u n     SizeUniv   -> pure SizeUniv     LockUniv   -> pure LockUniv+    LevelUniv  -> pure LevelUniv+    IntervalUniv -> pure IntervalUniv     PiSort s t u -> PiSort   <$> metasToVars s <*> metasToVars t <*> metasToVars u     FunSort s t -> FunSort <$> metasToVars s <*> metasToVars t     UnivSort s -> UnivSort <$> metasToVars s
src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE NondecreasingIndentation #-}  {- |  Non-linear matching of the lhs of a rewrite rule against a@@ -23,28 +25,22 @@ import Prelude hiding (null, sequence)  import Control.Applicative  ( Alternative )-import Control.Monad        ( void ) import Control.Monad.Except ( MonadError(..), ExceptT, runExceptT ) import Control.Monad.State  ( MonadState, StateT, runStateT ) -import qualified Control.Monad.Fail as Fail- import Data.Maybe import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet-import qualified Data.Set as Set  import Agda.Syntax.Common import Agda.Syntax.Internal-import Agda.Syntax.Internal.MetaVars -import Agda.TypeChecking.Conversion.Pure+import Agda.TypeChecking.Conversion.Pure (pureEqualTermB) import Agda.TypeChecking.Datatypes-import Agda.TypeChecking.Free import Agda.TypeChecking.Free.Reduce-import Agda.TypeChecking.Irrelevance (workOnTypes, isPropM)+import Agda.TypeChecking.Irrelevance (isPropM) import Agda.TypeChecking.Level import Agda.TypeChecking.Monad hiding (constructorForm) import Agda.TypeChecking.Pretty@@ -53,9 +49,10 @@ import Agda.TypeChecking.Reduce.Monad import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Primitive.Cubical+import Agda.TypeChecking.Primitive.Cubical.Base  import Agda.Utils.Either+import Agda.Utils.Function (applyWhen) import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List@@ -70,7 +67,7 @@  -- | Monad for non-linear matching. newtype NLM a = NLM { unNLM :: ExceptT Blocked_ (StateT NLMState ReduceM) a }-  deriving ( Functor, Applicative, Monad, Fail.MonadFail+  deriving ( Functor, Applicative, Monad, MonadFail            , Alternative, MonadPlus            , MonadError Blocked_, MonadState NLMState            , HasBuiltins, HasConstInfo, HasOptions, ReadTCState@@ -91,12 +88,12 @@  instance Null NLMState where   empty  = NLMState { _nlmSub = empty , _nlmEqs = empty }-  null s = null (s^.nlmSub) && null (s^.nlmEqs)+  null s = null (s ^. nlmSub) && null (s ^. nlmEqs) -nlmSub :: Lens' Sub NLMState+nlmSub :: Lens' NLMState Sub nlmSub f s = f (_nlmSub s) <&> \x -> s {_nlmSub = x} -nlmEqs :: Lens' PostponedEquations NLMState+nlmEqs :: Lens' NLMState PostponedEquations nlmEqs f s = f (_nlmEqs s) <&> \x -> s {_nlmEqs = x}  runNLM :: (MonadReduce m) => NLM () -> m (Either Blocked_ NLMState)@@ -120,10 +117,10 @@       | isIrrelevant r' -> nlmSub %= IntMap.insert i (r,v)       | otherwise       -> whenJustM (equal a v v') matchingBlocked -tellEq :: Telescope -> Telescope -> Type -> Term -> Term -> NLM ()+tellEq :: Telescope -> Context -> Type -> Term -> Term -> NLM () tellEq gamma k a u v = do   traceSDoc "rewriting.match" 30 (sep-               [ "adding equality between" <+> addContext (gamma `abstract` k) (prettyTCM u)+               [ "adding equality between" <+> addContext gamma (addContext k $ prettyTCM u)                , " and " <+> addContext k (prettyTCM v) ]) $ do   nlmEqs %= (PostponedEquation k a u v:) @@ -133,7 +130,7 @@ --   which we have to verify after applying --   the substitution computed by matching. data PostponedEquation = PostponedEquation-  { eqFreeVars :: Telescope -- ^ Telescope of free variables in the equation+  { eqFreeVars :: Context -- ^ Context of free variables in the equation   , eqType :: Type    -- ^ Type of the equation, living in same context as the rhs.   , eqLhs :: Term     -- ^ Term from pattern, living in pattern context.   , eqRhs :: Term     -- ^ Term from scrutinee, living in context where matching was invoked.@@ -143,30 +140,32 @@ -- | Match a non-linear pattern against a neutral term, --   returning a substitution. -class Match t a b where+class Match a b where   match :: Relevance  -- ^ Are we currently matching in an irrelevant context?         -> Telescope  -- ^ The telescope of pattern variables-        -> Telescope  -- ^ The telescope of lambda-bound variables-        -> t          -- ^ The type of the pattern+        -> Context    -- ^ The context of lambda-bound variables+        -> TypeOf b   -- ^ The type of the pattern         -> a          -- ^ The pattern to match         -> b          -- ^ The term to be matched against the pattern         -> NLM () -instance Match t a b => Match (Dom t) (Arg a) (Arg b) where+instance Match a b => Match (Arg a) (Arg b) where   match r gamma k t p v = let r' = r `composeRelevance` getRelevance p                           in  match r' gamma k (unDom t) (unArg p) (unArg v) -instance Match (Type, Elims -> Term) [Elim' NLPat] Elims where+instance Match [Elim' NLPat] Elims where   match r gamma k (t, hd) [] [] = return ()   match r gamma k (t, hd) [] _  = matchingBlocked $ NotBlocked ReallyNotBlocked ()   match r gamma k (t, hd) _  [] = matchingBlocked $ NotBlocked ReallyNotBlocked ()   match r gamma k (t, hd) (p:ps) (v:vs) =    traceSDoc "rewriting.match" 50 (sep-     [ "matching elimination " <+> addContext (gamma `abstract` k) (prettyTCM p)+     [ "matching elimination " <+> addContext gamma (addContext k $ prettyTCM p)      , "  with               " <+> addContext k (prettyTCM v)      , "  eliminating head   " <+> addContext k (prettyTCM $ hd []) <+> ":" <+> addContext k (prettyTCM t)]) $ do++   let no  = matchingBlocked $ NotBlocked ReallyNotBlocked ()    case (p,v) of-    (Apply p, Apply v) -> (addContext k $ unEl <$> reduce t) >>= \case+    (Apply p, Apply v) -> addContext k (unEl <$> reduce t) >>= \case       Pi a b -> do         match r gamma k a p v         let t'  = absApp b (unArg v)@@ -175,9 +174,9 @@       t -> traceSDoc "rewriting.match" 20         ("application at non-pi type (possible non-confluence?) " <+> prettyTCM t) mzero -    (IApply x y p , IApply u v i) -> (addContext k $ pathView =<< reduce t) >>= \case+    (IApply x y p , IApply u v i) -> addContext k (pathView =<< reduce t) >>= \case       PathType s q l b _u _v -> do-        Right interval <- runExceptT primIntervalType+        interval <- fromRight __IMPOSSIBLE__ <$> runExceptT primIntervalType         match r gamma k interval p i         let t' = El s $ unArg b `apply` [ defaultArg i ]         let hd' = hd . (IApply u v i:)@@ -186,32 +185,34 @@         ("interval application at non-pi type (possible non-confluence?) " <+> prettyTCM (pathUnview t)) mzero      (Proj o f, Proj o' f') | f == f' -> do-      ~(Just (El _ (Pi a b))) <- addContext k $ getDefType f =<< reduce t-      let u = hd []-          t' = b `absApp` u-      hd' <- addContext k $ applyE <$> applyDef o f (argFromDom a $> u)-      match r gamma k (t',hd') ps vs+      addContext k (getDefType f =<< reduce t) >>= \case+        Just (El _ (Pi a b)) -> do+          let u = hd []+              t' = b `absApp` u+          hd' <- addContext k $ applyE <$> applyDef o f (argFromDom a $> u)+          match r gamma k (t',hd') ps vs+        _ -> no      (Proj _ f, Proj _ f') | otherwise -> do       traceSDoc "rewriting.match" 20 (sep         [ "mismatch between projections " <+> prettyTCM f         , " and " <+> prettyTCM f' ]) mzero -    (Apply{}, Proj{} ) -> __IMPOSSIBLE__-    (Proj{} , Apply{}) -> __IMPOSSIBLE__+    (Apply{}, Proj{} ) -> no+    (Proj{} , Apply{}) -> no      (IApply{} , _    ) -> __IMPOSSIBLE__ -- TODO     (_ , IApply{}    ) -> __IMPOSSIBLE__ -- TODO -instance Match t a b => Match t (Dom a) (Dom b) where+instance Match a b => Match (Dom a) (Dom b) where   match r gamma k t p v = match r gamma k t (unDom p) (unDom v) -instance Match () NLPType Type where+instance Match NLPType Type where   match r gamma k _ (NLPType sp p) (El s a) = workOnTypes $ do     match r gamma k () sp s     match r gamma k (sort s) p a -instance Match () NLPSort Sort where+instance Match NLPSort Sort where   match r gamma k _ p s = do     bs <- addContext k $ reduceB s     let b = void bs@@ -219,15 +220,15 @@         yes = return ()         no  = matchingBlocked $ NotBlocked ReallyNotBlocked ()     traceSDoc "rewriting.match" 30 (sep-      [ "matching pattern " <+> addContext (gamma `abstract` k) (prettyTCM p)+      [ "matching pattern " <+> addContext gamma (addContext k $ prettyTCM p)       , "  with sort      " <+> addContext k (prettyTCM s) ]) $ do     case (p , s) of-      (PType lp  , Type l  ) -> match r gamma k () lp l-      (PProp lp  , Prop l  ) -> match r gamma k () lp l-      (PInf fp np , Inf f n)-        | fp == f, np == n   -> yes-      (PSizeUniv , SizeUniv) -> yes-      (PLockUniv , LockUniv) -> yes+      (PUniv u lp    , Univ u' l) | u == u'          -> match r gamma k () lp l+      (PInf up np    , Inf u n)   | up == u, np == n -> yes+      (PSizeUniv     , SizeUniv)                     -> yes+      (PLockUniv     , LockUniv)                     -> yes+      (PLevelUniv    , LevelUniv)                    -> yes+      (PIntervalUniv , IntervalUniv)                 -> yes        -- blocked cases       (_ , UnivSort{}) -> matchingBlocked b@@ -238,24 +239,32 @@       -- all other cases do not match       (_ , _) -> no -instance Match () NLPat Level where+instance Match NLPat Level where   match r gamma k _ p l = do     t <- El (mkType 0) . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevel     v <- reallyUnLevelView l     match r gamma k t p v -instance Match Type NLPat Term where+instance Match NLPat Term where+  match :: Relevance  -- Are we currently matching in an irrelevant context?+        -> Telescope  -- The telescope of pattern variables+        -> Context    -- The context of lambda-bound variables+        -> Type       -- The type of the pattern+        -> NLPat      -- The pattern to match+        -> Term       -- The term to be matched against the pattern+        -> NLM ()   match r0 gamma k t p v = do     vbt <- addContext k $ reduceB (v,t)     let n = size k         b = void vbt         (v,t) = ignoreBlocking vbt-        prettyPat  = withShowAllArguments $ addContext (gamma `abstract` k) (prettyTCM p)+        prettyPat  = withShowAllArguments $ addContext gamma $ addContext k $ prettyTCM p         prettyTerm = withShowAllArguments $ addContext k $ prettyTCM v         prettyType = withShowAllArguments $ addContext k $ prettyTCM t     etaRecord <- addContext k $ isEtaRecordType t+    pview <- pathViewAsPi'whnf     prop <- fromRight __IMPOSSIBLE__ <.> runBlocked . addContext k $ isPropM t-    let r = if prop then Irrelevant else r0+    let r = if prop then irrelevant else r0     traceSDoc "rewriting.match" 30 (sep       [ "matching pattern " <+> prettyPat       , "  with term      " <+> prettyTerm@@ -268,7 +277,7 @@       [ "pattern vars:   " <+> prettyTCM gamma       , "bound vars:     " <+> prettyTCM k ]) $ do     let yes = return ()-        no msg = if r == Irrelevant then yes else do+        no msg = if isIrrelevant r then yes else do           traceSDoc "rewriting.match" 10 (sep             [ "mismatch between" <+> prettyPat             , " and " <+> prettyTerm@@ -277,7 +286,7 @@           traceSDoc "rewriting.match" 30 (sep             [ "blocking tag from reduction: " <+> text (show b) ]) $ do           matchingBlocked b-        block b' = if r == Irrelevant then yes else do+        block b' = if isIrrelevant r then yes else do           traceSDoc "rewriting.match" 10 (sep             [ "matching blocked on meta"             , text (show b') ]) $ do@@ -289,14 +298,15 @@           _          -> no ""     case p of       PVar i bvs -> traceSDoc "rewriting.match" 60 ("matching a PVar: " <+> text (show i)) $ do+        let vars = map unArg bvs         let allowedVars :: IntSet-            allowedVars = IntSet.fromList (map unArg bvs)+            allowedVars = IntSet.fromList vars             badVars :: IntSet             badVars = IntSet.difference (IntSet.fromList (downFrom n)) allowedVars             perm :: Permutation-            perm = Perm n $ reverse $ map unArg $ bvs+            perm = Perm n $ reverse vars             tel :: Telescope-            tel = permuteTel perm k+            tel = permuteContext perm k         ok <- addContext k $ reallyFree badVars v         case ok of           Left b         -> block b@@ -315,40 +325,47 @@                 match r gamma k (ft , Def f) ps es           Con c ci vs             | f == conName c -> do-                ~(Just (_ , ct)) <- addContext k $ getFullyAppliedConType c t-                match r gamma k (ct , Con c ci) ps vs+                addContext k (getFullyAppliedConType c t) >>= \case+                  Just (_ , ct) -> match r gamma k (ct , Con c ci) ps vs+                  Nothing -> no ""           _ | Pi a b <- unEl t -> do             let ai    = domInfo a                 pbody = PDef f $ raise 1 ps ++ [ Apply $ Arg ai $ PTerm $ var 0 ]                 body  = raise 1 v `apply` [ Arg (domInfo a) $ var 0 ]-                k'    = ExtendTel a (Abs (absName b) k)+            k' <- extendContext k (absName b) a             match r gamma k' (absBody b) pbody body           _ | Just (d, pars) <- etaRecord -> do           -- If v is not of record constructor form but we are matching at record           -- type, e.g., we eta-expand both v to (c vs) and           -- the pattern (p = PDef f ps) to @c (p .f1) ... (p .fn)@.-            def <- addContext k $ theDef <$> getConstInfo d+            RecordDefn def <- addContext k $ theDef <$> getConstInfo d             (tel, c, ci, vs) <- addContext k $ etaExpandRecord_ d pars def v-            ~(Just (_ , ct)) <- addContext k $ getFullyAppliedConType c t-            let flds = map argFromDom $ recFields def-                mkField fld = PDef f (ps ++ [Proj ProjSystem fld])-                -- Issue #3335: when matching against the record constructor,-                -- don't add projections but take record field directly.-                ps'-                  | conName c == f = ps-                  | otherwise      = map (Apply . fmap mkField) flds-            match r gamma k (ct, Con c ci) ps' (map Apply vs)+            addContext k (getFullyAppliedConType c t) >>= \case+              Just (_ , ct) -> do+                let flds = map argFromDom $ _recFields def+                    mkField fld = PDef f (ps ++ [Proj ProjSystem fld])+                    -- Issue #3335: when matching against the record constructor,+                    -- don't add projections but take record field directly.+                    ps'+                      | conName c == f = ps+                      | otherwise      = map (Apply . fmap mkField) flds+                match r gamma k (ct, Con c ci) ps' (map Apply vs)+              Nothing -> no ""           v -> maybeBlock v       PLam i p' -> case unEl t of         Pi a b -> do           let body = raise 1 v `apply` [Arg i (var 0)]-              k'   = ExtendTel a (Abs (absName b) k)+          k' <- extendContext k (absName b) a           match r gamma k' (absBody b) (absBody p') body+        _ | Left ((a,b),(x,y)) <- pview t -> do+          let body = raise 1 v `applyE` [ IApply (raise 1 x) (raise 1 y) $ var 0 ]+          k' <- extendContext k "i" a+          match r gamma k' (absBody b) (absBody p') body         v -> maybeBlock v       PPi pa pb -> case v of         Pi a b -> do           match r gamma k () pa a-          let k' = ExtendTel a (Abs (absName b) k)+          k' <- extendContext k (absName b) a           match r gamma k' () (absBody pb) (absBody b)         v -> maybeBlock v       PSort ps -> case v of@@ -356,63 +373,38 @@         v -> maybeBlock v       PBoundVar i ps -> case v of         Var i' es | i == i' -> do-          let ti = unDom $ indexWithDefault __IMPOSSIBLE__ (flattenTel k) i+          let ti = maybe __IMPOSSIBLE__ (unDom . ctxEntryDom) $ lookupBV_ i k           match r gamma k (ti , Var i) ps es         _ | Pi a b <- unEl t -> do           let ai    = domInfo a-              pbody = PBoundVar (1+i) $ raise 1 ps ++ [ Apply $ Arg ai $ PTerm $ var 0 ]+              pbody = PBoundVar (1 + i) $ raise 1 ps ++ [ Apply $ Arg ai $ PTerm $ var 0 ]               body  = raise 1 v `apply` [ Arg ai $ var 0 ]-              k'    = ExtendTel a (Abs (absName b) k)+          k' <- extendContext k (absName b) a           match r gamma k' (absBody b) pbody body         _ | Just (d, pars) <- etaRecord -> do-          def <- addContext k $ theDef <$> getConstInfo d+          RecordDefn def <- addContext k $ theDef <$> getConstInfo d           (tel, c, ci, vs) <- addContext k $ etaExpandRecord_ d pars def v-          ~(Just (_ , ct)) <- addContext k $ getFullyAppliedConType c t-          let flds = map argFromDom $ recFields def-              ps'  = map (fmap $ \fld -> PBoundVar i (ps ++ [Proj ProjSystem fld])) flds-          match r gamma k (ct, Con c ci) (map Apply ps') (map Apply vs)+          addContext k (getFullyAppliedConType c t) >>= \case+            Just (_ , ct) -> do+              let flds = map argFromDom $ _recFields def+                  ps'  = map (fmap $ \fld -> PBoundVar i (ps ++ [Proj ProjSystem fld])) flds+              match r gamma k (ct, Con c ci) (map Apply ps') (map Apply vs)+            Nothing -> no ""         v -> maybeBlock v-      PTerm u -> traceSDoc "rewriting.match" 60 ("matching a PTerm" <+> addContext (gamma `abstract` k) (prettyTCM u)) $+      PTerm u -> traceSDoc "rewriting.match" 60 ("matching a PTerm" <+> addContext gamma (addContext k $ prettyTCM u)) $         tellEq gamma k t u v --- Checks if the given term contains any free variables that satisfy the--- given condition on their DBI, possibly reducing the term in the process.--- Returns `Right Nothing` if there are such variables, `Right (Just v')`--- if there are none (where v' is the possibly reduced version of the given--- term) or `Left b` if the problem is blocked on a meta.-reallyFree :: (MonadReduce m, Reduce a, ForceNotFree a)-           => IntSet -> a -> m (Either Blocked_ (Maybe a))-reallyFree xs v = do-  (mxs , v') <- forceNotFree xs v-  case IntMap.foldr pickFree NotFree mxs of-    MaybeFree ms-      | null ms   -> return $ Right Nothing-      | otherwise -> return $ Left $ Blocked blocker ()-      where blocker = unblockOnAll $ foldrMetaSet (Set.insert . unblockOnMeta) Set.empty ms-    NotFree -> return $ Right (Just v')--  where-    -- Check if any of the variables occur freely.-    -- Prefer occurrences that do not depend on any metas.-    pickFree :: IsFree -> IsFree -> IsFree-    pickFree f1@(MaybeFree ms1) f2-      | null ms1  = f1-    pickFree f1@(MaybeFree ms1) f2@(MaybeFree ms2)-      | null ms2  = f2-      | otherwise = f1-    pickFree f1@(MaybeFree ms1) NotFree = f1-    pickFree NotFree f2 = f2+extendContext :: MonadAddContext m => Context -> ArgName -> Dom Type -> m Context+extendContext cxt x a = withFreshName empty x \ y -> return $ CtxVar y a : cxt  -makeSubstitution :: Telescope -> Sub -> Substitution+makeSubstitution :: Telescope -> Sub -> Maybe Substitution makeSubstitution gamma sub =-  parallelS $ map (fromMaybe __DUMMY_TERM__ . val) [0 .. size gamma-1]+  parallelS <$> traverse val [0 .. size gamma-1]     where-      val i = case IntMap.lookup i sub of-                Just (Irrelevant, v) -> Just $ dontCare v-                Just (_         , v) -> Just v-                Nothing              -> Nothing+      val i = IntMap.lookup i sub <&> \ (rel, v) -> applyWhen (isIrrelevant rel) dontCare v +{-# SPECIALIZE checkPostponedEquations :: Substitution -> PostponedEquations -> TCM (Maybe Blocked_) #-} checkPostponedEquations :: PureTCM m                         => Substitution -> PostponedEquations -> m (Maybe Blocked_) checkPostponedEquations sub eqs = forM' eqs $@@ -424,26 +416,28 @@       addContext k $ equal a lhs' rhs  -- main function-nonLinMatch :: (PureTCM m, Match t a b)-            => Telescope -> t -> a -> b -> m (Either Blocked_ Substitution)+nonLinMatch :: (PureTCM m, Match a b)+            => Telescope -> TypeOf b -> a -> b -> m (Either Blocked_ Substitution) nonLinMatch gamma t p v = do   let no msg b = traceSDoc "rewriting.match" 10 (sep                    [ "matching failed during" <+> text msg                    , "blocking: " <+> text (show b) ]) $ return (Left b)-  caseEitherM (runNLM $ match Relevant gamma EmptyTel t p v) (no "matching") $ \ s -> do-    let sub = makeSubstitution gamma $ s^.nlmSub-        eqs = s^.nlmEqs-    traceSDoc "rewriting.match" 90 (text $ "sub = " ++ show sub) $ do-    ok <- checkPostponedEquations sub eqs-    case ok of-      Nothing -> return $ Right sub-      Just b  -> no "checking of postponed equations" b+  caseEitherM (runNLM $ match relevant gamma empty t p v) (no "matching") $ \ s -> do+    let msub = makeSubstitution gamma $ s ^. nlmSub+        eqs = s ^. nlmEqs+    traceSDoc "rewriting.match" 90 (text $ "msub = " ++ show msub) $ case msub of+      Nothing -> no "checking that all variables are bound" notBlocked_+      Just sub -> do+        ok <- checkPostponedEquations sub eqs+        case ok of+          Nothing -> return $ Right sub+          Just b  -> no "checking of postponed equations" b  -- | Typed βη-equality, also handles empty record types. --   Returns `Nothing` if the terms are equal, or `Just b` if the terms are not --   (where b contains information about possible metas blocking the comparison) equal :: PureTCM m => Type -> Term -> Term -> m (Maybe Blocked_)-equal a u v = runBlocked (pureEqualTerm a u v) >>= \case+equal a u v = pureEqualTermB a u v >>= \case   Left b      -> return $ Just $ Blocked b ()   Right True  -> return Nothing   Right False -> traceSDoc "rewriting.match" 10 (sep@@ -463,9 +457,11 @@     vs <- freeVarsToApply c     -- Jesper, 2020-06-17, issue #4755: add dummy arguments in     -- case we don't have enough parameters-    npars <- fromMaybe __IMPOSSIBLE__ <$> getNumberOfParameters c-    let ws = replicate (npars - size vs) $ defaultArg __DUMMY_TERM__-    t0 <- defType <$> getConstInfo c-    t <- t0 `piApplyM` (vs ++ ws)-    return $ Just (c , t)+    getNumberOfParameters c >>= \case+      Just npars -> do+        let ws = replicate (npars - size vs) $ defaultArg __DUMMY_TERM__+        t0 <- defType <$> getConstInfo c+        t <- t0 `piApplyM` (vs ++ ws)+        return $ Just (c , t)+      Nothing -> return Nothing   _ -> return Nothing
src/full/Agda/TypeChecking/Rewriting/NonLinPattern.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE NondecreasingIndentation #-}  {- | Various utility functions dealing with the non-linear, higher-order@@ -6,7 +8,8 @@  module Agda.TypeChecking.Rewriting.NonLinPattern where -import Control.Monad        ( (>=>), forM )+import Prelude hiding ( null )+ import Control.Monad.Reader ( asks )  import Data.IntSet (IntSet)@@ -15,11 +18,12 @@ import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Defs+import Agda.Syntax.Internal.MetaVars ( AllMetas, unblockOnAllMetasIn )  import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Free import Agda.TypeChecking.Free.Lazy-import Agda.TypeChecking.Irrelevance (workOnTypes, isPropM)+import Agda.TypeChecking.Irrelevance (isPropM) import Agda.TypeChecking.Level import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty@@ -27,13 +31,11 @@ import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Primitive.Cubical+import Agda.TypeChecking.Primitive.Cubical.Base -import Agda.Utils.Either import Agda.Utils.Functor import Agda.Utils.Impossible import Agda.Utils.List-import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Singleton@@ -46,56 +48,57 @@ --   The second argument is the number of bound variables (from pattern lambdas). --   The third argument is the type of the term. -class PatternFrom t a b where-  patternFrom :: Relevance -> Int -> t -> a -> TCM b+class PatternFrom a b where+  patternFrom :: Relevance -> Int -> TypeOf a -> a -> TCM b -instance (PatternFrom t a b) => PatternFrom (Dom t) (Arg a) (Arg b) where+instance (PatternFrom a b) => PatternFrom (Arg a) (Arg b) where   patternFrom r k t u = let r' = r `composeRelevance` getRelevance u                         in  traverse (patternFrom r' k $ unDom t) u -instance PatternFrom (Type, Term) Elims [Elim' NLPat] where+instance PatternFrom Elims [Elim' NLPat] where   patternFrom r k (t,hd) = \case     [] -> return []     (Apply u : es) -> do-      ~(Pi a b) <- unEl <$> reduce t+      (a, b) <- assertPi t       p   <- patternFrom r k a u-      t'  <- t `piApplyM` u-      let hd' = hd `apply` [ u ]+      let t'  = absApp b (unArg u)+      let hd' = hd . (Apply u:)       ps  <- patternFrom r k (t',hd') es       return $ Apply p : ps     (IApply x y i : es) -> do-      ~(PathType s q l b u v) <- pathView =<< reduce t+      (s, q, l, b, u, v) <- assertPath t       let t' = El s $ unArg b `apply` [ defaultArg i ]-      let hd' = hd `applyE` [IApply x y i]+      let hd' = hd . (IApply x y i:)       interval <- primIntervalType       p   <- patternFrom r k interval i       ps  <- patternFrom r k (t',hd') es       return $ IApply (PTerm x) (PTerm y) p : ps     (Proj o f : es) -> do-      ~(Just (El _ (Pi a b))) <- getDefType f =<< reduce t-      let t' = b `absApp` hd-      hd' <- applyDef o f (argFromDom a $> hd)-      ps  <- patternFrom r k (t',hd') es+      (a,b) <- assertProjOf f t+      let u = hd []+          t' = b `absApp` u+      hd' <- applyDef o f (argFromDom a $> u)+      ps  <- patternFrom r k (t',applyE hd') es       return $ Proj o f : ps -instance (PatternFrom t a b) => PatternFrom t (Dom a) (Dom b) where+instance (PatternFrom a b) => PatternFrom (Dom a) (Dom b) where   patternFrom r k t = traverse $ patternFrom r k t -instance PatternFrom () Type NLPType where+instance PatternFrom Type NLPType where   patternFrom r k _ a = workOnTypes $     NLPType <$> patternFrom r k () (getSort a)             <*> patternFrom r k (sort $ getSort a) (unEl a) -instance PatternFrom () Sort NLPSort where+instance PatternFrom Sort NLPSort where   patternFrom r k _ s = do-    s <- reduce s+    s <- abortIfBlocked s     case s of-      Type l   -> PType <$> patternFrom r k () l-      Prop l   -> PProp <$> patternFrom r k () l-      Inf f n  -> return $ PInf f n-      SSet l   -> __IMPOSSIBLE__+      Univ u l -> PUniv u <$> patternFrom r k () l+      Inf u n  -> return $ PInf u n       SizeUniv -> return PSizeUniv       LockUniv -> return PLockUniv+      LevelUniv -> return PLevelUniv+      IntervalUniv -> return PIntervalUniv       PiSort _ _ _ -> __IMPOSSIBLE__       FunSort _ _ -> __IMPOSSIBLE__       UnivSort _ -> __IMPOSSIBLE__@@ -108,40 +111,46 @@           ]         __IMPOSSIBLE__ -instance PatternFrom () Level NLPat where+instance PatternFrom Level NLPat where   patternFrom r k _ l = do     t <- levelType     v <- reallyUnLevelView l     patternFrom r k t v -instance PatternFrom Type Term NLPat where+instance PatternFrom Term NLPat where   patternFrom r0 k t v = do-    t <- reduce t+    t <- abortIfBlocked t     etaRecord <- isEtaRecordType t-    prop <- fromRight __IMPOSSIBLE__ <.> runBlocked $ isPropM t-    let r = if prop then Irrelevant else r0-    v <- unLevel =<< reduce v+    prop <- isPropM t+    let r = if prop then irrelevant else r0+    v <- unLevel =<< abortIfBlocked v     reportSDoc "rewriting.build" 60 $ sep       [ "building a pattern from term v = " <+> prettyTCM v       , " of type " <+> prettyTCM t       ]-    let done = return $ PTerm v+    pview <- pathViewAsPi'whnf+    let done = blockOnMetasIn v >> return (PTerm v)     case (unEl t , stripDontCare v) of       (Pi a b , _) -> do         let body = raise 1 v `apply` [ Arg (domInfo a) $ var 0 ]-        p <- addContext a (patternFrom r (k+1) (absBody b) body)+        p <- addContext a (patternFrom r (k + 1) (absBody b) body)         return $ PLam (domInfo a) $ Abs (absName b) p+      _ | Left ((a,b),(x,y)) <- pview t -> do+        let body = raise 1 v `applyE` [ IApply (raise 1 $ x) (raise 1 $ y) $ var 0 ]+        p <- addContext a (patternFrom r (k + 1) (absBody b) body)+        return $ PLam (domInfo a) $ Abs (absName b) p       (_ , Var i es)        | i < k     -> do            t <- typeOfBV i-           PBoundVar i <$> patternFrom r k (t , var i) es+           PBoundVar i <$> patternFrom r k (t , Var i) es        -- The arguments of `var i` should be distinct bound variables        -- in order to build a Miller pattern        | Just vs <- allApplyElims es -> do-           TelV tel _ <- telView =<< typeOfBV i-           unless (size tel >= size vs) __IMPOSSIBLE__+           TelV tel rest <- telViewPath =<< typeOfBV i+           unless (natSize tel >= natSize vs) $ blockOnMetasIn rest >> addContext tel (errNotPi rest)            let ts = applySubst (parallelS $ reverse $ map unArg vs) $ map unDom $ flattenTel tel            mbvs <- forM (zip ts vs) $ \(t , v) -> do+             blockOnMetasIn (v,t)              isEtaVar (unArg v) t >>= \case                Just j | j < k -> return $ Just $ v $> j                _              -> return Nothing@@ -154,11 +163,11 @@              _ -> done        | otherwise -> done       (_ , _ ) | Just (d, pars) <- etaRecord -> do-        def <- theDef <$> getConstInfo d+        RecordDefn def <- theDef <$> getConstInfo d         (tel, c, ci, vs) <- etaExpandRecord_ d pars def v-        caseMaybeM (getFullyAppliedConType c t) __IMPOSSIBLE__ $ \ (_ , ct) -> do-        PDef (conName c) <$> patternFrom r k (ct , Con c ci []) (map Apply vs)-      (_ , Lam i t) -> __IMPOSSIBLE__+        ct <- assertConOf c t+        PDef (conName c) <$> patternFrom r k (ct , Con c ci) (map Apply vs)+      (_ , Lam{})   -> errNotPi t       (_ , Lit{})   -> done       (_ , Def f es) | isIrrelevant r -> done       (_ , Def f es) -> do@@ -169,20 +178,20 @@           [x , y] | f == lmax -> done           _                   -> do             ft <- defType <$> getConstInfo f-            PDef f <$> patternFrom r k (ft , Def f []) es+            PDef f <$> patternFrom r k (ft , Def f) es       (_ , Con c ci vs) | isIrrelevant r -> done-      (_ , Con c ci vs) ->-        caseMaybeM (getFullyAppliedConType c t) __IMPOSSIBLE__ $ \ (_ , ct) -> do-        PDef (conName c) <$> patternFrom r k (ct , Con c ci []) vs+      (_ , Con c ci vs) -> do+        ct <- assertConOf c t+        PDef (conName c) <$> patternFrom r k (ct , Con c ci) vs       (_ , Pi a b) | isIrrelevant r -> done       (_ , Pi a b) -> do         pa <- patternFrom r k () a-        pb <- addContext a (patternFrom r (k+1) () $ absBody b)+        pb <- addContext a (patternFrom r (k + 1) () $ absBody b)         return $ PPi pa (Abs (absName b) pb)       (_ , Sort s)     -> PSort <$> patternFrom r k () s       (_ , Level l)    -> __IMPOSSIBLE__       (_ , DontCare{}) -> __IMPOSSIBLE__-      (_ , MetaV{})    -> __IMPOSSIBLE__+      (_ , MetaV m _)  -> __IMPOSSIBLE__       (_ , Dummy s _)  -> __IMPOSSIBLE_VERBOSE__ s  -- | Convert from a non-linear pattern to a term.@@ -224,11 +233,12 @@   nlPatToTerm (NLPType s a) = El <$> nlPatToTerm s <*> nlPatToTerm a  instance NLPatToTerm NLPSort Sort where-  nlPatToTerm (PType l) = Type <$> nlPatToTerm l-  nlPatToTerm (PProp l) = Prop <$> nlPatToTerm l-  nlPatToTerm (PInf f n) = return $ Inf f n+  nlPatToTerm (PUniv u l) = Univ u <$> nlPatToTerm l+  nlPatToTerm (PInf u n) = return $ Inf u n   nlPatToTerm PSizeUniv = return SizeUniv   nlPatToTerm PLockUniv = return LockUniv+  nlPatToTerm PLevelUniv = return LevelUniv+  nlPatToTerm PIntervalUniv = return IntervalUniv  -- | Gather the set of pattern variables of a non-linear pattern class NLPatVars a where@@ -245,11 +255,12 @@  instance NLPatVars NLPSort where   nlPatVarsUnder k = \case-    PType l   -> nlPatVarsUnder k l-    PProp l   -> nlPatVarsUnder k l+    PUniv _ l   -> nlPatVarsUnder k l     PInf f n  -> empty     PSizeUniv -> empty     PLockUniv -> empty+    PLevelUniv -> empty+    PIntervalUniv -> empty  instance NLPatVars NLPat where   nlPatVarsUnder k = \case@@ -266,7 +277,7 @@  instance NLPatVars a => NLPatVars (Abs a) where   nlPatVarsUnder k = \case-    Abs   _ v -> nlPatVarsUnder (k+1) v+    Abs   _ v -> nlPatVarsUnder (k + 1) v     NoAbs _ v -> nlPatVarsUnder k v  -- | Get all symbols that a non-linear pattern matches against@@ -289,7 +300,7 @@   getMatchables p =     case p of       PVar _ _       -> empty-      PDef f _       -> singleton f+      PDef f es      -> singleton f ++ getMatchables es       PLam _ x       -> getMatchables x       PPi a b        -> getMatchables (a,b)       PSort s        -> getMatchables s@@ -301,11 +312,12 @@  instance GetMatchables NLPSort where   getMatchables = \case-    PType l   -> getMatchables l-    PProp l   -> getMatchables l+    PUniv _ l -> getMatchables l     PInf f n  -> empty     PSizeUniv -> empty     PLockUniv -> empty+    PLevelUniv -> empty+    PIntervalUniv -> empty  instance GetMatchables Term where   getMatchables = getDefs' __IMPOSSIBLE__ singleton@@ -334,8 +346,69 @@  instance Free NLPSort where   freeVars' = \case-    PType l   -> freeVars' l-    PProp l   -> freeVars' l+    PUniv _ l -> freeVars' l     PInf f n  -> mempty     PSizeUniv -> mempty     PLockUniv -> mempty+    PLevelUniv -> mempty+    PIntervalUniv -> mempty++-- Throws a pattern violation if the given term contains any+-- metavariables.+blockOnMetasIn :: (MonadBlock m, AllMetas t) => t -> m ()+blockOnMetasIn t = case unblockOnAllMetasIn t of+  UnblockOnAll ms | null ms -> return ()+  b -> patternViolation b++-- Helper functions+++assertPi :: Type -> TCM (Dom Type, Abs Type)+assertPi t = abortIfBlocked t >>= \case+  El _ (Pi a b) -> return (a,b)+  t             -> errNotPi t++errNotPi :: Type -> TCM a+errNotPi t = typeError . GenericDocError =<< fsep+    [ prettyTCM t+    , "should be a function type, but it isn't."+    , "Do you have any non-confluent rewrite rules?"+    ]++assertPath :: Type -> TCM (Sort, QName, Arg Term, Arg Term, Arg Term, Arg Term)+assertPath t = abortIfBlocked t >>= pathView >>= \case+  PathType s q l b u v -> return (s,q,l,b,u,v)+  OType t -> errNotPath t++errNotPath :: Type -> TCM a+errNotPath t = typeError . GenericDocError =<< fsep+    [ prettyTCM t+    , "should be a path type, but it isn't."+    , "Do you have any non-confluent rewrite rules?"+    ]++assertProjOf :: QName -> Type -> TCM (Dom Type, Abs Type)+assertProjOf f t = do+  t <- abortIfBlocked t+  getDefType f t >>= \case+    Just (El _ (Pi a b)) -> return (a,b)+    _ -> errNotProjOf f t++errNotProjOf :: QName -> Type -> TCM a+errNotProjOf f t = typeError . GenericDocError =<< fsep+      [ prettyTCM f , "should be a projection from type"+      , prettyTCM t , "but it isn't."+      , "Do you have any non-confluent rewrite rules?"+      ]++assertConOf :: ConHead -> Type -> TCM Type+assertConOf c t = getFullyAppliedConType c t >>= \case+    Just (_ , ct) -> return ct+    Nothing -> errNotConOf c t++errNotConOf :: ConHead -> Type -> TCM a+errNotConOf c t = typeError . GenericDocError =<< fsep+      [ prettyTCM c , "should be a constructor of type"+      , prettyTCM t , "but it isn't."+      , "Do you have any non-confluent rewrite rules?"+      ]
src/full/Agda/TypeChecking/Rules/Application.hs view
@@ -6,1584 +6,1889 @@   , checkApplication   , inferApplication   , checkProjAppToKnownPrincipalArg-  ) where--import Prelude hiding ( null )--import Control.Applicative        ( (<|>) )-import Control.Monad              ( forM, forM_, guard, liftM2 )-import Control.Monad.Except-import Control.Monad.Trans-import Control.Monad.Trans.Maybe-import Control.Monad.Reader--import Data.Bifunctor-import Data.Maybe-import Data.Void-import qualified Data.Foldable as Fold-import qualified Data.IntSet   as IntSet--import Agda.Interaction.Highlighting.Generate-  ( storeDisambiguatedConstructor, storeDisambiguatedProjection )-import Agda.Interaction.Options--import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Abstract.Views as A-import qualified Agda.Syntax.Info as A-import Agda.Syntax.Concrete.Pretty () -- only Pretty instances-import Agda.Syntax.Common-import Agda.Syntax.Internal as I-import Agda.Syntax.Position--import Agda.TypeChecking.Conversion-import Agda.TypeChecking.Constraints-import Agda.TypeChecking.Datatypes-import Agda.TypeChecking.Free-import Agda.TypeChecking.Free.Lazy (VarMap, lookupVarMap)-import Agda.TypeChecking.Implicit-import Agda.TypeChecking.Injectivity-import Agda.TypeChecking.Irrelevance-import Agda.TypeChecking.InstanceArguments (postponeInstanceConstraints)-import Agda.TypeChecking.Level-import Agda.TypeChecking.MetaVars-import Agda.TypeChecking.Names-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Primitive-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Records-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Rules.Def-import Agda.TypeChecking.Rules.Term-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Telescope--import Agda.Utils.Either-import Agda.Utils.Functor-import Agda.Utils.Lens-import Agda.Utils.List  ( (!!!), groupOn, initWithDefault )-import Agda.Utils.List1 ( List1, pattern (:|) )-import qualified Agda.Utils.List1 as List1-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Pretty ( prettyShow )-import Agda.Utils.Size-import Agda.Utils.Tuple--import Agda.Utils.Impossible---------------------------------------------------------------------------------- * Applications---------------------------------------------------------------------------------- | Ranges of checked arguments, where present.-type MaybeRanges = [Maybe Range]--acHeadConstraints :: (Elims -> Term) -> ArgsCheckState a -> [Constraint]-acHeadConstraints hd ACState{acElims = es, acConstraints = cs} = go hd es cs-  where-    go hd [] [] = []-    go hd (e : es) (c : cs) = maybe id (\ c -> (lazyAbsApp c (hd []) :)) c $ go (hd . (e :)) es cs-    go _  [] (_:_) = __IMPOSSIBLE__-    go _  (_:_) [] = __IMPOSSIBLE__--checkHeadConstraints :: (Elims -> Term) -> ArgsCheckState a -> TCM Term-checkHeadConstraints hd st = do-  mapM_ solveConstraint_ (acHeadConstraints hd st)-  return $ hd (acElims st)----- | @checkApplication hd args e t@ checks an application.---   Precondition: @Application hs args = appView e@------   @checkApplication@ disambiguates constructors---   (and continues to 'checkConstructorApplication')---   and resolves pattern synonyms.-checkApplication :: Comparison -> A.Expr -> A.Args -> A.Expr -> Type -> TCM Term-checkApplication cmp hd args e t =-  turnOffExpandLastIfExistingMeta hd $-  postponeInstanceConstraints $ do-  reportSDoc "tc.check.app" 20 $ vcat-    [ "checkApplication"-    , nest 2 $ "hd   = " <+> prettyA hd-    , nest 2 $ "args = " <+> sep (map prettyA args)-    , nest 2 $ "e    = " <+> prettyA e-    , nest 2 $ "t    = " <+> prettyTCM t-    ]-  reportSDoc "tc.check.app" 70 $ vcat-    [ "checkApplication (raw)"-    , nest 2 $ text $ "hd   = " ++ show hd-    , nest 2 $ text $ "args = " ++ show (deepUnscope args)-    , nest 2 $ text $ "e    = " ++ show (deepUnscope e)-    , nest 2 $ text $ "t    = " ++ show t-    ]-  case unScope hd of-    -- Subcase: unambiguous projection-    A.Proj o p | Just x <- getUnambiguous p -> do-      checkUnambiguousProjectionApplication cmp e t x o hd args--    -- Subcase: ambiguous projection-    A.Proj o p -> do-      checkProjApp cmp e o (unAmbQ p) args t--    -- Subcase: unambiguous constructor-    A.Con ambC | Just c <- getUnambiguous ambC -> do-      -- augment c with record fields, but do not revert to original name-      con <- fromRightM (sigError __IMPOSSIBLE_VERBOSE__ (typeError $ AbstractConstructorNotInScope c)) $-        getOrigConHead c-      checkConstructorApplication cmp e t con args--    -- Subcase: ambiguous constructor-    A.Con (AmbQ cs0) -> disambiguateConstructor cs0 t >>= \ case-      Left unblock -> postponeTypeCheckingProblem (CheckExpr cmp e t) unblock-      Right c      -> checkConstructorApplication cmp e t c args--    -- Subcase: pattern synonym-    A.PatternSyn n -> do-      (ns, p) <- lookupPatternSyn n-      p <- return $ setRange (getRange n) $ killRange $ vacuous p   -- Pattern' Void -> Pattern' Expr-      -- Expand the pattern synonym by substituting for-      -- the arguments we have got and lambda-lifting-      -- over the ones we haven't.-      let meta r = A.Underscore $ A.emptyMetaInfo{ A.metaRange = r }   -- TODO: name suggestion-      case A.insertImplicitPatSynArgs meta (getRange n) ns args of-        Nothing      -> typeError $ BadArgumentsToPatternSynonym n-        Just (s, ns) -> do-          let p' = A.patternToExpr p-              e' = A.lambdaLiftExpr (map unArg ns) (A.substExpr s p')-          checkExpr' cmp e' t--    -- Subcase: macro-    A.Macro x -> do-      -- First go: no parameters-      TelV tel _ <- telView . defType =<< instantiateDef =<< getConstInfo x--      tTerm <- primAgdaTerm-      tName <- primQName--      -- Andreas, 2021-05-13, can we use @initWithDefault __IMPOSSIBLE__@ here?-      let argTel   = init $ telToList tel -- last argument is the hole term--          -- inspect macro type to figure out if arguments need to be wrapped in quote/quoteTerm-          mkArg :: Type -> NamedArg A.Expr -> NamedArg A.Expr-          mkArg t a | unEl t == tTerm =-            (fmap . fmap)-              (A.App (A.defaultAppInfo (getRange a)) (A.QuoteTerm A.exprNoRange) . defaultNamedArg) a-          mkArg t a | unEl t == tName =-            (fmap . fmap)-              (A.App (A.defaultAppInfo (getRange a)) (A.Quote A.exprNoRange) . defaultNamedArg) a-          mkArg t a | otherwise = a--          makeArgs :: [Dom (String, Type)] -> [NamedArg A.Expr] -> ([NamedArg A.Expr], [NamedArg A.Expr])-          makeArgs [] args = ([], args)-          makeArgs _  []   = ([], [])-          makeArgs tel@(d : tel1) (arg : args) =-            case insertImplicit arg tel of-              NoInsertNeeded -> first (mkArg (snd $ unDom d) arg :) $ makeArgs tel1 args-              ImpInsert is   -> makeArgs (drop (length is) tel) (arg : args)-              BadImplicits   -> (arg : args, [])  -- fail later in checkHeadApplication-              NoSuchName{}   -> (arg : args, [])  -- ditto--          (macroArgs, otherArgs) = makeArgs argTel args-          unq = A.App (A.defaultAppInfo $ fuseRange x args) (A.Unquote A.exprNoRange) . defaultNamedArg--          desugared = A.app (unq $ unAppView $ Application (A.Def x) $ macroArgs) otherArgs--      checkExpr' cmp desugared t--    -- Subcase: unquote-    A.Unquote _-      | [arg] <- args -> do-          (_, hole) <- newValueMeta RunMetaOccursCheck CmpLeq t-          unquoteM (namedArg arg) hole t-          return hole-      | arg : args <- args -> do-          -- Example: unquote v a b : A-          --  Create meta H : (x : X) (y : Y x) → Z x y for the hole-          --  Check a : X, b : Y a-          --  Unify Z a b == A-          --  Run the tactic on H-          tel    <- metaTel args                    -- (x : X) (y : Y x)-          target <- addContext tel newTypeMeta_      -- Z x y-          let holeType = telePi_ tel target         -- (x : X) (y : Y x) → Z x y-          (Just vs, EmptyTel) <- mapFst allApplyElims <$> checkArguments_ CmpLeq ExpandLast (getRange args) args tel-                                                    -- a b : (x : X) (y : Y x)-          let rho = reverse (map unArg vs) ++# IdS  -- [x := a, y := b]-          equalType (applySubst rho target) t       -- Z a b == A-          (_, hole) <- newValueMeta RunMetaOccursCheck CmpLeq holeType-          unquoteM (namedArg arg) hole holeType-          return $ apply hole vs-      where-        metaTel :: [Arg a] -> TCM Telescope-        metaTel []           = pure EmptyTel-        metaTel (arg : args) = do-          a <- newTypeMeta_-          let dom = a <$ domFromArg arg-          ExtendTel dom . Abs "x" <$>-            addContext ("x" :: String, dom) (metaTel args)--    -- Subcase: defined symbol or variable.-    _ -> do-      v <- checkHeadApplication cmp e t hd args-      reportSDoc "tc.term.app" 30 $ vcat-        [ "checkApplication: checkHeadApplication returned"-        , nest 2 $ "v = " <+> prettyTCM v-        ]-      return v---- | Precondition: @Application hd args = appView e@.-inferApplication :: ExpandHidden -> A.Expr -> A.Args -> A.Expr -> TCM (Term, Type)-inferApplication exh hd args e | not (defOrVar hd) = do-  t <- workOnTypes $ newTypeMeta_-  v <- checkExpr' CmpEq e t-  return (v, t)-inferApplication exh hd args e = postponeInstanceConstraints $ do-  SortKit{..} <- sortKit-  case unScope hd of-    A.Proj o p | isAmbiguous p -> inferProjApp e o (unAmbQ p) args-    A.Def' x s | x == nameOfSet      -> inferSet e x s args-    A.Def' x s | x == nameOfProp     -> inferProp e x s args-    A.Def' x s | x == nameOfSSet     -> inferSSet e x s args-    A.Def' x s | x == nameOfSetOmega IsFibrant -> inferSetOmega e x IsFibrant s args-    A.Def' x s | x == nameOfSetOmega IsStrict  -> inferSetOmega e x IsStrict s args-    _ -> do-      (f, t0) <- inferHead hd-      let r = getRange hd-      res <- runExceptT $ checkArgumentsE CmpEq exh (getRange hd) args t0 Nothing-      case res of-        Right st@(ACState{acType = t1}) -> fmap (,t1) $ unfoldInlined =<< checkHeadConstraints f st-        Left problem -> do-          t <- workOnTypes $ newTypeMeta_-          v <- postponeArgs problem CmpEq exh r args t $ \ st -> unfoldInlined =<< checkHeadConstraints f st-          return (v, t)---------------------------------------------------------------------------------- * Heads--------------------------------------------------------------------------------inferHeadDef :: ProjOrigin -> QName -> TCM (Elims -> Term, Type)-inferHeadDef o x = do-  -- Andreas, 2022-03-07, issue #5809: don't drop parameters of irrelevant projections.-  proj <- isRelevantProjection x-  rel  <- getRelevance . defArgInfo <$> getConstInfo x-  let app =-        case proj of-          Nothing -> \ args -> Def x $ map Apply args-          Just p  -> \ args -> projDropParsApply p o rel args-  mapFst applyE <$> inferDef app x---- | Infer the type of a head thing (variable, function symbol, or constructor).---   We return a function that applies the head to arguments.---   This is because in case of a constructor we want to drop the parameters.-inferHead :: A.Expr -> TCM (Elims -> Term, Type)-inferHead e = do-  case e of-    A.Var x -> do -- traceCall (InferVar x) $ do-      (u, a) <- getVarInfo x-      reportSDoc "tc.term.var" 20 $ hsep-        [ "variable" , prettyTCM x-        , "(" , text (show u) , ")"-        , "has type:" , prettyTCM a-        ]-      unless (usableRelevance a) $-        typeError $ VariableIsIrrelevant x-      -- Andreas, 2019-06-18, LAIM 2019, issue #3855:-      -- Conor McBride style quantity judgement:-      -- The available quantity for variable x must be below-      -- the required quantity to construct the term x.-      -- Note: this whole thing does not work for linearity, where we need some actual arithmetics.-      unlessM ((getQuantity a `moreQuantity`) <$> asksTC getQuantity) $-        typeError $ VariableIsErased x--      unless (usableCohesion a) $-        typeError $ VariableIsOfUnusableCohesion x (getCohesion a)--      return (applyE u, unDom a)--    A.Def x  -> inferHeadDef ProjPrefix x-    A.Def'{} -> __IMPOSSIBLE__ -- handled in checkHeadApplication and inferApplication--    A.Proj o ambP | Just d <- getUnambiguous ambP -> inferHeadDef o d-    A.Proj{} -> __IMPOSSIBLE__ -- inferHead will only be called on unambiguous projections--    A.Con ambC | Just c <- getUnambiguous ambC -> do--      -- Constructors are polymorphic internally.-      -- So, when building the constructor term-      -- we should throw away arguments corresponding to parameters.--      -- First, inferDef will try to apply the constructor-      -- to the free parameters of the current context. We ignore that.-      con <- fromRightM (sigError __IMPOSSIBLE_VERBOSE__ (typeError $ AbstractConstructorNotInScope c)) $-        getOrigConHead c-      (u, a) <- inferDef (\ _ -> Con con ConOCon []) c--      -- Next get the number of parameters in the current context.-      Constructor{conPars = n} <- theDef <$> (instantiateDef =<< getConstInfo c)--      reportSLn "tc.term.con" 7 $ unwords [prettyShow c, "has", show n, "parameters."]--      -- So when applying the constructor throw away the parameters.-      return (applyE u . drop n, a)-    A.Con{} -> __IMPOSSIBLE__  -- inferHead will only be called on unambiguous constructors-    A.QuestionMark i ii -> inferMeta (newQuestionMark ii) i-    A.Underscore i   -> inferMeta (newValueMeta RunMetaOccursCheck) i-    e -> do-      (term, t) <- inferExpr e-      return (applyE term, t)--inferDef :: (Args -> Term) -> QName -> TCM (Term, Type)-inferDef mkTerm x =-  traceCall (InferDef x) $ do-    -- getConstInfo retrieves the *absolute* (closed) type of x-    -- instantiateDef relativizes it to the current context-    d0 <- getConstInfo x-    d  <- instantiateDef d0-    reportSDoc "tc.term.def" 10 $ "inferDef" <+> prettyTCM x-    reportSDoc "tc.term.def" 30 $ "  absolute type:    " <+> inTopContext (prettyTCM $ defType d0)-    reportSDoc "tc.term.def" 30 $ "  instantiated type:" <+> prettyTCM (defType d)-    -- Irrelevant defs are only allowed in irrelevant position.-    -- Erased defs are only allowed in erased position (see #3855).-    checkModality x d-    case theDef d of-      GeneralizableVar{} -> do-        -- Generalizable variables corresponds to metas created-        -- at the point where they should be generalized. Module parameters-        -- have already been applied to the meta, so we don't have to do that-        -- here.-        val <- fromMaybe __IMPOSSIBLE__ <$> viewTC (eGeneralizedVars . key x)-        sub <- checkpointSubstitution (genvalCheckpoint val)-        let (v, t) = applySubst sub (genvalTerm val, genvalType val)-        debug [] t v-        return (v, t)-      _ -> do-        -- since x is considered living in the top-level, we have to-        -- apply it to the current context-        vs <- freeVarsToApply x-        reportSDoc "tc.term.def" 30 $ "  free vars:" <+> prettyList_ (map prettyTCM vs)-        let t = defType d-            v = mkTerm vs -- applies x to vs, dropping parameters--        -- Andrea 2019-07-16, Check that the supplied arguments-        -- respect the cohesion modalities of the current context.-        -- Cohesion is purely based on left-division, so it does not-        -- rely on "position" like Relevance/Quantity.-        checkCohesionArgs vs--        debug vs t v-        return (v, t)-  where-    debug :: Args -> Type -> Term -> TCM ()-    debug vs t v = do-      reportSDoc "tc.term.def" 60 $-        "freeVarsToApply to def " <+> hsep (map (text . show) vs)-      reportSDoc "tc.term.def" 10 $ vcat-        [ "inferred def " <+> prettyTCM x <+> hsep (map prettyTCM vs)-        , nest 2 $ ":" <+> prettyTCM t-        , nest 2 $ "-->" <+> prettyTCM v ]--checkCohesionArgs :: Args -> TCM ()-checkCohesionArgs vs = do-  let-    vmap :: VarMap-    vmap = freeVars vs--  -- we iterate over all vars in the context and their ArgInfo,-  -- checking for each that "vs" uses them as allowed.-  as <- getContextArgs-  forM_ as $ \ (Arg avail t) -> do-    let m = do-          v <- deBruijnView t-          varModality <$> lookupVarMap v vmap-    whenJust m $ \ used -> do-        unless (getCohesion avail `moreCohesion` getCohesion used) $-           (genericDocError =<<) $ fsep $-                ["Variable" , prettyTCM t]-             ++ pwords "is used as" ++ [text $ show $ getCohesion used]-             ++ pwords "but only available as" ++ [text $ show $ getCohesion avail]---- | The second argument is the definition of the first.---   Returns 'Nothing' if ok, otherwise the error message.-checkRelevance' :: QName -> Definition -> TCM (Maybe TypeError)-checkRelevance' x def = do-  case getRelevance def of-    Relevant -> return Nothing -- relevance functions can be used in any context.-    drel -> do-      -- Andreas,, 2018-06-09, issue #2170-      -- irrelevant projections are only allowed if --irrelevant-projections-      ifM (return (isJust $ isProjection_ $ theDef def) `and2M`-           (not .optIrrelevantProjections <$> pragmaOptions)) {-then-} needIrrProj {-else-} $ do-        rel <- asksTC getRelevance-        reportSDoc "tc.irr" 50 $ vcat-          [ "declaration relevance =" <+> text (show drel)-          , "context     relevance =" <+> text (show rel)-          ]-        return $ if (drel `moreRelevant` rel) then Nothing else Just $ DefinitionIsIrrelevant x-  where-  needIrrProj = Just . GenericDocError <$> do-    sep [ "Projection " , prettyTCM x, " is irrelevant."-        , " Turn on option --irrelevant-projections to use it (unsafe)."-        ]---- | The second argument is the definition of the first.---   Returns 'Nothing' if ok, otherwise the error message.-checkQuantity' :: QName -> Definition -> TCM (Maybe TypeError)-checkQuantity' x def = do-  case getQuantity def of-    dq@Quantityω{} -> do-      reportSDoc "tc.irr" 50 $ vcat-        [ "declaration quantity =" <+> text (show dq)-        -- , "context     quantity =" <+> text (show q)-        ]-      return Nothing -- Abundant definitions can be used in any context.-    dq -> do-      q <- asksTC getQuantity-      reportSDoc "tc.irr" 50 $ vcat-        [ "declaration quantity =" <+> text (show dq)-        , "context     quantity =" <+> text (show q)-        ]-      return $ if (dq `moreQuantity` q) then Nothing else Just $ DefinitionIsErased x---- | The second argument is the definition of the first.-checkModality' :: QName -> Definition -> TCM (Maybe TypeError)-checkModality' x def = do-  checkRelevance' x def >>= \case-    Nothing    -> checkQuantity' x def-    err@Just{} -> return err---- | The second argument is the definition of the first.-checkModality :: QName -> Definition -> TCM ()-checkModality x def = justToError $ checkModality' x def-  where-  justToError m = maybe (return ()) typeError =<< m---- | @checkHeadApplication e t hd args@ checks that @e@ has type @t@,--- assuming that @e@ has the form @hd args@. The corresponding--- type-checked term is returned.------ If the head term @hd@ is a coinductive constructor, then a--- top-level definition @fresh tel = hd args@ (where the clause is--- delayed) is added, where @tel@ corresponds to the current--- telescope. The returned term is @fresh tel@.------ Precondition: The head @hd@ has to be unambiguous, and there should--- not be any need to insert hidden lambdas.-checkHeadApplication :: Comparison -> A.Expr -> Type -> A.Expr -> [NamedArg A.Expr] -> TCM Term-checkHeadApplication cmp e t hd args = do-  SortKit{..} <- sortKit-  sharp <- fmap nameOfSharp <$> coinductionKit-  conId  <- getNameOfConstrained builtinConId-  pOr    <- getNameOfConstrained builtinPOr-  pComp  <- getNameOfConstrained builtinComp-  pHComp <- getNameOfConstrained builtinHComp-  pTrans <- getNameOfConstrained builtinTrans-  mglue  <- getNameOfConstrained builtin_glue-  mglueU  <- getNameOfConstrained builtin_glueU-  case hd of-    A.Def' c s | c == nameOfSet      -> checkSet cmp e t c s args-    A.Def' c s | c == nameOfProp     -> checkProp cmp e t c s args-    A.Def' c s | c == nameOfSSet     -> checkSSet cmp e t c s args-    A.Def' c s | c == nameOfSetOmega IsFibrant -> checkSetOmega cmp e t c IsFibrant s args-    A.Def' c s | c == nameOfSetOmega IsStrict  -> checkSetOmega cmp e t c IsStrict s args--    -- Type checking #. The # that the user can write will be a Def, but the-    -- sharp we generate in the body of the wrapper is a Con.-    A.Def c | Just c == sharp -> checkSharpApplication e t c args--    -- Cubical primitives-    A.Def c | Just c == pComp -> defaultResult' $ Just $ checkPrimComp c-    A.Def c | Just c == pHComp -> defaultResult' $ Just $ checkPrimHComp c-    A.Def c | Just c == pTrans -> defaultResult' $ Just $ checkPrimTrans c-    A.Def c | Just c == conId -> defaultResult' $ Just $ checkConId c-    A.Def c | Just c == pOr   -> defaultResult' $ Just $ checkPOr c-    A.Def c | Just c == mglue -> defaultResult' $ Just $ check_glue c-    A.Def c | Just c == mglueU -> defaultResult' $ Just $ check_glueU c--    _ -> defaultResult-  where-  defaultResult :: TCM Term-  defaultResult = defaultResult' Nothing-  defaultResult' :: Maybe (MaybeRanges -> Args -> Type -> TCM Args) -> TCM Term-  defaultResult' mk = do-    (f, t0) <- inferHead hd-    expandLast <- asksTC envExpandLast-    checkArguments cmp expandLast (getRange hd) args t0 t $ \ st@(ACState rs vs _ t1 checkedTarget) -> do-      let check = do-           k <- mk-           as <- allApplyElims vs-           pure $ k rs as t1-      vs <- case check of-              Just ck -> do-                map Apply <$> ck-              Nothing -> do-                return vs-      v <- unfoldInlined =<< checkHeadConstraints f (st { acElims = vs })-      coerce' cmp checkedTarget v t1 t---- Issue #3019 and #4170: Don't insert trailing implicits when checking arguments to existing--- metavariables.-turnOffExpandLastIfExistingMeta :: A.Expr -> TCM a -> TCM a-turnOffExpandLastIfExistingMeta hd-  | isExistingMeta = reallyDontExpandLast-  | otherwise      = id-  where-    isExistingMeta = isJust $ A.metaNumber =<< metaInfo hd-    metaInfo (A.QuestionMark i _) = Just i-    metaInfo (A.Underscore i)     = Just i-    metaInfo (A.ScopedExpr _ e)   = metaInfo e-    metaInfo _                    = Nothing---------------------------------------------------------------------------------- * Spines--------------------------------------------------------------------------------traceCallE :: Call -> ExceptT e TCM r -> ExceptT e TCM r-traceCallE call m = do-  z <- lift $ traceCall call $ runExceptT m-  case z of-    Right e  -> return e-    Left err -> throwError err---- | If we've already checked the target type we don't have to call coerce.-coerce' :: Comparison -> CheckedTarget -> Term -> Type -> Type -> TCM Term-coerce' cmp NotCheckedTarget           v inferred expected = coerce cmp v inferred expected-coerce' cmp (CheckedTarget Nothing)    v _        _        = return v-coerce' cmp (CheckedTarget (Just pid)) v _        expected = blockTermOnProblem expected v pid---- | Check a list of arguments: @checkArgs args t0 t1@ checks that---   @t0 = Delta -> t0'@ and @args : Delta@. Inserts hidden arguments to---   make this happen.  Returns the evaluated arguments @vs@, the remaining---   type @t0'@ (which should be a subtype of @t1@) and any constraints @cs@---   that have to be solved for everything to be well-formed.--checkArgumentsE :: Comparison -> ExpandHidden -> Range -> [NamedArg A.Expr] -> Type -> Maybe Type ->-                   ExceptT (ArgsCheckState [NamedArg A.Expr]) TCM (ArgsCheckState CheckedTarget)-checkArgumentsE = checkArgumentsE' NotCheckedTarget--checkArgumentsE'-  :: CheckedTarget     -- ^ Have we already checked the target?-  -> Comparison        -- ^ Comparison to use if checking target type-  -> ExpandHidden      -- ^ Insert trailing hidden arguments?-  -> Range             -- ^ Range of the function.-  -> [NamedArg A.Expr] -- ^ Arguments.-  -> Type              -- ^ Type of the function.-  -> Maybe Type        -- ^ Type of the application.-  -> ExceptT (ArgsCheckState [NamedArg A.Expr]) TCM (ArgsCheckState CheckedTarget)---- Case: no arguments, do not insert trailing hidden arguments: We are done.-checkArgumentsE' chk cmp exh _ [] t0 _ | isDontExpandLast exh = return $ ACState [] [] [] t0 chk---- Case: no arguments, but need to insert trailing hiddens.-checkArgumentsE' chk cmp _ExpandLast r [] t0 mt1 =-    traceCallE (CheckArguments r [] t0 mt1) $ lift $ do-      mt1' <- traverse (unEl <.> reduce) mt1-      (us, t) <- implicitArgs (-1) (expand mt1') t0-      return $ ACState (replicate (length us) Nothing) (map Apply us) (replicate (length us) Nothing) t chk-    where-      expand (Just (Pi dom _)) Hidden     = not (hidden dom)-      expand _                 Hidden     = True-      expand (Just (Pi dom _)) Instance{} = not (isInstance dom)-      expand _                 Instance{} = True-      expand _                 NotHidden  = False---- Case: argument given.-checkArgumentsE' chk cmp exh r args0@(arg@(Arg info e) : args) t0 mt1 =-    traceCallE (CheckArguments r args0 t0 mt1) $ do-      lift $ reportSDoc "tc.term.args" 30 $ sep-        [ "checkArgumentsE"---        , "  args0 =" <+> prettyA args0-        , nest 2 $ vcat-          [ "e     =" <+> prettyA e-          , "t0    =" <+> prettyTCM t0-          , "t1    =" <+> maybe "Nothing" prettyTCM mt1-          ]-        ]-      -- First, insert implicit arguments, depending on current argument @arg@.-      let hx = getHiding info  -- hiding of current argument-          mx :: Maybe ArgName-          mx = bareNameOf e    -- name of current argument-          -- do not insert visible arguments-          expand NotHidden y = False-          -- insert a hidden argument if arg is not hidden or has different name-          -- insert an instance argument if arg is not instance  or has different name-          expand hy        y = not (sameHiding hy hx) || maybe False (y /=) mx-      reportSDoc "tc.term.args" 30 $ vcat-        [ "calling implicitNamedArgs"-        , nest 2 $ "t0 = " <+> prettyTCM t0-        , nest 2 $ "hx = " <+> text (show hx)-        , nest 2 $ "mx = " <+> maybe "nothing" prettyTCM mx-        ]-      (nargs, t) <- lift $ implicitNamedArgs (-1) expand t0-      -- Separate names from args.-      let (mxs, us) = unzip $ map (\ (Arg ai (Named mx u)) -> (mx, Apply $ Arg ai u)) nargs-          xs        = catMaybes mxs--      -- We need a function type here, but we don't know which kind-      -- (implicit/explicit). But it might be possible to use injectivity to-      -- force a pi.-      t <- lift $ forcePiUsingInjectivity t--      -- We are done inserting implicit args.  Now, try to check @arg@.-      ifBlocked t (\ m t -> throwError $ ACState (replicate (length us) Nothing) us (replicate (length us) Nothing) t args0) $ \ _ t0' -> do--        -- What can go wrong?--        -- 1. We ran out of function types.-        let shouldBePi-              -- a) It is an explicit argument, but we ran out of function types.-              | visible info = lift $ typeError $ ShouldBePi t0'-              -- b) It is an implicit argument, and we did not insert any implicits.-              --    Thus, the type was not a function type to start with.-              | null xs        = lift $ typeError $ ShouldBePi t0'-              -- c) We did insert implicits, but we ran out of implicit function types.-              --    Then, we should inform the user that we did not find his one.-              | otherwise      = lift $ typeError $ WrongNamedArgument arg xs--        -- 2. We have a function type left, but it is the wrong one.-        --    Our argument must be implicit, case a) is impossible.-        --    (Otherwise we would have ran out of function types instead.)-        let wrongPi-              -- b) We have not inserted any implicits.-              | null xs   = lift $ typeError $ WrongHidingInApplication t0'-              -- c) We inserted implicits, but did not find his one.-              | otherwise = lift $ typeError $ WrongNamedArgument arg xs--        viewPath <- lift pathView'--        -- Check the target type if we can get away with it.-        chk' <- lift $-          case (chk, mt1) of-            (NotCheckedTarget, Just t1) | all visible args0 -> do-              let n = length args0-              TelV tel tgt <- telViewUpTo n t0'-              let dep = any (< n) $ IntSet.toList $ freeVars tgt-                  vis = all visible (telToList tel)-                  isRigid t | PathType{} <- viewPath t = return False -- Path is not rigid!-                  isRigid (El _ (Pi dom _)) = return $ visible dom-                  isRigid (El _ (Def d _))  = getConstInfo d <&> theDef <&> \ case-                    Axiom{}                   -> True-                    DataOrRecSig{}            -> True-                    AbstractDefn{}            -> True-                    Function{funClauses = cs} -> null cs-                    Datatype{}                -> True-                    Record{}                  -> True-                    Constructor{}             -> __IMPOSSIBLE__-                    GeneralizableVar{}        -> __IMPOSSIBLE__-                    Primitive{}               -> False-                    PrimitiveSort{}           -> False-                  isRigid _           = return False-              rigid <- isRigid tgt-              -- Andreas, 2019-03-28, issue #3248:-              -- If the target type is SIZELT, we need coerce, leqType is insufficient.-              -- For example, we have i : Size <= (Size< ↑ i), but not Size <= (Size< ↑ i).-              isSizeLt <- reduce t1 >>= isSizeType <&> \case-                Just (BoundedLt _) -> True-                _ -> False-              if | dep       -> return chk    -- must be non-dependent-                 | not rigid -> return chk    -- with a rigid target-                 | not vis   -> return chk    -- and only visible arguments-                 | isSizeLt  -> return chk    -- Issue #3248, not Size<-                 | otherwise -> do-                  let tgt1 = applySubst (strengthenS impossible $ size tel) tgt-                  reportSDoc "tc.term.args.target" 30 $ vcat-                    [ "Checking target types first"-                    , nest 2 $ "inferred =" <+> prettyTCM tgt1-                    , nest 2 $ "expected =" <+> prettyTCM t1 ]-                  traceCall (CheckTargetType (fuseRange r args0) tgt1 t1) $-                    CheckedTarget <$> ifNoConstraints_ (compareType cmp tgt1 t1)-                                        (return Nothing) (return . Just)--            _ -> return chk--        -- t0' <- lift $ forcePi (getHiding info) (maybe "_" rangedThing $ nameOf e) t0'-        case unEl t0' of-          Pi (Dom{domInfo = info', domName = dname, unDom = a}) b-            | let name = bareNameWithDefault "_" dname,-              sameHiding info info'-              && (visible info || maybe True (name ==) mx) -> do-                u <- lift $ applyModalityToContext info' $ do-                 -- Andreas, 2014-05-30 experiment to check non-dependent arguments-                 -- after the spine has been processed.  Allows to propagate type info-                 -- from ascribed type into extended-lambdas.  Would solve issue 1159.-                 -- However, leaves unsolved type checking problems in the test suite.-                 -- I do not know what I am doing wrong here.-                 -- Could be extreme order-sensitivity or my abuse of the postponing-                 -- mechanism.-                 -- Andreas, 2016-02-02: Ulf says unless there is actually some meta-                 -- blocking a postponed type checking problem, we might never retry,-                 -- since the trigger for retrying constraints is solving a meta.-                 -- Thus, the following naive use violates some invariant.-                 -- if not $ isBinderUsed b-                 -- then postponeTypeCheckingProblem (CheckExpr (namedThing e) a) (return True) else-                  let e' = e { nameOf = (nameOf e) <|> dname }-                  checkNamedArg (Arg info' e') a--                let c | IsLock == getLock info' = Just $ Abs "t" (CheckLockedVars (Var 0 []) (raise 1 t0') (raise 1 $ Arg info' u) (raise 1 a))-                      | otherwise = Nothing-                lift $ reportSDoc "tc.term.lock" 40 $ text "lock =" <+> text (show $ getLock info')-                lift $ reportSDoc "tc.term.lock" 40 $ addContext (defaultDom $ t0') $ maybe (text "nothing") prettyTCM (absBody <$> c)-                -- save relevance info' from domain in argument-                addCheckedArgs us (getRange e) (Apply $ Arg info' u) c $-                  checkArgumentsE' chk' cmp exh (fuseRange r e) args (absApp b u) mt1-            | otherwise -> do-                reportSDoc "error" 10 $ nest 2 $ vcat-                  [ text $ "info      = " ++ show info-                  , text $ "info'     = " ++ show info'-                  , text $ "absName b = " ++ absName b-                  , text $ "nameOf e  = " ++ show (nameOf e)-                  ]-                wrongPi-          _-            | visible info-            , PathType s _ _ bA x y <- viewPath t0' -> do-                lift $ reportSDoc "tc.term.args" 30 $ text $ show bA-                u <- lift $ checkExpr (namedThing e) =<< primIntervalType-                addCheckedArgs us (getRange e) (IApply (unArg x) (unArg y) u) Nothing $-                  checkArgumentsE cmp exh (fuseRange r e) args (El s $ unArg bA `apply` [argN u]) mt1-          _ -> shouldBePi-  where-    -- Andrea: Here one would add constraints too.-    addCheckedArgs us r u c rec = do-        st@ACState{acRanges = rs, acElims = vs} <- rec-        let rs' = replicate (length us) Nothing ++ Just r : rs-            cs' = replicate (length us) Nothing ++ c : acConstraints st-        return $ st { acRanges = rs', acElims = us ++ u : vs, acConstraints = cs' }-      `catchError` \ st@ACState{acRanges = rs, acElims = vs} -> do-          let rs' = replicate (length us) Nothing ++ Just r : rs-              cs' = replicate (length us) Nothing ++ c : acConstraints st-          throwError $ st { acRanges = rs', acElims = us ++ u : vs, acConstraints = cs' }---- | Check that a list of arguments fits a telescope.---   Inserts hidden arguments as necessary.---   Returns the type-checked arguments and the remaining telescope.-checkArguments_-  :: Comparison           -- ^ Comparison for target-  -> ExpandHidden         -- ^ Eagerly insert trailing hidden arguments?-  -> Range                -- ^ Range of application.-  -> [NamedArg A.Expr]    -- ^ Arguments to check.-  -> Telescope            -- ^ Telescope to check arguments against.-  -> TCM (Elims, Telescope)-     -- ^ Checked arguments and remaining telescope if successful.-checkArguments_ cmp exh r args tel = postponeInstanceConstraints $ do-    z <- runExceptT $-      checkArgumentsE cmp exh r args (telePi tel __DUMMY_TYPE__) Nothing-    case z of-      Right (ACState _ args cs t _) | all isNothing cs -> do-        let TelV tel' _ = telView' t-        return (args, tel')-                                    | otherwise -> do-        typeError $ GenericError $ "Head constraints are not (yet) supported in this position."-      Left _ -> __IMPOSSIBLE__  -- type cannot be blocked as it is generated by telePi---- | @checkArguments cmp exph r args t0 t k@ tries @checkArgumentsE exph args t0 t@.--- If it succeeds, it continues @k@ with the returned results.  If it fails,--- it registers a postponed typechecking problem and returns the resulting new--- meta variable.------ Checks @e := ((_ : t0) args) : t@.-checkArguments ::-  Comparison -> ExpandHidden -> Range -> [NamedArg A.Expr] -> Type -> Type ->-  (ArgsCheckState CheckedTarget -> TCM Term) -> TCM Term-checkArguments cmp exph r args t0 t k = postponeInstanceConstraints $ do-  z <- runExceptT $ checkArgumentsE cmp exph r args t0 (Just t)-  case z of-    Right st -> k st-      -- vs = evaluated args-      -- t1 = remaining type (needs to be subtype of t)-    Left problem -> postponeArgs problem cmp exph r args t k-      -- if unsuccessful, postpone checking until t0 unblocks--postponeArgs :: (ArgsCheckState [NamedArg A.Expr]) -> Comparison -> ExpandHidden -> Range -> [NamedArg A.Expr] -> Type ->-                (ArgsCheckState CheckedTarget -> TCM Term) -> TCM Term-postponeArgs (ACState rs us cs t0 es) cmp exph r args t k = do-  reportSDoc "tc.term.expr.args" 80 $-    sep [ "postponed checking arguments"-        , nest 4 $ prettyList (map (prettyA . namedThing . unArg) args)-        , nest 2 $ "against"-        , nest 4 $ prettyTCM t0 ] $$-    sep [ "progress:"-        , nest 2 $ "checked" <+> prettyList (map prettyTCM us)-        , nest 2 $ "remaining" <+> sep [ prettyList (map (prettyA . namedThing . unArg) es)-                                            , nest 2 $ ":" <+> prettyTCM t0 ] ]-  postponeTypeCheckingProblem_ (CheckArgs cmp exph r es t0 t $ \ (ACState rs' vs cs' t pid) -> k $ ACState (rs ++ rs') (us ++ vs) (cs ++ cs') t pid)---------------------------------------------------------------------------------- * Constructors---------------------------------------------------------------------------------- | Check the type of a constructor application. This is easier than---   a general application since the implicit arguments can be inserted---   without looking at the arguments to the constructor.-checkConstructorApplication :: Comparison -> A.Expr -> Type -> ConHead -> [NamedArg A.Expr] -> TCM Term-checkConstructorApplication cmp org t c args = do-  reportSDoc "tc.term.con" 50 $ vcat-    [ "entering checkConstructorApplication"-    , nest 2 $ vcat-      [ "org  =" <+> prettyTCM org-      , "t    =" <+> prettyTCM t-      , "c    =" <+> prettyTCM c-      , "args =" <+> prettyTCM args-    ] ]--  cdef  <- getConInfo c--  checkModality (conName c) cdef--  let paramsGiven = checkForParams args-  if paramsGiven then fallback else do-    reportSDoc "tc.term.con" 50 $ "checkConstructorApplication: no parameters explicitly supplied, continuing..."--    let Constructor{conData = d, conPars = npars} = theDef cdef-    reportSDoc "tc.term.con" 50 $ nest 2 $ "d    =" <+> prettyTCM d-    -- Issue 661: t maybe an evaluated form of d .., so we evaluate d-    -- as well and then check wether we deal with the same datatype-    t0 <- reduce (Def d [])-    tReduced <- reduce t-    case (t0, unEl tReduced) of -- Only fully applied constructors get special treatment-      (Def d0 _, Def d' es) -> do-        let ~(Just vs) = allApplyElims es-        reportSDoc "tc.term.con" 50 $ nest 2 $ "d0   =" <+> prettyTCM d0-        reportSDoc "tc.term.con" 50 $ nest 2 $ "d'   =" <+> prettyTCM d'-        reportSDoc "tc.term.con" 50 $ nest 2 $ "vs   =" <+> prettyTCM vs-        if d' /= d0 then fallback else do-         -- Issue 661: d' may take more parameters than d, in particular-         -- these additional parameters could be a module parameter telescope.-         -- Since we get the constructor type ctype from d but the parameters-         -- from t = Def d' vs, we drop the additional parameters.-         npars' <- getNumberOfParameters d'-         caseMaybe (sequenceA $ Pair (Just npars) npars') fallback $ \ (Pair n n') -> do-           reportSDoc "tc.term.con" 50 $ nest 2 $ text $ "n    = " ++ show n-           reportSDoc "tc.term.con" 50 $ nest 2 $ text $ "n'   = " ++ show n'-           when (n > n')  -- preprocessor does not like ', so put on next line-             __IMPOSSIBLE__-           let ps    = take n $ drop (n' - n) vs-               ctype = defType cdef-           reportSDoc "tc.term.con" 20 $ vcat-             [ "special checking of constructor application of" <+> prettyTCM c-             , nest 2 $ vcat [ "ps     =" <+> prettyTCM ps-                             , "ctype  =" <+> prettyTCM ctype ] ]-           let ctype' = ctype `piApply` ps-           reportSDoc "tc.term.con" 20 $ nest 2 $ "ctype' =" <+> prettyTCM ctype'-           -- get the parameter names-           let TelV ptel _ = telView'UpTo n ctype-           let pnames = map (fmap fst) $ telToList ptel-           -- drop the parameter arguments-               args' = dropArgs pnames args-           -- check the non-parameter arguments-           expandLast <- asksTC envExpandLast-           checkArguments cmp expandLast (getRange c) args' ctype' t $ \ st@(ACState _ _ _ t' targetCheck) -> do-             reportSDoc "tc.term.con" 20 $ nest 2 $ vcat-               [ text "es     =" <+> prettyTCM es-               , text "t'     =" <+> prettyTCM t' ]-             v <- checkHeadConstraints (Con c ConOCon) st-             coerce' cmp targetCheck v t' t-      _ -> do-        reportSDoc "tc.term.con" 50 $ nest 2 $ "we are not at a datatype, falling back"-        fallback-  where-    fallback = checkHeadApplication cmp org t (A.Con (unambiguous $ conName c)) args--    -- Check if there are explicitly given hidden arguments,-    -- in which case we fall back to default type checking.-    -- We could work harder, but let's not for now.-    ---    -- Andreas, 2012-04-18: if all inital args are underscores, ignore them-    checkForParams args =-      let (hargs, rest) = break visible args-          notUnderscore A.Underscore{} = False-          notUnderscore _              = True-      in  any (notUnderscore . unScope . namedArg) hargs--    -- Drop the constructor arguments that correspond to parameters.-    dropArgs [] args                = args-    dropArgs ps []                  = args-    dropArgs ps args@(arg : args')-      | Just p   <- name,-        Just ps' <- namedPar p ps   = dropArgs ps' args'-      | Nothing  <- name,-        Just ps' <- unnamedPar h ps = dropArgs ps' args'-      | otherwise                   = args-      where-        name = bareNameOf arg-        h    = getHiding arg--        namedPar   x = dropPar ((x ==) . unDom)-        unnamedPar h = dropPar (sameHiding h)--        dropPar this (p : ps) | this p    = Just ps-                              | otherwise = dropPar this ps-        dropPar _ [] = Nothing---- | Returns an unblocking action in case of failure.-disambiguateConstructor :: List1 QName -> Type -> TCM (Either Blocker ConHead)-disambiguateConstructor cs0 t = do-  reportSLn "tc.check.term.con" 40 $ "Ambiguous constructor: " ++ prettyShow cs0--  -- Get the datatypes of the various constructors-  let getData Constructor{conData = d} = d-      getData _                        = __IMPOSSIBLE__-  reportSLn "tc.check.term.con" 40 $ "  ranges before: " ++ prettyShow (getRange cs0)-  -- We use the reduced constructor when disambiguating, but-  -- the original constructor for type checking. This is important-  -- since they may have different types (different parameters).-  -- See issue 279.-  -- Andreas, 2017-08-13, issue #2686: ignore abstract constructors-  ccons  <- List1.rights <$> do-     forM cs0 $ \ c -> mapRight (c,) <$> getConForm c-  reportSLn "tc.check.term.con" 40 $ "  reduced: " ++ prettyShow (map snd ccons)-  case ccons of-    []    -> typeError $ AbstractConstructorNotInScope $ List1.head cs0-    [(c0,con)] -> do-      let c = setConName c0 con-      reportSLn "tc.check.term.con" 40 $ "  only one non-abstract constructor: " ++ prettyShow c-      storeDisambiguatedConstructor (conInductive c) (conName c)-      return (Right c)-    (c0,_):_   -> do-      dcs <- forM ccons $ \ (c, con) -> (, setConName c con) . getData . theDef <$> getConInfo con-      -- Type error-      let badCon t = typeError $ DoesNotConstructAnElementOf c0 t-      -- Lets look at the target type at this point-      TelV tel t1 <- telViewPath t-      addContext tel $ do-       reportSDoc "tc.check.term.con" 40 $ nest 2 $-         "target type: " <+> prettyTCM t1-       ifBlocked t1 (\ b t -> return $ Left b) $ \ _ t' ->-         caseMaybeM (isDataOrRecord $ unEl t') (badCon t') $ \ d ->-           case [ c | (d', c) <- dcs, d == d' ] of-             [c] -> do-               reportSLn "tc.check.term.con" 40 $ "  decided on: " ++ prettyShow c-               storeDisambiguatedConstructor (conInductive c) (conName c)-               return $ Right c-             []  -> badCon $ t' $> Def d []-             c:cs-> typeError $ CantResolveOverloadedConstructorsTargetingSameDatatype d $-                      fmap conName $ c :| cs-------------------------------------------------------------------------------- * Projections------------------------------------------------------------------------------checkUnambiguousProjectionApplication :: Comparison -> A.Expr -> Type -> QName -> ProjOrigin -> A.Expr -> [NamedArg A.Expr] -> TCM Term-checkUnambiguousProjectionApplication cmp e t x o hd args = do-  let fallback = checkHeadApplication cmp e t hd args-  -- Andreas, 2021-02-19, issue #3289-  -- If a postfix projection was moved to the head by appView,-  -- we have to patch the first argument with the correct hiding info.-  case (o, args) of-    (ProjPostfix, arg : rest) -> do-      -- Andreas, 2021-11-19, issue #5657:-      -- If @x@ has been brought into scope by e.g. @open R r@, it is no longer-      -- a projection even though the scope checker labels it so.-      -- Thus, @isProjection@ may fail.-      caseMaybeM (isProjection x) fallback $ \ pr -> do-        checkHeadApplication cmp e t hd (setArgInfo (projArgInfo pr) arg : rest)-    _ -> fallback---- | Inferring the type of an overloaded projection application.---   See 'inferOrCheckProjApp'.--inferProjApp :: A.Expr -> ProjOrigin -> List1 QName -> A.Args -> TCM (Term, Type)-inferProjApp e o ds args0 = do-  (v, t, _) <- inferOrCheckProjApp e o ds args0 Nothing-  return (v, t)---- | Checking the type of an overloaded projection application.---   See 'inferOrCheckProjApp'.--checkProjApp  :: Comparison -> A.Expr -> ProjOrigin -> List1 QName -> A.Args -> Type -> TCM Term-checkProjApp cmp e o ds args0 t = do-  (v, ti, targetCheck) <- inferOrCheckProjApp e o ds args0 (Just (cmp, t))-  coerce' cmp targetCheck v ti t---- | Checking the type of an overloaded projection application.---   See 'inferOrCheckProjAppToKnownPrincipalArg'.--checkProjAppToKnownPrincipalArg  :: Comparison -> A.Expr -> ProjOrigin -> List1 QName -> A.Args -> Type -> Int -> Term -> Type -> PrincipalArgTypeMetas -> TCM Term-checkProjAppToKnownPrincipalArg cmp e o ds args0 t k v0 pt patm = do-  (v, ti, targetCheck) <- inferOrCheckProjAppToKnownPrincipalArg e o ds args0 (Just (cmp, t)) k v0 pt (Just patm)-  coerce' cmp targetCheck v ti t---- | Inferring or Checking an overloaded projection application.------   The overloaded projection is disambiguated by inferring the type of its---   principal argument, which is the first visible argument.--inferOrCheckProjApp-  :: A.Expr-     -- ^ The whole expression which constitutes the application.-  -> ProjOrigin-     -- ^ The origin of the projection involved in this projection application.-  -> List1 QName-     -- ^ The projection name (potentially ambiguous).-  -> A.Args-     -- ^ The arguments to the projection.-  -> Maybe (Comparison, Type)-     -- ^ The expected type of the expression (if 'Nothing', infer it).-  -> TCM (Term, Type, CheckedTarget)-     -- ^ The type-checked expression and its type (if successful).-inferOrCheckProjApp e o ds args mt = do-  reportSDoc "tc.proj.amb" 20 $ vcat-    [ "checking ambiguous projection"-    , text $ "  ds   = " ++ prettyShow ds-    , text   "  args = " <+> sep (map prettyTCM args)-    , text   "  t    = " <+> caseMaybe mt "Nothing" prettyTCM-    ]--  let cmp = caseMaybe mt CmpEq fst--      -- Postpone the whole type checking problem-      -- if type of principal argument (or the type where we get it from)-      -- is blocked by meta m.-      postpone b = do-        tc <- caseMaybe mt newTypeMeta_ (return . snd)-        v <- postponeTypeCheckingProblem (CheckExpr cmp e tc) b-        return (v, tc, NotCheckedTarget)--  -- The following cases need to be considered:-  -- 1. No arguments to the projection.-  -- 2. Arguments (parameters), but not the principal argument.-  -- 3. Argument(s) including the principal argument.--  -- For now, we only allow ambiguous projections if the first visible-  -- argument is the record value.--  case filter (visible . snd) $ zip [0..] args of--    -- Case: we have no visible argument to the projection.-    -- In inference mode, we really need the visible argument, postponing does not help-    [] -> caseMaybe mt (refuseProjNotApplied ds) $ \ (cmp , t) -> do-      -- If we have the type, we can try to get the type of the principal argument.-      -- It is the first visible argument.-      TelV _ptel core <- telViewUpTo' (-1) (not . visible) t-      ifBlocked core (\ m _ -> postpone m) $ {-else-} \ _ core -> do-      ifNotPiType core (\ _ -> refuseProjNotApplied ds) $ {-else-} \ dom _b -> do-      ifBlocked (unDom dom) (\ m _ -> postpone m) $ {-else-} \ _ ta -> do-      caseMaybeM (isRecordType ta) (refuseProjNotRecordType ds) $ \ (_q, _pars, defn) -> do-      case defn of-        Record { recFields = fs } -> do-          case forMaybe fs $ \ f -> Fold.find (unDom f ==) ds of-            [] -> refuseProjNoMatching ds-            [d] -> do-              storeDisambiguatedProjection d-              -- checkHeadApplication will check the target type-              (, t, CheckedTarget Nothing) <$>-                checkHeadApplication cmp e t (A.Proj o $ unambiguous d) args-            _ -> __IMPOSSIBLE__-        _ -> __IMPOSSIBLE__--    -- Case: we have a visible argument-    ((k, arg) : _) -> do-      (v0, ta) <- inferExpr $ namedArg arg-      reportSDoc "tc.proj.amb" 25 $ vcat-        [ "  principal arg " <+> prettyTCM arg-        , "  has type "      <+> prettyTCM ta-        ]-      inferOrCheckProjAppToKnownPrincipalArg e o ds args mt k v0 ta Nothing---- | Same arguments 'inferOrCheckProjApp' above but also gets the position,---   value and type of the principal argument.-inferOrCheckProjAppToKnownPrincipalArg-  :: A.Expr-     -- ^ The whole expression which constitutes the application.-  -> ProjOrigin-     -- ^ The origin of the projection involved in this projection application.-  -> List1 QName-     -- ^ The projection name (potentially ambiguous).-  -> A.Args-     -- ^ The arguments to the projection.-  -> Maybe (Comparison, Type)-     -- ^ The expected type of the expression (if 'Nothing', infer it).-  -> Int-     -- ^ The position of the principal argument.-  -> Term-     -- ^ The value of the principal argument.-  -> Type-     -- ^ The type of the principal argument.-  -> Maybe PrincipalArgTypeMetas-     -- ^ The metas previously created for the principal argument's type, when-     --   picking up a postponed problem. 'Nothing', otherwise.-  -> TCM (Term, Type, CheckedTarget)-     -- ^ The type-checked expression and its type (if successful).-inferOrCheckProjAppToKnownPrincipalArg e o ds args mt k v0 ta mpatm = do-  let cmp = caseMaybe mt CmpEq fst-      postpone b patm = do-        tc <- caseMaybe mt newTypeMeta_ (return . snd)-        v <- postponeTypeCheckingProblem (CheckProjAppToKnownPrincipalArg cmp e o ds args tc k v0 ta patm) b-        return (v, tc, NotCheckedTarget)-  -- ta should be a record type (after introducing the hidden args in v0)-  patm@(PrincipalArgTypeMetas vargs ta) <- case mpatm of-    -- keep using the previously created metas, when picking up a postponed-    -- problem - see #4924-    Just patm -> return patm-    -- create fresh metas-    Nothing -> uncurry PrincipalArgTypeMetas <$> implicitArgs (-1) (not . visible) ta-  let v = v0 `apply` vargs-  ifBlocked ta (\ m _ -> postpone m patm) {-else-} $ \ _ ta -> do-  caseMaybeM (isRecordType ta) (refuseProjNotRecordType ds) $ \ (q, _pars0, _) -> do--      -- try to project it with all of the possible projections-      let try d = do-            reportSDoc "tc.proj.amb" 30 $ vcat-              [ text $ "trying projection " ++ prettyShow d-              , "  td  = " <+> caseMaybeM (getDefType d ta) "Nothing" prettyTCM-              ]--            -- get the original projection name-            def <- lift $ getConstInfo d-            let isP = isProjection_ $ theDef def-            reportSDoc "tc.proj.amb" 40 $ vcat $-              text ( "  isProjection = " ++ caseMaybe isP "no" (const "yes")-                   ) : caseMaybe isP [] (\ Projection{ projProper = proper, projOrig = orig } ->-              [ text $ "  proper       = " ++ show proper-              , text $ "  orig         = " ++ prettyShow orig-              ])--            -- Andreas, 2017-01-21, issue #2422-            -- The scope checker considers inherited projections (from nested records)-            -- as projections and allows overloading.  However, since they are defined-            -- as *composition* of projections, the type checker does *not* recognize them,-            -- and @isP@ will be @Nothing@.-            -- However, we can ignore this, as we only need the @orig@inal projection name-            -- for removing false ambiguity.  Thus, we skip these checks:--            -- Projection{ projProper = proper, projOrig = orig } <- MaybeT $ return isP-            -- guard $ isJust proper-            let orig = caseMaybe isP d projOrig--            -- try to eliminate-            (dom, u, tb) <- MaybeT (projectTyped v ta o d `catchError` \ _ -> return Nothing)-            reportSDoc "tc.proj.amb" 30 $ vcat-              [ "  dom = " <+> prettyTCM dom-              , "  u   = " <+> prettyTCM u-              , "  tb  = " <+> prettyTCM tb-              ]-            (q', pars, _) <- MaybeT $ isRecordType $ unDom dom-            reportSDoc "tc.proj.amb" 30 $ vcat-              [ "  q   = " <+> prettyTCM q-              , "  q'  = " <+> prettyTCM q'-              ]-            guard (q == q')-            -- Get the type of the projection and check-            -- that the first visible argument is the record value.-            let tfull = defType def-            TelV tel _ <- lift $ telViewUpTo' (-1) (not . visible) tfull-            reportSDoc "tc.proj.amb" 30 $ vcat-              [ text $ "  size tel  = " ++ show (size tel)-              , text $ "  size pars = " ++ show (size pars)-              ]-            -- See issue 1960 for when the following assertion fails for-            -- the correct disambiguation.-            -- guard (size tel == size pars)--            guard =<< do isNothing <$> do lift $ checkModality' d def-            return (orig, (d, (pars, (dom, u, tb))))--      cands <- groupOn fst . List1.catMaybes <$> mapM (runMaybeT . try) ds-      case cands of-        [] -> refuseProjNoMatching ds-        [[]] -> refuseProjNoMatching ds-        (_:_:_) -> refuseProj ds $ "several matching candidates found: "-             ++ prettyShow (map (fst . snd) $ concat cands)-        -- case: just one matching projection d-        -- the term u = d v-        -- the type tb is the type of this application-        [ (_orig, (d, (pars, (_dom,u,tb)))) : _ ] -> do-          storeDisambiguatedProjection d--          -- Check parameters-          tfull <- typeOfConst d-          (_,_) <- checkKnownArguments (take k args) pars tfull--          -- Check remaining arguments-          let r     = getRange e-              args' = drop (k + 1) args-          z <- runExceptT $ checkArgumentsE cmp ExpandLast r args' tb (snd <$> mt)-          case z of-            Right st@(ACState _ _ _ trest targetCheck) -> do-              v <- checkHeadConstraints (u `applyE`) st-              return (v, trest, targetCheck)-            Left problem -> do-              -- In the inference case:-              -- To create a postponed type checking problem,-              -- we do not use typeDontCare, but create a meta.-              tc <- caseMaybe mt newTypeMeta_ (return . snd)-              v  <- postponeArgs problem cmp ExpandLast r args' tc $ \ st@(ACState _ _ _ trest targetCheck) -> do-                      v <- checkHeadConstraints (u `applyE`) st-                      coerce' cmp targetCheck v trest tc--              return (v, tc, NotCheckedTarget)--refuseProj :: List1 QName -> String -> TCM a-refuseProj ds reason = typeError $ GenericError $-        "Cannot resolve overloaded projection "-        ++ prettyShow (A.nameConcrete $ A.qnameName $ List1.head ds)-        ++ " because " ++ reason--refuseProjNotApplied, refuseProjNoMatching, refuseProjNotRecordType :: List1 QName -> TCM a-refuseProjNotApplied    ds = refuseProj ds "it is not applied to a visible argument"-refuseProjNoMatching    ds = refuseProj ds "no matching candidate found"-refuseProjNotRecordType ds = refuseProj ds "principal argument is not of record type"---------------------------------------------------------------------------------- * Sorts--------------------------------------------------------------------------------checkSet-  :: Comparison -> A.Expr -> Type-  -> QName -> Suffix -> [NamedArg A.Expr] -> TCM Term-checkSet = checkSetOrProp Type--checkProp-  :: Comparison -> A.Expr -> Type-  -> QName -> Suffix -> [NamedArg A.Expr] -> TCM Term-checkProp cmp e t q s args = do-  unlessM isPropEnabled $ typeError NeedOptionProp-  checkSetOrProp Prop cmp e t q s args--checkSSet-  :: Comparison -> A.Expr -> Type-  -> QName -> Suffix -> [NamedArg A.Expr] -> TCM Term-checkSSet cmp e t q s args = do-  unlessM isTwoLevelEnabled $ typeError NeedOptionTwoLevel-  checkLeveledSort SSet SSet cmp e t q s args--checkSetOrProp-  :: (Level -> Sort) -> Comparison -> A.Expr -> Type-  -> QName -> Suffix -> [NamedArg A.Expr] -> TCM Term-checkSetOrProp mkSort cmp e t q suffix args = do-  checkLeveledSort mkSort Type cmp e t q suffix args--checkLeveledSort-  :: (Level -> Sort) -> (Level -> Sort) -> Comparison -> A.Expr -> Type-  -> QName -> Suffix -> [NamedArg A.Expr] -> TCM Term-checkLeveledSort mkSort mkSortOfSort cmp e t q suffix args = do-  (v, t0) <- inferLeveledSort mkSort mkSortOfSort e q suffix args-  coerce cmp v t0 t--inferSet :: A.Expr -> QName -> Suffix -> [NamedArg A.Expr] -> TCM (Term, Type)-inferSet = inferSetOrProp Type--inferProp :: A.Expr -> QName -> Suffix -> [NamedArg A.Expr] -> TCM (Term, Type)-inferProp e q s args = do-  unlessM isPropEnabled $ typeError NeedOptionProp-  inferSetOrProp Prop e q s args--inferSSet :: A.Expr -> QName -> Suffix -> [NamedArg A.Expr] -> TCM (Term, Type)-inferSSet e q s args = do-  unlessM isTwoLevelEnabled $ typeError NeedOptionTwoLevel-  inferLeveledSort SSet SSet e q s args--inferSetOrProp-  :: (Level -> Sort) -> A.Expr-  -> QName -> Suffix -> [NamedArg A.Expr] -> TCM (Term, Type)-inferSetOrProp mkSort e q suffix args = inferLeveledSort mkSort Type e q suffix args--inferLeveledSort-  :: (Level -> Sort) -> (Level -> Sort) -> A.Expr-  -> QName -> Suffix -> [NamedArg A.Expr] -> TCM (Term, Type)-inferLeveledSort mkSort mkSortOfSort e q suffix args = case args of-  [] -> do-    let n = case suffix of-              NoSuffix -> 0-              Suffix n -> n-    return (Sort (mkSort $ ClosedLevel n) , sort (mkSortOfSort $ ClosedLevel $ n + 1))-  [arg] -> do-    unless (visible arg) $ typeError $ WrongHidingInApplication $ sort $ mkSort $ ClosedLevel 0-    unlessM hasUniversePolymorphism $ genericError-      "Use --universe-polymorphism to enable level arguments to Set"-    l <- applyRelevanceToContext NonStrict $ checkLevel arg-    return (Sort $ mkSort l , sort (mkSortOfSort $ levelSuc l))-  arg : _ -> typeError . GenericDocError =<< fsep-    [ prettyTCM q , "cannot be applied to more than one argument" ]--checkSetOmega :: Comparison -> A.Expr -> Type -> QName -> IsFibrant -> Suffix -> [NamedArg A.Expr] -> TCM Term-checkSetOmega cmp e t q f s args = do-  (v, t0) <- inferSetOmega e q f s args-  coerce cmp v t0 t--inferSetOmega :: A.Expr -> QName -> IsFibrant -> Suffix -> [NamedArg A.Expr] -> TCM (Term, Type)-inferSetOmega e q f suffix args = do-  when (f == IsStrict) $-    unlessM isTwoLevelEnabled $ typeError NeedOptionTwoLevel-  let n = case suffix of-            NoSuffix -> 0-            Suffix n -> n-  case args of-    [] -> return (Sort (Inf f n) , sort (Inf f $ 1 + n))-    arg : _ -> typeError . GenericDocError =<< fsep-        [ prettyTCM q , "cannot be applied to an argument" ]---------------------------------------------------------------------------------- * Coinduction--------------------------------------------------------------------------------checkSharpApplication :: A.Expr -> Type -> QName -> [NamedArg A.Expr] -> TCM Term-checkSharpApplication e t c args = do-  arg <- case args of-           [a] | visible a -> return $ namedArg a-           _ -> typeError $ GenericError $ prettyShow c ++ " must be applied to exactly one argument."--  -- The name of the fresh function.-  i <- fresh :: TCM Int-  let name = filter (/= '_') (prettyShow $ A.nameConcrete $ A.qnameName c) ++ "-" ++ show i--  kit <- coinductionKit'-  let flat = nameOfFlat kit-      inf  = nameOfInf  kit--  -- Add the type signature of the fresh function to the-  -- signature.-  -- To make sure we can type check the generated function we have to make-  -- sure that its type is \inf. The reason for this is that we don't yet-  -- postpone checking of patterns when we don't know their types (Issue480).-  forcedType <- do-    lvl <- levelType-    (_, l) <- newValueMeta RunMetaOccursCheck CmpLeq lvl-    lv  <- levelView l-    (_, a) <- newValueMeta RunMetaOccursCheck CmpEq (sort $ Type lv)-    return $ El (Type lv) $ Def inf [Apply $ setHiding Hidden $ defaultArg l, Apply $ defaultArg a]--  wrapper <- inFreshModuleIfFreeParams $ localTC (set eQuantity topQuantity) $ do-    -- Andreas, 2019-10-12: create helper functions in non-erased mode.-    -- Otherwise, they are not usable in meta-solutions in the term world.-    c' <- setRange (getRange c) <$>-            liftM2 qualify (killRange <$> currentModule)-                           (freshName_ name)--    -- Define and type check the fresh function.-    mod <- asksTC getModality-    abs <- asksTC (^. lensIsAbstract)-    let info   = A.mkDefInfo (A.nameConcrete $ A.qnameName c') noFixity'-                             PublicAccess abs noRange-        core   = A.LHSProj { A.lhsDestructor = unambiguous flat-                           , A.lhsFocus      = defaultNamedArg $ A.LHSHead c' []-                           , A.lhsPats       = [] }-        clause = A.Clause (A.LHS empty core) []-                          (A.RHS arg Nothing)-                          A.noWhereDecls False--    i <- currentOrFreshMutualBlock--    -- If we are in irrelevant position, add definition irrelevantly.-    -- If we are in erased position, add definition as erased.-    -- TODO: is this sufficient?-    addConstant c' =<< do-      let ai = setModality mod defaultArgInfo-      lang <- getLanguage-      useTerPragma $-        (defaultDefn ai c' forcedType lang emptyFunction)-        { defMutual = i }--    checkFunDef NotDelayed info c' [clause]--    reportSDoc "tc.term.expr.coind" 15 $ do-      def <- theDef <$> getConstInfo c'-      vcat $-        [ "The coinductive wrapper"-        , nest 2 $ prettyTCM mod <> (prettyTCM c' <+> ":")-        , nest 4 $ prettyTCM t-        , nest 2 $ prettyA clause-        , ("The definition is" <+> text (show $ funDelayed def)) <>-          "."-        ]-    return c'--  -- The application of the fresh function to the relevant-  -- arguments.-  e' <- Def wrapper . map Apply <$> getContextArgs--  reportSDoc "tc.term.expr.coind" 15 $ vcat $-      [ "The coinductive constructor application"-      , nest 2 $ prettyTCM e-      , "was translated into the application"-      , nest 2 $ prettyTCM e'-      ]--  blockTerm t $ e' <$ workOnTypes (leqType forcedType t)---------------------------------------------------------------------------------- * Cubical---------------------------------------------------------------------------------- | "pathAbs (PathView s _ l a x y) t" builds "(\ t) : pv"---   Preconditions: PathView is PathType, and t[i0] = x, t[i1] = y-pathAbs :: PathView -> Abs Term -> TCM Term-pathAbs (OType _) t = __IMPOSSIBLE__-pathAbs (PathType s path l a x y) t = do-  return $ Lam defaultArgInfo t---- | @primComp : ∀ {ℓ} (A : (i : I) → Set (ℓ i)) (φ : I) (u : ∀ i → Partial φ (A i)) (a : A i0) → A i1@------   Check:  @u i0 = (λ _ → a) : Partial φ (A i0)@.----checkPrimComp :: QName -> MaybeRanges -> Args -> Type -> TCM Args-checkPrimComp c rs vs _ = do-  case vs of-    -- WAS: [l, a, phi, u, a0] -> do-    l : a : phi : u : a0 : rest -> do-      iz <- Arg defaultArgInfo <$> intervalUnview IZero-      let lz = unArg l `apply` [iz]-          az = unArg a `apply` [iz]-      ty <- el's (pure (unArg l `apply` [iz])) $ primPartial <#> pure (unArg l `apply` [iz]) <@> pure (unArg phi) <@> pure (unArg a `apply` [iz])-      bAz <- el' (pure $ lz) (pure $ az)-      a0 <- blockArg bAz (rs !!! 4) a0 $ do-        equalTerm ty -- (El (getSort t1) (apply (unArg a) [iz]))-          (Lam defaultArgInfo $ NoAbs "_" $ unArg a0)-          (apply (unArg u) [iz])-      return $ l : a : phi : u : a0 : rest-    _ -> typeError . GenericDocError =<< prettyTCM c <+> "must be fully applied"---- | @primHComp : ∀ {ℓ} {A : Set ℓ} {φ : I} (u : ∀ i → Partial φ A) (a : A) → A@------   Check:  @u i0 = (λ _ → a) : Partial φ A@.----checkPrimHComp :: QName -> MaybeRanges -> Args -> Type -> TCM Args-checkPrimHComp c rs vs _ = do-  case vs of-    -- WAS: [l, a, phi, u, a0] -> do-    l : a : phi : u : a0 : rest -> do-      -- iz = i0-      iz <- Arg defaultArgInfo <$> intervalUnview IZero-      -- ty = Partial φ A-      ty <- el's (pure (unArg l)) $ primPartial <#> pure (unArg l) <@> pure (unArg phi) <@> pure (unArg a)-      -- (λ _ → a) = u i0 : ty-      bA <- el' (pure $ unArg l) (pure $ unArg a)-      a0 <- blockArg bA (rs !!! 4) a0 $ do-        equalTerm ty -- (El (getSort t1) (apply (unArg a) [iz]))-            (Lam defaultArgInfo $ NoAbs "_" $ unArg a0)-            (apply (unArg u) [iz])-      return $ l : a : phi : u : a0 : rest-    _ -> typeError . GenericDocError =<< prettyTCM c <+> "must be fully applied"---- | @transp : ∀{ℓ} (A : (i : I) → Set (ℓ i)) (φ : I) (a0 : A i0) → A i1@------   Check:  If φ, then @A i = A i0 : Set (ℓ i)@ must hold for all @i : I@.----checkPrimTrans :: QName -> MaybeRanges -> Args -> Type -> TCM Args-checkPrimTrans c rs vs _ = do-  case vs of-    -- Andreas, 2019-03-02, issue #3601, why exactly 4 arguments?-    -- Only 3 are needed to check the side condition.-    -- WAS:-    -- [l, a, phi, a0] -> do-    l : a : phi : rest -> do-      iz <- Arg defaultArgInfo <$> intervalUnview IZero-      -- ty = (i : I) -> Set (l i)-      ty <- runNamesT [] $ do-        l <- open $ unArg l-        nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (l <@> i))-      a <- blockArg ty (rs !!! 1) a $ do-        equalTermOnFace (unArg phi) ty-          (unArg a)-          (Lam defaultArgInfo $ NoAbs "_" $ apply (unArg a) [iz])-      return $ l : a : phi : rest-    _ -> typeError . GenericDocError =<< prettyTCM c <+> "must be fully applied"--blockArg :: HasRange r => Type -> r -> Arg Term -> TCM () -> TCM (Arg Term)-blockArg t r a m =-  setCurrentRange (getRange $ r) $ fmap (a $>) $ blockTerm t $ m >> return (unArg a)--checkConId :: QName -> MaybeRanges -> Args -> Type -> TCM Args-checkConId c rs vs t1 = do-  case vs of-   args@[_, _, _, _, phi, p] -> do-      iv@(PathType s _ l a x y) <- idViewAsPath t1-      let ty = pathUnview iv-      -- the following duplicates reduction of phi-      const_x <- blockTerm ty $ do-          equalTermOnFace (unArg phi) (El s (unArg a)) (unArg x) (unArg y)-          pathAbs iv (NoAbs (stringToArgName "_") (unArg x))-      p <- blockArg ty (rs !!! 5) p $ do-        equalTermOnFace (unArg phi) ty (unArg p) const_x   -- G, phi |- p = \ i . x-      return $ initWithDefault __IMPOSSIBLE__ args ++ [p]-      -- phi <- reduce phi-      -- forallFaceMaps (unArg phi) $ \ alpha -> do-      --   iv@(PathType s _ l a x y) <- idViewAsPath (applySubst alpha t1)-      --   let ty = pathUnview iv-      --   equalTerm (El s (unArg a)) (unArg x) (unArg y) -- precondition for cx being well-typed at ty-      --   cx <- pathAbs iv (NoAbs (stringToArgName "_") (applySubst alpha (unArg x)))-      --   equalTerm ty (applySubst alpha (unArg p)) cx   -- G, phi |- p = \ i . x-   _ -> typeError . GenericDocError =<< prettyTCM c <+> "must be fully applied"----- The following comment contains silly ' escapes to calm CPP about ∨ (\vee).--- May not be haddock-parseable.---- ' @primPOr : ∀ {ℓ} (φ₁ φ₂ : I) {A : Partial (φ₁ ∨ φ₂) (Set ℓ)}--- '         → (u : PartialP φ₁ (λ (o : IsOne φ₁) → A (IsOne1 φ₁ φ₂ o)))--- '         → (v : PartialP φ₂ (λ (o : IsOne φ₂) → A (IsOne2 φ₁ φ₂ o)))--- '         → PartialP (φ₁ ∨ φ₂) A@--- '--- ' Checks: @u = v : PartialP (φ₁ ∨ φ₂) A@ whenever @IsOne (φ₁ ∧ φ₂)@.-checkPOr :: QName -> MaybeRanges -> Args -> Type -> TCM Args-checkPOr c rs vs _ = do-  case vs of-   l : phi1 : phi2 : a : u : v : rest -> do-      phi <- intervalUnview (IMin phi1 phi2)-      reportSDoc "tc.term.por" 10 $ text (show phi)-      -- phi <- reduce phi-      -- alphas <- toFaceMaps phi-      -- reportSDoc "tc.term.por" 10 $ text (show alphas)-      t1 <- runNamesT [] $ do-             [l,a] <- mapM (open . unArg) [l,a]-             psi <- open =<< intervalUnview (IMax phi1 phi2)-             pPi' "o" psi $ \ o -> el' l (a <..> o)-      tv <- runNamesT [] $ do-             [l,a,phi1,phi2] <- mapM (open . unArg) [l,a,phi1,phi2]-             pPi' "o" phi2 $ \ o -> el' l (a <..> (cl primIsOne2 <@> phi1 <@> phi2 <@> o))-      v <- blockArg tv (rs !!! 5) v $ do-        -- ' φ₁ ∧ φ₂  ⊢ u , v : PartialP (φ₁ ∨ φ₂) \ o → a o-        equalTermOnFace phi t1 (unArg u) (unArg v)-      return $ l : phi1 : phi2 : a : u : v : rest-   _ -> typeError . GenericDocError =<< prettyTCM c <+> "must be fully applied"---- | @prim^glue : ∀ {ℓ ℓ'} {A : Set ℓ} {φ : I}---              → {T : Partial φ (Set ℓ')} → {e : PartialP φ (λ o → T o ≃ A)}---              → (t : PartialP φ T) → (a : A) → primGlue A T e@------   Check   @φ ⊢ a = e 1=1 (t 1=1)@  or actually the equivalent:  @(\ _ → a) = (\ o -> e o (t o)) : PartialP φ A@-check_glue :: QName -> MaybeRanges -> Args -> Type -> TCM Args-check_glue c rs vs _ = do-  case vs of-   -- WAS: [la, lb, bA, phi, bT, e, t, a] -> do-   la : lb : bA : phi : bT : e : t : a : rest -> do-      let iinfo = setRelevance Irrelevant defaultArgInfo-      v <- runNamesT [] $ do-            [lb, la, bA, phi, bT, e, t] <- mapM (open . unArg) [lb, la, bA, phi, bT, e, t]-            let f o = cl primEquivFun <#> lb <#> la <#> (bT <..> o) <#> bA <@> (e <..> o)-            glam iinfo "o" $ \ o -> f o <@> (t <..> o)-      ty <- runNamesT [] $ do-            [lb, phi, bA] <- mapM (open . unArg) [lb, phi, bA]-            el's lb $ cl primPartialP <#> lb <@> phi <@> glam iinfo "o" (\ _ -> bA)-      let a' = Lam iinfo (NoAbs "o" $ unArg a)-      ta <- el' (pure $ unArg la) (pure $ unArg bA)-      a <- blockArg ta (rs !!! 7) a $ equalTerm ty a' v-      return $ la : lb : bA : phi : bT : e : t : a : rest-   _ -> typeError . GenericDocError =<< prettyTCM c <+> "must be fully applied"----- | @prim^glueU : ∀ {ℓ} {φ : I}---              → {T : I → Partial φ (Set ℓ)} → {A : Set ℓ [ φ ↦ T i0 ]}---              → (t : PartialP φ (T i1)) → (a : outS A) → hcomp T (outS A)@------   Check   @φ ⊢ a = transp (\ i -> T 1=1 (~ i)) i0 (t 1=1)@  or actually the equivalent:---           @(\ _ → a) = (\o -> transp (\ i -> T o (~ i)) i0 (t o)) : PartialP φ (T i0)@-check_glueU :: QName -> MaybeRanges -> Args -> Type -> TCM Args-check_glueU c rs vs _ = do-  case vs of-   -- WAS: [la, lb, bA, phi, bT, e, t, a] -> do-   la : phi : bT : bA : t : a : rest -> do-      let iinfo = setRelevance Irrelevant defaultArgInfo-      v <- runNamesT [] $ do-            [la, phi, bT, bA, t] <- mapM (open . unArg) [la, phi, bT, bA, t]-            let f o = cl primTrans <#> lam "i" (const la) <@> lam "i" (\ i -> bT <@> (cl primINeg <@> i) <..> o) <@> cl primIZero-            glam iinfo "o" $ \ o -> f o <@> (t <..> o)-      ty <- runNamesT [] $ do-            [la, phi, bT] <- mapM (open . unArg) [la, phi, bT]-            pPi' "o" phi $ \ o -> el' la (bT <@> cl primIZero <..> o)-      let a' = Lam iinfo (NoAbs "o" $ unArg a)-      ta <- runNamesT [] $ do-            [la, phi, bT, bA] <- mapM (open . unArg) [la, phi, bT, bA]-            el' la (cl primSubOut <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <#> (bT <@> cl primIZero) <@> bA)-      a <- blockArg ta (rs !!! 5) a $ equalTerm ty a' v-      return $ la : phi : bT : bA : t : a : rest-   _ -> typeError . GenericDocError =<< prettyTCM c <+> "must be fully applied"+  , disambiguateConstructor'+  , univChecks+  , suffixToLevel+  ) where++import Prelude hiding ( null )++import Control.Applicative        ( (<|>) )+import Control.Monad.Except       ( ExceptT, runExceptT, MonadError, catchError, throwError )+import Control.Monad.Trans.Maybe++import Data.Bifunctor+import Data.Maybe+import Data.Void+import qualified Data.Foldable as Fold+import qualified Data.IntSet   as IntSet++import Agda.Interaction.Highlighting.Generate+  ( storeDisambiguatedConstructor, storeDisambiguatedProjection )++import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract.Pattern (patternToExpr)+import Agda.Syntax.Abstract.Views as A+import qualified Agda.Syntax.Info as A+import Agda.Syntax.Concrete.Pretty () -- only Pretty instances+import Agda.Syntax.Common+import Agda.Syntax.Internal as I+import Agda.Syntax.Position++import Agda.TypeChecking.Conversion+import Agda.TypeChecking.Constraints+import Agda.TypeChecking.Datatypes+import Agda.TypeChecking.Free+import Agda.TypeChecking.Implicit+import Agda.TypeChecking.Injectivity+import Agda.TypeChecking.InstanceArguments (postponeInstanceConstraints)+import Agda.TypeChecking.Level+import Agda.TypeChecking.MetaVars+import Agda.TypeChecking.Modalities+import Agda.TypeChecking.Names+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Primitive hiding (Nat)+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Records+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Rules.Def+import Agda.TypeChecking.Rules.Term+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Warnings (warning)++import Agda.Utils.Either+import Agda.Utils.Function+import Agda.Utils.Functor+import Agda.Utils.Lens+import Agda.Utils.List  ( (!!!), initWithDefault )+import qualified Agda.Utils.List as List+import Agda.Utils.List1 ( List1, pattern (:|) )+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Syntax.Common.Pretty ( prettyShow )+import Agda.Utils.Size+import Agda.Utils.Tuple++import Agda.Utils.Impossible++---------------------------------------------------------------------------+-- * Data structures for checking arguments+---------------------------------------------------------------------------++-- | Ranges of checked arguments, where present.+type MaybeRanges = [Maybe Range]++acElims :: ArgsCheckState a -> [Elim]+acElims = map caElim . acCheckedArgs++acRanges :: ArgsCheckState a -> MaybeRanges+acRanges = map caRange . acCheckedArgs++setACElims :: [Elim] -> ArgsCheckState a -> ArgsCheckState a+setACElims es st = st{ acCheckedArgs = go es (acCheckedArgs st) }+  where+    go [] [] = []+    go (e : es) (ca : cas) = ca{ caElim = e } : go es cas+    go _ _ = __IMPOSSIBLE__++-- | A checked argument without constraint or range.+defaultCheckedArg :: Elim -> CheckedArg+defaultCheckedArg e = CheckedArg { caElim = e, caRange = Nothing, caConstraint = Nothing }++-----------------------------------------------------------------------------+-- * Applications+-----------------------------------------------------------------------------++acHeadConstraints :: (Elims -> Term) -> ArgsCheckState a -> [Constraint]+acHeadConstraints hd = go hd . acCheckedArgs+  where+    go :: (Elims -> Term) -> [CheckedArg] -> [Constraint]+    go hd = \case+      [] -> []+      CheckedArg e _ mc : cas -> applyWhenJust mc (\ c -> (lazyAbsApp c (hd []) :)) $+        go (hd . (e :)) cas++checkHeadConstraints :: (Elims -> Term) -> ArgsCheckState a -> TCM Term+checkHeadConstraints hd st = do+  mapM_ solveConstraint_ (acHeadConstraints hd st)+  return $ hd (acElims st)+++-- | @checkApplication hd args e t@ checks an application.+--   Precondition: @Application hs args = appView e@+--+--   @checkApplication@ disambiguates constructors+--   (and continues to 'checkConstructorApplication')+--   and resolves pattern synonyms.+checkApplication :: Comparison -> A.Expr -> A.Args -> A.Expr -> Type -> TCM Term+checkApplication cmp hd args e t =+  turnOffExpandLastIfExistingMeta hd $+  postponeInstanceConstraints $ do+  reportSDoc "tc.check.app" 20 $ vcat+    [ "checkApplication"+    , nest 2 $ "hd   = " <+> prettyA hd+    , nest 2 $ "args = " <+> sep (map prettyA args)+    , nest 2 $ "e    = " <+> prettyA e+    , nest 2 $ "t    = " <+> prettyTCM t+    ]+  reportSDoc "tc.check.app" 70 $ vcat+    [ "checkApplication (raw)"+    , nest 2 $ text $ "hd   = " ++ show hd+    , nest 2 $ text $ "args = " ++ show (deepUnscope args)+    , nest 2 $ text $ "e    = " ++ show (deepUnscope e)+    , nest 2 $ text $ "t    = " ++ show t+    ]+  case unScope hd of+    -- Subcase: unambiguous projection+    A.Proj o p | Just x <- getUnambiguous p -> do+      checkUnambiguousProjectionApplication cmp e t x o hd args++    -- Subcase: ambiguous projection+    A.Proj o p -> do+      checkProjApp cmp e o (unAmbQ p) hd args t++    -- Subcase: unambiguous constructor+    A.Con ambC | Just c <- getUnambiguous ambC -> do+      -- augment c with record fields, but do not revert to original name+      con <-+        fromRightM+          (sigError c (typeError $ AbstractConstructorNotInScope c)) $+          getOrigConHead c+      checkConstructorApplication cmp e t con hd args++    -- Subcase: ambiguous constructor+    A.Con (AmbQ cs0) -> do+      let cont c = checkConstructorApplication cmp e t c hd args+      afterDisambiguation cont $ disambiguateConstructor cs0 args t++    -- Subcase: pattern synonym+    A.PatternSyn n -> do+      (ns, p) <- lookupPatternSyn n+      p <- return $ setRange (getRange n) $ killRange $ vacuous p   -- Pattern' Void -> Pattern' Expr+      -- Expand the pattern synonym by substituting for+      -- the arguments we have got and lambda-lifting+      -- over the ones we haven't.+      let meta h r = A.Underscore $ A.emptyMetaInfo{ A.metaRange = r, A.metaKind = A.hidingToMetaKind h }   -- TODO: name suggestion+      case A.insertImplicitPatSynArgs meta (getRange n) ns args of+        Nothing      -> typeError $ BadArgumentsToPatternSynonym n+        Just (s, ns) -> do+          let p' = patternToExpr p+              e' = A.lambdaLiftExpr ns (A.substExpr s p')+          checkExpr' cmp e' t++    -- Subcase: macro+    A.Macro x -> do+      -- First go: no parameters+      TelV tel _ <- telView . defType =<< instantiateDef =<< getConstInfo x++      tTerm <- primAgdaTerm+      tName <- primQName++      -- Andreas, 2021-05-13, can we use @initWithDefault __IMPOSSIBLE__@ here?+      let argTel   = init $ telToList tel -- last argument is the hole term++          -- inspect macro type to figure out if arguments need to be wrapped in quote/quoteTerm+          mkArg :: Type -> NamedArg A.Expr -> NamedArg A.Expr+          mkArg t a | unEl t == tTerm =+            (fmap . fmap)+              (A.App (A.defaultAppInfo (getRange a)) (A.QuoteTerm A.exprNoRange) . defaultNamedArg) a+          mkArg t a | unEl t == tName =+            (fmap . fmap)+              (A.App (A.defaultAppInfo (getRange a)) (A.Quote A.exprNoRange) . defaultNamedArg) a+          mkArg t a | otherwise = a++          makeArgs :: [Dom (String, Type)] -> [NamedArg A.Expr] -> ([NamedArg A.Expr], [NamedArg A.Expr])+          makeArgs [] args = ([], args)+          makeArgs _  []   = ([], [])+          makeArgs tel@(d : tel1) (arg : args) =+            case insertImplicit arg tel of+              NoInsertNeeded -> first (mkArg (snd $ unDom d) arg :) $ makeArgs tel1 args+              ImpInsert is   -> makeArgs (drop (length is) tel) (arg : args)+              BadImplicits   -> (arg : args, [])  -- fail later in checkHeadApplication+              NoSuchName{}   -> (arg : args, [])  -- ditto++          (macroArgs, otherArgs) = makeArgs argTel args+          unq = A.App (A.defaultAppInfo $ fuseRange x args) (A.Unquote A.exprNoRange) . defaultNamedArg++          desugared = A.app (unq $ unAppView $ Application (A.Def x) $ macroArgs) otherArgs++      checkExpr' cmp desugared t++    -- Subcase: unquote+    A.Unquote _+      | [arg] <- args -> do+          (_, hole) <- newValueMeta RunMetaOccursCheck CmpLeq t+          unquoteM (namedArg arg) hole t+          return hole+      | arg : args <- args -> do+          -- Example: unquote v a b : A+          --  Create meta H : (x : X) (y : Y x) → Z x y for the hole+          --  Check a : X, b : Y a+          --  Run the tactic on H+          --  Check H a b : A+          tel    <- metaTel args                    -- (x : X) (y : Y x)+          target <- addContext tel newTypeMeta_     -- Z x y+          let holeType = telePi_ tel target         -- (x : X) (y : Y x) → Z x y+          let hd       = namedArg arg+          (Just vs, EmptyTel) <- mapFst allApplyElims <$> checkArguments_ CmpLeq ExpandLast hd args tel+                                                    -- a b : (x : X) (y : Y x)+          (_, hole) <- newValueMeta RunMetaOccursCheck CmpLeq holeType+          unquoteM hd hole holeType+          let rho = reverse (map unArg vs) ++# IdS  -- [x := a, y := b]+          coerce CmpEq (apply hole vs) (applySubst rho target) t -- H a b : A+      where+        metaTel :: [Arg a] -> TCM Telescope+        metaTel []           = pure EmptyTel+        metaTel (arg : args) = do+          a <- newTypeMeta_+          let dom = a <$ domFromArg arg+          ExtendTel dom . Abs "x" <$>+            addContext ("x" :: String, dom) (metaTel args)++    -- Subcase: defined symbol or variable.+    _ -> do+      v <- checkHeadApplication cmp e t hd args+      reportSDoc "tc.term.app" 30 $ vcat+        [ "checkApplication: checkHeadApplication returned"+        , nest 2 $ "v = " <+> prettyTCM v+        ]+      return v++-- | Precondition: @Application hd args = appView e@.+inferApplication :: ExpandHidden -> A.Expr -> A.Args -> A.Expr -> TCM (Term, Type)+inferApplication exh hd args e | not (defOrVar hd) = do+  t <- workOnTypes $ newTypeMeta_+  v <- checkExpr' CmpEq e t+  return (v, t)+inferApplication exh hd args e = postponeInstanceConstraints $ do+  SortKit{..} <- sortKit+  case unScope hd of+    A.Proj o p | isAmbiguous p -> inferProjApp e o (unAmbQ p) hd args+    A.Def' x s | Just (sz, u) <- isNameOfUniv x -> inferUniv sz u e x s args+    _ -> do+      (f, t0) <- inferHead hd+      res <- runExceptT $ checkArgumentsE CmpEq exh hd args t0 Nothing+      case res of+        Right st@(ACState{acType = t1}) -> fmap (,t1) $ unfoldInlined =<< checkHeadConstraints f st+        Left problem -> do+          t <- workOnTypes $ newTypeMeta_+          v <- postponeArgs problem CmpEq exh hd args t0 t $ \ st -> unfoldInlined =<< checkHeadConstraints f st+          return (v, t)++-----------------------------------------------------------------------------+-- * Heads+-----------------------------------------------------------------------------++inferHeadDef :: ProjOrigin -> QName -> TCM (Elims -> Term, Type)+inferHeadDef o x = do+  -- Andreas, 2022-03-07, issue #5809: don't drop parameters of irrelevant projections.+  proj <- isRelevantProjection x+  rel  <- getRelevance . defArgInfo <$> getConstInfo x+  let app =+        case proj of+          Nothing -> \ args -> Def x $ map Apply args+          Just p  -> \ args -> projDropParsApply p o rel args+  mapFst applyE <$> inferDef app x++-- | Infer the type of a head thing (variable, function symbol, or constructor).+--   We return a function that applies the head to arguments.+--   This is because in case of a constructor we want to drop the parameters.+inferHead :: A.Expr -> TCM (Elims -> Term, Type)+inferHead e = do+  case e of+    A.Var x -> do -- traceCall (InferVar x) $ do+      (u, a) <- getVarInfo x+      reportSDoc "tc.term.var" 20 $ hsep+        [ "variable" , prettyTCM x+        , "(" , text (show u) , ")"+        , "has type:" , prettyTCM a+        ]+      unless (usableRelevance a) $+        typeError $ VariableIsIrrelevant x+      -- Andreas, 2019-06-18, LAIM 2019, issue #3855:+      -- Conor McBride style quantity judgement:+      -- The available quantity for variable x must be below+      -- the required quantity to construct the term x.+      -- Note: this whole thing does not work for linearity, where we need some actual arithmetics.+      unlessM ((getQuantity a `moreQuantity`) <$> viewTC eQuantity) $+        typeError $ VariableIsErased x++      unless (usableCohesion a) $+        typeError $ VariableIsOfUnusableCohesion x (getCohesion a)++      unless (usablePolarity a) $+        typeError $ VariableIsOfUnusablePolarity x (getModalPolarity a)++      return (applyE u, unDom a)++    A.Def x  -> inferHeadDef ProjPrefix x+    A.Def'{} -> __IMPOSSIBLE__ -- handled in checkHeadApplication and inferApplication++    A.Proj o ambP | Just d <- getUnambiguous ambP -> inferHeadDef o d+    A.Proj{} -> __IMPOSSIBLE__ -- inferHead will only be called on unambiguous projections++    A.Con ambC | Just c <- getUnambiguous ambC -> do++      -- Constructors are polymorphic internally.+      -- So, when building the constructor term+      -- we should throw away arguments corresponding to parameters.++      -- First, inferDef will try to apply the constructor+      -- to the free parameters of the current context. We ignore that.+      con <-+        fromRightM+          (sigError c (typeError $ AbstractConstructorNotInScope c)) $+          getOrigConHead c+      (u, a) <- inferDef (\ _ -> Con con ConOCon []) c++      -- Next get the number of parameters in the current context.+      Constructor{conPars = n} <- theDef <$> (instantiateDef =<< getConstInfo c)++      reportSLn "tc.term.con" 7 $ unwords [prettyShow c, "has", show n, "parameters."]++      -- So when applying the constructor throw away the parameters.+      return (applyE u . drop n, a)+    A.Con{} -> __IMPOSSIBLE__  -- inferHead will only be called on unambiguous constructors+    A.QuestionMark i ii -> inferMeta i (newQuestionMark ii)+    A.Underscore i      -> inferMeta i (newValueMetaOfKind i RunMetaOccursCheck)+    e -> do+      (term, t) <- inferExpr e+      return (applyE term, t)++inferDef :: (Args -> Term) -> QName -> TCM (Term, Type)+inferDef mkTerm x =+  traceCall (InferDef x) $ do+    -- getConstInfo retrieves the *absolute* (closed) type of x+    -- instantiateDef relativizes it to the current context+    d0 <- getConstInfo x+    d  <- instantiateDef d0+    reportSDoc "tc.term.def" 10 $ "inferDef" <+> prettyTCM x+    reportSDoc "tc.term.def" 30 $ "  absolute type:    " <+> inTopContext (prettyTCM $ defType d0)+    reportSDoc "tc.term.def" 30 $ "  instantiated type:" <+> prettyTCM (defType d)+    -- Irrelevant defs are only allowed in irrelevant position.+    -- Erased defs are only allowed in erased position (see #3855).+    checkModality x d+    case theDef d of+      GeneralizableVar{} -> do+        -- Generalizable variables corresponds to metas created+        -- at the point where they should be generalized. Module parameters+        -- have already been applied to the meta, so we don't have to do that+        -- here.+        val <- fromMaybe __IMPOSSIBLE__ <$> viewTC (eGeneralizedVars . key x)+        sub <- checkpointSubstitution (genvalCheckpoint val)+        let (v, t) = applySubst sub (genvalTerm val, genvalType val)+        debug [] t v+        return (v, t)+      _ -> do+        -- since x is considered living in the top-level, we have to+        -- apply it to the current context+        vs <- freeVarsToApply x+        reportSDoc "tc.term.def" 30 $ "  free vars:" <+> prettyList_ (map prettyTCM vs)+        let t = defType d+            v = mkTerm vs -- applies x to vs, dropping parameters++        -- Andrea 2019-07-16, Check that the supplied arguments+        -- respect the pure modalities of the current context.+        -- Pure modalities are based on left-division, so it does not+        -- rely on "position" like positional modalities.+        checkModalityArgs d0 vs++        debug vs t v+        return (v, t)+  where+    debug :: Args -> Type -> Term -> TCM ()+    debug vs t v = do+      reportSDoc "tc.term.def" 60 $+        "freeVarsToApply to def " <+> hsep (map (text . show) vs)+      reportSDoc "tc.term.def" 10 $ vcat+        [ "inferred def " <+> prettyTCM x <+> hsep (map prettyTCM vs)+        , nest 2 $ ":" <+> prettyTCM t+        , nest 2 $ "-->" <+> prettyTCM v ]++-- | @checkHeadApplication e t hd args@ checks that @e@ has type @t@,+-- assuming that @e@ has the form @hd args@. The corresponding+-- type-checked term is returned.+--+-- If the head term @hd@ is a coinductive constructor, then a+-- top-level definition @fresh tel = hd args@ (where the clause is+-- delayed) is added, where @tel@ corresponds to the current+-- telescope. The returned term is @fresh tel@.+--+-- Precondition: The head @hd@ has to be unambiguous, and there should+-- not be any need to insert hidden lambdas.+checkHeadApplication :: Comparison -> A.Expr -> Type -> A.Expr -> [NamedArg A.Expr] -> TCM Term+checkHeadApplication cmp e t hd args = do+  SortKit{..} <- sortKit+  sharp <- fmap nameOfSharp <$> coinductionKit+  pOr    <- getNameOfConstrained builtinPOr+  pComp  <- getNameOfConstrained builtinComp+  pHComp <- getNameOfConstrained builtinHComp+  pTrans <- getNameOfConstrained builtinTrans+  mglue  <- getNameOfConstrained builtin_glue+  mglueU  <- getNameOfConstrained builtin_glueU+  case hd of+    A.Def' c s | Just (sz, u) <- isNameOfUniv c -> checkUniv sz u cmp e t c s args++    -- Type checking #. The # that the user can write will be a Def, but the+    -- sharp we generate in the body of the wrapper is a Con.+    A.Def c | Just c == sharp -> checkSharpApplication e t c args++    -- Cubical primitives+    A.Def c | Just c == pComp -> defaultResult' $ Just $ checkPrimComp c+    A.Def c | Just c == pHComp -> defaultResult' $ Just $ checkPrimHComp c+    A.Def c | Just c == pTrans -> defaultResult' $ Just $ checkPrimTrans c+    A.Def c | Just c == pOr   -> defaultResult' $ Just $ checkPOr c+    A.Def c | Just c == mglue -> defaultResult' $ Just $ check_glue c+    A.Def c | Just c == mglueU -> defaultResult' $ Just $ check_glueU c++    _ -> defaultResult+  where+  defaultResult :: TCM Term+  defaultResult = defaultResult' Nothing+  defaultResult' :: Maybe (MaybeRanges -> Args -> Type -> TCM Args) -> TCM Term+  defaultResult' mk = do+    (f, t0) <- inferHead hd+    expandLast <- asksTC envExpandLast+    checkArguments cmp expandLast hd args t0 t $ \ st@(ACState cas _fun t1 checkedTarget) -> do+      let check :: Maybe (TCM Args)+          check = do+            k <- mk+            vs <- allApplyElims $ map caElim cas+            pure $ k (map caRange cas) vs t1+      st' <- case check of+               Just ck -> (`setACElims` st) . map Apply <$> ck+               Nothing -> pure st+      v <- unfoldInlined =<< checkHeadConstraints f st'+      coerce' cmp checkedTarget v t1 t++-- Issue #3019 and #4170: Don't insert trailing implicits when checking arguments to existing+-- metavariables.+turnOffExpandLastIfExistingMeta :: A.Expr -> TCM a -> TCM a+turnOffExpandLastIfExistingMeta hd+  | isExistingMeta = reallyDontExpandLast+  | otherwise      = id+  where+    isExistingMeta = isJust $ A.metaNumber =<< metaInfo hd+    metaInfo (A.QuestionMark i _) = Just i+    metaInfo (A.Underscore i)     = Just i+    metaInfo (A.ScopedExpr _ e)   = metaInfo e+    metaInfo _                    = Nothing++-----------------------------------------------------------------------------+-- * Spines+-----------------------------------------------------------------------------++traceCallE :: Call -> ExceptT e TCM r -> ExceptT e TCM r+traceCallE call m = do+  z <- lift $ traceCall call $ runExceptT m+  case z of+    Right e  -> return e+    Left err -> throwError err++-- | If we've already checked the target type we don't have to call coerce.+coerce' :: Comparison -> CheckedTarget -> Term -> Type -> Type -> TCM Term+coerce' cmp NotCheckedTarget           v inferred expected = coerce cmp v inferred expected+coerce' cmp (CheckedTarget Nothing)    v _        _        = return v+coerce' cmp (CheckedTarget (Just pid)) v _        expected = blockTermOnProblem expected v pid++-- | Check a list of arguments: @checkArgs args t0 t1@ checks that+--   @t0 = Delta -> t0'@ and @args : Delta@. Inserts hidden arguments to+--   make this happen.  Returns the evaluated arguments @vs@, the remaining+--   type @t0'@ (which should be a subtype of @t1@) and any constraints @cs@+--   that have to be solved for everything to be well-formed.++checkArgumentsE ::+     Comparison+       -- ^ How the inferred type should be compared to the expected result type.+  -> ExpandHidden+       -- ^ Insert trailing hidden arguments?+  -> A.Expr+       -- ^ The function.+  -> [NamedArg A.Expr]+       -- ^ The arguments.+  -> Type+       -- ^ Type of the function.+  -> Maybe Type+       -- ^ Optional: expected result type (type of the whole application).+  -> ExceptT (ArgsCheckState [NamedArg A.Expr]) TCM (ArgsCheckState CheckedTarget)+       -- ^ Upon failure, return the current state for creating a postponed type checking problem.+checkArgumentsE cmp exph hd args t0 t = do+  sPathView <- pathView'+  checkArgumentsE'+    S{ sChecked       = NotCheckedTarget+     , sComp          = cmp+     , sExpand        = exph+     , sFun           = hd+     , sArgs          = zip args $ List.suffixesSatisfying visible args+     , sArgsLen       = length args+     , sFunType       = t0+     , sResultType    = t+     , sSizeLtChecked = False+     , sSkipCheck     = DontSkip+     , sPathView      = sPathView+     }++-- | State used by 'checkArgumentsE''.++data CheckArgumentsE'State = S+  { sChecked :: CheckedTarget+    -- ^ Have we already checked the target?+  , sComp :: Comparison+    -- ^ Comparison to use if checking the target type.+  , sExpand :: ExpandHidden+    -- ^ Insert trailing hidden arguments?+  , sFun :: A.Expr+    -- ^ The function.+  , sArgs :: [(NamedArg A.Expr, Bool)]+    -- ^ Arguments, along with information about whether a given+    -- argument and all remaining arguments are 'visible'.+  , sArgsLen :: !Nat+    -- ^ The length of 'sArgs'.+  , sFunType :: Type+    -- ^ The function's type.+  , sResultType :: Maybe Type+    -- ^ The type of the application.+  , sSizeLtChecked :: !Bool+    -- ^ Have we checked if 'sResultType' is 'BoundedLt'?+  , sSkipCheck :: !SkipCheck+    -- ^ Should the target type check be skipped?+  , sPathView :: Type -> PathView+    -- ^ The function returned by 'pathView''.+  }++-- | Should the target type check in 'checkArgumentsE'' be skipped?++data SkipCheck+  = Skip+  | SkipNext !Nat+    -- ^ Skip the given number of checks.+  | DontSkip++type CheckArgumentsE' = ExceptT (ArgsCheckState [NamedArg A.Expr]) TCM (ArgsCheckState CheckedTarget)++checkArgumentsE'+  :: CheckArgumentsE'State+  -> CheckArgumentsE'++-- Case: no arguments, do not insert trailing hidden arguments: We are done.+checkArgumentsE' S{ sArgs = [], .. }+  | isDontExpandLast sExpand =+    return $ ACState+      { acCheckedArgs = []+      , acFun         = sFun+      , acType        = sFunType+      , acData        = sChecked+      }++-- Case: no arguments, but need to insert trailing hiddens.+checkArgumentsE' S{ sArgs = [], .. } =+  traceCallE (CheckArguments sFun [] sFunType sResultType) $ lift $ do+    sResultType <- traverse (unEl <.> reduce) sResultType+    (us, t)     <- implicitArgs (-1) (expand sResultType) sFunType+    return $ ACState+      { acCheckedArgs = map (defaultCheckedArg . Apply) us+      , acFun         = sFun+      , acType        = t+      , acData        = sChecked+      }+  where+  expand (Just (Pi dom _)) Hidden     = not (hidden dom)+  expand _                 Hidden     = True+  expand (Just (Pi dom _)) Instance{} = not (isInstance dom)+  expand _                 Instance{} = True+  expand _                 NotHidden  = False++-- Case: argument given.+checkArgumentsE'+  s@S{ sArgs = sArgs@((arg@(Arg info e), sArgsVisible) : args), .. } =++    traceCallE (CheckArguments sFun (map fst sArgs) sFunType sResultType) $ do+      lift $ reportSDoc "tc.term.args" 30 $ sep+        [ "checkArgumentsE"+--        , "  sArgs =" <+> prettyA sArgs+        , nest 2 $ vcat+          [ "e (argument) =" <+> prettyA e+          , "sFun         =" <+> prettyA sFun+          , "sFunType     =" <+> prettyTCM sFunType+          , "sResultType  =" <+> maybe "Nothing" prettyTCM sResultType+          ]+        ]+      -- First, insert implicit arguments, depending on current argument @arg@.+      let hx = getHiding info  -- hiding of current argument+          mx :: Maybe ArgName+          mx = bareNameOf e    -- name of current argument+          -- do not insert visible arguments+          expand NotHidden y = False+          -- insert a hidden argument if arg is not hidden or has different name+          -- insert an instance argument if arg is not instance  or has different name+          expand hy        y = not (sameHiding hy hx) || maybe False (y /=) mx+      reportSDoc "tc.term.args" 30 $ vcat+        [ "calling implicitNamedArgs"+        , nest 2 $ "hx       = " <+> text (show hx)+        , nest 2 $ "mx       = " <+> maybe "nothing" prettyTCM mx+        ]+      (nargs, sFunType) <- lift $ implicitNamedArgs (-1) expand sFunType+      -- Separate names from args.+      let (mxs, us) = unzip $ map (\ (Arg ai (Named mx u)) -> (mx, Apply $ Arg ai u)) nargs+          xs        = catMaybes mxs++      -- We need a function type here, but we don't know which kind+      -- (implicit/explicit). But it might be possible to use injectivity to+      -- force a pi.+      sFunType <- lift $ forcePiUsingInjectivity sFunType++      -- We are done inserting implicit args.  Now, try to check @arg@.+      ifBlocked sFunType+        (\ _ sFunType -> throwError $ ACState+            { acCheckedArgs = map defaultCheckedArg us+            , acFun         = sFun+            , acType        = sFunType+            , acData        = map fst sArgs+            }) {- else -} $ \ _ sFunType -> do++        -- What can go wrong?++        -- 1. We ran out of function types.+        let shouldBePi =+              -- a) It is an explicit argument, but we ran out of function types.+              if visible info then liftTCM . typeError $ CannotApply sFun sFunType+              -- b) It is an implicit argument, and we did not insert any implicits.+              --    Thus, the type was not a function type to start with.+              else List1.ifNull xs {-then-} (liftTCM . typeError $ CannotApply sFun sFunType)+              -- c) We did insert implicits, but we ran out of implicit function types.+              --    Then, we should inform the user that we did not find his one.+              {-else-} (liftTCM . typeError . WrongNamedArgument arg)++        -- 2. We have a function type left, but it is the wrong one.+        --    Our argument must be implicit, case a) is impossible.+        --    (Otherwise we would have ran out of function types instead.)+        let wrongPi = List1.ifNull xs+              -- b) We have not inserted any implicits.+                {-then-} (liftTCM . typeError $ WrongHidingInApplication sFunType)+              -- c) We inserted implicits, but did not find his one.+                {-else-} (liftTCM . typeError . WrongNamedArgument arg)++        let (skip, next) = case sSkipCheck of+              Skip       -> (True, Skip)+              DontSkip   -> (False, DontSkip)+              SkipNext n -> case compare n 1 of+                LT -> (False, DontSkip)+                EQ -> (True,  DontSkip)+                GT -> (True,  SkipNext (n - 1))++        s <- pure s+          { sFun       = A.App (A.defaultAppInfo $ getRange (sFun, arg)) sFun arg+          , sArgs      = args+          , sArgsLen   = sArgsLen - 1+          , sFunType   = sFunType+          , sSkipCheck = next+          }++        -- Check the target type if we can get away with it.+        s <- lift $+          case (sChecked, skip, sResultType) of+            (NotCheckedTarget, False, Just sResultType) | sArgsVisible -> do+              -- How many visible Π's (up to at most sArgsLen) does+              -- sFunType start with?+              TelV tel tgt <- telViewUpTo' sArgsLen visible sFunType+              let visiblePis = size tel++                  -- The free variables less than visiblePis in tgt.+                  freeInTgt =+                    fst $ IntSet.split visiblePis $ freeVars tgt++              rigid <- isRigid s tgt+              -- The target must be rigid.+              case rigid of+                IsNotRigid reason ->+                      -- Skip the next visiblePis - 1 - k checks.+                  let skip k   = s{ sSkipCheck =+                                    SkipNext $ visiblePis - 1 - k+                                  }+                      dontSkip = s+                  in return $ case reason of+                    Permanent   -> skip 0+                    Unspecified -> dontSkip+                    AVar x      ->+                      if x `IntSet.member` freeInTgt+                      then skip x+                      else skip 0+                IsRigid -> do+                  -- Andreas, 2024-03-01, issue #7158 reported by Amy.+                  -- We need to check that the arity of the function type+                  -- is sufficient before checking the target,+                  -- otherwise the target is non-sensical.+                  if visiblePis < sArgsLen then return s else do++                      -- Is any free variable in tgt less than+                      -- visiblePis?+                  let dep = not (IntSet.null freeInTgt)+                  -- The target must be non-dependent.+                  if dep then return s else do++                  -- Andreas, 2019-03-28, issue #3248:+                  -- If the target type is SIZELT, we need coerce, leqType is insufficient.+                  -- For example, we have i : Size <= (Size< ↑ i), but not Size <= (Size< ↑ i).+                  (isSizeLt, sResultType, s) <-+                    if sSizeLtChecked+                    then return (False, sResultType, s)+                    else do+                      sResultType <- reduce sResultType+                      isSizeLt    <- isSizeType sResultType <&> \case+                        Just (BoundedLt _) -> True+                        _                  -> False+                      return ( isSizeLt+                             , sResultType+                             , s{ sResultType    = Just sResultType+                                , sSizeLtChecked = True+                                , sSkipCheck     =+                                    if isSizeLt then Skip else DontSkip+                                }+                             )+                  if isSizeLt then return s else do++                  let tgt1 = applySubst+                               (strengthenS impossible visiblePis)+                               tgt+                  reportSDoc "tc.term.args.target" 30 $ vcat+                    [ "Checking target types first"+                    , nest 2 $ "inferred =" <+> prettyTCM tgt1+                    , nest 2 $ "expected =" <+> prettyTCM sResultType ]+                  chk <-+                    traceCall+                      (CheckTargetType+                         (fuseRange sFun sArgs) tgt1 sResultType) $+                      CheckedTarget <$>+                        ifNoConstraints_ (compareType sComp tgt1 sResultType)+                          (return Nothing) (return . Just)+                  return s{ sChecked = chk }++            _ -> return s++        -- sFunType <- lift $ forcePi (getHiding info)+        --                  (maybe "_" rangedThing $ nameOf e) sFunType+        case unEl sFunType of+          Pi (Dom{domInfo = info', domName = dname, unDom = a}) b+            | let name = bareNameWithDefault "_" dname,+              sameHiding info info'+              && (visible info || maybe True (name ==) mx) -> do+                u <- lift $ applyModalityToContext info' $ do+                 -- Andreas, 2014-05-30 experiment to check non-dependent arguments+                 -- after the spine has been processed.  Allows to propagate type info+                 -- from ascribed type into extended-lambdas.  Would solve issue 1159.+                 -- However, leaves unsolved type checking problems in the test suite.+                 -- I do not know what I am doing wrong here.+                 -- Could be extreme order-sensitivity or my abuse of the postponing+                 -- mechanism.+                 -- Andreas, 2016-02-02: Ulf says unless there is actually some meta+                 -- blocking a postponed type checking problem, we might never retry,+                 -- since the trigger for retrying constraints is solving a meta.+                 -- Thus, the following naive use violates some invariant.+                 -- if not $ isBinderUsed b+                 -- then postponeTypeCheckingProblem (CheckExpr (namedThing e) a) (return True) else+                  let e' = e { nameOf = (nameOf e) <|> dname }+                  checkNamedArg (Arg info' e') a++                let+                  c = case getLock info' of+                    IsLock{} -> Just $ Abs "t" $+                        CheckLockedVars (Var 0 []) (raise 1 sFunType)+                          (raise 1 $ Arg info' u) (raise 1 a)+                    _ -> Nothing+                lift $ reportSDoc "tc.term.lock" 40 $ text "lock =" <+> text (show $ getLock info')+                lift $ reportSDoc "tc.term.lock" 40 $+                  addContext (defaultDom $ sFunType) $+                  maybe (text "nothing") (prettyTCM . absBody) c+                -- save relevance info' from domain in argument+                let ca = CheckedArg{ caElim = Apply (Arg info' u), caRange = Just (getRange e), caConstraint = c }+                addCheckedArgs us ca $+                  checkArgumentsE' s{ sFunType = absApp b u }+            | otherwise -> do+                reportSDoc "error" 10 $ nest 2 $ vcat+                  [ text $ "info      = " ++ show info+                  , text $ "info'     = " ++ show info'+                  , text $ "absName b = " ++ absName b+                  , text $ "nameOf e  = " ++ show (nameOf e)+                  ]+                wrongPi+          _+            | visible info+            , PathType sort _ _ bA x y <- sPathView sFunType -> do+                lift $ reportSDoc "tc.term.args" 30 $ text $ show bA+                u <- lift $ checkExpr (namedThing e) =<< primIntervalType+                let ca = CheckedArg+                     { caElim       = IApply (unArg x) (unArg y) u+                     , caRange      = Just (getRange e)+                     , caConstraint = Nothing+                     }+                addCheckedArgs us ca $+                  checkArgumentsE'+                    s{ sChecked = NotCheckedTarget+                     , sFunType = El sort $ unArg bA `apply` [argN u]+                     }+          _ -> shouldBePi+  where+    -- Andrea: Here one would add constraints too.+    addCheckedArgs ::+         Elims+      -> CheckedArg+      -> CheckArgumentsE'+      -> CheckArgumentsE'+    addCheckedArgs us ca cont = do+      let upd :: ArgsCheckState a -> ArgsCheckState a+          upd st = st{ acCheckedArgs = map defaultCheckedArg us ++ ca : acCheckedArgs st }+      -- Add checked arguments to both regular and exceptional result of @cont@.+      withError upd $ upd <$> cont++-- | The result of 'isRigid'.++data IsRigid+  = IsRigid+    -- ^ The type is rigid.+  | IsNotRigid !IsPermanent+    -- ^ The type is not rigid. If the argument is 'Nothing', then+    -- this will not change. If the argument is @'Just' reason@, then+    -- this might change for the given @reason@.++-- | Is the result of 'isRigid' \"permanent\"?++data IsPermanent+  = Permanent+    -- ^ Yes.+  | AVar !Nat+    -- ^ The result does not change unless the given variable is+    -- instantiated.+  | Unspecified+    -- ^ Maybe, maybe not.++-- | Is the type \"rigid\"?++isRigid :: CheckArgumentsE'State -> Type -> TCM IsRigid+isRigid s t | PathType{} <- sPathView s t =+  -- Path is not rigid.+  return $ IsNotRigid Permanent+isRigid _ (El _ t) = case t of+  Var x _    -> return $ IsNotRigid (AVar x)+  Lam{}      -> return $ IsNotRigid Permanent+  Lit{}      -> return $ IsNotRigid Permanent+  Con{}      -> return $ IsNotRigid Permanent+  Pi dom _   -> return $+                if visible dom then IsRigid else IsNotRigid Permanent+  Sort{}     -> return $ IsNotRigid Permanent+  Level{}    -> return $ IsNotRigid Permanent+  MetaV{}    -> return $ IsNotRigid Unspecified+  DontCare{} -> return $ IsNotRigid Permanent+  Dummy{}    -> return $ IsNotRigid Permanent+  Def d _    -> getConstInfo d <&> theDef <&> \case+    Axiom{}                   -> IsRigid+    DataOrRecSig{}            -> IsRigid+    AbstractDefn{}            -> IsRigid+    Function{funClauses = cs} -> if null cs+                                 then IsRigid+                                 else IsNotRigid Unspecified+                                      -- This Reason could perhaps be+                                      -- more precise (in some cases).+    Datatype{}                -> IsRigid+    Record{}                  -> IsRigid+    Constructor{}             -> __IMPOSSIBLE__+    GeneralizableVar{}        -> __IMPOSSIBLE__+    Primitive{}               -> IsNotRigid Unspecified+    PrimitiveSort{}           -> IsNotRigid Unspecified++-- | Check that a list of arguments fits a telescope.+--   Inserts hidden arguments as necessary.+--   Returns the type-checked arguments and the remaining telescope.+checkArguments_+  :: Comparison           -- ^ Comparison for target+  -> ExpandHidden         -- ^ Eagerly insert trailing hidden arguments?+  -> A.Expr               -- ^ Function.+  -> [NamedArg A.Expr]    -- ^ Arguments to check.+  -> Telescope            -- ^ Telescope to check arguments against.+  -> TCM (Elims, Telescope)+     -- ^ Checked arguments and remaining telescope if successful.+checkArguments_ cmp exh fun args tel = postponeInstanceConstraints $ do+    z <- runExceptT $+      checkArgumentsE cmp exh fun args (telePi tel __DUMMY_TYPE__) Nothing+    case z of+      Right (ACState cas _ t _) -> do+        unless (all (isNothing . caConstraint) cas) do+          typeError $ NotSupported $+            "Head constraints are not (yet) supported in this position."+        let TelV tel' _ = telView' t+        return (map caElim cas, tel')+      Left _ -> __IMPOSSIBLE__  -- type cannot be blocked as it is generated by telePi++-- | @checkArguments cmp exph hd args t0 t k@ tries @checkArgumentsE cmp exph hd args t0 t@.+-- If it succeeds, it continues @k@ with the returned results.  If it fails,+-- it registers a postponed typechecking problem and returns the resulting new+-- meta variable.+--+-- Checks @e := ((hd : t0) args) : t@.+checkArguments ::+     Comparison+       -- ^ How the inferred type should be compared to the expected result type.+  -> ExpandHidden+       -- ^ Insert trailing hidden arguments?+  -> A.Expr+       -- ^ The function (a head).+  -> [NamedArg A.Expr]+       -- ^ The arguments to check.+  -> Type+       -- ^ Type of the function.+  -> Type+       -- ^ Expected result type (type of the whole application).+  -> (ArgsCheckState CheckedTarget -> TCM Term)+       -- ^ Continuation receiving the check arguments.+  -> TCM Term+checkArguments cmp exph hd args t0 t k = postponeInstanceConstraints $ do+  z <- runExceptT $ checkArgumentsE cmp exph hd args t0 (Just t)+  case z of+    Right st -> k st+    Left problem -> postponeArgs problem cmp exph hd args t0 t k+      -- if unsuccessful, postpone checking until t0 unblocks++postponeArgs ::+     (ArgsCheckState [NamedArg A.Expr])+       -- ^ The last sound state of the arguments checker.+  -> Comparison+       -- ^ How the inferred type should be compared to the expected result type.+  -> ExpandHidden+       -- ^ Insert trailing hidden arguments?+  -> A.Expr+       -- ^ The original function (a head).+  -> [NamedArg A.Expr]+       -- ^ The original arguments to check.+  -> Type+       -- ^ Type of the original function.+  -> Type+       -- ^ Expected result type (type of the whole application).+  -> (ArgsCheckState CheckedTarget -> TCM Term)+       -- ^ Continuation receiving the check arguments.+  -> TCM Term+postponeArgs (ACState cas fun t1 es) cmp exph hd args t0 t k = do+  reportSDoc "tc.term.expr.args" 80 $+    sep [ "postponed checking arguments"+        , nest 4 $ prettyList (map (prettyA . namedThing . unArg) args)+        , nest 2 $ "against"+        , nest 4 $ prettyTCM t0+        ] $$+    sep [ "progress:"+        , nest 2 $ "checked" <+> prettyList (map (prettyTCM . caElim) cas)+        , nest 2 $ "remaining" <+> sep+            [ prettyList (map (prettyA . namedThing . unArg) es)+            , nest 2 $ ":" <+> prettyTCM t1+            ]+        ]+  postponeTypeCheckingProblem_ $+    CheckArgs cmp exph fun es t1 t $ \ (ACState cas' func t pid) ->+      k $ ACState (cas ++ cas') func t pid++-----------------------------------------------------------------------------+-- * Constructors+-----------------------------------------------------------------------------++-- | Check the type of a constructor application. This is easier than+--   a general application since the implicit arguments can be inserted+--   without looking at the arguments to the constructor.+checkConstructorApplication ::+  Comparison+       -- ^ How the inferred type of the application should be compared to the expected type.+  -> A.Expr+       -- ^ The whole application expression.+  -> Type+       -- ^ The expected type of the whole application.+  -> ConHead+       -- ^ The head of the application.+  -> A.Expr+       -- ^ The original head of the application.+  -> [NamedArg A.Expr]+       -- ^ The arguments.+  -> TCM Term+checkConstructorApplication cmp org t c hd args = do+  reportSDoc "tc.term.con" 50 $ vcat+    [ "entering checkConstructorApplication"+    , nest 2 $ vcat+      [ "org  =" <+> prettyTCM org+      , "t    =" <+> prettyTCM t+      , "c    =" <+> prettyTCM c+      , "args =" <+> prettyTCM args+    ] ]++  cdef  <- getConInfo c++  checkModality (conName c) cdef++  let paramsGiven = checkForParams args+  if paramsGiven then fallback else do+    reportSDoc "tc.term.con" 50 $ "checkConstructorApplication: no parameters explicitly supplied, continuing..."++    let Constructor{conData = d, conPars = npars} = theDef cdef+    reportSDoc "tc.term.con" 50 $ nest 2 $ "d    =" <+> prettyTCM d+    -- Issue 661: t maybe an evaluated form of d .., so we evaluate d+    -- as well and then check wether we deal with the same datatype+    t0 <- reduce (Def d [])+    tReduced <- reduce t+    case (t0, unEl tReduced) of -- Only fully applied constructors get special treatment+      (Def d0 _, Def d' es) -> do+        let ~(Just vs) = allApplyElims es+        reportSDoc "tc.term.con" 50 $ nest 2 $ "d0   =" <+> prettyTCM d0+        reportSDoc "tc.term.con" 50 $ nest 2 $ "d'   =" <+> prettyTCM d'+        reportSDoc "tc.term.con" 50 $ nest 2 $ "vs   =" <+> prettyTCM vs+        if d' /= d0 then fallback else do+         -- Issue 661: d' may take more parameters than d, in particular+         -- these additional parameters could be a module parameter telescope.+         -- Since we get the constructor type ctype from d but the parameters+         -- from t = Def d' vs, we drop the additional parameters.+         npars' <- getNumberOfParameters d'+         caseMaybe (sequenceA $ Pair (Just npars) npars') fallback $ \ (Pair n n') -> do+           reportSDoc "tc.term.con" 50 $ nest 2 $ text $ "n    = " ++ show n+           reportSDoc "tc.term.con" 50 $ nest 2 $ text $ "n'   = " ++ show n'+           when (n > n')  -- preprocessor does not like ', so put on next line+             __IMPOSSIBLE__+           let ps    = take n $ drop (n' - n) vs+               ctype = defType cdef+           reportSDoc "tc.term.con" 20 $ vcat+             [ "special checking of constructor application of" <+> prettyTCM c+             , nest 2 $ vcat [ "ps     =" <+> prettyTCM ps+                             , "ctype  =" <+> prettyTCM ctype ] ]+           let ctype' = ctype `piApply` ps+           reportSDoc "tc.term.con" 20 $ nest 2 $ "ctype' =" <+> prettyTCM ctype'+           -- get the parameter names+           let TelV ptel _ = telView'UpTo n ctype+           let pnames = map (fmap fst) $ telToList ptel+           -- drop the parameter arguments+               args' = dropArgs pnames args+           -- check the non-parameter arguments+           expandLast <- asksTC envExpandLast+           checkArguments cmp expandLast hd args' ctype' t \ st@(ACState _ _ t' targetCheck) -> do+             reportSDoc "tc.term.con" 20 $ nest 2 $ vcat+               [ text "es     =" <+> prettyTCM es+               , text "t'     =" <+> prettyTCM t' ]+             v <- checkHeadConstraints (Con c ConOCon) st+             coerce' cmp targetCheck v t' t+      _ -> do+        reportSDoc "tc.term.con" 50 $ nest 2 $ "we are not at a datatype, falling back"+        fallback+  where+    fallback = checkHeadApplication cmp org t (A.Con (unambiguous $ conName c)) args++    -- Check if there are explicitly given hidden arguments,+    -- in which case we fall back to default type checking.+    -- We could work harder, but let's not for now.+    --+    -- Andreas, 2012-04-18: if all inital args are underscores, ignore them+    checkForParams args =+      let (hargs, rest) = break visible args+          notUnderscore A.Underscore{} = False+          notUnderscore _              = True+      in  any (notUnderscore . unScope . namedArg) hargs++    -- Drop the constructor arguments that correspond to parameters.+    dropArgs [] args                = args+    dropArgs ps []                  = args+    dropArgs ps args@(arg : args')+      | Just p   <- name,+        Just ps' <- namedPar p ps   = dropArgs ps' args'+      | Nothing  <- name,+        Just ps' <- unnamedPar h ps = dropArgs ps' args'+      | otherwise                   = args+      where+        name = bareNameOf arg+        h    = getHiding arg++        namedPar   x = dropPar ((x ==) . unDom)+        unnamedPar h = dropPar (sameHiding h)++        dropPar this (p : ps) | this p    = Just ps+                              | otherwise = dropPar this ps+        dropPar _ [] = Nothing++-- | Return an unblocking action in case of failure.+type DisambiguateConstructor = TCM (Either (Blocker, ConstructorDisambiguationData) ConHead)++-- | Successfully disambiguate constructor with given choice.+decideOn :: ConHead -> DisambiguateConstructor+decideOn c = do+  reportSLn "tc.check.term.con" 40 $ "  decided on: " ++ prettyShow c+  storeDisambiguatedConstructor (conInductive c) (conName c)+  return $ Right c++-- | Returns an unblocking action in case of failure.+disambiguateConstructor :: List1 QName -> A.Args -> Type -> DisambiguateConstructor+disambiguateConstructor cs0 args t = do+  reportSLn "tc.check.term.con" 40 $ "Ambiguous constructor: " ++ prettyShow cs0+  reportSDoc "tc.check.term.con" 40 $ vcat $ "Arguments:" : map (nest 2 . prettyTCM) args++  -- Get the datatypes of the various constructors+  let getData Constructor{conData = d} = d+      getData _                        = __IMPOSSIBLE__+  reportSLn "tc.check.term.con" 40 $ "  ranges before: " ++ prettyShow (getRange cs0)+  -- We use the reduced constructor when disambiguating, but+  -- the original constructor for type checking. This is important+  -- since they may have different types (different parameters).+  -- See issue 279.+  -- Andreas, 2017-08-13, issue #2686: ignore abstract constructors+  ccons  <- List1.rights <$> do+     forM cs0 $ \ c -> mapRight (c,) <$> getConForm c+  reportSLn "tc.check.term.con" 40 $ "  reduced: " ++ prettyShow (map snd ccons)+  case ccons of+    []    -> typeError $ AbstractConstructorNotInScope $ List1.head cs0+    [(c0,con)] -> do+      let c = setConName c0 con+      reportSLn "tc.check.term.con" 40 $ "  only one non-abstract constructor: " ++ prettyShow c+      decideOn c+    cons@(c0,_):conss   -> do+      dcs :: List1 (QName, Type, ConHead) <- forM (cons :| conss) $ \ (c, con) -> do+        t   <- defType <$> getConstInfo c+        def <- getConInfo con+        pure (getData (theDef def), t, setConName c con)+      resolveAmbiguousConstructor $ ConstructorDisambiguationData c0 dcs args t++-- | Retry a constructor disambiguation.+disambiguateConstructor' :: ConstructorDisambiguationData -> (ConHead -> TCM Term) -> TCM Term+disambiguateConstructor' bcd cont = do+  afterDisambiguation cont $ resolveAmbiguousConstructor bcd++-- | Postpone a failing disambiguation or call given continuation.+afterDisambiguation :: (ConHead -> TCM Term) -> DisambiguateConstructor -> TCM Term+afterDisambiguation cont run =+  run >>= \case+    Left (unblock, bcd) -> postponeTypeCheckingProblem (DisambiguateConstructor bcd cont) unblock+    Right c -> cont c++-- | Resolve ambiguous constructor by looking at target type and argument skeleton.+resolveAmbiguousConstructor :: ConstructorDisambiguationData -> DisambiguateConstructor+resolveAmbiguousConstructor bcd@(ConstructorDisambiguationData c0 dcs1 args t) = do+      let dcs = List1.toList dcs1++      -- Lets look at the target type at this point+      TelV tel t1 <- telViewPath t+      addContext tel $ do+       reportSDoc "tc.check.term.con" 40 $ nest 2 $+         "target type: " <+> prettyTCM t1+       -- If we don't have a target type yet, try to look at the argument types.+       ifBlocked t1 (\ b _ -> disambiguateByArgs dcs args $ postpone b) $ \ _ t' ->+         caseMaybeM (isDataOrRecord $ unEl t') (badCon t') $ \ (d, _) -> do+           let dcs' = filter ((d ==) . fst3) dcs+           case map thd3 dcs' of+             [c] -> decideOn c+             []  -> badCon $ t' $> Def d []+             -- If the information from the target type did not eliminate ambiguity fully,+             -- try to further eliminate alternatives by looking at the arguments.+             c:cs-> disambiguateByArgs dcs' args $+                      typeError $ CantResolveOverloadedConstructorsTargetingSameDatatype d $+                        fmap conName $ c :| cs+  where+    postpone b = return $ Left (b, bcd)+    badCon t = typeError $ ConstructorDoesNotTargetGivenType c0 t++-- | Disambiguate constructor by looking at its arguments.+--+-- Look at simple visible arguments (variables (bound and generalizable ones) and defined names).+-- From these we can compute an approximate type effortlessly:+-- 1. Throw away hidden domains (needed for generalizable variables).+-- 2. If the remainder is a defined name that is not blocked on anything, we take this name as+--    approximate type of the argument.+-- This gives us a skeleton @[Maybe QName]@.  Compute the same from the constructor types+-- of the candidates and see if we find any mismatches that allow us to rule out the candidate.+disambiguateByArgs :: [(QName, Type, ConHead)] -> A.Args -> DisambiguateConstructor -> DisambiguateConstructor+disambiguateByArgs dcs args fallback = do++    -- Look for visible arguments that are just variables,+    -- so that we can get their type directly from the context+    -- without full-fledged type inference.+    askel <- visibleVarArgs+    reportSDoc "tc.check.term.con" 40 $ hsep $+      "trying disambiguation by arguments" : map prettyTCM askel+    reportSDoc "tc.check.term.con" 80 $ hsep $+      "trying disambiguation by arguments" : map pretty askel++    -- Filter out candidates with definitive mismatches.+    cands <- filterM (\ (_d, t, _c) -> matchSkel askel =<< visibleConDoms t) dcs+    case cands of+      [(_d, _t, c)] -> decideOn c+      _ -> fallback+    where++    -- @match@ is successful if there no name conflict (q ≠ q')+    -- and the argument skeleton is not longer thatn the constructor skeleton.+    match ::+          [Maybe QName]   -- Specification (argument skeleton).+       -> [Maybe QName]   -- Candidate (constructor skeleton).+       -> Bool+    match = curry $ \case+      ([], _ ) -> True+      (_ , []) -> False+      (Just q : ms, Just q' : ms') -> q == q' && match ms ms'+      (_ : ms, _ : ms') -> match ms ms'++    -- @match@ with debug printing.+    matchSkel :: [Maybe QName] -> [Maybe QName] -> TCM Bool+    matchSkel argsSkel conSkel = do+      let res = match argsSkel conSkel+      reportSDoc "tc.check.term.con" 40 $ vcat+        [ "matchSkel returns" <+> pretty res <+> "on:"+        , nest 2 $ pretty argsSkel+        , nest 2 $ pretty conSkel+        ]+      return res++    -- Only look at visible arguments that are variables or similar identifiers.+    -- For variables/symbols @Just getTypeHead@ else @Nothing@.+    visibleVarArgs :: TCM [Maybe QName]+    visibleVarArgs = forM (filter visible args) $ \ (arg :: NamedArg A.Expr) -> do+        let v = unScope $ namedArg arg+        reportSDoc "tc.check.term.con" 40 $ "is this a variable? :" <+> prettyTCM v+        reportSDoc "tc.check.term.con" 90 $ "is this a variable? :" <+> (text . show) v+        case v of++          -- We can readly grab the type of a variable from the context.+          A.Var x -> do+            t <- unDom . snd <$> getVarInfo x+            reportSDoc "tc.check.term.con" 40 $ "type of variable:" <+> prettyTCM t+            -- Just keep the name @D@ of type @D vs@+            getTypeHead t++          -- We can also grab the type of defined symbols if we find them in the signature.+          A.Def x -> do+            getConstInfo' x >>= \case+              Right def -> getTypeHead $ defType def+              Left{} -> return Nothing+          _ -> return Nothing++    -- List of visible arguments of the constructor candidate.+    -- E.g. vcons : {A : Set} {n : Nat} (x : A) (xs : Vec A n) → Vec A (suc n)+    -- becomes vcons : ? → Vec → .+    visibleConDoms :: Type -> TCM [Maybe QName]+    visibleConDoms t = do+      TelV tel _ <- telViewPath t+      mapM (getTypeHead . snd . unDom) $ filter visible $ telToList tel++-- | If type is of the form @F vs@ and not blocked in any way, return @F@.+getTypeHead :: Type -> TCM (Maybe QName)+getTypeHead t = do+  res <- ifBlocked t (\ _ _ -> return Nothing) $ \ nb t -> do+    case nb of+      ReallyNotBlocked -> do+        -- Drop initial hidden domains (only needed for generalizable variables).+        TelV _ core <- telViewUpTo' (negate 1) (not . visible) t+        case unEl core of+          Def q _ -> return $ Just q+          _ -> return Nothing+      -- In the other cases, we do not get the data name.+      _ -> return Nothing+  reportSDoc "tc.check.term.con" 80 $ hcat $ "getTypeHead(" : prettyTCM t : ") = " : pretty res : []+  return res+++---------------------------------------------------------------------------+-- * Projections+---------------------------------------------------------------------------++checkUnambiguousProjectionApplication :: Comparison -> A.Expr -> Type -> QName -> ProjOrigin -> A.Expr -> [NamedArg A.Expr] -> TCM Term+checkUnambiguousProjectionApplication cmp e t x o hd args = do+  let fallback = checkHeadApplication cmp e t hd args+  -- Andreas, 2021-02-19, issue #3289+  -- If a postfix projection was moved to the head by appView,+  -- we have to patch the first argument with the correct hiding info.+  case (o, args) of+    (ProjPostfix, arg : rest) -> do+      -- Andreas, 2021-11-19, issue #5657:+      -- If @x@ has been brought into scope by e.g. @open R r@, it is no longer+      -- a projection even though the scope checker labels it so.+      -- Thus, @isProjection@ may fail.+      caseMaybeM (isProjection x) fallback $ \ pr -> do+        checkHeadApplication cmp e t hd (setArgInfo (projArgInfo pr) arg : rest)+    _ -> fallback++-- | Inferring the type of an overloaded projection application.+--   See 'inferOrCheckProjApp'.++inferProjApp :: A.Expr -> ProjOrigin -> List1 QName -> A.Expr -> A.Args -> TCM (Term, Type)+inferProjApp e o ds hd args0 = do+  (v, t, _) <- inferOrCheckProjApp e o ds hd args0 Nothing+  return (v, t)++-- | Checking the type of an overloaded projection application.+--   See 'inferOrCheckProjApp'.++checkProjApp  :: Comparison -> A.Expr -> ProjOrigin -> List1 QName -> A.Expr -> A.Args -> Type -> TCM Term+checkProjApp cmp e o ds hd args0 t = do+  (v, ti, targetCheck) <- inferOrCheckProjApp e o ds hd args0 (Just (cmp, t))+  coerce' cmp targetCheck v ti t++-- | Checking the type of an overloaded projection application.+--   See 'inferOrCheckProjAppToKnownPrincipalArg'.++checkProjAppToKnownPrincipalArg ::+  Comparison+  -> A.Expr+  -> ProjOrigin+  -> List1 QName+  -> A.Expr+  -> A.Args+  -> Type+  -> Int+  -> Term+  -> Type+  -> PrincipalArgTypeMetas+  -> TCM Term+checkProjAppToKnownPrincipalArg cmp e o ds hd args0 t k v0 pt patm = do+  (v, ti, targetCheck) <- inferOrCheckProjAppToKnownPrincipalArg e o ds hd args0 (Just (cmp, t)) k v0 pt (Just patm)+  coerce' cmp targetCheck v ti t++-- | Inferring or Checking an overloaded projection application.+--+--   The overloaded projection is disambiguated by inferring the type of its+--   principal argument, which is the first visible argument.++inferOrCheckProjApp+  :: A.Expr+     -- ^ The whole expression which constitutes the application.+  -> ProjOrigin+     -- ^ The origin of the projection involved in this projection application.+  -> List1 QName+     -- ^ The projection name (potentially ambiguous).+  -> A.Expr+     -- ^ The projection as expression.+  -> A.Args+     -- ^ The arguments to the projection.+  -> Maybe (Comparison, Type)+     -- ^ The expected type of the expression (if 'Nothing', infer it).+  -> TCM (Term, Type, CheckedTarget)+     -- ^ The type-checked expression and its type (if successful).+inferOrCheckProjApp e o ds hd args mt = do+  reportSDoc "tc.proj.amb" 20 $ vcat+    [ "checking ambiguous projection"+    , text $ "  ds   = " ++ prettyShow ds+    , text   "  args = " <+> sep (map prettyTCM args)+    , text   "  t    = " <+> caseMaybe mt "Nothing" prettyTCM+    ]++  let cmp = caseMaybe mt CmpEq fst++      -- Postpone the whole type checking problem+      -- if type of principal argument (or the type where we get it from)+      -- is blocked by meta m.+      postpone b = do+        tc <- caseMaybe mt newTypeMeta_ (return . snd)+        v <- postponeTypeCheckingProblem (CheckExpr cmp e tc) b+        return (v, tc, NotCheckedTarget)++  -- The following cases need to be considered:+  -- 1. No arguments to the projection.+  -- 2. Arguments (parameters), but not the principal argument.+  -- 3. Argument(s) including the principal argument.++  -- For now, we only allow ambiguous projections if the first visible+  -- argument is the record value.++  case filter (visible . snd) $ zip [0..] args of++    -- Case: we have no visible argument to the projection.+    -- In inference mode, we really need the visible argument, postponing does not help+    [] -> caseMaybe mt (refuseProjNotApplied ds) $ \ (cmp , t) -> do+      -- If we have the type, we can try to get the type of the principal argument.+      -- It is the first visible argument.+      TelV _ptel core <- telViewUpTo' (-1) (not . visible) t+      ifBlocked core (\ m _ -> postpone m) $ {-else-} \ _ core -> do+      ifNotPiType core (\ _ -> refuseProjNotApplied ds) $ {-else-} \ dom _b -> do+      ifBlocked (unDom dom) (\ m _ -> postpone m) $ {-else-} \ _ ta -> do+      caseMaybeM (isRecordType ta) (refuseProjNotRecordType ds Nothing ta)+        \ (_q, _pars, RecordData{ _recFields = fs }) -> do+          case forMaybe fs $ \ f -> Fold.find (unDom f ==) ds of+            [] -> refuseProjNoMatching ds+            [d] -> do+              storeDisambiguatedProjection d+              -- checkHeadApplication will check the target type+              (, t, CheckedTarget Nothing) <$>+                checkHeadApplication cmp e t (A.Proj o $ unambiguous d) args+            _ -> __IMPOSSIBLE__++    -- Case: we have a visible argument+    ((k, arg) : _) -> do+      (v0, ta) <- inferExpr $ namedArg arg+      reportSDoc "tc.proj.amb" 25 $ vcat+        [ "  principal arg " <+> prettyTCM arg+        , "  has type "      <+> prettyTCM ta+        ]+      inferOrCheckProjAppToKnownPrincipalArg e o ds hd args mt k v0 ta Nothing++-- | Same arguments 'inferOrCheckProjApp' above but also gets the position,+--   value and type of the principal argument.+inferOrCheckProjAppToKnownPrincipalArg+  :: A.Expr+     -- ^ The whole expression which constitutes the application.+  -> ProjOrigin+     -- ^ The origin of the projection involved in this projection application.+  -> List1 QName+     -- ^ The projection name (potentially ambiguous).+  -> A.Expr+     -- ^ The projection (as application head).+  -> A.Args+     -- ^ The arguments to the projection.+  -> Maybe (Comparison, Type)+     -- ^ The expected type of the expression (if 'Nothing', infer it).+  -> Int+     -- ^ The position of the principal argument.+  -> Term+     -- ^ The value of the principal argument.+  -> Type+     -- ^ The type of the principal argument.+  -> Maybe PrincipalArgTypeMetas+     -- ^ The metas previously created for the principal argument's type, when+     --   picking up a postponed problem. 'Nothing', otherwise.+  -> TCM (Term, Type, CheckedTarget)+     -- ^ The type-checked expression and its type (if successful).+inferOrCheckProjAppToKnownPrincipalArg e o ds hd args mt k v0 ta mpatm = do+  let cmp = caseMaybe mt CmpEq fst+      postpone b patm = do+        tc <- caseMaybe mt newTypeMeta_ (return . snd)+        v <- postponeTypeCheckingProblem (CheckProjAppToKnownPrincipalArg cmp e o ds hd args tc k v0 ta patm) b+        return (v, tc, NotCheckedTarget)+  -- ta should be a record type (after introducing the hidden args in v0)+  patm@(PrincipalArgTypeMetas vargs ta) <- case mpatm of+    -- keep using the previously created metas, when picking up a postponed+    -- problem - see #4924+    Just patm -> return patm+    -- create fresh metas+    Nothing -> uncurry PrincipalArgTypeMetas <$> implicitArgs (-1) (not . visible) ta+  let v = v0 `apply` vargs+  ifBlocked ta (\ m _ -> postpone m patm) {-else-} $ \ _ ta -> do+  caseMaybeM (isRecordType ta) (refuseProjNotRecordType ds (Just v0) ta) $ \ (q, _pars0, _) -> do++      -- try to project it with all of the possible projections+      let try d = do+            reportSDoc "tc.proj.amb" 30 $ vcat+              [ text $ "trying projection " ++ prettyShow d+              , "  td  = " <+> caseMaybeM (getDefType d ta) "Nothing" prettyTCM+              ]++            -- get the original projection name+            def <- lift $ getConstInfo d+            let isP = isProjection_ $ theDef def+            reportSDoc "tc.proj.amb" 40 $ vcat $+              text ( "  isProjection = " ++ caseMaybe isP "no" (const "yes")+                   ) : caseMaybe isP [] (\ Projection{ projProper = proper, projOrig = orig } ->+              [ text $ "  proper       = " ++ show proper+              , text $ "  orig         = " ++ prettyShow orig+              ])++            -- Andreas, 2017-01-21, issue #2422+            -- The scope checker considers inherited projections (from nested records)+            -- as projections and allows overloading.  However, since they are defined+            -- as *composition* of projections, the type checker does *not* recognize them,+            -- and @isP@ will be @Nothing@.+            -- However, we can ignore this, as we only need the @orig@inal projection name+            -- for removing false ambiguity.  Thus, we skip these checks:++            -- Projection{ projProper = proper, projOrig = orig } <- MaybeT $ return isP+            -- guard $ isJust proper+            let orig = caseMaybe isP d projOrig++            -- try to eliminate+            (dom, u, tb) <- MaybeT (projectTyped v ta o d `catchError` \ _ -> return Nothing)+            reportSDoc "tc.proj.amb" 30 $ vcat+              [ "  dom = " <+> prettyTCM dom+              , "  u   = " <+> prettyTCM u+              , "  tb  = " <+> prettyTCM tb+              ]+            (q', pars, _) <- MaybeT $ isRecordType $ unDom dom+            reportSDoc "tc.proj.amb" 30 $ vcat+              [ "  q   = " <+> prettyTCM q+              , "  q'  = " <+> prettyTCM q'+              ]+            guard (q == q')+            -- Get the type of the projection and check+            -- that the first visible argument is the record value.+            let tfull = defType def+            TelV tel _ <- lift $ telViewUpTo' (-1) (not . visible) tfull+            reportSDoc "tc.proj.amb" 30 $ vcat+              [ text $ "  size tel  = " ++ show (size tel)+              , text $ "  size pars = " ++ show (size pars)+              ]+            -- See issue 1960 for when the following assertion fails for+            -- the correct disambiguation.+            -- guard (natSize tel == natSize pars)++            guard =<< do isNothing <$> do lift $ checkModality' d def+            return (orig, (d, (pars, (dom, u, tb))))++      cands <- List1.groupOn fst . List1.catMaybes <$> mapM (runMaybeT . try) ds+      case cands of+        [] -> refuseProjNoMatching ds+        (_:_:_) -> refuseProj ds $ fwords "several matching candidates can be applied."+        -- case: just one matching projection d+        -- the term u = d v+        -- the type tb is the type of this application+        [ (_orig, (d, (pars, (_dom,u,tb)))) :| _ ] -> do+          storeDisambiguatedProjection d++          -- Check parameters+          tfull <- typeOfConst d+          (args0, princArg : args') <- pure $ splitAt k args+          (_,_) <- checkKnownArguments args0 pars tfull++          -- Check remaining arguments+          fun <- pure $ A.App (A.defaultAppInfo $ getRange (hd, args0, princArg))+            (A.unAppView $ A.Application hd args0)+             princArg+          z <- runExceptT $ checkArgumentsE cmp ExpandLast fun args' tb (snd <$> mt)+          case z of+            Right st@(ACState _ _ trest targetCheck) -> do+              v <- checkHeadConstraints (u `applyE`) st+              return (v, trest, targetCheck)+            Left problem -> do+              -- In the inference case:+              -- To create a postponed type checking problem,+              -- we do not use typeDontCare, but create a meta.+              tc <- caseMaybe mt newTypeMeta_ (return . snd)+              v  <- postponeArgs problem cmp ExpandLast fun args' tb tc \ st@(ACState _ _ trest targetCheck) -> do+                      v <- checkHeadConstraints (u `applyE`) st+                      coerce' cmp targetCheck v trest tc++              return (v, tc, NotCheckedTarget)++-- | Throw 'AmbiguousOverloadedProjection' with additional explanation.+refuseProj :: List1 QName -> TCM Doc -> TCM a+refuseProj ds reason = typeError . AmbiguousOverloadedProjection ds =<< reason++refuseProjNotApplied, refuseProjNoMatching :: List1 QName -> TCM a+refuseProjNotApplied    ds = refuseProj ds $ fwords "it is not applied to a visible argument"+refuseProjNoMatching    ds = refuseProj ds $ fwords "no matching candidate found"+refuseProjNotRecordType :: List1 QName -> Maybe Term -> Type -> TCM a+refuseProjNotRecordType ds pValue pType = do+  let dType = prettyTCM pType+  let dValue = caseMaybe pValue (return empty) prettyTCM+  refuseProj ds $ fsep $+    ["principal argument", dValue, "has type", dType, "while it should be of record type"]++-----------------------------------------------------------------------------+-- * Sorts+-----------------------------------------------------------------------------++checkUniv+  :: UnivSize -> Univ -> Comparison -> A.Expr -> Type+  -> QName -> Suffix -> [NamedArg A.Expr] -> TCM Term+checkUniv sz u cmp e t q suffix args = do+  (v, t0) <- inferUniv sz u e q suffix args+  coerce cmp v t0 t++inferUniv :: UnivSize -> Univ -> A.Expr -> QName -> Suffix -> [NamedArg A.Expr] -> TCM (Term, Type)+inferUniv sz u e q s args = do+  univChecks u+  case sz of+    USmall -> inferLeveledSort u q s args+    ULarge -> inferUnivOmega u q s args++univChecks :: Univ -> TCM ()+univChecks = \case+  UProp -> unlessM isPropEnabled $ typeError NeedOptionProp+  UType -> pure ()+  USSet -> unlessM isTwoLevelEnabled $ typeError NeedOptionTwoLevel++suffixToLevel :: Suffix -> Integer+suffixToLevel = \case+  NoSuffix -> 0+  Suffix n -> n++inferLeveledSort ::+     Univ                -- ^ The universe type.+  -> QName               -- ^ Name of the universe, for error reporting.+  -> Suffix              -- ^ Level of the universe given via suffix (optional).+  -> [NamedArg A.Expr]   -- ^ Level of the universe given via argument (absent if suffix).+  -> TCM (Term, Type)    -- ^ Universe and its sort.+inferLeveledSort u q suffix = \case+  [] -> do+    let n = suffixToLevel suffix+    return (Sort (Univ u $ ClosedLevel n) , sort (Univ (univUniv u) $ ClosedLevel $ n + 1))+  arg : args -> do+    unless (visible arg) $ typeError $ WrongHidingInApplication $ sort $ Univ u $ ClosedLevel 0+    unlessM hasUniversePolymorphism $ typeError NeedOptionUniversePolymorphism+    List1.unlessNull args $ warning . TooManyArgumentsToSort q+    l <- applyRelevanceToContext shapeIrrelevant $ checkLevel arg+    return (Sort $ Univ u l , sort (Univ (univUniv u) $ levelSuc l))++inferUnivOmega ::+     Univ                -- ^ The universe type.+  -> QName               -- ^ Name of the universe, for error reporting.+  -> Suffix              -- ^ Level of the universe given via suffix (optional).+  -> [NamedArg A.Expr]   -- ^ Level of the universe given via argument (should be absent).+  -> TCM (Term, Type)    -- ^ Universe and its sort.+inferUnivOmega u q suffix args = do+    List1.unlessNull args $ warning . TooManyArgumentsToSort q+    let n = suffixToLevel suffix+    return (Sort (Inf u n) , sort (Inf (univUniv u) $ 1 + n))++-----------------------------------------------------------------------------+-- * Coinduction+-----------------------------------------------------------------------------++checkSharpApplication :: A.Expr -> Type -> QName -> [NamedArg A.Expr] -> TCM Term+checkSharpApplication e t c args = do+  arg <- case args of+           [a] | visible a -> return $ namedArg a+           _ -> typeError $ WrongSharpArity c++  -- The name of the fresh function.+  i <- fresh :: TCM Int+  let name = filter (/= '_') (prettyShow $ A.nameConcrete $ A.qnameName c) ++ "-" ++ show i++  kit <- coinductionKit'+  let flat = nameOfFlat kit+      inf  = nameOfInf  kit++  -- Add the type signature of the fresh function to the+  -- signature.+  -- To make sure we can type check the generated function we have to make+  -- sure that its type is \inf. The reason for this is that we don't yet+  -- postpone checking of patterns when we don't know their types (Issue480).+  forcedType <- do+    lvl <- levelType+    (_, l) <- newValueMeta RunMetaOccursCheck CmpLeq lvl+    lv  <- levelView l+    (_, a) <- newValueMeta RunMetaOccursCheck CmpEq (sort $ Type lv)+    return $ El (Type lv) $ Def inf [Apply $ setHiding Hidden $ defaultArg l, Apply $ defaultArg a]++  wrapper <- inFreshModuleIfFreeParams $+             setRunTimeModeUnlessInHardCompileTimeMode $ do+    -- Andreas, 2019-10-12: create helper functions in non-erased mode.+    -- Otherwise, they are not usable in meta-solutions in the term world.+    -- #4743: Except if hard compile-time mode is enabled.+    c' <- setRange (getRange c) <$>+            liftM2 qualify (killRange <$> currentModule)+                           (freshName_ name)++    -- Define and type check the fresh function.+    mod <- currentModality+    abs <- asksTC (^. lensIsAbstract)+    let info   = A.mkDefInfo (A.nameConcrete $ A.qnameName c') noFixity'+                             PublicAccess abs noRange+        core   = A.LHSProj { A.lhsDestructor = unambiguous flat+                           , A.lhsFocus      = defaultNamedArg $ A.LHSHead c' []+                           , A.lhsPats       = [] }+        clause = A.Clause (A.LHS empty core) []+                          (A.RHS arg Nothing)+                          A.noWhereDecls empty++    i <- currentOrFreshMutualBlock++    -- If we are in irrelevant position, add definition irrelevantly.+    -- If we are in erased position, add definition as erased.+    -- TODO: is this sufficient?+    addConstant c' =<< do+      let ai = setModality mod defaultArgInfo+      lang <- getLanguage+      fun  <- emptyFunction+      useTerPragma $+        (defaultDefn ai c' forcedType lang fun)+        { defMutual = i }++    checkFunDef info c' [clause]++    reportSDoc "tc.term.expr.coind" 15 $ do+      def <- theDef <$> getConstInfo c'+      vcat $+        [ "The coinductive wrapper"+        , nest 2 $ prettyTCM mod <> (prettyTCM c' <+> ":")+        , nest 4 $ prettyTCM t+        , nest 2 $ prettyA clause+        ]+    return c'++  -- The application of the fresh function to the relevant+  -- arguments.+  e' <- Def wrapper . map Apply <$> getContextArgs++  reportSDoc "tc.term.expr.coind" 15 $ vcat $+      [ "The coinductive constructor application"+      , nest 2 $ prettyTCM e+      , "was translated into the application"+      , nest 2 $ prettyTCM e'+      ]++  blockTerm t $ e' <$ workOnTypes (leqType forcedType t)++-----------------------------------------------------------------------------+-- * Cubical+-----------------------------------------------------------------------------++-- | "pathAbs (PathView s _ l a x y) t" builds "(\ t) : pv"+--   Preconditions: PathView is PathType, and t[i0] = x, t[i1] = y+pathAbs :: PathView -> Abs Term -> TCM Term+pathAbs (OType _) t = __IMPOSSIBLE__+pathAbs (PathType s path l a x y) t = do+  return $ Lam defaultArgInfo t++-- | @primComp : ∀ {ℓ} (A : (i : I) → Set (ℓ i)) (φ : I) (u : ∀ i → Partial φ (A i)) (a : A i0) → A i1@+--+--   Check:  @u i0 = (λ _ → a) : Partial φ (A i0)@.+--+checkPrimComp :: QName -> MaybeRanges -> Args -> Type -> TCM Args+checkPrimComp c rs vs _ = do+  case vs of+    -- WAS: [l, a, phi, u, a0] -> do+    l : a : phi : u : a0 : rest -> do+      iz <- Arg defaultArgInfo <$> intervalUnview IZero+      let lz = unArg l `apply` [iz]+          az = unArg a `apply` [iz]+      ty <- el's (pure (unArg l `apply` [iz])) $ primPartial <#> pure (unArg l `apply` [iz]) <@> pure (unArg phi) <@> pure (unArg a `apply` [iz])+      bAz <- el' (pure $ lz) (pure $ az)+      a0 <- blockArg bAz (rs !!! 4) a0 $ do+        equalTerm ty -- (El (getSort t1) (apply (unArg a) [iz]))+          (Lam defaultArgInfo $ NoAbs "_" $ unArg a0)+          (apply (unArg u) [iz])+      return $ l : a : phi : u : a0 : rest+    _ -> typeError $ CubicalPrimitiveNotFullyApplied c++-- | @primHComp : ∀ {ℓ} {A : Set ℓ} {φ : I} (u : ∀ i → Partial φ A) (a : A) → A@+--+--   Check:  @u i0 = (λ _ → a) : Partial φ A@.+--+checkPrimHComp :: QName -> MaybeRanges -> Args -> Type -> TCM Args+checkPrimHComp c rs vs _ = do+  case vs of+    -- WAS: [l, a, phi, u, a0] -> do+    l : a : phi : u : a0 : rest -> do+      -- iz = i0+      iz <- Arg defaultArgInfo <$> intervalUnview IZero+      -- ty = Partial φ A+      ty <- el's (pure (unArg l)) $ primPartial <#> pure (unArg l) <@> pure (unArg phi) <@> pure (unArg a)+      -- (λ _ → a) = u i0 : ty+      bA <- el' (pure $ unArg l) (pure $ unArg a)+      a0 <- blockArg bA (rs !!! 4) a0 $ do+        equalTerm ty -- (El (getSort t1) (apply (unArg a) [iz]))+            (Lam defaultArgInfo $ NoAbs "_" $ unArg a0)+            (apply (unArg u) [iz])+      return $ l : a : phi : u : a0 : rest+    _ -> typeError $ CubicalPrimitiveNotFullyApplied c++-- | @transp : ∀{ℓ} (A : (i : I) → Set (ℓ i)) (φ : I) (a0 : A i0) → A i1@+--+--   Check:  If φ, then @A i = A i0 : Set (ℓ i)@ must hold for all @i : I@.+--+checkPrimTrans :: QName -> MaybeRanges -> Args -> Type -> TCM Args+checkPrimTrans c rs vs _ = do+  case vs of+    -- Andreas, 2019-03-02, issue #3601, why exactly 4 arguments?+    -- Only 3 are needed to check the side condition.+    -- WAS:+    -- [l, a, phi, a0] -> do+    l : a : phi : rest -> do+      iz <- Arg defaultArgInfo <$> intervalUnview IZero+      -- ty = (i : I) -> Set (l i)+      ty <- runNamesT [] $ do+        l <- open $ unArg l+        nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (l <@> i))+      a <- blockArg ty (rs !!! 1) a $ do+        equalTermOnFace (unArg phi) ty+          (unArg a)+          (Lam defaultArgInfo $ NoAbs "_" $ apply (unArg a) [iz])+      return $ l : a : phi : rest+    _ -> typeError $ CubicalPrimitiveNotFullyApplied c++blockArg :: HasRange r => Type -> r -> Arg Term -> TCM () -> TCM (Arg Term)+blockArg t r a m =+  setCurrentRange (getRange $ r) $ fmap (a $>) $ blockTerm t $ m >> return (unArg a)++-- The following comment contains silly ' escapes to calm CPP about ∨ (\vee).+-- May not be haddock-parseable.++-- ' @primPOr : ∀ {ℓ} (φ₁ φ₂ : I) {A : Partial (φ₁ ∨ φ₂) (Set ℓ)}+-- '         → (u : PartialP φ₁ (λ (o : IsOne φ₁) → A (IsOne1 φ₁ φ₂ o)))+-- '         → (v : PartialP φ₂ (λ (o : IsOne φ₂) → A (IsOne2 φ₁ φ₂ o)))+-- '         → PartialP (φ₁ ∨ φ₂) A@+-- '+-- ' Checks: @u = v : PartialP (φ₁ ∨ φ₂) A@ whenever @IsOne (φ₁ ∧ φ₂)@.+checkPOr :: QName -> MaybeRanges -> Args -> Type -> TCM Args+checkPOr c rs vs _ = do+  case vs of+   l : phi1 : phi2 : a : u : v : rest -> do+      phi <- intervalUnview (IMin phi1 phi2)+      reportSDoc "tc.term.por" 10 $ text (show phi)+      t1 <- runNamesT [] $ do+             l <- open . unArg $ l+             a <- open . unArg $ a+             psi <- open =<< intervalUnview (IMax phi1 phi2)+             pPi' "o" psi $ \ o -> el' l (a <..> o)+      tv <- runNamesT [] $ do+             l    <- open . unArg $ l+             a    <- open . unArg $ a+             phi1 <- open . unArg $ phi1+             phi2 <- open . unArg $ phi2+             pPi' "o" phi2 $ \ o -> el' l (a <..> (cl primIsOne2 <@> phi1 <@> phi2 <@> o))+      v <- blockArg tv (rs !!! 5) v $ do+        -- ' φ₁ ∧ φ₂  ⊢ u , v : PartialP (φ₁ ∨ φ₂) \ o → a o+        equalTermOnFace phi t1 (unArg u) (unArg v)+      return $ l : phi1 : phi2 : a : u : v : rest+   _ -> typeError $ CubicalPrimitiveNotFullyApplied c++-- | @prim^glue : ∀ {ℓ ℓ'} {A : Set ℓ} {φ : I}+--              → {T : Partial φ (Set ℓ')} → {e : PartialP φ (λ o → T o ≃ A)}+--              → (t : PartialP φ T) → (a : A) → primGlue A T e@+--+--   Check   @φ ⊢ a = e 1=1 (t 1=1)@  or actually the equivalent:  @(\ _ → a) = (\ o -> e o (t o)) : PartialP φ A@+check_glue :: QName -> MaybeRanges -> Args -> Type -> TCM Args+check_glue c rs vs _ = do+  case vs of+   -- WAS: [la, lb, bA, phi, bT, e, t, a] -> do+   la : lb : bA : phi : bT : e : t : a : rest -> do+      v <- runNamesT [] $ do+            lb  <- open . unArg $ lb+            la  <- open . unArg $ la+            bA  <- open . unArg $ bA+            phi <- open . unArg $ phi+            bT  <- open . unArg $ bT+            e   <- open . unArg $ e+            t   <- open . unArg $ t+            let f o = cl primEquivFun <#> lb <#> la <#> (bT <..> o) <#> bA <@> (e <..> o)+            glam defaultIrrelevantArgInfo "o" $ \ o -> f o <@> (t <..> o)+      ty <- runNamesT [] $ do+            lb  <- open . unArg $ lb+            phi <- open . unArg $ phi+            bA  <- open . unArg $ bA+            el's lb $ cl primPartialP <#> lb <@> phi <@> glam defaultIrrelevantArgInfo "o" (\ _ -> bA)+      let a' = Lam defaultIrrelevantArgInfo (NoAbs "o" $ unArg a)+      ta <- el' (pure $ unArg la) (pure $ unArg bA)+      a <- blockArg ta (rs !!! 7) a $ equalTerm ty a' v+      return $ la : lb : bA : phi : bT : e : t : a : rest+   _ -> typeError $ CubicalPrimitiveNotFullyApplied c+++-- | @prim^glueU : ∀ {ℓ} {φ : I}+--              → {T : I → Partial φ (Set ℓ)} → {A : Set ℓ [ φ ↦ T i0 ]}+--              → (t : PartialP φ (T i1)) → (a : outS A) → hcomp T (outS A)@+--+--   Check   @φ ⊢ a = transp (\ i -> T 1=1 (~ i)) i0 (t 1=1)@  or actually the equivalent:+--           @(\ _ → a) = (\o -> transp (\ i -> T o (~ i)) i0 (t o)) : PartialP φ (T i0)@+check_glueU :: QName -> MaybeRanges -> Args -> Type -> TCM Args+check_glueU c rs vs _ = do+  case vs of+   -- WAS: [la, lb, bA, phi, bT, e, t, a] -> do+   la : phi : bT : bA : t : a : rest -> do+      v <- runNamesT [] $ do+            la  <- open . unArg $ la+            phi <- open . unArg $ phi+            bT  <- open . unArg $ bT+            bA  <- open . unArg $ bA+            t   <- open . unArg $ t+            let f o = cl primTrans <#> lam "i" (const la) <@> lam "i" (\ i -> bT <@> (cl primINeg <@> i) <..> o) <@> cl primIZero+            glam defaultIrrelevantArgInfo "o" $ \ o -> f o <@> (t <..> o)+      ty <- runNamesT [] $ do+            la  <- open . unArg $ la+            phi <- open . unArg $ phi+            bT  <- open . unArg $ bT+            pPi' "o" phi $ \ o -> el' la (bT <@> cl primIZero <..> o)+      let a' = Lam defaultIrrelevantArgInfo (NoAbs "o" $ unArg a)+      ta <- runNamesT [] $ do+            la  <- open . unArg $ la+            phi <- open . unArg $ phi+            bT  <- open . unArg $ bT+            bA  <- open . unArg $ bA+            el' la (cl primSubOut <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <#> (bT <@> cl primIZero) <@> bA)+      a <- blockArg ta (rs !!! 5) a $ equalTerm ty a' v+      return $ la : phi : bT : bA : t : a : rest+   _ -> typeError $ CubicalPrimitiveNotFullyApplied c
src/full/Agda/TypeChecking/Rules/Application.hs-boot view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Rules.Application where @@ -6,17 +7,46 @@ import Agda.Syntax.Common (NamedArg, ProjOrigin) import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Internal-import Agda.Syntax.Position import Agda.TypeChecking.Monad.Base -checkArguments :: Comparison -> ExpandHidden -> Range -> [NamedArg A.Expr] -> Type -> Type ->-                  (ArgsCheckState CheckedTarget -> TCM Term) -> TCM Term+checkArguments ::+     Comparison+  -> ExpandHidden+  -> A.Expr+  -> [NamedArg A.Expr]+  -> Type+  -> Type+  -> (ArgsCheckState CheckedTarget -> TCM Term)+  -> TCM Term -checkArguments_ :: Comparison -> ExpandHidden -> Range -> [NamedArg A.Expr] -> Telescope ->-                   TCM (Elims, Telescope)+checkArguments_ ::+     Comparison+  -> ExpandHidden+  -> A.Expr+  -> [NamedArg A.Expr]+  -> Telescope+  -> TCM (Elims, Telescope)  checkApplication :: Comparison -> A.Expr -> A.Args -> A.Expr -> Type -> TCM Term  inferApplication :: ExpandHidden -> A.Expr -> A.Args -> A.Expr -> TCM (Term, Type) -checkProjAppToKnownPrincipalArg  :: Comparison -> A.Expr -> ProjOrigin -> NonEmpty QName -> A.Args -> Type -> Int -> Term -> Type -> PrincipalArgTypeMetas -> TCM Term+checkProjAppToKnownPrincipalArg ::+     Comparison+  -> A.Expr+  -> ProjOrigin+  -> NonEmpty QName+  -> A.Expr+  -> A.Args+  -> Type+  -> Int+  -> Term+  -> Type+  -> PrincipalArgTypeMetas+  -> TCM Term++disambiguateConstructor' :: ConstructorDisambiguationData -> (ConHead -> TCM Term) -> TCM Term++univChecks :: Univ -> TCM ()++suffixToLevel :: Suffix -> Integer
src/full/Agda/TypeChecking/Rules/Builtin.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE NondecreasingIndentation #-}  module Agda.TypeChecking.Rules.Builtin@@ -11,13 +13,14 @@  import Prelude hiding (null) -import Control.Monad-import Control.Monad.Except+import Control.Monad.Except      ( catchError )+import Control.Monad.Trans.Maybe  import Data.List (find, sortBy)-import Data.List.NonEmpty (NonEmpty(..)) import Data.Function (on) +import Agda.Interaction.Options.Base+ import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common import Agda.Syntax.Internal@@ -28,10 +31,8 @@  import qualified Agda.TypeChecking.CompiledClause as CC import Agda.TypeChecking.Conversion-import Agda.TypeChecking.Constraints-import Agda.TypeChecking.EtaContract+import Agda.TypeChecking.Constraints ( noConstraints ) import Agda.TypeChecking.Functions-import Agda.TypeChecking.Irrelevance import Agda.TypeChecking.Names import Agda.TypeChecking.Pretty import Agda.TypeChecking.Primitive@@ -39,14 +40,15 @@ import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Rules.Term ( checkExpr , inferExpr ) import Agda.TypeChecking.Warnings +import {-# SOURCE #-} Agda.TypeChecking.Rules.Term ( checkExpr , inferExpr ) import {-# SOURCE #-} Agda.TypeChecking.Rules.Builtin.Coinduction import {-# SOURCE #-} Agda.TypeChecking.Rewriting  import Agda.Utils.Functor import Agda.Utils.List+import Agda.Utils.List1 (pattern (:|)) import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null@@ -59,13 +61,13 @@ ---------------------------------------------------------------------------  builtinPostulate :: TCM Type -> BuiltinDescriptor-builtinPostulate = BuiltinPostulate Relevant+builtinPostulate = BuiltinPostulate relevant  builtinPostulateC :: Cubical -> TCM Type -> BuiltinDescriptor builtinPostulateC c m =-  BuiltinPostulate Relevant $ requireCubical c "" >> m+  builtinPostulate $ requireCubical c >> m -findBuiltinInfo :: String -> Maybe BuiltinInfo+findBuiltinInfo :: BuiltinId -> Maybe BuiltinInfo findBuiltinInfo b = find ((b ==) . builtinName) coreBuiltins  coreBuiltins :: [BuiltinInfo]@@ -84,7 +86,7 @@                                                               nPi' "B" (el' a bA --> (sort . tmSort <$> b)) $ \bB ->                                                               ((sort . tmSort) <$> (cl primLevelMax <@> a <@> b))                                                               )-                                                             ["SIGMACON"])+                                                             [BuiltinSigmaCon])   , (builtinUnit                             |-> BuiltinData tset [builtinUnitUnit])  -- actually record, but they are treated the same   , (builtinAgdaLiteral                      |-> BuiltinData tset [builtinAgdaLitNat, builtinAgdaLitWord64, builtinAgdaLitFloat,                                                                    builtinAgdaLitChar, builtinAgdaLitString,@@ -97,7 +99,7 @@   , (builtinAgdaPatLit                       |-> BuiltinDataCons (tliteral --> tpat))   , (builtinAgdaPatProj                      |-> BuiltinDataCons (tqname --> tpat))   , (builtinAgdaPatAbsurd                    |-> BuiltinDataCons (tnat --> tpat))-  , (builtinLevel                            |-> builtinPostulate tset)+  , (builtinLevel                            |-> builtinPostulate tLevelUniv)   , (builtinWord64                           |-> builtinPostulate tset)   , (builtinInteger                          |-> BuiltinData tset [builtinIntegerPos, builtinIntegerNegSuc])   , (builtinIntegerPos                       |-> BuiltinDataCons (tnat --> tinteger))@@ -109,7 +111,7 @@   , (builtinAgdaMeta                         |-> builtinPostulate tset)   , (builtinIO                               |-> builtinPostulate (tset --> tset))   , (builtinPath                             |-> BuiltinUnknown-                                                             (Just $ requireCubical CErased "" >>+                                                             (Just $ requireCubical CErased >>                                                              hPi "a" (el primLevel) (                                                               hPi "A" (return $ sort $ varSort 0) $                                                               (El (varSort 1) <$> varM 0) -->@@ -121,8 +123,9 @@                                                               (El (varSort 1) <$> varM 0 <@> primIZero) -->                                                               (El (varSort 1) <$> varM 0 <@> primIOne) -->                                                               return (sort $ varSort 1)))-  , (builtinInterval                         |-> BuiltinData (requireCubical CErased "" >>-                                                              (return $ ssort $ ClosedLevel 0)) [builtinIZero,builtinIOne])+  , (builtinIntervalUniv                     |-> BuiltinSort SortIntervalUniv)+  , (builtinInterval                         |-> BuiltinData (requireCubical CErased >>+                                                              return (sort IntervalUniv)) [builtinIZero,builtinIOne])   , (builtinSub                              |-> builtinPostulateC CErased (runNamesT [] $ hPi' "a" (el $ cl primLevel) $ \ a ->                                                                    nPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->                                                                    nPi' "φ" (cl tinterval) $ \ phi ->@@ -131,13 +134,13 @@   , (builtinSubIn                            |-> builtinPostulateC CErased (runNamesT [] $                                                                    hPi' "a" (el $ cl primLevel) $ \ a ->                                                                    hPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->-                                                                   hPi' "φ" (elSSet $ cl primInterval) $ \ phi ->+                                                                   hPi' "φ" (cl tinterval) $ \ phi ->                                                                    nPi' "x" (el' a bA) $ \ x ->                                                                    el's a $ cl primSub <#> a <@> bA <@> phi <@> lam "o" (\ _ -> x)))   , (builtinIZero                            |-> BuiltinDataCons tinterval)   , (builtinIOne                             |-> BuiltinDataCons tinterval)-  , (builtinPartial                          |-> BuiltinPrim "primPartial" (const $ return ()))-  , (builtinPartialP                         |-> BuiltinPrim "primPartialP" (const $ return ()))+  , (builtinPartial                          |-> BuiltinPrim PrimPartial (const $ return ()))+  , (builtinPartialP                         |-> BuiltinPrim PrimPartialP (const $ return ()))   , (builtinIsOne                            |-> builtinPostulateC CErased (tinterval --> return (ssort $ ClosedLevel 0)))   , (builtinItIsOne                          |-> builtinPostulateC CErased (elSSet $ primIsOne <@> primIOne))   , (builtinIsOne1                           |-> builtinPostulateC CErased (runNamesT [] $@@ -155,21 +158,9 @@                                                                    hPi' "A" (pPi' "o" (cl primIZero) $ \ _ ->                                                                                   el' (cl primLevelSuc <@> l) (Sort . tmSort <$> l)) $ \ bA ->                                                                    pPi' "o" (cl primIZero) (\ o ->-                                                                        el' l $ gApply' (setRelevance Irrelevant defaultArgInfo) bA o)))+                                                                        el' l $ gApply' defaultIrrelevantArgInfo bA o))) -  , (builtinId                               |-> builtinPostulateC CErased (hPi "a" (el primLevel) $-                                                              hPi "A" (return $ sort $ varSort 0) $-                                                              (El (varSort 1) <$> varM 0) -->-                                                              (El (varSort 1) <$> varM 0) -->-                                                              return (sort $ varSort 1)))-  , (builtinConId                            |-> builtinPostulateC CErased (hPi "a" (el primLevel) $-                                                           hPi "A" (return $ sort $ varSort 0) $-                                                           hPi "x" (El (varSort 1) <$> varM 0) $-                                                           hPi "y" (El (varSort 2) <$> varM 1) $-                                                           tinterval -->-                                                           (El (varSort 3) <$> primPath <#> varM 3 <#> varM 2 <@> varM 1 <@> varM 0) -->-                                                           (El (varSort 3) <$> primId <#> varM 3 <#> varM 2 <@> varM 1 <@> varM 0)))-  , (builtinEquiv                            |-> BuiltinUnknown (Just $ requireCubical CFull "" >> runNamesT [] (+  , (builtinEquiv                            |-> BuiltinUnknown (Just $ requireCubical CErased >> runNamesT [] (                                                                     hPi' "l" (el $ cl primLevel) $ \ a ->                                                                     hPi' "l'" (el $ cl primLevel) $ \ b ->                                                                     nPi' "A" (sort . tmSort <$> a) $ \bA ->@@ -177,7 +168,7 @@                                                                     ((sort . tmSort) <$> (cl primLevelMax <@> a <@> b))                                                                   ))                                                                    (const $ const $ return ()))-  , (builtinEquivFun                         |-> BuiltinUnknown (Just $ requireCubical CFull "" >> runNamesT [] (+  , (builtinEquivFun                         |-> BuiltinUnknown (Just $ requireCubical CErased >> runNamesT [] (                                                                  hPi' "l" (el $ cl primLevel) $ \ a ->                                                                  hPi' "l'" (el $ cl primLevel) $ \ b ->                                                                  hPi' "A" (sort . tmSort <$> a) $ \bA ->@@ -186,7 +177,7 @@                                                                  (el' a bA --> el' b bB)                                                                ))                                                                 (const $ const $ return ()))-  , (builtinEquivProof                       |-> BuiltinUnknown (Just $ requireCubical CFull "" >> runNamesT [] (+  , (builtinEquivProof                       |-> BuiltinUnknown (Just $ requireCubical CErased >> runNamesT [] (                                                                hPi' "l" (el $ cl primLevel) $ \ la ->                                                                hPi' "l'" (el $ cl primLevel) $ \ lb ->                                                                nPi' "A" (sort . tmSort <$> la) $ \ bA ->@@ -195,16 +186,18 @@                                                                              (cl primEquiv <#> la <#> lb <@> bA <@> bB)) $ \ e -> do                                                                nPi' "b" (el' lb bB) $ \ b -> do                                                                 let f = cl primEquivFun <#> la <#> lb <#> bA <#> bB <@> e-                                                                    fiber = el' (cl primLevelMax <@> la <@> lb)+                                                                    lub = cl primLevelMax <@> la <@> lb+                                                                    fiber = el' lub                                                                                 (cl primSigma <#> la <#> lb                                                                                   <@> bA                                                                                   <@> lam "a" (\ a ->                                                                                          cl primPath <#> lb <#> bB <@> (f <@> a) <@> b))                                                                 nPi' "φ" (cl tinterval) $ \ phi ->-                                                                  pPi' "o" phi (\ o -> fiber) --> fiber+                                                                  nPi' "f" (pPi' "o" phi (\ o -> fiber)) $ \ pfib ->+                                                                    el' lub (cl primSub <#> lub <#> fmap unEl fiber <@> phi <@> pfib)                                                              ))                                                               (const $ const $ return ()))-  , (builtinTranspProof                       |-> BuiltinUnknown (Just $ requireCubical CErased "" >> runNamesT [] (+  , (builtinTranspProof                       |-> BuiltinUnknown (Just $ requireCubical CErased >> runNamesT [] (                                                                hPi' "l" (el $ cl primLevel) $ \ la -> do                                                                nPi' "e" (cl tinterval --> (sort . tmSort <$> la)) $ \ e -> do                                                                let lb = la; bA = e <@> cl primIZero; bB = e <@> cl primIOne@@ -232,10 +225,15 @@                                                    , builtinAgdaTermPi, builtinAgdaTermSort                                                    , builtinAgdaTermLit, builtinAgdaTermMeta                                                    , builtinAgdaTermUnsupported])-  , builtinAgdaErrorPart                     |-> BuiltinData tset [ builtinAgdaErrorPartString, builtinAgdaErrorPartTerm, builtinAgdaErrorPartName ]+  , builtinAgdaErrorPart                     |-> BuiltinData tset [ builtinAgdaErrorPartString, builtinAgdaErrorPartTerm, builtinAgdaErrorPartPatt, builtinAgdaErrorPartName ]   , builtinAgdaErrorPartString               |-> BuiltinDataCons (tstring --> terrorpart)   , builtinAgdaErrorPartTerm                 |-> BuiltinDataCons (tterm --> terrorpart)+  , builtinAgdaErrorPartPatt                 |-> BuiltinDataCons (tpat --> terrorpart)   , builtinAgdaErrorPartName                 |-> BuiltinDataCons (tqname --> terrorpart)+  , builtinAgdaBlocker                       |-> BuiltinData tset [ builtinAgdaBlockerAll, builtinAgdaBlockerAny, builtinAgdaBlockerMeta ]+  , builtinAgdaBlockerAny                    |-> BuiltinDataCons (tlist tblocker --> tblocker)+  , builtinAgdaBlockerAll                    |-> BuiltinDataCons (tlist tblocker --> tblocker)+  , builtinAgdaBlockerMeta                   |-> BuiltinDataCons (tmeta --> tblocker)   -- Andreas, 2017-01-12, issue #2386: special handling of builtinEquality   -- , (builtinEquality                         |-> BuiltinData (hPi "a" (el primLevel) $   --                                                             hPi "A" (return $ sort $ varSort 0) $@@ -304,9 +302,7 @@   , (builtinHidden                           |-> BuiltinDataCons thiding)   , (builtinInstance                         |-> BuiltinDataCons thiding)   , (builtinVisible                          |-> BuiltinDataCons thiding)-  , (builtinSizeUniv                         |-> builtinPostulate tSizeUniv) -- SizeUniv : SizeUniv--- See comment on tSizeUniv: the following does not work currently.---  , (builtinSizeUniv                          |-> builtinPostulate tSetOmega) -- SizeUniv : Setω+  , (builtinSizeUniv                         |-> builtinPostulate tsetOmega) -- SizeUniv : Setω   , (builtinSize                             |-> builtinPostulate tSizeUniv)   , (builtinSizeLt                           |-> builtinPostulate (tsize ..--> tSizeUniv))   , (builtinSizeSuc                          |-> builtinPostulate (tsize --> tsize))@@ -320,21 +316,23 @@   , (builtinAgdaSortPropLit                  |-> BuiltinDataCons (tnat --> tsort))   , (builtinAgdaSortInf                      |-> BuiltinDataCons (tnat --> tsort))   , (builtinAgdaSortUnsupported              |-> BuiltinDataCons tsort)-  , (builtinNatPlus                          |-> BuiltinPrim "primNatPlus" verifyPlus)-  , (builtinNatMinus                         |-> BuiltinPrim "primNatMinus" verifyMinus)-  , (builtinNatTimes                         |-> BuiltinPrim "primNatTimes" verifyTimes)-  , (builtinNatDivSucAux                     |-> BuiltinPrim "primNatDivSucAux" verifyDivSucAux)-  , (builtinNatModSucAux                     |-> BuiltinPrim "primNatModSucAux" verifyModSucAux)-  , (builtinNatEquals                        |-> BuiltinPrim "primNatEquality" verifyEquals)-  , (builtinNatLess                          |-> BuiltinPrim "primNatLess" verifyLess)-  , (builtinLevelZero                        |-> BuiltinPrim "primLevelZero" (const $ return ()))-  , (builtinLevelSuc                         |-> BuiltinPrim "primLevelSuc" (const $ return ()))-  , (builtinLevelMax                         |-> BuiltinPrim "primLevelMax" verifyMax)-  , (builtinSet                              |-> BuiltinSort "primSet")-  , (builtinProp                             |-> BuiltinSort "primProp")-  , (builtinSetOmega                         |-> BuiltinSort "primSetOmega")-  , (builtinSSetOmega                        |-> BuiltinSort "primStrictSetOmega")-  , (builtinStrictSet                        |-> BuiltinSort "primStrictSet")+  , (builtinNatPlus                          |-> BuiltinPrim PrimNatPlus verifyPlus)+  , (builtinNatMinus                         |-> BuiltinPrim PrimNatMinus verifyMinus)+  , (builtinNatTimes                         |-> BuiltinPrim PrimNatTimes verifyTimes)+  , (builtinNatDivSucAux                     |-> BuiltinPrim PrimNatDivSucAux verifyDivSucAux)+  , (builtinNatModSucAux                     |-> BuiltinPrim PrimNatModSucAux verifyModSucAux)+  , (builtinNatEquals                        |-> BuiltinPrim PrimNatEquality verifyEquals)+  , (builtinNatLess                          |-> BuiltinPrim PrimNatLess verifyLess)+  , (builtinLevelUniv                        |-> BuiltinSort SortLevelUniv)+  , (builtinLevelZero                        |-> BuiltinPrim PrimLevelZero (const $ return ()))+  , (builtinLevelSuc                         |-> BuiltinPrim PrimLevelSuc (const $ return ()))+  , (builtinLevelMax                         |-> BuiltinPrim PrimLevelMax verifyMax)+  , (builtinProp                             |-> BuiltinSort SortProp)+  , (builtinSet                              |-> BuiltinSort SortSet)+  , (builtinStrictSet                        |-> BuiltinSort SortStrictSet)+  , (builtinPropOmega                        |-> BuiltinSort SortPropOmega)+  , (builtinSetOmega                         |-> BuiltinSort SortSetOmega)+  , (builtinSSetOmega                        |-> BuiltinSort SortStrictSetOmega)   , (builtinAgdaClause                       |-> BuiltinData tset [builtinAgdaClauseClause, builtinAgdaClauseAbsurd])   , (builtinAgdaClauseClause                 |-> BuiltinDataCons (ttelescope --> tlist (targ tpat) --> tterm --> tclause))   , (builtinAgdaClauseAbsurd                 |-> BuiltinDataCons (ttelescope --> tlist (targ tpat) --> tclause))@@ -346,7 +344,7 @@                                                                   ,builtinAgdaDefinitionPrimitive])   , (builtinAgdaDefinitionFunDef             |-> BuiltinDataCons (tlist tclause --> tdefn))   , (builtinAgdaDefinitionDataDef            |-> BuiltinDataCons (tnat --> tlist tqname --> tdefn))-  , (builtinAgdaDefinitionDataConstructor    |-> BuiltinDataCons (tqname --> tdefn))+  , (builtinAgdaDefinitionDataConstructor    |-> BuiltinDataCons (tqname --> tquantity --> tdefn))   , (builtinAgdaDefinitionRecordDef          |-> BuiltinDataCons (tqname --> tlist (targ tqname) --> tdefn))   , (builtinAgdaDefinitionPostulate          |-> BuiltinDataCons tdefn)   , (builtinAgdaDefinitionPrimitive          |-> BuiltinDataCons tdefn)@@ -365,36 +363,49 @@   , builtinAgdaTCMReduce                     |-> builtinPostulate (tterm --> tTCM_ primAgdaTerm)   , builtinAgdaTCMCatchError                 |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $                                                                    tTCM 1 (varM 0) --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))-  , builtinAgdaTCMGetContext                 |-> builtinPostulate (tTCM_ (unEl <$> tlist (targ ttype)))+  , builtinAgdaTCMGetContext                 |-> builtinPostulate (tTCM_ (unEl <$> ttelescope))   , builtinAgdaTCMExtendContext              |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $-                                                                   targ ttype --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))+                                                                   tstring --> targ ttype --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))   , builtinAgdaTCMInContext                  |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $-                                                                   tlist (targ ttype) --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))+                                                                   ttelescope --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))   , builtinAgdaTCMFreshName                  |-> builtinPostulate (tstring --> tTCM_ primQName)   , builtinAgdaTCMDeclareDef                 |-> builtinPostulate (targ tqname --> ttype --> tTCM_ primUnit)   , builtinAgdaTCMDeclarePostulate           |-> builtinPostulate (targ tqname --> ttype --> tTCM_ primUnit)+  , builtinAgdaTCMDeclareData                |-> builtinPostulate (tqname --> tnat --> ttype --> tTCM_ primUnit)+  , builtinAgdaTCMDefineData                 |-> builtinPostulate (tqname --> tlist (tpair primLevelZero primLevelZero tqname (tpair primLevelZero primLevelZero tquantity ttype)) --> tTCM_ primUnit)   , builtinAgdaTCMDefineFun                  |-> builtinPostulate (tqname --> tlist tclause --> tTCM_ primUnit)   , builtinAgdaTCMGetType                    |-> builtinPostulate (tqname --> tTCM_ primAgdaTerm)   , builtinAgdaTCMGetDefinition              |-> builtinPostulate (tqname --> tTCM_ primAgdaDefinition)   , builtinAgdaTCMQuoteTerm                  |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ elV 1 (varM 0) --> tTCM_ primAgdaTerm)   , builtinAgdaTCMUnquoteTerm                |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tterm --> tTCM 1 (varM 0))-  , builtinAgdaTCMQuoteOmegaTerm             |-> builtinPostulate (hPi "A" tsetOmega $ (elInf $ varM 0) --> tTCM_ primAgdaTerm)-  , builtinAgdaTCMBlockOnMeta                |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tmeta --> tTCM 1 (varM 0))+  , builtinAgdaTCMQuoteOmegaTerm             |-> builtinPostulate (hPi "A" tsetOmega $ elInf (varM 0) --> tTCM_ primAgdaTerm)+  , builtinAgdaTCMBlock                      |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tblocker --> tTCM 1 (varM 0))   , builtinAgdaTCMCommit                     |-> builtinPostulate (tTCM_ primUnit)   , builtinAgdaTCMIsMacro                    |-> builtinPostulate (tqname --> tTCM_ primBool)   , builtinAgdaTCMWithNormalisation          |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tbool --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))-  , builtinAgdaTCMWithReconsParams           |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tTCM 1 (varM 0) --> tTCM 1 (varM 0))+  , builtinAgdaTCMWithReconstructed          |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tbool --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))+  , builtinAgdaTCMWithExpandLast             |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tbool --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))+  , builtinAgdaTCMWithReduceDefs             |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ (tpair primLevelZero primLevelZero tbool (tlist tqname)) --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))+  , builtinAgdaTCMAskNormalisation           |-> builtinPostulate (tTCM_ (unEl <$> tbool))+  , builtinAgdaTCMAskReconstructed           |-> builtinPostulate (tTCM_ (unEl <$> tbool))+  , builtinAgdaTCMAskExpandLast              |-> builtinPostulate (tTCM_ (unEl <$> tbool))+  , builtinAgdaTCMAskReduceDefs              |-> builtinPostulate (tTCM_ (unEl <$> (tpair primLevelZero primLevelZero tbool (tlist tqname))))+  , builtinAgdaTCMFormatErrorParts           |-> builtinPostulate (tlist terrorpart --> tTCM_ primString)   , builtinAgdaTCMDebugPrint                 |-> builtinPostulate (tstring --> tnat --> tlist terrorpart --> tTCM_ primUnit)-  , builtinAgdaTCMOnlyReduceDefs             |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tlist tqname --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))-  , builtinAgdaTCMDontReduceDefs             |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tlist tqname --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))    , builtinAgdaTCMNoConstraints              |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tTCM 1 (varM 0) --> tTCM 1 (varM 0))+  , builtinAgdaTCMWorkOnTypes                |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tTCM 1 (varM 0) --> tTCM 1 (varM 0))   , builtinAgdaTCMRunSpeculative             |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $                                                                    tTCM 1 (primSigma <#> varM 1 <#> primLevelZero <@> varM 0 <@> (Lam defaultArgInfo . Abs "_" <$> primBool)) --> tTCM 1 (varM 0))   , builtinAgdaTCMExec                       |-> builtinPostulate (tstring --> tlist tstring --> tstring -->                                                                    tTCM_ (primSigma <#> primLevelZero <#> primLevelZero <@> primNat <@>                                                                           (Lam defaultArgInfo . Abs "_" <$> (primSigma <#> primLevelZero <#> primLevelZero <@> primString <@>                                                                            (Lam defaultArgInfo . Abs "_" <$> primString)))))+  , builtinAgdaTCMCheckFromString            |-> builtinPostulate (tstring --> ttype --> tTCM_ primAgdaTerm)+  , builtinAgdaTCMGetInstances               |-> builtinPostulate (tmeta --> tTCM_ (list primAgdaTerm))+  , builtinAgdaTCMSolveInstances             |-> builtinPostulate (tTCM_ primUnit)+  , builtinAgdaTCMPragmaForeign              |-> builtinPostulate (tstring --> tstring --> tTCM_ primUnit)+  , builtinAgdaTCMPragmaCompile              |-> builtinPostulate (tstring --> tqname --> tstring --> tTCM_ primUnit)   ]   where         (|->) = BuiltinInfo@@ -411,7 +422,7 @@         elV x a = El (varSort x) <$> a          tsetL l    = return $ sort (varSort l)-        tsetOmega  = return $ sort $ Inf IsFibrant 0+        tsetOmega  = return $ sort $ Inf UType 0         tlevel     = el primLevel         tlist x    = el $ list (fmap unEl x)         tmaybe x   = el $ tMaybe (fmap unEl x)@@ -433,6 +444,7 @@         tstring    = el primString         tqname     = el primQName         tmeta      = el primAgdaMeta+        tblocker   = el primAgdaBlocker         tsize      = El sSizeUniv <$> primSize         tbool      = el primBool         thiding    = el primHiding@@ -453,7 +465,7 @@         ttelescope = tlist (tpair primLevelZero primLevelZero tstring (targ ttype))         tTCM l a   = elV l (primAgdaTCM <#> varM l <@> a)         tTCM_ a    = el (primAgdaTCM <#> primLevelZero <@> a)-        tinterval  = El (SSet $ ClosedLevel 0) <$> primInterval+        tinterval  = El IntervalUniv <$> primInterval          verifyPlus plus =             verify ["n","m"] $ \(@@) zero suc (==) (===) choice -> do@@ -579,7 +591,7 @@ -- | Checks that builtin with name @b : String@ of type @t : Term@ --   is a data type or inductive record with @n : Int@ constructors. --   Returns the name of the data/record type.-inductiveCheck :: String -> Int -> Term -> TCM (QName, Definition)+inductiveCheck :: BuiltinId -> Int -> Term -> TCM (QName, Definition) inductiveCheck b n t = do   caseMaybeM (headSymbol t) no $ \q -> do       def <- getConstInfo q@@ -597,24 +609,14 @@     Lam _ b -> headSymbol $ lazyAbsApp b __DUMMY_TERM__     _       -> return Nothing -  no-    | n == 1 = typeError $ GenericError $ unwords-        [ "The builtin", b-        , "must be a datatype with a single constructor"-        , "or an (inductive) record type"-        ]-    | otherwise = typeError $ GenericError $ unwords-        [ "The builtin", b-        , "must be a datatype with", show n-        , "constructors"-        ]+  no = typeError $ BuiltinMustBeData b n  -- | @bindPostulatedName builtin q m@ checks that @q@ is a postulated -- name, and binds the builtin @builtin@ to the term @m q def@, -- where @def@ is the current 'Definition' of @q@.  bindPostulatedName ::-  String -> ResolvedName -> (QName -> Definition -> TCM Term) -> TCM ()+  BuiltinId -> ResolvedName -> (QName -> Definition -> TCM Term) -> TCM () bindPostulatedName builtin x m = do   q   <- getName x   def <- getConstInfo q@@ -623,9 +625,7 @@     _        -> err   where   err :: forall m a. MonadTCError m => m a-  err = typeError $ GenericError $-          "The argument to BUILTIN " ++ builtin ++-          " must be a postulated name"+  err = typeError $ BuiltinMustBePostulate builtin   getName = \case     DefinedName _ d NoSuffix -> return $ anameName d     _ -> err@@ -633,7 +633,7 @@ addHaskellPragma :: QName -> String -> TCM () addHaskellPragma = addPragma ghcBackendName -bindAndSetHaskellCode :: String -> String -> Term -> TCM ()+bindAndSetHaskellCode :: BuiltinId -> String -> Term -> TCM () bindAndSetHaskellCode b hs t = do   d <- fromMaybe __IMPOSSIBLE__ <$> getDef t   bindBuiltinName b t@@ -649,7 +649,7 @@   true  <- getBuiltin' builtinTrue   false <- getBuiltin' builtinFalse   when (true == false) $-    genericError "Cannot bind TRUE and FALSE to the same constructor"+    typeError $ InvalidBuiltin "Cannot bind TRUE and FALSE to the same constructor"  bindBuiltinInt :: Term -> TCM () bindBuiltinInt = bindAndSetHaskellCode builtinInteger "= type Integer"@@ -662,7 +662,7 @@  -- | Only use for datatypes with distinct arities of constructors. --   Binds the constructors together with the datatype.-bindBuiltinData :: String -> Term -> TCM ()+bindBuiltinData :: BuiltinId -> Term -> TCM () bindBuiltinData s t = do   bindBuiltinName s t   name <- fromMaybe __IMPOSSIBLE__ <$> getDef t@@ -691,7 +691,7 @@     Record { recFields = [], recConHead = con } -> do       bindBuiltinName builtinUnit t       bindBuiltinName builtinUnitUnit (Con con ConOSystem [])-    _ -> genericError "Builtin UNIT must be a singleton record type"+    _ -> typeError $ InvalidBuiltin "Builtin UNIT must be a singleton record type"  bindBuiltinSigma :: Term -> TCM () bindBuiltinSigma t = do@@ -700,7 +700,7 @@   case def of     Record { recFields = [fst,snd], recConHead = con } -> do       bindBuiltinName builtinSigma t-    _ -> genericError "Builtin SIGMA must be a record type with two fields"+    _ -> typeError $ InvalidBuiltin "Builtin SIGMA must be a record type with two fields"  -- | Bind BUILTIN EQUALITY and BUILTIN REFL. bindBuiltinEquality :: ResolvedName -> TCM ()@@ -713,13 +713,13 @@   -- Check that the type is the type of a polymorphic relation, i.e.,   -- Γ → (A : Set _) → A → A → Set _   TelV eqTel eqCore <- telView $ defType def-  let no = genericError "The type of BUILTIN EQUALITY must be a polymorphic relation"+  let no = typeError $ InvalidBuiltin "The type of BUILTIN EQUALITY must be a polymorphic relation"    -- The target is a sort since eq is a data type.   unless (isJust $ isSort $ unEl eqCore) __IMPOSSIBLE__    -- The types of the last two arguments must be the third-last argument-  unless (size eqTel >= 3) no+  unless (natSize eqTel >= 3) no   let (a, b) = fromMaybe __IMPOSSIBLE__ $ last2 $ telToList eqTel   [a,b] <- reduce $ map (unEl . snd . unDom) [a,b]   unless (deBruijnView a == Just 0) no@@ -750,9 +750,9 @@           unless (deBruijnView b == Just 0) wrongRefl           bindBuiltinName builtinRefl (Con (ConHead c IsData Inductive []) ConOSystem [])         _ -> __IMPOSSIBLE__-    _ -> genericError "Builtin EQUALITY must be a data type with a single constructor"+    _ -> typeError $ InvalidBuiltin "Builtin EQUALITY must be a data type with a single constructor"   where-  wrongRefl = genericError "Wrong type of constructor of BUILTIN EQUALITY"+  wrongRefl = typeError $ InvalidBuiltin "Wrong type of constructor of BUILTIN EQUALITY"  bindBuiltinInfo :: BuiltinInfo -> A.Expr -> TCM () bindBuiltinInfo (BuiltinInfo s d) e = do@@ -801,27 +801,33 @@             info <- getConstInfo qx             let cls = defClauses info                 a   = defAbstract info+                o   = defOpaque info                 mcc = defCompiled info                 inv = defInverse info+            -- What happens if defArgOccurrences info does not match+            -- primFunArgOccurrences pf? Let's require the latter to+            -- be the empty list.+            unless (primFunArgOccurrences pf == []) __IMPOSSIBLE__             bindPrimitive pfname $ pf { primFunName = qx }             addConstant qx $ info { theDef = Primitive { primAbstr    = a                                                        , primName     = pfname                                                        , primClauses  = cls                                                        , primInv      = inv-                                                       , primCompiled = mcc } }+                                                       , primCompiled = mcc+                                                       , primOpaque   = o+                                                       } }              -- needed? yes, for checking equations for mul             bindBuiltinName s v -          _ -> typeError $ GenericError $ "Builtin " ++ s ++ " must be bound to a function"+          _ -> typeError $ BuiltinMustBeFunction s        BuiltinSort{} -> __IMPOSSIBLE__ -- always a "BuiltinNoDef"        BuiltinPostulate rel t -> do         t' <- t         v <- applyRelevanceToContext rel $ checkExpr e t'-        let err = typeError $ GenericError $-                    "The argument to BUILTIN " ++ s ++ " must be a postulated name"+        let err = typeError $ BuiltinMustBePostulate s         case e of           A.Def q -> do             def <- getConstInfo q@@ -844,7 +850,10 @@           t <- tcmt           (,t) <$> checkExpr e t         f v t-        bindBuiltinName s v+        if | s == builtinRewrite -> runMaybeT (getQNameFromTerm v) >>= \case+              Nothing -> typeError $ InvalidBuiltin "Invalid rewrite relation"+              Just q  -> bindBuiltinRewriteRelation q+           | otherwise           -> bindBuiltinName s v  setConstTranspAxiom :: QName -> TCM () setConstTranspAxiom q =@@ -857,7 +866,7 @@       . updateDefArgOccurrences (const [Unused,StrictPos,Mixed,Mixed])  -- | Bind a builtin thing to an expression.-bindBuiltin :: String -> ResolvedName -> TCM ()+bindBuiltin :: BuiltinId -> ResolvedName -> TCM () bindBuiltin b x = do   unlessM ((0 ==) <$> getContextSize) $ do     -- Andreas, 2017-11-01, issue #2824@@ -875,7 +884,7 @@       PatternSynResName xs -> failure       UnknownName          -> failure     -- For ambiguous names, we check all of their definitions:-    unlessM (allM xs $ ((0 ==) . size) <.> lookupSection . qnameModule . anameName) $+    unlessM (forallM xs $ null <.> lookupSection . qnameModule . anameName) $       failure   -- Since the name was define in a parameter-free context, we can switch to the empty context.   -- (And we should!)@@ -890,14 +899,14 @@      | b == builtinFlat  -> bindBuiltinFlat x      | b == builtinEquality -> bindBuiltinEquality x      | Just i <- findBuiltinInfo b -> bindBuiltinInfo i (A.nameToExpr x)-     | otherwise -> typeError $ NoSuchBuiltinName b+     | otherwise -> typeError $ NoSuchBuiltinName (getBuiltinId b)   where     now new b = warning $ OldBuiltin b new -isUntypedBuiltin :: String -> Bool+isUntypedBuiltin :: BuiltinId -> Bool isUntypedBuiltin = hasElem [ builtinFromNat, builtinFromNeg, builtinFromString ] -bindUntypedBuiltin :: String -> ResolvedName -> TCM ()+bindUntypedBuiltin :: BuiltinId -> ResolvedName -> TCM () bindUntypedBuiltin b = \case   DefinedName _ x NoSuffix -> bind x   DefinedName _ x Suffix{} -> wrong@@ -909,7 +918,7 @@   PatternSynResName xs -> err xs   where   bind x = bindBuiltinName b (Def (anameName x) [])-  wrong  = genericError $ "The argument to BUILTIN " ++ b ++ " must be a defined name"+  wrong  = typeError $ BuiltinMustBeDef b   amb x  = genericDocError =<< do text "Name " <+> prettyTCM x <+> text " is ambiguous"   err (x :| xs1)     | null xs1  = wrong@@ -920,16 +929,17 @@ -- Since their type is closed, it does not matter whether we are in a -- parameterized module when we declare them. -- We simply ignore the parameters.-bindBuiltinNoDef :: String -> A.QName -> TCM ()+bindBuiltinNoDef :: BuiltinId -> A.QName -> TCM () bindBuiltinNoDef b q = inTopContext $ do-  when (b `elem` sizeBuiltins) $ unlessM sizedTypesOption $-    genericError $ "Cannot declare size BUILTIN " ++ b ++ " with option --no-sized-types"+  when (b `elem` sizeBuiltins) $+    requireOptionSizedTypes $ "to declare size BUILTIN " ++ getBuiltinId b   case builtinDesc <$> findBuiltinInfo b of      Just (BuiltinPostulate rel mt) -> do       -- We start by adding the corresponding postulate-      t <- mt-      addConstant' q (setRelevance rel defaultArgInfo) q t def+      t   <- mt+      fun <- emptyFunctionData+      addConstant' q (setRelevance rel defaultArgInfo) t (def fun)       -- And we then *modify* the definition based on our needs:       -- We add polarity information for SIZE-related definitions       builtinSizeHook b q t@@ -938,11 +948,12 @@       where         -- Andreas, 2015-02-14         -- Special treatment of SizeUniv, should maybe be a primitive.-        def | b == builtinSizeUniv = emptyFunction-                { funClauses = [ (empty :: Clause) { clauseBody = Just $ Sort sSizeUniv } ]-                , funCompiled = Just (CC.Done [] $ Sort sSizeUniv)-                , funMutual    = Just []-                , funTerminates = Just True+        def fun+            | b == builtinSizeUniv = FunctionDefn $ fun+                { _funClauses    = [ (empty :: Clause) { clauseBody = Just $ Sort sSizeUniv } ]+                , _funCompiled   = Just (CC.Done [] $ Sort sSizeUniv)+                , _funMutual     = Just []+                , _funTerminates = Just True                 }             | otherwise = defaultAxiom @@ -955,14 +966,19 @@                           , primClauses  = []                           , primInv      = NotInjective                           , primCompiled = Just (CC.Done [] $ Def q [])+                          , primOpaque   = TransparentDef                           }-      addConstant' q defaultArgInfo q t def+      lang <- getLanguage+      addConstant q $+        (defaultDefn defaultArgInfo q t lang def)+          { defArgOccurrences = primFunArgOccurrences pf }       axioms v       bindBuiltinName b v      Just (BuiltinDataCons mt) -> do-      t <- mt-      d <- return $! getPrimName $ unEl t+      t       <- mt+      d       <- return $! getPrimName $ unEl t+      erasure <- optErasure <$> pragmaOptions       let         ch = ConHead q IsData Inductive []         def = Constructor@@ -971,19 +987,21 @@               , conSrcCon = ch               , conData   = d               , conAbstr  = ConcreteDef-              , conInd    = Inductive               , conComp   = emptyCompKit               , conProj   = Nothing               , conForced = []               , conErased = Nothing+              , conErasure = erasure+              , conInline  = False               }-      addConstant' q defaultArgInfo q t def+      addConstant' q defaultArgInfo t def       addDataCons d [q]+       bindBuiltinName b $ Con ch ConOSystem []      Just (BuiltinData mt cs) -> do       t <- mt-      addConstant' q defaultArgInfo q t (def t)+      addConstant' q defaultArgInfo t (def t)       bindBuiltinName b $ Def q []       where         def t = Datatype@@ -995,25 +1013,29 @@               , dataAbstr      = ConcreteDef               , dataMutual     = Nothing               , dataPathCons   = []+              , dataTranspIx   = Nothing -- Id has custom transp def.+              , dataTransp     = Nothing               } -    Just (BuiltinSort sortname) -> do-      let s = case sortname of-                "primSet"      -> mkType 0-                "primProp"     -> mkProp 0-                "primStrictSet" -> mkSSet 0-                "primSetOmega" -> Inf IsFibrant 0-                "primStrictSetOmega" -> Inf IsStrict 0-                _              -> __IMPOSSIBLE__-          def = PrimitiveSort sortname s-      addConstant' q defaultArgInfo q (sort $ univSort s) def+    Just (BuiltinSort builtinSort) -> do+      let s = case builtinSort of+                SortUniv u       -> Univ u $ ClosedLevel 0+                SortOmega u      -> Inf u 0+                SortIntervalUniv -> IntervalUniv+                SortLevelUniv    -> LevelUniv+          def = PrimitiveSort builtinSort s+      -- Check for the cubical flag if the sort requries it+      case builtinSort of+        SortIntervalUniv -> requireCubical CErased+        _ -> return ()+      addConstant' q defaultArgInfo (sort $ univSort s) def       bindBuiltinName b $ Def q []      Just{}  -> __IMPOSSIBLE__     Nothing -> __IMPOSSIBLE__ -- typeError $ NoSuchBuiltinName b  -builtinKindOfName :: String -> Maybe KindOfName+builtinKindOfName :: BuiltinId -> Maybe KindOfName builtinKindOfName = distinguish <.> findBuiltinInfo   where   distinguish d = case builtinDesc d of
src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wunused-imports #-}  ------------------------------------------------------------------------ -- | Handling of the INFINITY, SHARP and FLAT builtins.@@ -5,6 +6,10 @@  module Agda.TypeChecking.Rules.Builtin.Coinduction where +import Prelude hiding (null)++import Agda.Interaction.Options.Base+ import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common import Agda.Syntax.Internal@@ -16,12 +21,14 @@ import Agda.TypeChecking.Monad import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.Primitive-import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope import Agda.TypeChecking.Rules.Builtin import Agda.TypeChecking.Rules.Term +import Agda.Utils.Lens+import Agda.Utils.Null+ -- | The type of @∞@.  typeOfInf :: TCM Type@@ -68,6 +75,7 @@     _ <- checkExpr (A.Def sharp) sharpType     Def inf _ <- primInf     infDefn   <- getConstInfo inf+    erasure   <- optErasure <$> pragmaOptions     addConstant (defName infDefn) $       infDefn { defPolarity       = [] -- not monotone               , defArgOccurrences = [Unused, StrictPos]@@ -82,6 +90,7 @@                   , recEtaEquality'   = Inferred $ NoEta CopatternMatching                   , recPatternMatching= CopatternMatching                   , recMutual         = Just []+                  , recTerminates     = Just True  -- not recursive                   , recAbstr          = ConcreteDef                   , recComp           = emptyCompKit                   }@@ -93,11 +102,12 @@                     , conSrcCon = ConHead sharp (IsRecord CopatternMatching) CoInductive [] -- flat is added as field later                     , conData   = defName infDefn                     , conAbstr  = ConcreteDef-                    , conInd    = CoInductive                     , conComp   = emptyCompKit                     , conProj   = Nothing                     , conForced = []                     , conErased = Nothing+                    , conErasure = erasure+                    , conInline  = True  -- This might make the sharp-translation superfluous.                     }                 }     return $ Def sharp []@@ -131,14 +141,14 @@           , clauseFullRange = noRange           , clauseTel       = tel           , namedClausePats = [ argN $ Named Nothing $-              ConP sharpCon cpi [ argN $ Named Nothing $ debruijnNamedVar "x" 0 ] ]+              ConP sharpCon cpi [ argN $ Named Nothing $ deBruijnNamedVar "x" 0 ] ]           , clauseBody      = Just $ var 0           , clauseType      = Just $ defaultArg $ El (varSort 2) $ var 1-          , clauseCatchall  = False-          , clauseExact       = Just True+          , clauseCatchall    = empty           , clauseRecursive   = Just False           , clauseUnreachable = Just False-          , clauseEllipsis  = NoEllipsis+          , clauseEllipsis    = NoEllipsis+          , clauseWhereModule = Nothing           }         cc = Case (defaultArg 0) $ conCase sharp False $ WithArity 1 $ Done [defaultArg "x"] $ var 0         projection = Projection@@ -148,24 +158,25 @@           , projIndex    = 3           , projLams     = ProjLams $ [ argH "a" , argH "A" , argN "x" ]           }+    fun <- emptyFunctionData     addConstant flat $       flatDefn { defPolarity       = []                , defArgOccurrences = [StrictPos]  -- changing that to [Mixed] destroys monotonicity of 'Rec' in test/succeed/GuardednessPreservingTypeConstructors                , defCopatternLHS = hasProjectionPatterns cc-               , theDef = emptyFunction-                   { funClauses      = [clause]-                   , funCompiled     = Just $ cc-                   , funProjection   = Just projection-                   , funMutual       = Just []-                   , funTerminates   = Just True+               , theDef = FunctionDefn fun+                   { _funClauses      = [clause]+                   , _funCompiled     = Just $ cc+                   , _funProjection   = Right projection+                   , _funMutual       = Just []+                   , _funTerminates   = Just True                    }                 }      -- register flat as record field for constructor sharp-    modifySignature $ updateDefinition sharp $ updateTheDef $ \ def ->-      def { conSrcCon = sharpCon }-    modifySignature $ updateDefinition inf $ updateTheDef $ \ def ->-      def { recConHead = sharpCon, recFields = [defaultDom flat] }+    modifySignature $ updateDefinition sharp $ updateTheDef $ over lensConstructor $ \ def ->+      def { _conSrcCon = sharpCon }+    modifySignature $ updateDefinition inf $ updateTheDef $ over lensRecord $ \ def ->+      def { _recConHead = sharpCon, _recFields = [defaultDom flat] }     return $ Def flat []  -- The coinductive primitives.
src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs-boot view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.Rules.Builtin.Coinduction where  import Agda.Syntax.Scope.Base
src/full/Agda/TypeChecking/Rules/Data.hs view
@@ -2,1148 +2,1802 @@  module Agda.TypeChecking.Rules.Data where -import Prelude hiding (null)--import Control.Monad-import Control.Monad.Except-import Control.Monad.Trans-import Control.Monad.Trans.Maybe--import Data.Set (Set)-import qualified Data.Set as Set--import qualified Agda.Syntax.Abstract as A-import qualified Agda.Syntax.Concrete.Name as C-import Agda.Syntax.Abstract.Views (deepUnscope)-import Agda.Syntax.Internal-import Agda.Syntax.Common-import Agda.Syntax.Position-import qualified Agda.Syntax.Info as Info-import Agda.Syntax.Scope.Monad--import {-# SOURCE #-} Agda.TypeChecking.CompiledClause.Compile-import Agda.TypeChecking.Monad-import Agda.TypeChecking.Conversion-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Generalize-import Agda.TypeChecking.Implicit-import Agda.TypeChecking.MetaVars-import Agda.TypeChecking.Names-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Positivity.Occurrence (Occurrence(StrictPos))-import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Primitive hiding (Nat)-import Agda.TypeChecking.Free-import Agda.TypeChecking.Forcing-import Agda.TypeChecking.Irrelevance-import Agda.TypeChecking.Telescope--import {-# SOURCE #-} Agda.TypeChecking.Rules.Term ( isType_ )--import Agda.Utils.List-import Agda.Utils.List1 (List1, pattern (:|))-import qualified Agda.Utils.List1 as List1-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import qualified Agda.Utils.Pretty as P-import Agda.Utils.Size--import Agda.Utils.Impossible-------------------------------------------------------------------------------- * Datatypes-------------------------------------------------------------------------------- | Type check a datatype definition. Assumes that the type has already been---   checked.-checkDataDef :: A.DefInfo -> QName -> UniverseCheck -> A.DataDefParams -> [A.Constructor] -> TCM ()-checkDataDef i name uc (A.DataDefParams gpars ps) cs =-    traceCall (CheckDataDef (getRange name) name ps cs) $ do--        -- Add the datatype module-        addSection (qnameToMName name)--        -- Look up the type of the datatype.-        def <- instantiateDef =<< getConstInfo name-        t   <- instantiateFull $ defType def-        let npars =-              case theDef def of-                DataOrRecSig n -> n-                _              -> __IMPOSSIBLE__--        -- Make sure the shape of the type is visible-        let unTelV (TelV tel a) = telePi tel a-        t <- unTelV <$> telView t--        parNames <- getGeneralizedParameters gpars name--        -- Top level free vars-        freeVars <- getContextSize--        -- The parameters are in scope when checking the constructors.-        dataDef <- bindGeneralizedParameters parNames t $ \ gtel t0 ->-                   bindParameters (npars - length parNames) ps t0 $ \ ptel t0 -> do--            -- Parameters are always hidden in constructors-            let tel  = abstract gtel ptel-                tel' = hideAndRelParams <$> tel-            -- let tel' = hideTel tel--            -- The type we get from bindParameters is Θ -> s where Θ is the type of-            -- the indices. We count the number of indices and return s.-            -- We check that s is a sort.-            let TelV ixTel s0 = telView' t0-                nofIxs = size ixTel--            s <- workOnTypes $ do-              -- Andreas, 2016-11-02 issue #2290-              -- Trying to unify the sort with a fresh sort meta which is-              -- defined outside the index telescope is the most robust way-              -- to check independence of the indices.-              -- However, it might give the dreaded "Cannot instantiate meta..."-              -- error which we replace by a more understandable error-              -- in case of a suspected dependency.-              s <- newSortMetaBelowInf-              catchError_ (addContext ixTel $ equalType s0 $ raise nofIxs $ sort s) $ \ err ->-                  if any (`freeIn` s0) [0..nofIxs - 1] then typeError . GenericDocError =<<-                     fsep [ "The sort of" <+> prettyTCM name-                          , "cannot depend on its indices in the type"-                          , prettyTCM t0-                          ]-                  else throwError err-              reduce s--            -- when `--without-K`, all the indices should fit in the-            -- sort of the datatype (see #3420).-            let s' = case s of-                  Prop l -> Type l-                  _      -> s-            -- Andreas, 2019-07-16, issue #3916:-            -- NoUniverseCheck should also disable the index sort check!-            unless (uc == NoUniverseCheck) $-              whenM withoutKOption $ checkIndexSorts s' ixTel--            reportSDoc "tc.data.sort" 20 $ vcat-              [ "checking datatype" <+> prettyTCM name-              , nest 2 $ vcat-                [ "type (parameters instantiated):   " <+> prettyTCM t0-                , "type (full):   " <+> prettyTCM t-                , "sort:   " <+> prettyTCM s-                , "indices:" <+> text (show nofIxs)-                , "gparams:" <+> text (show parNames)-                , "params: " <+> text (show $ deepUnscope ps)-                ]-              ]-            let npars = size tel--            -- Change the datatype from an axiom to a datatype with no constructors.-            let dataDef = Datatype-                  { dataPars       = npars-                  , dataIxs        = nofIxs-                  , dataClause     = Nothing-                  , dataCons       = []     -- Constructors are added later-                  , dataSort       = s-                  , dataAbstr      = Info.defAbstract i-                  , dataMutual     = Nothing-                  , dataPathCons   = []     -- Path constructors are added later-                  }--            escapeContext impossible npars $ do-              addConstant' name defaultArgInfo name t dataDef-                -- polarity and argOcc.s determined by the positivity checker--            -- Check the types of the constructors-            pathCons <- forM cs $ \ c -> do-              isPathCons <- checkConstructor name uc tel' nofIxs s c-              return $ if isPathCons == PathCons then Just (A.axiomName c) else Nothing--            -- Return the data definition-            return dataDef{ dataPathCons = catMaybes pathCons }--        let cons   = map A.axiomName cs  -- get constructor names--        -- Add the datatype to the signature with its constructors.-        -- It was previously added without them.-        addConstant' name defaultArgInfo name t $-            dataDef{ dataCons = cons }----- | Ensure that the type is a sort.---   If it is not directly a sort, compare it to a 'newSortMetaBelowInf'.-forceSort :: Type -> TCM Sort-forceSort t = reduce (unEl t) >>= \case-  Sort s -> return s-  _      -> do-    s <- newSortMetaBelowInf-    equalType t (sort s)-    return s----- | Type check a constructor declaration. Checks that the constructor targets---   the datatype and that it fits inside the declared sort.---   Returns the non-linear parameters.-checkConstructor-  :: QName         -- ^ Name of data type.-  -> UniverseCheck -- ^ Check universes?-  -> Telescope     -- ^ Parameter telescope.-  -> Nat           -- ^ Number of indices of the data type.-  -> Sort          -- ^ Sort of the data type.-  -> A.Constructor -- ^ Constructor declaration (type signature).-  -> TCM IsPathCons-checkConstructor d uc tel nofIxs s (A.ScopedDecl scope [con]) = do-  setScope scope-  checkConstructor d uc tel nofIxs s con-checkConstructor d uc tel nofIxs s con@(A.Axiom _ i ai Nothing c e) =-    traceCall (CheckConstructor d tel s con) $ do-{- WRONG-      -- Andreas, 2011-04-26: the following happens to the right of ':'-      -- we may use irrelevant arguments in a non-strict way in types-      t' <- workOnTypes $ do--}-        debugEnter c e-        -- check that we are relevant-        case getRelevance ai of-          Relevant   -> return ()-          Irrelevant -> typeError $ GenericError $ "Irrelevant constructors are not supported"-          NonStrict  -> typeError $ GenericError $ "Shape-irrelevant constructors are not supported"-        case getQuantity ai of-          Quantityω{} -> return ()-          Quantity0{} -> return ()-          Quantity1{} -> typeError $ GenericError $ "Quantity-restricted constructors are not supported"-        -- check that the type of the constructor is well-formed-        (t, isPathCons) <- applyQuantityToContext ai $-                           checkConstructorType e d--        -- compute which constructor arguments are forced (only point constructors)-        forcedArgs <- if isPathCons == PointCons-                      then computeForcingAnnotations c t-                      else return []-        -- check that the sort (universe level) of the constructor type-        -- is contained in the sort of the data type-        -- (to avoid impredicative existential types)-        debugFitsIn s-        -- To allow propositional squash, we turn @Prop ℓ@ into @Set ℓ@-        -- for the purpose of checking the type of the constructors.-        let s' = case s of-              Prop l -> Type l-              _      -> s-        arity <- traceCall (CheckConstructorFitsIn c t s') $-                 applyQuantityToContext ai $-                 fitsIn uc forcedArgs t s'-        -- this may have instantiated some metas in s, so we reduce-        s <- reduce s-        debugAdd c t--        (TelV fields _, boundary) <- telViewUpToPathBoundaryP (-1) t--        -- We assume that the current context matches the parameters-        -- of the datatype in an empty context (c.f. getContextSize above).-        params <- getContextTelescope--        (con, comp, projNames) <- do-            -- Name for projection of ith field of constructor c is just c-i-            names <- forM [0 .. size fields - 1] $ \ i ->-              freshAbstractQName'_ $ P.prettyShow (A.qnameName c) ++ "-" ++ show i--            -- nofIxs == 0 means the data type can be reconstructed-            -- by appling the QName d to the parameters.-            let dataT = El s $ Def d $ map Apply $ teleArgs params--            reportSDoc "tc.data.con.comp" 5 $ inTopContext $ vcat $-              [ "params =" <+> pretty params-              , "dataT  =" <+> pretty dataT-              , "fields =" <+> pretty fields-              , "names  =" <+> pretty names-              ]--            let con = ConHead c IsData Inductive $ zipWith (<$) names $ map argFromDom $ telToList fields--            defineProjections d con params names fields dataT-            -- Cannot compose indexed inductive types yet.-            comp <- if nofIxs /= 0 || (Info.defAbstract i == AbstractDef)-                    then return emptyCompKit-                    else inTopContext $ defineCompData d con params names fields dataT boundary-            return (con, comp, Just names)--        -- add parameters to constructor type and put into signature-        escapeContext impossible (size tel) $ do--          addConstant' c ai c (telePi tel t) $ Constructor-              { conPars   = size tel-              , conArity  = arity-              , conSrcCon = con-              , conData   = d-              , conAbstr  = Info.defAbstract i-              , conInd    = Inductive-              , conComp   = comp-              , conProj   = projNames-              , conForced = forcedArgs-              , conErased = Nothing  -- computed during compilation to treeless-              }--        -- Add the constructor to the instance table, if needed-        case Info.defInstance i of-          InstanceDef _r -> setCurrentRange c $ do-            -- Including the range of the @instance@ keyword, like-            -- @(getRange (r,c))@, does not produce good results.-            -- Andreas, 2020-01-28, issue #4360:-            -- Use addTypedInstance instead of addNamedInstance-            -- to detect unusable instances.-            addTypedInstance c t-            -- addNamedInstance c d-          NotInstanceDef -> pure ()--        return isPathCons--  where-    -- Issue 3362: we need to do the `constructs` call inside the-    -- generalization, so unpack the A.Generalize-    checkConstructorType (A.ScopedExpr s e) d = withScope_ s $ checkConstructorType e d-    checkConstructorType e d = do-      let check k e = do-            t <- workOnTypes $ isType_ e-            -- check that the type of the constructor ends in the data type-            n <- getContextSize-            debugEndsIn t d (n - k)-            isPathCons <- constructs (n - k) k t d-            return (t, isPathCons)--      case e of-        A.Generalized s e -> do-          (_, t, isPathCons) <- generalizeType' s (check 1 e)-          return (t, isPathCons)-        _ -> check 0 e--    debugEnter c e =-      reportSDoc "tc.data.con" 5 $ vcat-        [ "checking constructor" <+> prettyTCM c <+> ":" <+> prettyTCM e-        ]-    debugEndsIn t d n =-      reportSDoc "tc.data.con" 15 $ vcat-        [ sep [ "checking that"-              , nest 2 $ prettyTCM t-              , "ends in" <+> prettyTCM d-              ]-        , nest 2 $ "nofPars =" <+> text (show n)-        ]-    debugFitsIn s =-      reportSDoc "tc.data.con" 15 $ sep-        [ "checking that the type fits in"-        , nest 2 $ prettyTCM s-        ]-    debugAdd c t =-      reportSDoc "tc.data.con" 5 $ vcat-        [ "adding constructor" <+> prettyTCM c <+> ":" <+> prettyTCM t-        ]-checkConstructor _ _ _ _ _ _ = __IMPOSSIBLE__ -- constructors are axioms--defineCompData :: QName      -- datatype name-               -> ConHead-               -> Telescope  -- Γ parameters-               -> [QName]    -- projection names-               -> Telescope  -- Γ ⊢ Φ field types-               -> Type       -- Γ ⊢ T target type-               -> Boundary   -- [(i,t_i,b_i)],  Γ.Φ ⊢ [ (i=0) -> t_i; (i=1) -> u_i ] : B_i-               -> TCM CompKit-defineCompData d con params names fsT t boundary = do-  required <- mapM getTerm'-    [ builtinInterval-    , builtinIZero-    , builtinIOne-    , builtinIMin-    , builtinIMax-    , builtinINeg-    , builtinPOr-    , builtinItIsOne-    ]-  if not (all isJust required) then return $ emptyCompKit else do-    hcomp  <- whenDefined (null boundary) [builtinHComp,builtinTrans] (defineTranspOrHCompD DoHComp  d con params names fsT t boundary)-    transp <- whenDefined True            [builtinTrans]              (defineTranspOrHCompD DoTransp d con params names fsT t boundary)-    return $ CompKit-      { nameOfTransp = transp-      , nameOfHComp  = hcomp-      }-  where-    -- Δ^I, i : I |- sub Δ : Δ-    sub tel = parallelS [ var n `apply` [Arg defaultArgInfo $ var 0] | n <- [1..size tel] ]-    withArgInfo tel = zipWith Arg (map domInfo . telToList $ tel)--    defineTranspOrHCompD cmd d con params names fsT t boundary = do-      let project = (\ t p -> apply (Def p []) [argN t])-      stuff <- defineTranspOrHCompForFields cmd-                 (guard (not $ null boundary) >> Just (Con con ConOSystem $ teleElims fsT boundary))-                 project d params fsT (map argN names) t-      caseMaybe stuff (return Nothing) $ \ ((theName, gamma , ty, _cl_types , bodies), theSub) -> do--      iz <- primIZero-      body <- do-        case cmd of-          DoHComp -> return $ Con con ConOSystem (map Apply $ withArgInfo fsT bodies)-          DoTransp | null boundary -> return $ Con con ConOSystem (map Apply $ withArgInfo fsT bodies)-                   | otherwise -> do-            io <- primIOne-            tIMax <- primIMax-            tIMin <- primIMin-            tINeg <- primINeg-            tPOr  <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPOr-            tHComp <- primHComp-            -- Δ = params-            -- Δ ⊢ Φ = fsT-            -- (δ : Δ) ⊢ T = R δ-            -- (δ : Δ) ⊢ con : Φ → R δ  -- no indexing-            -- boundary = [(i,t_i,u_i)]-            -- Δ.Φ ⊢ [ (i=0) -> t_i; (i=1) -> u_i ] : B_i-            -- Δ.Φ | PiPath Φ boundary (R δ) |- teleElims fsT boundary : R δ-            -- Γ = ((δ : Δ^I), φ, us : Φ[δ 0]) = gamma-            -- Γ ⊢ ty = R (δ i1)-            -- (γ : Γ) ⊢ cl_types = (flatten Φ)[n ↦ f_n (transpR γ)]-            -- Γ ⊢ bodies : Φ[δ i1]-            -- Γ ⊢ t : ty-            -- Γ, i : I ⊢ theSub : Δ.Φ-            let--              -- Δ.Φ ⊢ u = Con con ConOSystem $ teleElims fsT boundary : R δ-              u = Con con ConOSystem $ teleElims fsT boundary-              -- Γ ⊢ u-              the_u = liftS (size fsT) d0 `applySubst` u-                where-                  -- δ : Δ^I, φ : F ⊢ [δ 0] : Δ-                  d0 :: Substitution-                  d0 = wkS 1 -- Δ^I, φ : F ⊢ Δ-                             (consS iz IdS `composeS` sub params) -- Δ^I ⊢ Δ-                                       -- Δ^I , i:I ⊢ sub params : Δ-              the_phi = raise (size fsT) $ var 0-              -- Γ ⊢ sigma : Δ.Φ-              -- sigma = [δ i1,bodies]-              sigma = reverse bodies ++# d1-               where-                -- δ i1-                d1 :: Substitution-                d1 = wkS (size gamma - size params) -- Γ ⊢ Δ-                       (consS io IdS `composeS` sub params) -- Δ^I ⊢ Δ-                                 -- Δ^I , i:I ⊢ sub params : Δ--              -- Δ.Φ ⊢ [ (i=0) -> t_i; (i=1) -> u_i ] : R δ-              bs = fullBoundary fsT boundary-              -- ψ = sigma `applySubst` map (\ i → i ∨ ~ i) . map fst $ boundary-              -- Γ ⊢ t : R (δ i1)-              w1' = Con con ConOSystem $ sigma `applySubst` teleElims fsT boundary-              -- (δ, φ, u0) : Γ ⊢-              -- w1 = hcomp (\ i → R (δ i1))-              --            (\ i → [ ψ ↦ α (~ i), φ ↦ u0])-              --            w1'-              imax x y = pure tIMax <@> x <@> y-              ineg r = pure tINeg <@> r-              lvlOfType = (\ (Type l) -> Level l) . getSort-              pOr la i j u0 u1 = pure tPOr <#> (lvlOfType <$> la) <@> i <@> j-                                           <#> ilam "o" (\ _ -> unEl <$> la) <@> u0 <@> u1-              absAp x y = liftM2 absApp x y--              mkFace (r,(u1,u2)) = runNamesT [] $ do-                -- Γ-                phi <- open the_phi  -- (δ , φ , us) ⊢ φ-                -- Γ ⊢ ty = Abs i. R (δ i)-                ty <- open (Abs "i" $ (liftS 1 (raiseS (size gamma - size params)) `composeS` sub params) `applySubst` t)--                bind "i" $ \ i -> do-                  -- Γ, i-                  [r,u1,u2] <- mapM (open . applySubst theSub) [r,u1,u2]-                  psi <- imax r (ineg r)-                  let-                    -- Γ, i ⊢ squeeze u = primTrans (\ j -> ty [i := i ∨ j]) (φ ∨ i) u-                    squeeze u = cl primTrans-                                          <#> lam "j" (\ j -> lvlOfType <$> ty `absAp` (imax i j))-                                          <@> lam "j" (\ j -> unEl <$> ty `absAp` (imax i j))-                                          <@> (phi `imax` i)-                                          <@> u-                  alpha <- pOr (ty `absAp` i)-                              (ineg r)-                              r-                           (ilam "o" $ \ _ -> squeeze u1) (ilam "o" $ \ _ -> squeeze u2)-                  return $ (psi, alpha)--            -- Γ ⊢ Abs i. [(ψ_n,α_n : [ψ] → R (δ i))]-            faces <- mapM mkFace bs--            runNamesT [] $ do-                -- Γ-                w1' <- open w1'-                phi <- open the_phi-                u   <- open the_u-                -- R (δ i1)-                ty <- open ty-                faces <- mapM (\ x -> liftM2 (,) (open . noabsApp __IMPOSSIBLE__ $ fmap fst x) (open $ fmap snd x)) faces-                let-                  thePsi = foldl1 imax (map fst faces)-                  hcomp ty phi sys a0 = pure tHComp <#> (lvlOfType <$> ty)-                                                    <#> (unEl <$> ty)-                                                    <#> phi-                                                    <@> sys-                                                    <@> a0-                let-                 sys = lam "i" $ \ i -> do-                  let-                    recurse [(psi,alpha)] = alpha `absAp` (ineg i)-                    recurse ((psi,alpha):xs) = pOr ty-                                                   psi  theOr-                                                   (alpha `absAp` (ineg i)) (recurse xs)-                      where-                        theOr = foldl1 imax (map fst xs)-                    recurse [] = __IMPOSSIBLE__-                    sys_alpha = recurse faces-                  pOr ty-                                                   thePsi    phi-                                                   sys_alpha (ilam "o" $ \ _ -> u)-                hcomp ty (thePsi `imax` phi) sys w1'---      let--        -- δ : Δ^I, φ : F ⊢ [δ 0] : Δ-        d0 :: Substitution-        d0 = wkS 1 -- Δ^I, φ : F ⊢ Δ-                       (consS iz IdS `composeS` sub params) -- Δ^I ⊢ Δ-                                 -- Δ^I , i:I ⊢ sub params : Δ--        -- Δ.Φ ⊢ u = Con con ConOSystem $ teleElims fsT boundary : R δ---        u = Con con ConOSystem $ teleElims fsT boundary-        up = ConP con (ConPatternInfo defaultPatternInfo False False Nothing False) $-               telePatterns (d0 `applySubst` fsT) (liftS (size fsT) d0 `applySubst` boundary)---        gamma' = telFromList $ take (size gamma - 1) $ telToList gamma--        -- (δ , φ , fs : Φ[d0]) ⊢ u[liftS Φ d0]-        -- (δ , φ, u) : Γ ⊢ body-        -- Δ ⊢ Φ = fsT-        -- (δ , φ , fs : Φ[d0]) ⊢ u[liftS Φ d0] `consS` raiseS Φ : Γ---        (tel',theta) = (abstract gamma' (d0 `applySubst` fsT), (liftS (size fsT) d0 `applySubst` u) `consS` raiseS (size fsT))--      let-        pats | null boundary = teleNamedArgs gamma-             | otherwise     = take (size gamma - size fsT) (teleNamedArgs gamma) ++ [argN $ unnamed $ up]-        clause = Clause-          { clauseTel         = gamma-          , clauseType        = Just . argN $ ty-          , namedClausePats   = pats-          , clauseFullRange   = noRange-          , clauseLHSRange    = noRange-          , clauseCatchall    = False-          , clauseBody        = Just $ body-          , clauseExact       = Just True-          , clauseRecursive   = Nothing-              -- Andreas 2020-02-06 TODO-              -- Or: Just False;  is it known to be non-recursive?-          , clauseUnreachable = Just False-          , clauseEllipsis    = NoEllipsis-          }-        cs = [clause]-      addClauses theName cs-      (mst, _, cc) <- inTopContext (compileClauses Nothing cs)-      whenJust mst $ setSplitTree theName-      setCompiledClauses theName cc-      setTerminates theName True-      return $ Just theName--    whenDefined False _ _ = return Nothing-    whenDefined True xs m = do-      xs <- mapM getTerm' xs-      if all isJust xs then m else return Nothing---- Andrea: TODO handle Irrelevant fields somehow.--- | Define projections for non-indexed data types (families don't work yet).---   Of course, these projections are partial functions in general.------   Precondition: we are in the context Γ of the data type parameters.-defineProjections :: QName      -- datatype name-                  -> ConHead-                  -> Telescope  -- Γ parameters-                  -> [QName]    -- projection names-                  -> Telescope  -- Γ ⊢ Φ field types-                  -> Type       -- Γ ⊢ T target type-                  -> TCM ()-defineProjections dataName con params names fsT t = do-  let-    -- Γ , (d : T) ⊢ Φ[n ↦ proj n d]-    fieldTypes = ([ Def f [] `apply` [argN $ var 0] | f <- reverse names ] ++# raiseS 1) `applySubst`-                    flattenTel fsT  -- Γ , Φ ⊢ Φ-    -- ⊢ Γ , (d : T)-    projTel    = abstract params (ExtendTel (defaultDom t) (Abs "d" EmptyTel))-    np         = size params--  forM_ (zip3 (downFrom (size fieldTypes)) names fieldTypes) $ \ (i,projName,ty) -> do-    let-      projType = abstract projTel <$> ty-      cpi    = ConPatternInfo defaultPatternInfo False False (Just $ argN $ raise (size fsT) t) False-      conp   = defaultNamedArg $ ConP con cpi $ teleNamedArgs fsT-      sigma  = Con con ConOSystem (map Apply $ teleArgs fsT) `consS` raiseS (size fsT)-      clause = empty-          { clauseTel         = abstract params fsT-          , namedClausePats   = [ conp ]-          , clauseBody        = Just $ var i-          , clauseType        = Just $ argN $ applySubst sigma $ unDom ty-          , clauseRecursive   = Just False  -- non-recursive-          , clauseUnreachable = Just False-          }--    reportSDoc "tc.data.proj" 20 $ inTopContext $ sep-      [ "proj" <+> prettyTCM (i,ty)-      , nest 2 $ sep [ prettyTCM projName, ":", prettyTCM projType ]-      ]--    -- Andreas, 2020-02-14, issue #4437-    -- Define data projections as projection-like from the start.-    noMutualBlock $ do-      let cs = [ clause ]-      (mst, _, cc) <- compileClauses Nothing cs-      let fun = emptyFunction-                { funClauses    = cs-                , funCompiled   = Just cc-                , funSplitTree  = mst-                , funProjection = Just $ Projection-                    { projProper   = Nothing-                    , projOrig     = projName-                    , projFromType = Arg (getArgInfo ty) dataName-                    , projIndex    = np + 1-                    , projLams     = ProjLams $ map (argFromDom . fmap fst) $ telToList projTel-                    }-                , funMutual     = Just []-                , funTerminates = Just True-                }-      lang <- getLanguage-      inTopContext $ addConstant projName $-        (defaultDefn defaultArgInfo projName (unDom projType) lang fun)-          { defNoCompilation  = True-          , defArgOccurrences = [StrictPos]-          }--      reportSDoc "tc.data.proj.fun" 60 $ inTopContext $ vcat-        [ "proj" <+> prettyTCM i-        , nest 2 $ pretty fun-        ]---freshAbstractQName'_ :: String -> TCM QName-freshAbstractQName'_ = freshAbstractQName noFixity' . C.simpleName----- * Special cases of Type---------------------------------------------------------------- | A @Type@ with sort @Type l@---   Such a type supports both hcomp and transp.-data LType = LEl Level Term deriving (Eq,Show)--fromLType :: LType -> Type-fromLType (LEl l t) = El (Type l) t--lTypeLevel :: LType -> Level-lTypeLevel (LEl l t) = l--toLType :: MonadReduce m => Type -> m (Maybe LType)-toLType ty = do-  sort <- reduce $ getSort ty-  case sort of-    Type l -> return $ Just $ LEl l (unEl ty)-    _      -> return $ Nothing--instance Subst LType where-  type SubstArg LType = Term-  applySubst rho (LEl l t) = LEl (applySubst rho l) (applySubst rho t)---- | A @Type@ that either has sort @Type l@ or is a closed definition.---   Such a type supports some version of transp.---   In particular we want to allow the Interval as a @ClosedType@.-data CType = ClosedType Sort QName | LType LType deriving (Eq,Show)--fromCType :: CType -> Type-fromCType (ClosedType s q) = El s (Def q [])-fromCType (LType t) = fromLType t--toCType :: MonadReduce m => Type -> m (Maybe CType)-toCType ty = do-  sort <- reduce $ getSort ty-  case sort of-    Type l -> return $ Just $ LType (LEl l (unEl ty))-    SSet l  -> do-      t <- reduce (unEl ty)-      case t of-        Def q [] -> return $ Just $ ClosedType (SSet l) q-        _        -> return $ Nothing-    _      -> return $ Nothing--instance Subst CType where-  type SubstArg CType = Term-  applySubst rho (ClosedType s t) = ClosedType (applySubst rho s) t-  applySubst rho (LType t) = LType $ applySubst rho t---defineTranspOrHCompForFields-  :: TranspOrHComp-  -> (Maybe Term)            -- ^ PathCons, Δ.Φ ⊢ u : R δ-  -> (Term -> QName -> Term) -- ^ how to apply a "projection" to a term-  -> QName       -- ^ some name, e.g. record name-  -> Telescope   -- ^ param types Δ-  -> Telescope   -- ^ fields' types Δ ⊢ Φ-  -> [Arg QName] -- ^ fields' names-  -> Type        -- ^ record type Δ ⊢ T-  -> TCM (Maybe ((QName, Telescope, Type, [Dom Type], [Term]), Substitution))-defineTranspOrHCompForFields cmd pathCons project name params fsT fns rect =-   case cmd of-       DoTransp -> runMaybeT $ do-         fsT' <- traverse (traverse (MaybeT . toCType)) fsT-         lift $ defineTranspForFields pathCons project name params fsT' fns rect-       DoHComp -> runMaybeT $ do-         fsT' <- traverse (traverse (MaybeT . toLType)) fsT-         rect' <- MaybeT $ toLType rect-         lift $ defineHCompForFields project name params fsT' fns rect'----- invariant: resulting tel Γ is such that Γ = ... , (φ : I), (a0 : ...)---            where a0 has type matching the arguments of primTrans.-defineTranspForFields-  :: (Maybe Term)            -- ^ PathCons, Δ.Φ ⊢ u : R δ-  -> (Term -> QName -> Term) -- ^ how to apply a "projection" to a term-  -> QName       -- ^ some name, e.g. record name-  -> Telescope   -- ^ param types Δ-  -> Tele (Dom CType)   -- ^ fields' types Δ ⊢ Φ-  -> [Arg QName] -- ^ fields' names-  -> Type        -- ^ record type Δ ⊢ T-  -> TCM ((QName, Telescope, Type, [Dom Type], [Term]), Substitution)-defineTranspForFields pathCons applyProj name params fsT fns rect = do-  interval <- primIntervalType-  let deltaI = expTelescope interval params-  iz <- primIZero-  io <- primIOne-  imin <- getPrimitiveTerm "primIMin"-  imax <- getPrimitiveTerm "primIMax"-  ineg <- getPrimitiveTerm "primINeg"-  transp <- getPrimitiveTerm builtinTrans-  -- por <- getPrimitiveTerm "primPOr"-  -- one <- primItIsOne-  reportSDoc "trans.rec" 20 $ text $ show params-  reportSDoc "trans.rec" 20 $ text $ show deltaI-  reportSDoc "trans.rec" 10 $ text $ show fsT--  let thePrefix = "transp-"-  theName <- freshAbstractQName'_ $ thePrefix ++ P.prettyShow (A.qnameName name)--  reportSLn "trans.rec" 5 $ ("Generated name: " ++ show theName ++ " " ++ showQNameId theName)--  theType <- (abstract deltaI <$>) $ runNamesT [] $ do-              rect' <- open (runNames [] $ bind "i" $ \ x -> let _ = x `asTypeOf` pure (undefined :: Term) in-                                                             pure rect')-              nPi' "phi" primIntervalType $ \ phi ->-               (absApp <$> rect' <*> pure iz) --> (absApp <$> rect' <*> pure io)--  reportSDoc "trans.rec" 20 $ prettyTCM theType-  reportSDoc "trans.rec" 60 $ text $ "sort = " ++ show (getSort rect')--  lang <- getLanguage-  noMutualBlock $ addConstant theName $-    (defaultDefn defaultArgInfo theName theType lang-       (emptyFunction { funTerminates = Just True }))-      { defNoCompilation = True }-  -- ⊢ Γ = gamma = (δ : Δ^I) (φ : I) (u0 : R (δ i0))-  -- Γ ⊢     rtype = R (δ i1)-  TelV gamma rtype <- telView theType---  let-      -- (γ : Γ) ⊢ transpR γ : rtype-      theTerm = Def theName [] `apply` teleArgs gamma--      -- (γ : Γ) ⊢ (flatten Φ[δ i1])[n ↦ f_n (transpR γ)]-      clause_types = parallelS [theTerm `applyProj` (unArg fn)-                               | fn <- reverse fns] `applySubst`-                       flattenTel (singletonS 0 io `applySubst` fsT') -- Γ, Φ[δ i1] ⊢ flatten Φ[δ i1]--      -- Γ, i : I ⊢ [δ i] : Δ-      delta_i = (liftS 1 (raiseS (size gamma - size deltaI)) `composeS` sub params) -- Defined but not used--      -- Γ, i : I ⊢ Φ[δ i]-      fsT' = (liftS 1 (raiseS (size gamma - size deltaI)) `composeS` sub params)  `applySubst`-               fsT -- Δ ⊢ Φ-      lam_i = Lam defaultArgInfo . Abs "i"----      -- (δ , φ , u0) : Γ ⊢ φ : I-      -- the_phi = var 1-      -- -- (δ , φ , u0) : Γ ⊢ u0 : R (δ i0)-      -- the_u0  = var 0--      -- Γ' = (δ : Δ^I, φ : I)-      gamma' = telFromList $ take (size gamma - 1) $ telToList gamma--      -- δ : Δ^I, φ : F ⊢ [δ 0] : Δ-      d0 :: Substitution-      d0 = wkS 1 -- Δ^I, φ : F ⊢ Δ-                       (consS iz IdS `composeS` sub params) -- Δ^I ⊢ Δ-                                 -- Δ^I , i:I ⊢ sub params : Δ--      -- Ξ , Ξ ⊢ θ : Γ, Ξ ⊢ φ, Ξ ⊢ u : R (δ i0), Ξ ⊢ us : Φ[δ i0]-      (tel,theta,the_phi,the_u0, the_fields) =-        case pathCons of-          -- (δ : Δ).Φ ⊢ u : R δ-          Just u -> (abstract gamma' (d0 `applySubst` fmap (fmap fromCType) fsT) -- Ξ = δ : Δ^I, φ : F, _ : Φ[δ i0]-                    , (liftS (size fsT) d0 `applySubst` u) `consS` raiseS (size fsT)-                    , raise (size fsT) (var 0)-                    , (liftS (size fsT) d0 `applySubst` u)-                    , drop (size gamma') $ map unArg $ teleArgs tel)-          Nothing -> (gamma, IdS, var 1, var 0, map (\ fname -> var 0 `applyProj` unArg fname) fns )--      fsT_tel = (liftS 1 (raiseS (size tel - size deltaI)) `composeS` sub params) `applySubst` fsT--      iMin x y = imin `apply` [argN x, argN y]-      iMax x y = imax `apply` [argN x, argN y]-      iNeg x = ineg `apply` [argN x]--      -- .. ⊢ field : filled_ty' i0-      mkBody (field, filled_ty') = do-        let-          filled_ty = lam_i $ (unEl . fromCType . unDom) filled_ty'-          -- Γ ⊢ l : I -> Level of filled_ty-        -- sort <- reduce $ getSort $ unDom filled_ty'-        case unDom filled_ty' of-          LType (LEl l _) -> do-            let lvl = lam_i $ Level l-            return $ runNames [] $ do-             lvl <- open lvl-             [phi,field] <- mapM open [the_phi,field]-             pure transp <#> lvl <@> pure filled_ty-                                 <@> phi-                                 <@> field-          -- interval arg-          ClosedType{}  ->-            return $ runNames [] $ do-            [field] <- mapM open [field]-            field--  let-        -- ' Ξ , i : I ⊢ τ = [(\ j → δ (i ∧ j)), φ ∨ ~ i, u] : Ξ-        tau = parallelS $ us ++ (phi `iMax` iNeg (var 0))-                        : map (\ d -> Lam defaultArgInfo $ Abs "i" $ raise 1 d `apply` [argN $ (iMin (var 0) (var 1))]) ds-         where-          -- Ξ, i : I-          (us, phi:ds) = splitAt (size tel - size gamma') $ reverse (raise 1 (map unArg (teleArgs tel)))--  let-    go acc [] = return []-    go acc ((fname,field_ty) : ps) = do-      -- Ξ, i : I, Φ[δ i]|_f ⊢ Φ_f = field_ty-      -- Ξ ⊢ b : field_ty [i := i1][acc]-      -- Ξ ⊢ parallesS acc : Φ[δ i1]|_f-      -- Ξ , i : I ⊢ τ = [(\ j → δ (i ∨ j), φ ∨ ~ i, us] : Ξ-      -- Ξ , i : I ⊢ parallesS (acc[τ]) : Φ[δ i1]|_f-      -- Ξ, i : I ⊢ field_ty [parallesS (acc[τ])]-      let-        filled_ty = parallelS (tau `applySubst` acc) `applySubst` field_ty-      b <- mkBody (fname,filled_ty)-      bs <- go (b : acc) ps-      return $ b : bs--  bodys <- go [] (zip the_fields (map (fmap snd) $ telToList fsT_tel)) -- ∀ f.  Ξ, i : I, Φ[δ i]|_f ⊢ Φ[δ i]_f-  let-    -- Ξ, i : I ⊢ ... : Δ.Φ-    theSubst = reverse (tau `applySubst` bodys) ++# (liftS 1 (raiseS (size tel - size deltaI)) `composeS` sub params)-  return $ ((theName, tel, theta `applySubst` rtype, map (fmap fromCType) clause_types, bodys), theSubst)-  where-    -- record type in 'exponentiated' context-    -- (params : Δ^I), i : I |- T[params i]-    rect' = sub params `applySubst` rect-    -- Δ^I, i : I |- sub Δ : Δ-    sub tel = parallelS [ var n `apply` [Arg defaultArgInfo $ var 0] | n <- [1..size tel] ]-    -- given I type, and Δ telescope, build Δ^I such that-    -- (x : A, y : B x, ...)^I = (x : I → A, y : (i : I) → B (x i), ...)-    expTelescope :: Type -> Telescope -> Telescope-    expTelescope int tel = unflattenTel names ys-      where-        xs = flattenTel tel-        names = teleNames tel-        t = ExtendTel (defaultDom $ raise (size tel) int) (Abs "i" EmptyTel)-        s = sub tel-        ys = map (fmap (abstract t) . applySubst s) xs---- invariant: resulting tel Γ is such that Γ = (δ : Δ), (φ : I), (u : ...), (a0 : R δ))---            where u and a0 have types matching the arguments of primHComp.-defineHCompForFields-  :: (Term -> QName -> Term) -- ^ how to apply a "projection" to a term-  -> QName       -- ^ some name, e.g. record name-  -> Telescope   -- ^ param types Δ-  -> Tele (Dom LType)   -- ^ fields' types Δ ⊢ Φ-  -> [Arg QName] -- ^ fields' names-  -> LType        -- ^ record type (δ : Δ) ⊢ R[δ]-  -> TCM ((QName, Telescope, Type, [Dom Type], [Term]),Substitution)-defineHCompForFields applyProj name params fsT fns rect = do-  interval <- primIntervalType-  let delta = params-  iz <- primIZero-  io <- primIOne-  imin <- getPrimitiveTerm "primIMin"-  imax <- getPrimitiveTerm "primIMax"-  tIMax <- getPrimitiveTerm "primIMax"-  ineg <- getPrimitiveTerm "primINeg"-  hcomp <- getPrimitiveTerm builtinHComp-  transp <- getPrimitiveTerm builtinTrans-  por <- getPrimitiveTerm "primPOr"-  one <- primItIsOne-  reportSDoc "comp.rec" 20 $ text $ show params-  reportSDoc "comp.rec" 20 $ text $ show delta-  reportSDoc "comp.rec" 10 $ text $ show fsT--  let thePrefix = "hcomp-"-  theName <- freshAbstractQName'_ $ thePrefix ++ P.prettyShow (A.qnameName name)--  reportSLn "hcomp.rec" 5 $ ("Generated name: " ++ show theName ++ " " ++ showQNameId theName)--  theType <- (abstract delta <$>) $ runNamesT [] $ do-              rect <- open $ fromLType rect-              nPi' "phi" primIntervalType $ \ phi ->-               nPi' "i" primIntervalType (\ i ->-                pPi' "o" phi $ \ _ -> rect) -->-               rect --> rect--  reportSDoc "hcomp.rec" 20 $ prettyTCM theType-  reportSDoc "hcomp.rec" 60 $ text $ "sort = " ++ show (lTypeLevel rect)--  lang <- getLanguage-  noMutualBlock $ addConstant theName $-    (defaultDefn defaultArgInfo theName theType lang-       (emptyFunction { funTerminates = Just True }))-      { defNoCompilation = True }-  --   ⊢ Γ = gamma = (δ : Δ) (φ : I) (_ : (i : I) -> Partial φ (R δ)) (_ : R δ)-  -- Γ ⊢     rtype = R δ-  TelV gamma rtype <- telView theType--  let -- Γ ⊢ R δ-      drect_gamma = raiseS (size gamma - size delta) `applySubst` rect--  reportSDoc "hcomp.rec" 60 $ text $ "sort = " ++ show (lTypeLevel drect_gamma)--  let--      -- (γ : Γ) ⊢ hcompR γ : rtype-      compTerm = Def theName [] `apply` teleArgs gamma--      -- (δ, φ, u, u0) : Γ ⊢ φ : I-      the_phi = var 2-      -- (δ, φ, u, u0) : Γ ⊢ u : (i : I) → [φ] → R (δ i)-      the_u   = var 1-      -- (δ, φ, u, u0) : Γ ⊢ u0 : R (δ i0)-      the_u0  = var 0--      -- ' (δ, φ, u, u0) : Γ ⊢ fillR Γ : (i : I) → rtype[ δ ↦ (\ j → δ (i ∧ j))]-      fillTerm = runNames [] $ do-        rect <- open . unEl  . fromLType  $ drect_gamma-        lvl  <- open . Level . lTypeLevel $ drect_gamma-        params     <- mapM open $ take (size delta) $ teleArgs gamma-        [phi,w,w0] <- mapM open [the_phi,the_u,the_u0]-        -- (δ : Δ, φ : I, w : .., w0 : R δ) ⊢-        -- ' fillR Γ = λ i → hcompR δ (φ ∨ ~ i) (\ j → [ φ ↦ w (i ∧ j) , ~ i ↦ w0 ]) w0-        --           = hfillR δ φ w w0-        lam "i" $ \ i -> do-          args <- sequence params-          psi  <- pure imax <@> phi <@> (pure ineg <@> i)-          u <- lam "j" (\ j -> pure por <#> lvl-                                        <@> phi-                                        <@> (pure ineg <@> i)-                                        <#> lam "_" (\ o -> rect)-                                        <@> (w <@> (pure imin <@> i <@> j))-                                        <@> lam "_" (\ o -> w0) -- TODO wait for i = 0-                       )-          u0 <- w0-          pure $ Def theName [] `apply` (args ++ [argN psi, argN u, argN u0])--      -- (γ : Γ) ⊢ (flatten Φ)[n ↦ f_n (compR γ)]-      clause_types = parallelS [compTerm `applyProj` (unArg fn)-                               | fn <- reverse fns] `applySubst`-                       flattenTel (raiseS (size gamma - size delta) `applySubst` fsT) -- Γ, Φ ⊢ flatten Φ-      -- Δ ⊢ Φ = fsT-      -- Γ, i : I ⊢ Φ'-      fsT' = raiseS ((size gamma - size delta) + 1) `applySubst` fsT--      -- Γ, i : I ⊢ (flatten Φ')[n ↦ f_n (fillR Γ i)]-      filled_types = parallelS [raise 1 fillTerm `apply` [argN $ var 0] `applyProj` (unArg fn)-                               | fn <- reverse fns] `applySubst`-                       flattenTel fsT' -- Γ, i : I, Φ' ⊢ flatten Φ'---  comp <- do-        let-          imax i j = pure tIMax <@> i <@> j-        let forward la bA r u = pure transp <#> lam "i" (\ i -> la <@> (i `imax` r))-                                            <@> lam "i" (\ i -> bA <@> (i `imax` r))-                                            <@> r-                                            <@> u-        return $ \ la bA phi u u0 ->-          pure hcomp <#> (la <@> pure io) <#> (bA <@> pure io) <#> phi-                      <@> lam "i" (\ i -> ilam "o" $ \ o ->-                              forward la bA i (u <@> i <..> o))-                      <@> forward la bA (pure iz) u0-  let-      mkBody (fname, filled_ty') = do-        let-          proj t = (`applyProj` unArg fname) <$> t-          filled_ty = Lam defaultArgInfo (Abs "i" $ (unEl . fromLType . unDom) filled_ty')-          -- Γ ⊢ l : I -> Level of filled_ty-        l <- reduce $ lTypeLevel $ unDom filled_ty'-        let lvl = Lam defaultArgInfo (Abs "i" $ Level l)-        return $ runNames [] $ do-             lvl <- open lvl-             [phi,w,w0] <- mapM open [the_phi,the_u,the_u0]-             filled_ty <- open filled_ty--             comp lvl-                  filled_ty-                  phi-                  (lam "i" $ \ i -> lam "o" $ \ o -> proj $ w <@> i <@> o) -- TODO wait for phi = 1-                  (proj w0)--  reportSDoc "hcomp.rec" 60 $ text $ "filled_types sorts:" ++ show (map (getSort . fromLType . unDom) filled_types)--  bodys <- mapM mkBody (zip fns filled_types)-  return $ ((theName, gamma, rtype, map (fmap fromLType) clause_types, bodys),IdS)---getGeneralizedParameters :: Set Name -> QName -> TCM [Maybe Name]-getGeneralizedParameters gpars name | Set.null gpars = return []-getGeneralizedParameters gpars name = do-  -- Drop the named parameters that shouldn't be in scope (if the user-  -- wrote a split data type)-  let inscope x = x <$ guard (Set.member x gpars)-  map (>>= inscope) . defGeneralizedParams <$> (instantiateDef =<< getConstInfo name)---- | Bind the named generalized parameters.-bindGeneralizedParameters :: [Maybe Name] -> Type -> (Telescope -> Type -> TCM a) -> TCM a-bindGeneralizedParameters [] t ret = ret EmptyTel t-bindGeneralizedParameters (name : names) t ret =-  case unEl t of-    Pi a b -> ext $ bindGeneralizedParameters names (unAbs b) $ \ tel t -> ret (ExtendTel a (tel <$ b)) t-      where-        ext | Just x <- name = addContext (x, a)-            | otherwise      = addContext (absName b, a)-    _      -> __IMPOSSIBLE__---- | Bind the parameters of a datatype.------   We allow omission of hidden parameters at the definition site.---   Example:---   @---     data D {a} (A : Set a) : Set a---     data D A where---       c : A -> D A---   @--bindParameters-  :: Int            -- ^ Number of parameters-  -> [A.LamBinding] -- ^ Bindings from definition site.-  -> Type           -- ^ Pi-type of bindings coming from signature site.-  -> (Telescope -> Type -> TCM a)-     -- ^ Continuation, accepting parameter telescope and rest of type.-     --   The parameters are part of the context when the continutation is invoked.-  -> TCM a--bindParameters 0 [] a ret = ret EmptyTel a--bindParameters 0 (par : _) _ _ = setCurrentRange par $-  typeError . GenericDocError =<< do-    text "Unexpected parameter" <+> prettyA par--bindParameters npars [] t ret =-  case unEl t of-    Pi a b | not (visible a) -> do-              x <- freshName_ (absName b)-              bindParameter npars [] x a b ret-           | otherwise ->-              typeError . GenericDocError =<<-                sep [ "Expected binding for parameter"-                    , text (absName b) <+> text ":" <+> prettyTCM (unDom a) ]-    _ -> __IMPOSSIBLE__--bindParameters npars par@(A.DomainFull (A.TBind _ _ xs e) : bs) a ret =-  setCurrentRange par $-  typeError . GenericDocError =<< do-    let s | length xs > 1 = "s"-          | otherwise     = ""-    text ("Unexpected type signature for parameter" ++ s) <+> sep (fmap prettyA xs)--bindParameters _ (A.DomainFull A.TLet{} : _) _ _ = __IMPOSSIBLE__--bindParameters _ (par@(A.DomainFree _ arg) : ps) _ _-  | getModality arg /= defaultModality = setCurrentRange par $-     typeError . GenericDocError =<< do-       text "Unexpected modality/relevance annotation in" <+> prettyA par--bindParameters npars ps0@(par@(A.DomainFree _ arg) : ps) t ret = do-  let x          = namedArg arg-      TelV tel _ = telView' t-  case insertImplicit arg $ telToList tel of-    NoInsertNeeded -> continue ps $ A.unBind $ A.binderName x-    ImpInsert _    -> continue ps0 =<< freshName_ (absName b)-    BadImplicits   -> setCurrentRange par $-     typeError . GenericDocError =<< do-       text "Unexpected parameter" <+> prettyA par-    NoSuchName x   -> setCurrentRange par $-      typeError . GenericDocError =<< do-        text ("No parameter of name " ++ x)-  where-    Pi dom@(Dom{domInfo = info', unDom = a}) b = unEl t -- TODO:: Defined but not used: info', a-    continue ps x = bindParameter npars ps x dom b ret--bindParameter :: Int -> [A.LamBinding] -> Name -> Dom Type -> Abs Type -> (Telescope -> Type -> TCM a) -> TCM a-bindParameter npars ps x a b ret =-  addContext (x, a) $-    bindParameters (npars - 1) ps (absBody b) $ \ tel s ->-      ret (ExtendTel a $ Abs (nameToArgName x) tel) s---- | Check that the arguments to a constructor fits inside the sort of the datatype.---   The third argument is the type of the constructor.------   When @--without-K@ is active and the type is fibrant the---   procedure also checks that the type is usable at the current---   modality. See #4784 and #5434.------   As a side effect, return the arity of the constructor.--fitsIn :: UniverseCheck -> [IsForced] -> Type -> Sort -> TCM Int-fitsIn uc forceds t s = do-  reportSDoc "tc.data.fits" 10 $-    sep [ "does" <+> prettyTCM t-        , "of sort" <+> prettyTCM (getSort t)-        , "fit in" <+> prettyTCM s <+> "?"-        ]-  -- The code below would be simpler, but doesn't allow datatypes-  -- to be indexed by the universe level.-  -- s' <- instantiateFull (getSort t)-  -- noConstraints $ s' `leqSort` s--  withoutK <- withoutKOption-  when withoutK $ whenM (isFibrant s) $ do-    q <- viewTC eQuantity-    usableAtModality (setQuantity q defaultModality) (unEl t)--  fitsIn' withoutK forceds t s-  where-  fitsIn' withoutK forceds t s = do-    vt <- do-      t <- pathViewAsPi t-      return $ case t of-                    Left (a,b)     -> Just (True ,a,b)-                    Right (El _ t) | Pi a b <- t-                                   -> Just (False,a,b)-                    _              -> Nothing-    case vt of-      Just (isPath, dom, b) -> do-        let (forced,forceds') = nextIsForced forceds-        unless (isForced forced && not withoutK) $ do-          sa <- reduce $ getSort dom-          unless (isPath || uc == NoUniverseCheck || sa == SizeUniv) $-            sa `leqSort` s-        addContext (absName b, dom) $ do-          succ <$> fitsIn' withoutK forceds' (absBody b) (raise 1 s)-      _ -> do-        getSort t `leqSort` s-        return 0+import Prelude hiding (null, not, (&&), (||) )++import Control.Monad.Except ( MonadError(..), ExceptT(..), runExceptT )+import Control.Monad.Trans.Maybe+import Control.Exception as E++import Data.Set (Set)+import qualified Data.Set as Set++import Agda.Interaction.Options.Base++import qualified Agda.Syntax.Abstract as A+import qualified Agda.Syntax.Concrete.Name as C+import Agda.Syntax.Abstract.Views (deepUnscope)+import Agda.Syntax.Internal+import Agda.Syntax.Internal.Pattern+import Agda.Syntax.Common+import qualified Agda.Syntax.Common.Pretty as P+import Agda.Syntax.Position+import qualified Agda.Syntax.Info as Info+import Agda.Syntax.Scope.Monad++import {-# SOURCE #-} Agda.TypeChecking.CompiledClause.Compile+import Agda.TypeChecking.Monad+import Agda.TypeChecking.Conversion+import {-# SOURCE #-} Agda.TypeChecking.CheckInternal+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Generalize+import Agda.TypeChecking.Implicit+import Agda.TypeChecking.InstanceArguments+import Agda.TypeChecking.MetaVars+import Agda.TypeChecking.Names+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Positivity.Occurrence (Occurrence(StrictPos))+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Primitive hiding (Nat)+import Agda.TypeChecking.Free+import Agda.TypeChecking.Forcing+import Agda.TypeChecking.Irrelevance+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Warnings (warning)++import {-# SOURCE #-} Agda.TypeChecking.Rules.Term ( isType_ )++import Agda.Utils.Boolean+import Agda.Utils.Either+import Agda.Utils.Function (applyWhen)+import Agda.Utils.Functor+import Agda.Utils.List+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+import qualified Agda.Utils.Set1 as Set1+import Agda.Utils.Size++import Agda.Utils.Impossible++---------------------------------------------------------------------------+-- * Datatypes+---------------------------------------------------------------------------++-- | Type check a datatype definition. Assumes that the type has already been+--   checked.+checkDataDef :: A.DefInfo -> QName -> UniverseCheck -> A.DataDefParams -> [A.Constructor] -> TCM ()+checkDataDef i name uc (A.DataDefParams gpars ps) cs =+    traceCall (CheckDataDef (getRange name) name ps cs) $ do++        -- Add the datatype module+        addSection (qnameToMName name)++        -- Look up the type of the datatype.+        def <- instantiateDef =<< getConstInfo name+        t   <- instantiateFull $ defType def+        let npars =+              case theDef def of+                DataOrRecSig n -> n+                _              -> __IMPOSSIBLE__++        -- If the data type is erased, then hard compile-time mode is+        -- entered.+        setHardCompileTimeModeIfErased' def $ do++        -- Make sure the shape of the type is visible+        let unTelV (TelV tel a) = telePi tel a+        t <- unTelV <$> telView t++        parNames <- getGeneralizedParameters gpars name++        -- Top level free vars+        freeVars <- getContextSize++        -- The parameters are in scope when checking the constructors.+        dataDef <- bindGeneralizedParameters parNames t $ \ gtel t0 ->+                   bindParameters (npars - length parNames) ps t0 $ \ ptel t0 -> do++            -- The type we get from bindParameters is Θ -> s where Θ is the type of+            -- the indices. We count the number of indices and return s.+            -- We check that s is a sort.+            let TelV ixTel s0 = telView' t0+                nofIxs = size ixTel++            s <- workOnTypes $ do+              -- Andreas, 2016-11-02 issue #2290+              -- Trying to unify the sort with a fresh sort meta which is+              -- defined outside the index telescope is the most robust way+              -- to check independence of the indices.+              -- However, it might give the dreaded "Cannot instantiate meta..."+              -- error which we replace by a more understandable error+              -- in case of a suspected dependency.+              s <- newSortMetaBelowInf+              catchError_ (addContext ixTel $ equalType s0 $ raise nofIxs $ sort s) $ \ err ->+                  if any (`freeIn` s0) [0..nofIxs - 1] then typeError $ SortCannotDependOnItsIndex name t0+                  else throwError err+              reduce s++            withK   <- not <$> withoutKOption+            erasure <- optErasure <$> pragmaOptions+            -- Parameters are always hidden in constructors. If+            -- --erasure is used, then the parameters are erased for+            -- non-indexed data types, and if --with-K is active this+            -- applies also to indexed data types.+            let tel  = abstract gtel ptel+                tel' = applyWhen (erasure && (withK || nofIxs == 0)) (applyQuantity zeroQuantity) .+                       hideAndRelParams <$>+                       tel++            reportSDoc "tc.data.sort" 20 $ vcat+              [ "checking datatype" <+> prettyTCM name+              , nest 2 $ vcat+                [ "type (parameters instantiated):   " <+> prettyTCM t0+                , "type (full):   " <+> prettyTCM t+                , "sort:   " <+> prettyTCM s+                , "indices:" <+> text (show nofIxs)+                , "gparams:" <+> text (show parNames)+                , "params: " <+> text (show $ deepUnscope ps)+                ]+              ]+            let npars = size tel++            -- Change the datatype from an axiom to a datatype with no constructors.+            let dataDef = DatatypeData+                  { _dataPars       = npars+                  , _dataIxs        = nofIxs+                  , _dataClause     = Nothing+                  , _dataCons       = []     -- Constructors are added later+                  , _dataSort       = s+                  , _dataAbstr      = Info.defAbstract i+                  , _dataMutual     = Nothing+                  , _dataPathCons   = []     -- Path constructors are added later+                  , _dataTranspIx   = Nothing -- Generated later if nofIxs > 0.+                  , _dataTransp     = Nothing -- Added later+                  }++            escapeContext impossible npars $ do+              addConstant' name defaultArgInfo t $ DatatypeDefn dataDef+                -- polarity and argOcc.s determined by the positivity checker++            -- Check the types of the constructors+            pathCons <- forM cs $ \ c -> do+              isPathCons <- checkConstructor name uc tel' nofIxs s c+              return $ if isPathCons == PathCons then Just (A.axiomName c) else Nothing+++            -- cubical: the interval universe does not contain datatypes+            -- similar: SizeUniv, ...+            checkDataSort name s++            -- when `--without-K`, all the indices should fit in the+            -- sort of the datatype (see #3420).+            -- Andreas, 2019-07-16, issue #3916:+            -- NoUniverseCheck should also disable the index sort check!+            unless (uc == NoUniverseCheck) $+              whenM withoutKOption $ do+                let s' = case s of+                      Prop l -> Type l+                      _      -> s+                checkIndexSorts s' ixTel++            -- Return the data definition+            return dataDef{ _dataPathCons = catMaybes pathCons+                          }++        let cons   = map A.axiomName cs  -- get constructor names++        (mtranspix, transpFun) <-+          ifM cubicalCompatibleOption+            (do mtranspix <- inTopContext $ defineTranspIx name+                transpFun <- inTopContext $+                               defineTranspFun name mtranspix cons+                                 (_dataPathCons dataDef)+                return (mtranspix, transpFun))+            (return (Nothing, Nothing))++        -- Add the datatype to the signature with its constructors.+        -- It was previously added without them.+        addConstant' name defaultArgInfo t $ DatatypeDefn+            dataDef{ _dataCons = cons+                   , _dataTranspIx = mtranspix+                   , _dataTransp   = transpFun+                   }++-- | Make sure that the target universe admits data type definitions.+--   E.g. @IUniv@, @SizeUniv@ etc. do not accept new constructions.+checkDataSort :: QName -> Sort -> TCM ()+checkDataSort name s = setCurrentRange name $ do+  ifBlocked s postpone {-else-} $ \ _ (s :: Sort) -> do+    let+      yes :: TCM ()+      yes = return ()+      no  :: TCM ()+      no  = typeError $ SortDoesNotAdmitDataDefinitions name s+    case s of+      -- Sorts that admit data definitions.+      Univ _ _     -> yes+      Inf _ _      -> yes+      DefS _ _     -> yes+      -- Sorts that do not admit data definitions.+      SizeUniv     -> no+      LockUniv     -> no+      LevelUniv    -> no+      IntervalUniv -> no+      -- Blocked sorts.+      PiSort _ _ _ -> __IMPOSSIBLE__+      FunSort _ _  -> __IMPOSSIBLE__+      UnivSort _   -> __IMPOSSIBLE__+      MetaS _ _    -> __IMPOSSIBLE__+      DummyS _     -> __IMPOSSIBLE__+  where+    postpone :: Blocker -> Sort -> TCM ()+    postpone b s = addConstraint b $ CheckDataSort name s++-- | Ensure that the type is a sort.+--   If it is not directly a sort, compare it to a 'newSortMetaBelowInf'.+forceSort :: Type -> TCM Sort+forceSort t = reduce (unEl t) >>= \case+  Sort s -> return s+  _      -> do+    s <- newSortMetaBelowInf+    equalType t (sort s)+    return s++-- | Type check a constructor declaration. Checks that the constructor targets+--   the datatype and that it fits inside the declared sort.+--   Returns the non-linear parameters.+checkConstructor+  :: QName         -- ^ Name of data type.+  -> UniverseCheck -- ^ Check universes?+  -> Telescope     -- ^ Parameter telescope.+  -> Nat           -- ^ Number of indices of the data type.+  -> Sort          -- ^ Sort of the data type.+  -> A.Constructor -- ^ Constructor declaration (type signature).+  -> TCM IsPathCons+checkConstructor d uc tel nofIxs s (A.ScopedDecl scope [con]) = do+  setScope scope+  checkConstructor d uc tel nofIxs s con+checkConstructor d uc tel nofIxs s con@(A.Axiom _ i ai Nothing c e) =+    traceCall (CheckConstructor d tel s con) $ do+{- WRONG+      -- Andreas, 2011-04-26: the following happens to the right of ':'+      -- we may use irrelevant arguments in a non-strict way in types+      t' <- workOnTypes $ do+-}+        debugEnter c e+        -- Remember that we are of a suitable modality.+        unless (isRelevant ai) __IMPOSSIBLE__+        unless ((isQuantityω || isQuantity0) ai) __IMPOSSIBLE__++        -- If the constructor is erased, then hard compile-time mode+        -- is entered.+        setHardCompileTimeModeIfErased' ai $ do++        -- check that the type of the constructor is well-formed+        (t, isPathCons) <- checkConstructorType e d++        -- compute which constructor arguments are forced (only point constructors)+        forcedArgs <- if isPathCons == PointCons+                      then computeForcingAnnotations c t+                      else return []+        -- check that the sort (universe level) of the constructor type+        -- is contained in the sort of the data type+        -- (to avoid impredicative existential types)+        debugFitsIn s+        arity <- applyQuantityToJudgement ai $+          fitsIn IsData c uc forcedArgs t s+        -- this may have instantiated some metas in s, so we reduce+        s <- reduce s+        debugAdd c t++        (TelV fields _, boundary) <- telViewPathBoundary t++        -- We assume that the current context matches the parameters+        -- of the datatype in an empty context (c.f. getContextSize above).+        params <- getContextTelescope++        (con, comp, projNames) <- do+            -- Name for projection of ith field of constructor c is just c-i+            names <- forM [0 .. size fields - 1] $ \ i ->+              freshAbstractQName'_ $ P.prettyShow (A.qnameName c) ++ "-" ++ show i++            -- nofIxs == 0 means the data type can be reconstructed+            -- by appling the QName d to the parameters.+            let dataT = El s $ Def d $ map Apply $ teleArgs params++            reportSDoc "tc.data.con.comp" 5 $ inTopContext $ vcat $+              [ "params =" <+> pretty params+              , "dataT  =" <+> pretty dataT+              , "fields =" <+> pretty fields+              , "names  =" <+> pretty names+              ]++            let con = ConHead c IsData Inductive $ zipWith (<$) names $ map argFromDom $ telToList fields++            defineProjections d con params names fields dataT+            -- Andreas, 2024-01-05 issue #7048:+            -- Only define hcomp when --cubical-compatible.+            cubicalCompatible <- cubicalCompatibleOption+            -- Cannot compose indexed inductive types yet.+            comp <- if cubicalCompatible && nofIxs == 0 && Info.defAbstract i == ConcreteDef+                    then inTopContext $ defineCompData d con params names fields dataT boundary+                    else return emptyCompKit+            return (con, comp, Just names)++        -- add parameters to constructor type and put into signature+        escapeContext impossible (size tel) $ do+          erasure <- optErasure <$> pragmaOptions+          addConstant' c ai (telePi tel t) $ Constructor+              { conPars   = size tel+              , conArity  = arity+              , conSrcCon = con+              , conData   = d+              , conAbstr  = Info.defAbstract i+              , conComp   = comp+              , conProj   = projNames+              , conForced = forcedArgs+              , conErased = Nothing  -- computed during compilation to treeless+              , conErasure = erasure+              , conInline  = False+              }++        -- Add the constructor to the instance table, if needed+        case Info.defInstance i of+          InstanceDef _r -> setCurrentRange c $ do+            -- Including the range of the @instance@ keyword, like+            -- @(getRange (r,c))@, does not produce good results.+            -- Andreas, 2020-01-28, issue #4360:+            -- Use addTypedInstance instead of addNamedInstance+            -- to detect unusable instances.+            addTypedInstance c t+            -- addNamedInstance c d+          NotInstanceDef -> pure ()++        return isPathCons++  where+    -- Issue 3362: we need to do the `constructs` call inside the+    -- generalization, so unpack the A.Generalize+    checkConstructorType (A.ScopedExpr s e) d = withScope_ s $ checkConstructorType e d+    checkConstructorType e d = do+      let check k e = do+            t <- workOnTypes $ isType_ e+            -- check that the type of the constructor ends in the data type+            n <- getContextSize+            debugEndsIn t d (n - k)+            isPathCons <- constructs (n - k) k t d+            return (t, isPathCons)++      case e of+        A.Generalized s e -> do+          (_, t, isPathCons) <- generalizeType' (Set1.toSet s) (check 1 e)+          return (t, isPathCons)+        _ -> check 0 e++    debugEnter c e =+      reportSDoc "tc.data.con" 5 $ vcat+        [ "checking constructor" <+> prettyTCM c <+> ":" <+> prettyTCM e+        ]+    debugEndsIn t d n =+      reportSDoc "tc.data.con" 15 $ vcat+        [ sep [ "checking that"+              , nest 2 $ prettyTCM t+              , "ends in" <+> prettyTCM d+              ]+        , nest 2 $ "nofPars =" <+> text (show n)+        ]+    debugFitsIn s =+      reportSDoc "tc.data.con" 15 $ sep+        [ "checking that the type fits in"+        , nest 2 $ prettyTCM s+        ]+    debugAdd c t =+      reportSDoc "tc.data.con" 5 $ vcat+        [ "adding constructor" <+> prettyTCM c <+> ":" <+> prettyTCM t+        ]+checkConstructor _ _ _ _ _ _ = __IMPOSSIBLE__ -- constructors are axioms++defineCompData ::+     QName         -- ^ Datatype name.+  -> ConHead       -- ^ Constructor.+  -> Telescope     -- ^ @Γ@ parameters.+  -> [QName]       -- ^ Projection names.+  -> Telescope     -- ^ @Γ ⊢ Φ@ field types.+  -> Type          -- ^ @Γ ⊢ T@ target type.+  -> Boundary      -- ^ @[(i,t_i,b_i)],  Γ.Φ ⊢ [ (i=0) -> t_i; (i=1) -> u_i ] : B_i@+  -> TCM CompKit+defineCompData d con params names fsT t boundary = do+  required <- mapM getTerm'+    [ someBuiltin builtinInterval+    , someBuiltin builtinIZero+    , someBuiltin builtinIOne+    , someBuiltin builtinIMin+    , someBuiltin builtinIMax+    , someBuiltin builtinINeg+    , someBuiltin builtinPOr+    , someBuiltin builtinItIsOne+    ]+  if not (all isJust required) then return $ emptyCompKit else do+    hcomp  <- whenDefined (null boundary) [builtinHComp,builtinTrans]+      (defineKanOperationD DoHComp  d con params names fsT t boundary)+    transp <- whenDefined True            [builtinTrans]+      (defineKanOperationD DoTransp d con params names fsT t boundary)+    return $ CompKit+      { nameOfTransp = transp+      , nameOfHComp  = hcomp+      }+  where+    -- Δ^I, i : I |- sub Δ : Δ+    sub tel = [ var n `apply` [Arg defaultArgInfo $ var 0] | n <- [1..size tel] ] ++# EmptyS __IMPOSSIBLE__+    withArgInfo tel = zipWith Arg (map domInfo . telToList $ tel)++    defineKanOperationD cmd d con params names fsT t boundary = do+      let project = (\ t p -> apply (Def p []) [argN t])+      stuff <- defineKanOperationForFields cmd+                 (guard (not $ null boundary) >> Just (Con con ConOSystem $ teleElims fsT boundary))+                 project d params fsT (map argN names) t+      caseMaybe stuff (return Nothing) $ \ ((theName, gamma , ty, _cl_types , bodies), theSub) -> do++      iz <- primIZero+      body <- do+        case cmd of+          DoHComp -> return $ Con con ConOSystem (map Apply $ withArgInfo fsT bodies)+          DoTransp | null boundary {- && null ixs -} -> return $ Con con ConOSystem (map Apply $ withArgInfo fsT bodies)+                   | otherwise -> do+            io <- primIOne+            tIMax <- primIMax+            tIMin <- primIMin+            tINeg <- primINeg+            tPOr  <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPOr+            tHComp <- primHComp+            -- Δ = params+            -- Δ ⊢ Φ = fsT+            -- (δ : Δ) ⊢ T = R δ+            -- (δ : Δ) ⊢ con : Φ → R δ  -- no indexing+            -- boundary = [(i,t_i,u_i)]+            -- Δ.Φ ⊢ [ (i=0) -> t_i; (i=1) -> u_i ] : B_i+            -- Δ.Φ | PiPath Φ boundary (R δ) |- teleElims fsT boundary : R δ+            -- Γ = ((δ : Δ^I), φ, us : Φ[δ 0]) = gamma+            -- Γ ⊢ ty = R (δ i1)+            -- (γ : Γ) ⊢ cl_types = (flatten Φ)[n ↦ f_n (transpR γ)]+            -- Γ ⊢ bodies : Φ[δ i1]+            -- Γ ⊢ t : ty+            -- Γ, i : I ⊢ theSub : Δ.Φ+            let++              -- Δ.Φ ⊢ u = Con con ConOSystem $ teleElims fsT boundary : R δ+              u = Con con ConOSystem $ teleElims fsT boundary+              -- Γ ⊢ u+              the_u = liftS (size fsT) d0 `applySubst` u+                where+                  -- δ : Δ^I, φ : F ⊢ [δ 0] : Δ+                  d0 :: Substitution+                  d0 = wkS 1 -- Δ^I, φ : F ⊢ Δ+                             (consS iz IdS `composeS` sub params) -- Δ^I ⊢ Δ+                                       -- Δ^I , i:I ⊢ sub params : Δ+              the_phi = raise (size fsT) $ var 0+              -- Γ ⊢ sigma : Δ.Φ+              -- sigma = [δ i1,bodies]+              -- sigma = theSub[i1]+              sigma = reverse bodies ++# d1+               where+                -- δ i1+                d1 :: Substitution+                d1 = wkS (size gamma - size params) -- Γ ⊢ Δ+                       (consS io IdS `composeS` sub params) -- Δ^I ⊢ Δ+                                 -- Δ^I , i:I ⊢ sub params : Δ++              -- Δ.Φ ⊢ [ (i=0) -> t_i; (i=1) -> u_i ] : R δ+              bs = fullBoundary fsT boundary+              -- ψ = sigma `applySubst` map (\ i → i ∨ ~ i) . map fst $ boundary+              -- Γ ⊢ t : R (δ i1)+              w1' = Con con ConOSystem $ sigma `applySubst` teleElims fsT boundary+              -- (δ, φ, u0) : Γ ⊢+              -- w1 = hcomp (\ i → R (δ i1))+              --            (\ i → [ ψ ↦ α (~ i), φ ↦ u0])+              --            w1'+              imax x y = pure tIMax <@> x <@> y+              ineg r = pure tINeg <@> r+              lvlOfType = (\ (Type l) -> Level l) . getSort+              pOr la i j u0 u1 = pure tPOr <#> (lvlOfType <$> la) <@> i <@> j+                                           <#> ilam "o" (\ _ -> unEl <$> la) <@> u0 <@> u1+              absAp x y = liftM2 absApp x y++              mkFace (r,(u1,u2)) = runNamesT [] $ do+                -- Γ+                phi <- open the_phi  -- (δ , φ , us) ⊢ φ+                -- Γ ⊢ ty = Abs i. R (δ i)+                ty <- open (Abs "i" $ (liftS 1 (raiseS (size gamma - size params)) `composeS` sub params) `applySubst` t)++                bind "i" $ \ i -> do+                  -- Γ, i+                  r  <- open . applySubst theSub $ r+                  u1 <- open . applySubst theSub $ u1+                  u2 <- open . applySubst theSub $ u2+                  psi <- imax r (ineg r)+                  let+                    -- Γ, i ⊢ squeeze u = primTrans (\ j -> ty [i := i ∨ j]) (φ ∨ i) u+                    squeeze u = cl primTrans+                                          <#> lam "j" (\ j -> lvlOfType <$> ty `absAp` (imax i j))+                                          <@> lam "j" (\ j -> unEl <$> ty `absAp` (imax i j))+                                          <@> (phi `imax` i)+                                          <@> u+                  alpha <- pOr (ty `absAp` i)+                              (ineg r)+                              r+                           (ilam "o" $ \ _ -> squeeze u1) (ilam "o" $ \ _ -> squeeze u2)+                  return $ (psi, alpha)++            -- Γ ⊢ Abs i. [(ψ_n,α_n : [ψ] → R (δ i))]+            faces <- mapM mkFace $ theBoundary $ tmBoundary bs++            runNamesT [] $ do+                -- Γ+                w1' <- open w1'+                phi <- open the_phi+                u   <- open the_u+                -- R (δ i1)+                ty <- open ty+                faces <- mapM (\ x -> liftM2 (,) (open . noabsApp __IMPOSSIBLE__ $ fmap fst x) (open $ fmap snd x)) faces+                let+                  thePsi = foldl1 imax (map fst faces)+                  hcomp ty phi sys a0 = pure tHComp <#> (lvlOfType <$> ty)+                                                    <#> (unEl <$> ty)+                                                    <#> phi+                                                    <@> sys+                                                    <@> a0+                let+                 sys = lam "i" $ \ i -> do+                  let+                    recurse [(psi,alpha)] = alpha `absAp` (ineg i)+                    recurse ((psi,alpha):xs) = pOr ty+                                                   psi  theOr+                                                   (alpha `absAp` (ineg i)) (recurse xs)+                      where+                        theOr = foldl1 imax (map fst xs)+                    recurse [] = __IMPOSSIBLE__+                    sys_alpha = recurse faces+                  pOr ty+                                                   thePsi    phi+                                                   sys_alpha (ilam "o" $ \ _ -> u)+                hcomp ty (thePsi `imax` phi) sys w1'+++      let++        -- δ : Δ^I, φ : F ⊢ [δ 0] : Δ+        d0 :: Substitution+        d0 = wkS 1 -- Δ^I, φ : F ⊢ Δ+                       (consS iz IdS `composeS` sub params) -- Δ^I ⊢ Δ+                                 -- Δ^I , i:I ⊢ sub params : Δ++        -- Δ.Φ ⊢ u = Con con ConOSystem $ teleElims fsT boundary : R δ+--        u = Con con ConOSystem $ teleElims fsT boundary+        up = ConP con (ConPatternInfo defaultPatternInfo False False Nothing False) $+               telePatterns (d0 `applySubst` fsT) (liftS (size fsT) d0 `applySubst` boundary)+--        gamma' = telFromList $ take (size gamma - 1) $ telToList gamma++        -- (δ , φ , fs : Φ[d0]) ⊢ u[liftS Φ d0]+        -- (δ , φ, u) : Γ ⊢ body+        -- Δ ⊢ Φ = fsT+        -- (δ , φ , fs : Φ[d0]) ⊢ u[liftS Φ d0] `consS` raiseS Φ : Γ+--        (tel',theta) = (abstract gamma' (d0 `applySubst` fsT), (liftS (size fsT) d0 `applySubst` u) `consS` raiseS (size fsT))++      let+        pats | null boundary = teleNamedArgs gamma+             | otherwise     = take (size gamma - size fsT) (teleNamedArgs gamma) ++ [argN $ unnamed $ up]+        clause = Clause+          { clauseTel         = gamma+          , clauseType        = Just . argN $ ty+          , namedClausePats   = pats+          , clauseFullRange   = noRange+          , clauseLHSRange    = noRange+          , clauseCatchall    = empty+          , clauseBody        = Just $ body+          , clauseRecursive   = Nothing+              -- Andreas 2020-02-06 TODO+              -- Or: Just False;  is it known to be non-recursive?+          , clauseUnreachable = Just False+          , clauseEllipsis    = NoEllipsis+          , clauseWhereModule = Nothing+          }+        cs = [clause]+      addClauses theName cs+      (mst, _, cc) <- inTopContext (compileClauses Nothing cs)+      whenJust mst $ setSplitTree theName+      setCompiledClauses theName cc+      setTerminates theName True+      return $ Just theName++    whenDefined False _ _ = return Nothing+    whenDefined True xs m = do+      xs <- mapM getTerm' xs+      if all isJust xs then m else return Nothing++-- Andrea: TODO handle Irrelevant fields somehow.+-- | Define projections for non-indexed data types (families don't work yet).+--   Of course, these projections are partial functions in general.+--+--   Precondition: we are in the context Γ of the data type parameters.+defineProjections :: QName      -- datatype name+                  -> ConHead+                  -> Telescope  -- Γ parameters+                  -> [QName]    -- projection names+                  -> Telescope  -- Γ ⊢ Φ field types+                  -> Type       -- Γ ⊢ T target type+                  -> TCM ()+defineProjections dataName con params names fsT t = do+  let+    -- Γ , (d : T) ⊢ Φ[n ↦ proj n d]+    fieldTypes = ([ Def f [] `apply` [argN $ var 0] | f <- reverse names ] ++# raiseS 1) `applySubst`+                    flattenTel fsT  -- Γ , Φ ⊢ Φ+    -- ⊢ Γ , (d : T)+    projTel    = abstract params (ExtendTel (defaultDom t) (Abs "d" EmptyTel))+    np         = size params++  forM_ (zip3 (downFrom (size fieldTypes)) names fieldTypes) $ \ (i,projName,ty) -> do+    let+      projType = abstract projTel <$> ty+      cpi    = ConPatternInfo defaultPatternInfo False False (Just $ argN $ raise (size fsT) t) False+      conp   = defaultNamedArg $ ConP con cpi $ teleNamedArgs fsT+      sigma  = Con con ConOSystem (map Apply $ teleArgs fsT) `consS` raiseS (size fsT)+      clause = empty+          { clauseTel         = abstract params fsT+          , namedClausePats   = [ conp ]+          , clauseBody        = Just $ var i+          , clauseType        = Just $ argN $ applySubst sigma $ unDom ty+          , clauseRecursive   = Just False  -- non-recursive+          , clauseUnreachable = Just False+          }++    reportSDoc "tc.data.proj" 20 $ inTopContext $ sep+      [ "proj" <+> prettyTCM (i,ty)+      , nest 2 $ sep [ prettyTCM projName, ":", prettyTCM projType ]+      ]++    -- Andreas, 2020-02-14, issue #4437+    -- Define data projections as projection-like from the start.+    noMutualBlock $ do+      let cs = [ clause ]+      (mst, _, cc) <- compileClauses Nothing cs+      fun          <- emptyFunctionData <&> \fun -> fun+                { _funClauses    = cs+                , _funCompiled   = Just cc+                , _funSplitTree  = mst+                , _funProjection = Right Projection+                    { projProper   = Nothing+                    , projOrig     = projName+                    , projFromType = Arg (getArgInfo ty) dataName+                    , projIndex    = np + 1+                    , projLams     = ProjLams $ map (argFromDom . fmap fst) $ telToList projTel+                    }+                , _funMutual     = Just []+                , _funTerminates = Just True+                }+      lang <- getLanguage+      inTopContext $ addConstant projName $+        (defaultDefn defaultArgInfo projName (unDom projType) lang $ FunctionDefn fun)+          { defNoCompilation  = True+          , defArgOccurrences = [StrictPos]+          }++      reportSDoc "tc.data.proj.fun" 60 $ inTopContext $ vcat+        [ "proj" <+> prettyTCM i+        , nest 2 $ pretty fun+        ]+++freshAbstractQName'_ :: String -> TCM QName+freshAbstractQName'_ = freshAbstractQName noFixity' . C.simpleName+++-- | Defines and returns the name of the `transpIx` function.+defineTranspIx :: QName  -- ^ datatype name+               -> TCM (Maybe QName)+defineTranspIx d = do+  def <- getConstInfo d+  case theDef def of+    Datatype { dataPars = npars+             , dataIxs = nixs+             , dataSort = s}+     -> do+      let t = defType def+      reportSDoc "tc.data.ixs" 20 $ vcat+        [ "name :" <+> prettyTCM d+        , "type :" <+> prettyTCM t+        , "npars:" <+> pretty npars+        , "nixs :" <+> pretty nixs+        ]+      if nixs == 0 then return Nothing else do+      trIx <- freshAbstractQName'_ $ "transpX-" ++ P.prettyShow (A.qnameName d)+      TelV params t' <- telViewUpTo npars t+      TelV ixs    dT <- telViewUpTo nixs t'+      -- params     ⊢ s+      -- params     ⊢ ixs+      -- params.ixs ⊢ dT+      reportSDoc "tc.data.ixs" 20 $ vcat+        [ "params :" <+> prettyTCM params+        , "ixs    :" <+> addContext params (prettyTCM ixs)+        , "dT     :" <+> addContext params (addContext ixs $ prettyTCM dT)+        ]+      -- theType <- abstract params <$> undefined+      interval <- primIntervalType+      let deltaI = expTelescope interval ixs+      iz <- primIZero+      io@(Con c _ _) <- primIOne+      imin <- getPrimitiveTerm builtinIMin+      imax <- getPrimitiveTerm builtinIMax+      ineg <- getPrimitiveTerm builtinINeg+      transp <- getPrimitiveTerm builtinTrans+      por <- getPrimitiveTerm builtinPOr+      one <- primItIsOne+      -- reportSDoc "trans.rec" 20 $ text $ show params+      -- reportSDoc "trans.rec" 20 $ text $ show deltaI+      -- reportSDoc "trans.rec" 10 $ text $ show fsT++      -- let thePrefix = "transp-"+      -- theName <- freshAbstractQName'_ $ thePrefix ++ P.prettyShow (A.qnameName name)++      -- reportSLn "trans.rec" 5 $ ("Generated name: " ++ show theName ++ " " ++ showQNameId theName)++      -- record type in 'exponentiated' context+      -- (params : Γ)(ixs : Δ^I), i : I |- T[params, ixs i]+      let rect' = sub ixs `applySubst` El (raise (size ixs) s) (Def d (teleElims (abstract params ixs) empty))+      addContext params $ reportSDoc "tc.data.ixs" 20 $ "deltaI:" <+> prettyTCM deltaI+      addContext params $ addContext deltaI $ addContext ("i"::String, defaultDom interval) $ do+        reportSDoc "tc.data.ixs" 20 $ "rect':" <+> pretty (sub ixs)+        reportSDoc "tc.data.ixs" 20 $ "rect':" <+> pretty rect'++      theType <- (abstract (setHiding Hidden <$> params) <$>) . (abstract deltaI <$>) $ runNamesT [] $ do+                  rect' <- open (runNames [] $ bind "i" $ \ x -> let _ = x `asTypeOf` pure (undefined :: Term) in+                                                                 pure rect')+                  nPi' "phi" (primIntervalType) $ \ phi ->+                   (absApp <$> rect' <*> pure iz) --> (absApp <$> rect' <*> pure io)++      reportSDoc "tc.data.ixs" 20 $ "transpIx:" <+> prettyTCM theType+      let+        ctel = abstract params $ abstract deltaI $ ExtendTel (defaultDom $ subst 0 iz rect') (Abs "t" EmptyTel)+        ps = telePatterns ctel empty+        cpi = noConPatternInfo { conPType = Just (defaultArg interval) }+        pat :: NamedArg (Pattern' DBPatVar)+        pat = defaultNamedArg $ ConP c cpi []+        clause = empty+          { clauseTel         = ctel+          , namedClausePats   = init ps ++ [pat, last ps]++          , clauseBody        = Just $ var 0+          , clauseType        = Just $ defaultArg $ raise 1 $ subst 0 io rect'+          , clauseRecursive   = Just False  -- non-recursive+          , clauseUnreachable = Just False+          }++      noMutualBlock $ do+        let cs = [ clause ]+--        we do not compile clauses as that leads to throwing missing clauses errors.+--        (mst, _, cc) <- compileClauses Nothing cs+        fun <- emptyFunctionData <&> \fun -> fun+                  { _funClauses    = cs+               --   , _funCompiled   = Just cc+               --   , _funSplitTree  = mst+                  , _funProjection = Left MaybeProjection+                  , _funMutual     = Just []+                  , _funTerminates = Just True+                  , _funIsKanOp    = Just d+                  }+        inTopContext $ do+         reportSDoc "tc.transpx.type" 15 $ vcat+           [ "type of" <+> prettyTCM trIx <+> ":"+           , nest 2 $ prettyTCM theType+           ]++         addConstant trIx $+          (defaultDefn defaultArgInfo trIx theType (Cubical CErased) $ FunctionDefn fun)+            { defNoCompilation  = True+            }++        -- reportSDoc "tc.data.proj.fun" 60 $ inTopContext $ vcat+        --   [ "proj" <+> prettyTCM i+        --   , nest 2 $ pretty fun+        --   ]+      -- addContext ctel $ do+      --   let es = teleElims ctel []+      --   r <- reduce $ Def trIx es+      --   reportSDoc "tc.data.ixs" 20 $ "reducedx:" <+> prettyTCM r+      --   r <- reduce $ Def trIx (init es ++ [Apply $ argN io, last es])+      --   reportSDoc "tc.data.ixs" 20 $ "reduced1:" <+> prettyTCM r+      return $ Just trIx+    _ -> __IMPOSSIBLE__+  where++    -- Γ, Δ^I, i : I |- sub (Γ ⊢ Δ) : Γ, Δ+    sub tel = expS $ size tel+++defineTranspFun :: QName -- ^ datatype+                -> Maybe QName -- ^ transpX "constructor"+                -> [QName]     -- ^ constructor names+                -> [QName]     -- ^ path cons+                -> TCM (Maybe QName) -- transp function for the datatype.+defineTranspFun d mtrX cons pathCons = do+  def <- getConstInfo d+  case theDef def of+    Datatype { dataPars = npars+             , dataIxs = nixs+             , dataSort = s@(Type _)+--             , dataCons = cons -- not there yet+             }+     -> do+      let t = defType def+      reportSDoc "tc.data.transp" 20 $ vcat+        [ "name :" <+> prettyTCM d+        , "type :" <+> prettyTCM t+        , "npars:" <+> pretty npars+        , "nixs :" <+> pretty nixs+        ]+      trD <- freshAbstractQName'_ $ "transp" ++ P.prettyShow (A.qnameName d)+      TelV params t' <- telViewUpTo npars t+      TelV ixs    dT <- telViewUpTo nixs t'++      let tel = abstract params ixs+      mixs <- runMaybeT $ traverse (traverse (MaybeT . toLType)) ixs+      caseMaybe mixs (return Nothing) $ \ _ -> do++      io@(Con io_c _ []) <- primIOne+      iz <- primIZero++      interval <- primIntervalType+      let telI = expTelescope interval tel+          sigma = sub tel+          dTs = (sigma `applySubst` El s (Def d $ map Apply $ teleArgs tel))++      theType <- (abstract telI <$>) $ runNamesT [] $ do+                  dT <- open $ Abs "i" $ dTs+                  nPi' "phi" primIntervalType $ \ phi ->+                   (absApp <$> dT <*> pure iz) --> (absApp <$> dT <*> pure io)+++      reportSDoc "tc.data.transp" 20 $ "transpD:" <+> prettyTCM theType+++      noMutualBlock $ do+        fun <- emptyFunction+        inTopContext $ addConstant trD $+          (defaultDefn defaultArgInfo trD theType (Cubical CErased) fun)+        let+          ctel = abstract telI $ ExtendTel (defaultDom $ subst 0 iz dTs) (Abs "t" EmptyTel)+          ps = telePatterns ctel empty+          cpi = noConPatternInfo { conPType = Just (defaultArg interval)+                                 , conPFallThrough = True+                                 }+          pat :: NamedArg (Pattern' DBPatVar)+          pat = defaultNamedArg $ ConP io_c cpi []+          clause = empty+            { clauseTel         = ctel+            , namedClausePats   = init ps ++ [pat, last ps]++            , clauseBody        = Just $ var 0+            , clauseType        = Just $ defaultArg $ raise 1 $ subst 0 io dTs+            , clauseRecursive   = Just False  -- non-recursive+            , clauseUnreachable = Just False+            }+        let debugNoTransp cl = enterClosure cl $ \ t -> do+              reportSDoc "tc.data.transp" 20 $ addContext ("i" :: String, __DUMMY_DOM__) $+                "could not transp" <+> prettyTCM (absBody t)+        -- TODO: if no params nor indexes trD phi u0 = u0.+        ecs <- tryTranspError $ (clause:) <$> defineConClause trD (not $ null pathCons) mtrX npars nixs ixs telI sigma dTs cons+        caseEitherM (pure ecs) (\ cl -> debugNoTransp cl >> return Nothing) $ \ cs -> do+        (mst, _, cc) <- compileClauses Nothing cs+        fun <- emptyFunctionData <&> \fun -> fun+                  { _funClauses    = cs+                  , _funCompiled   = Just cc+                  , _funSplitTree  = mst+                  , _funProjection = Left MaybeProjection+                  , _funMutual     = Just []+                  , _funTerminates = Just True+                  , _funIsKanOp    = Just d+                  }+        inTopContext $ addConstant trD $+          (defaultDefn defaultArgInfo trD theType (Cubical CErased) $ FunctionDefn fun)+            { defNoCompilation  = True+            }+        reportSDoc "tc.data.transp" 20 $ sep+          [ "transp: compiled clauses of " <+> prettyTCM trD+          , nest 2 $ return $ P.pretty cc+          ]++        return $ Just trD+++    Datatype {} -> return Nothing+    _           -> __IMPOSSIBLE__+  where+    -- Γ, Δ^I, i : I |- sub (Γ ⊢ Δ) : Γ, Δ+    sub tel = expS (size tel)++defineConClause :: QName -- ^ trD+                -> Bool  -- ^ HIT+                -> Maybe QName -- ^ trX+                -> Nat  -- ^ npars = size Δ+                -> Nat  -- ^ nixs = size X+                -> Telescope -- ^ Δ ⊢ X+                -> Telescope -- ^ (Δ.X)^I+                -> Substitution -- ^ (Δ.X)^I, i : I ⊢ σ : Δ.X+                -> Type       -- ^ (Δ.X)^I, i : I ⊢ D[δ i,x i] -- datatype+                -> [QName]      -- ^ Constructors+                -> TCM [Clause]+defineConClause trD' isHIT mtrX npars nixs xTel' telI sigma dT' cnames = do++  unless (isNothing mtrX == (nixs == 0)) $ __IMPOSSIBLE__++  io <- primIOne+  iz <- primIZero+  tHComp <- primHComp+  tINeg <- primINeg+  let max i j = cl primIMax <@> i <@> j+  let min i j = cl primIMin <@> i <@> j+  let neg i = cl primINeg <@> i+  let hcomp ty sys u0 = do+          ty <- ty+          LEl l ty <- fromMaybe __IMPOSSIBLE__ <$> toLType ty+          l <- open $ Level l+          ty <- open $ ty+          face <- (foldr max (pure iz) $ map fst $ sys)+          sys <- lam "i'" $ \ i -> combineSys l ty [(phi, u <@> i) | (phi,u) <- sys]+          pure tHComp <#> l <#> ty <#> pure face <@> pure sys <@> u0+  interval <- primIntervalType+  let intervalTel nm = ExtendTel (defaultDom interval) (Abs nm EmptyTel)++  let (parI,ixsI) = splitTelescopeAt npars telI+  let+    abstract_trD :: Monad m => (Vars m -> Vars m -> Vars m -> NamesT m Telescope) -> NamesT m Telescope+    abstract_trD k = do+               ixsI <- open $ AbsN (teleNames parI) ixsI+               parI <- open parI+               abstractN parI $ \ delta -> do+               abstractN (ixsI `applyN` delta) $ \ x -> do+               abstractN (pure $ intervalTel "phi") $ \ phi -> do+               k delta x phi+    bind_trD :: Monad m => (ArgVars m -> ArgVars m -> ArgVars m -> NamesT m b) ->+                NamesT m (AbsN (AbsN (AbsN b)))+    bind_trD k = do+      bindNArg (teleArgNames parI) $ \ delta_ps -> do+      bindNArg (teleArgNames ixsI) $ \ x_ps -> do+      bindNArg (teleArgNames $ intervalTel "phi") $ \ phi_ps -> do+      k delta_ps x_ps phi_ps+  let trD = bindNArg (teleArgNames parI) $ \ delta ->+            bindNArg (teleArgNames ixsI) $ \ x ->+            bindN ["phi","u0"]           $ \ [phi,u0] ->+              ((Def trD' [] `apply`) <$> sequence (delta ++ x)) <@> phi <@> u0+  -- [Δ] ⊢ X+  let xTel = pure $ AbsN (teleNames parI) xTel'+  -- [δ : Δ^I, x : X^I, i : I] ⊢ D (δ i) (x i)+  let dT = pure $ AbsN (teleNames parI ++ teleNames ixsI ++ ["i"]) dT'++  let hcompComputes = not $ isHIT || nixs > 0+  c_HComp <- if hcompComputes then return [] else do+      reportSDoc "tc.data.transp.con" 20 $ "======================="+      reportSDoc "tc.data.transp.con" 20 $ "hcomp"+      qHComp <- fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' builtinHComp+      hcomp_ty <- defType <$> getConstInfo qHComp+      gamma <- runNamesT [] $ do+               ixsI <- open $ AbsN (teleNames parI) ixsI+               parI <- open parI+               abstract_trD $ \ delta x _ -> do+               LEl l ty <- fromMaybe __IMPOSSIBLE__ <.> toLType =<< (dT `applyN` (delta ++ x ++ [pure iz]))+               -- (φ : I), (I → Partial φ (D (δ i0) (x i0))), D (δ i0) (x i0)+               TelV args _ <- lift $ telView =<< piApplyM hcomp_ty [Level l,ty]+               unless (size args == 3) __IMPOSSIBLE__+               pure args+      res <- runNamesT [] $ do+        let hcompArgs = map argN ["phi","u","u0"]+        bind_trD $ \ delta_ps x_ps phi_ps -> do+        let x = map (fmap unArg) x_ps+        let delta = map (fmap unArg) delta_ps+        let [phi] = map (fmap unArg) phi_ps+        bindNArg hcompArgs $ \ as0 -> do -- as0 : aTel[delta 0]+        let+          origPHComp = do+            LEl l t <- fromMaybe __IMPOSSIBLE__ <.> toLType =<< (dT `applyN` (delta ++ x ++ [pure iz]))+            let ds = map (argH . unnamed . dotP) [Level l, t]+            sequence as0 >>= \case+              ps0@[_hphi,_u,_u0] ->+                pure $ DefP defaultPatternInfo qHComp $ ds ++ ps0+              _ -> __IMPOSSIBLE__+          psHComp = sequence $ delta_ps ++ x_ps ++ phi_ps ++ [argN . unnamed <$> origPHComp]+        let+          rhsTy = dT `applyN` (delta ++ x ++ [pure io])+        -- trD δ x φ (hcomp [hφ ↦ u] u0) ↦ rhsHComp+        let rhsHComp = do+              let [hphi,u,u0] = map (fmap unArg) as0+              -- TODO: should trD be transp for the datatype?+              let baseHComp = trD `applyN` delta `applyN` x `applyN` [phi,u0]+              let sideHComp = lam "i" $ \ i -> ilam "o" $ \ o -> do+                     trD `applyN` delta `applyN` x `applyN` [phi,u <@> i <..> o]+              hcomp rhsTy [(hphi, sideHComp)] baseHComp+        (,,) <$> psHComp <*> rhsTy <*> rhsHComp+      let (ps,rhsTy,rhs) = unAbsN $ unAbsN $ unAbsN $ unAbsN $ res+      (:[]) <$> mkClause gamma ps rhsTy rhs+++  c_trX   <- caseMaybe mtrX (pure []) $ \ trX -> do+        reportSDoc "tc.data.transp.con" 20 $ "======================="+        reportSDoc "tc.data.transp.con" 20 $ prettyTCM trX+        gamma <- runNamesT [] $ do+                     ixsI <- open $ AbsN (teleNames parI) ixsI+                     parI <- open parI+                     abstract_trD $ \ delta _ _ -> do+                     let delta0_refl = for delta $ \ p -> lam "i" $ \ _ -> p <@> pure iz+                     abstractN (ixsI `applyN` delta0_refl) $ \ x' -> do+                     abstractN (pure $ intervalTel "phi'") $ \ _ -> do+                     ty <- dT `applyN` (delta0_refl ++ x' ++ [pure iz])+                     pure $ ExtendTel (defaultDom ty) $ Abs "t" EmptyTel+        res <- runNamesT [] $+          bind_trD $ \ delta_ps x_ps phi_ps -> do+          let x = map (fmap unArg) x_ps+          let delta = map (fmap unArg) delta_ps+          let [phi] = map (fmap unArg) phi_ps+          --- pattern matching args below+          bindNArg (map (fmap (++ "'")) (teleArgNames ixsI)) $ \ x'_ps -> do+          let x' = map (fmap unArg) x'_ps :: [NamesT TCM Term]+          let phi'name = teleArgNames $ intervalTel "phi'"+          bindNArg phi'name $ \ phi'_ps -> do+          let phi's = map (fmap unArg) phi'_ps+          bindNArg [argN "t"] $ \ as0 -> do+          let deltaArg i = do+                i <- i+                xs <- sequence delta_ps+                pure $ map (fmap (`apply` [argN i])) xs++          let+            origPTrX = do+              x'_ps <- sequence x'_ps+              phi'_ps <- sequence phi'_ps+              ds <- map (setHiding Hidden . fmap (unnamed . dotP)) <$> deltaArg (pure iz)+              ps0 <- sequence as0+              unless (length ps0 == 1) __IMPOSSIBLE__+              pure $ DefP defaultPatternInfo trX $ ds ++ x'_ps ++ phi'_ps ++ ps0+            psTrX = sequence $ delta_ps ++ x_ps ++ phi_ps ++ [argN . unnamed <$> origPTrX]++            rhsTy = dT `applyN` (delta ++ x ++ [pure io])++          -- trD δ x φ (trX x' φ' t) ↦ rhsTrx+          let rhsTrX = do+                let [t] = map (fmap unArg) as0+                let [phi'] = phi's+                let telXdeltai = bind "i" $ \ i -> applyN xTel (map (<@> i) delta)+                let reflx1 = for x $ \ q -> lam "i" $ \ _ -> q <@> pure io+                let symx' = for x' $ \ q' -> lam "i" $ \ i -> q' <@> neg i+                x_tr <- mapM (open . unArg) =<< transpPathTel' telXdeltai symx' reflx1 phi' x+                let baseTrX = trD `applyN` delta `applyN` x_tr `applyN` [phi `min` phi',t]+                let sideTrX = lam "j" $ \ j -> ilam "o" $ \ _ -> do+                      let trD_f = trD `applyN` for delta (\ p -> lam "i" $ \ i -> p <@> (i `min` neg j))+                                      `applyN` for x_tr (\ p -> lam "i" $ \ i -> p <@> (i `min` neg j))+                                      `applyN` [(phi `min` phi') `max` j,t]+                      let x_tr_f = fmap (fmap (\ (Abs n (Arg i t)) -> Arg i $ Lam defaultArgInfo (Abs n t)) . sequence) $+                           bind "i" $ \ i -> do+                            j <- j+                            map (fmap (`apply` [argN j])) <$> trFillPathTel' telXdeltai symx' reflx1 phi' x (neg i)+                      let args = liftM2 (++) (map (setHiding Hidden) <$> deltaArg (pure io)) x_tr_f+                      (apply (Def trX []) <$> args) <@> (phi' `max` neg j) <@> trD_f+                hcomp rhsTy [(phi,sideTrX),(phi',lam "i" $ \ _ -> ilam "o" $ \ _ -> baseTrX)]+                            baseTrX++          (,,) <$> psTrX <*> rhsTy <*> rhsTrX+++        let (ps,rhsTy,rhs) = unAbsN $ unAbsN $ unAbsN $ unAbsN $ unAbsN $ unAbsN $ res+        (:[]) <$> mkClause gamma ps rhsTy rhs++  fmap ((c_HComp ++ c_trX) ++) $ forM cnames $ \ cname -> do+    def <- getConstInfo cname+    let+      Constructor+       { conPars = npars'+       , conArity = nargs+       , conSrcCon = chead+       } = theDef def+    do+        let tcon = defType def++        reportSDoc "tc.data.transp.con" 20 $ "======================="+        reportSDoc "tc.data.transp.con" 20 $ "tcon:" <+> prettyTCM (conName chead) <+> prettyTCM tcon++        unless (conName chead == cname && npars' == npars) $ __IMPOSSIBLE__+++        TelV prm tcon' <- telViewUpTo npars' tcon+        -- Δ ⊢ aTel+        -- Δ.aTel ⊢ ty+        -- Δ.aTel ⊢ [(φ,(l,r))] = boundary : ty+        (TelV aTel ty, boundary) <- telViewUpToPathBoundary nargs tcon'++        Def _ es <- unEl <$> reduce ty+        -- Δ.aTel ⊢ con_ixs : X+        let con_ixs = fromMaybe __IMPOSSIBLE__ $ allApplyElims $ drop npars es++        reportSDoc "tc.data.transp.con" 20 $+          addContext prm $ "aTel:" <+> prettyTCM aTel+        reportSDoc "tc.data.transp.con" 20 $+          addContext prm $ addContext aTel $ "ty:" <+> prettyTCM ty+        reportSDoc "tc.data.transp.con" 20 $+          addContext prm $ addContext aTel $ "boundary:" <+> prettyTCM boundary++        gamma <- runNamesT [] $ do+                     ixsI <- open $ AbsN (teleNames parI) ixsI+                     aTel <- open $ AbsN (teleNames prm) aTel+                     parI <- open parI+                     abstract_trD $ \ delta _ _ -> do+                     let args = aTel `applyN` map (<@> pure iz) delta+                     args+        res <- runNamesT [] $ do+          let aTelNames = teleNames aTel+              aTelArgs = teleArgNames aTel+          con_ixs <- open $ AbsN (teleNames prm ++ teleNames aTel) $ map unArg con_ixs+          bndry <- open $ AbsN (teleNames prm ++ teleNames aTel) $ tmBoundary boundary+          u    <- open $ AbsN (teleNames prm ++ aTelNames) $ Con chead ConOSystem (teleElims aTel boundary)+          aTel <- open $ AbsN (teleNames prm) aTel+          -- bsys : Abs Δ.Args ([phi] → ty)+          (bsysFace,bsys) <- do+            p <- bindN (teleNames prm ++ aTelNames) $ \ ts -> do+              LEl l ty <- fromMaybe __IMPOSSIBLE__ <$> toLType ty+              l <- open (Level l)+              ty <- open ty+              bs <- bndry `applyN` ts+              xs <- mapM (\(phi,u) -> (,) <$> open phi <*> open u) $ do+                (i,(l,r)) <- theBoundary bs+                let pElem t = Lam defaultIrrelevantArgInfo $ NoAbs "o" t+                [(tINeg `apply` [argN i],pElem l),(i,pElem r)]+              combineSys' l ty xs+            (,) <$> open (fst <$> p) <*> open (snd <$> p)+          bind_trD $ \ delta_ps x_ps phi_ps -> do+          let x = map (fmap unArg) x_ps+          let delta = map (fmap unArg) delta_ps+          let [phi] = map (fmap unArg) phi_ps+          --- pattern matching args below+          bindNArg aTelArgs $ \ as0 -> do -- as0 : aTel[delta 0]++          let aTel0 = aTel `applyN` map (<@> pure iz) delta++          -- telePatterns is not context invariant, so we need an open here where the context ends in aTel0.+          ps0 <- (open =<<) $ (telePatterns <$> aTel0 <*> (varBoundary <$> applyN bndry (map (<@> pure iz) delta ++ map (fmap unArg) as0)))++          let deltaArg i = do+                i <- i+                xs <- sequence delta_ps+                pure $ map (fmap (`apply` [argN i])) xs++          let+            origP = ConP chead noConPatternInfo <$> ps0+            ps = sequence $ delta_ps ++ x_ps ++ phi_ps ++ [argN . unnamed <$> origP]+          let+            orig = patternToTerm <$> origP+            rhsTy = dT `applyN` (delta ++ x ++ [pure io])++          (,,) <$> ps <*> rhsTy <*> do++          -- Declared Constructors.+          let aTelI = bind "i" $ \ i -> aTel `applyN` map (<@> i) delta++          eas1 <- (=<<) (lift . runExceptT) $ transpTel <$> aTelI <*> phi <*> sequence as0++          caseEitherM (pure eas1) (lift . lift . E.throw . CannotTransp) $ \ as1 -> do++          as1 <- mapM (open . unArg) as1++          as01 <- (open =<<) $ bind "i" $ \ i -> do+            eas01 <- (=<<) (lift . runExceptT) $ trFillTel <$> aTelI <*> phi <*> sequence as0 <*> i+            caseEitherM (pure eas01) (lift . lift . E.throw . CannotTransp) pure++          let argApp a t = liftM2 (\ a t -> fmap (`apply` [argN t]) a) a t+          let+            argLam :: Monad m => String -> (Var m -> NamesT m (Arg Term)) -> NamesT m (Arg Term)+            argLam n f = (\ (Abs n (Arg i t)) -> Arg i $ Lam defaultArgInfo $ Abs n t) <$> bind "n" f+          let cas1 = applyN u $ map (<@> pure io) delta ++ as1++          let base | Nothing <- mtrX = cas1+                   | Just trX <- mtrX = do+                       let theTel = bind "j" $ \ j -> bind "i" $ \ i -> applyN xTel (map (<@> max i j) delta)+                       let theLeft = lamTel $ bind "i" $ \ i -> do+                             as01 <- mapM (open . unArg) =<< (absApp <$> as01 <*> i)+                             con_ixs `applyN` (map (<@> i) delta ++ as01)+                       theLeft <- mapM open =<< theLeft+                       theRight <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> do+                         con_ixs `applyN` (map (<@> pure io) delta ++ as1)++                       trx' <- transpPathPTel' theTel x theRight phi theLeft+                       let args = liftM2 (++) (map (setHiding Hidden) <$> deltaArg (pure io)) (forM trx' $ \ q' -> do+                                                                       q' <- open q'+                                                                       argLam "i" $ \ i -> q' `argApp` neg i)+                       (apply (Def trX []) <$> args) <@> phi <@> cas1+++          if null boundary then base else do++          -- We have to correct the boundary for path constructors.++          -- bline : Abs I ([phi] → ty)+          let blineFace = applyN bsysFace $ map (<@> pure io) delta ++ as1+          let bline = do+                let theTel = bind "j" $ \ j -> bind "i" $ \ i -> applyN xTel (map (<@> max i j) delta)+                let theLeft = lamTel $ bind "i" $ \ i -> do+                      as01 <- mapM (open . unArg) =<< (absApp <$> as01 <*> i)+                      con_ixs `applyN` (map (<@> i) delta ++ as01)+                theLeft <- mapM open =<< theLeft+                theRight <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> do+                  con_ixs `applyN` (map (<@> pure io) delta ++ as1)+                let q2_f = bind "i" $ \ i -> map unArg <$> trFillPathPTel' theTel x theRight phi theLeft i++                lam "i" $ \ i -> do+                let v0 = do+                     as01 <- mapM (open . unArg) =<< (absApp <$> as01 <*> i)+                     applyN bsys $ map (<@> i) delta ++ as01+                let squeezedv0 = ilam "o" $ \ o -> do+                      let+                        delta_f :: [NamesT TCM Term]+                        delta_f = for delta $ \ p -> lam "j" $ \ j -> p <@> (j `max` i)+                      x_f <- (mapM open =<<) $ lamTel $ bind "j" $ \ j ->+                                 (absApp <$> q2_f <*> j) `appTel` i+                      trD `applyN` delta_f `applyN` x_f `applyN` [phi `max` i, v0 <..> o]++                caseMaybe mtrX squeezedv0 $ \ trX -> ilam "o" $ \ o -> do+                  q2 <- transpPathPTel' theTel x theRight phi theLeft+                  let args = liftM2 (++) (map (setHiding Hidden) <$> deltaArg (pure io))+                                         (forM q2 $ \ q' -> do+                                            q' <- open q'+                                            argLam "j" $ \ j -> q' `argApp` (neg j `min` i))++                  (apply (Def trX []) <$> args) <@> (neg i `max` phi) <@> (squeezedv0 <..> o)+          hcomp+             rhsTy+             [(blineFace,lam "i" $ \ i -> bline <@> (neg i))+             ,(phi      ,lam "i" $ \ _ -> ilam "o" $ \ _ -> orig)+             ]+             base++        let+          (ps,rhsTy,rhs) = unAbsN $ unAbsN $ unAbsN $ unAbsN $ res+        mkClause gamma ps rhsTy rhs+  where+    mkClause gamma ps rhsTy rhs = do+      let+        c = Clause+            { clauseTel         = gamma+            , clauseType        = Just . argN $ rhsTy+            , namedClausePats   = ps+            , clauseFullRange   = noRange+            , clauseLHSRange    = noRange+            , clauseCatchall    = empty+            , clauseBody        = Just $ rhs+            , clauseRecursive   = Nothing+            -- it is indirectly recursive through transp, does it count?+            , clauseUnreachable = Just False+            , clauseEllipsis    = NoEllipsis+            , clauseWhereModule = Nothing+            }+      reportSDoc "tc.data.transp.con" 20 $+        "gamma:" <+> prettyTCM gamma+      reportSDoc "tc.data.transp.con" 20 $ addContext gamma $+        "ps   :" <+> prettyTCM (patternsToElims ps)+      reportSDoc "tc.data.transp.con" 20 $ addContext gamma $+        "type :" <+> prettyTCM rhsTy+      reportSDoc "tc.data.transp.con" 20 $ addContext gamma $+        "body :" <+> prettyTCM rhs++      reportSDoc "tc.data.transp.con" 30 $+        addContext gamma $ "c:" <+> pretty c+      return c+++defineKanOperationForFields+  :: Command+  -> (Maybe Term)            -- ^ PathCons, Δ.Φ ⊢ u : R δ+  -> (Term -> QName -> Term) -- ^ how to apply a "projection" to a term+  -> QName       -- ^ some name, e.g. record name+  -> Telescope   -- ^ param types Δ+  -> Telescope   -- ^ fields' types Δ ⊢ Φ+  -> [Arg QName] -- ^ fields' names+  -> Type        -- ^ record type Δ ⊢ T+  -> TCM (Maybe ((QName, Telescope, Type, [Dom Type], [Term]), Substitution))+defineKanOperationForFields cmd pathCons project name params fsT fns rect =+   case cmd of+       DoTransp -> runMaybeT $ do+         fsT' <- traverse (traverse (MaybeT . toCType)) fsT+         lift $ defineTranspForFields pathCons project name params fsT' fns rect+       DoHComp -> runMaybeT $ do+         fsT' <- traverse (traverse (MaybeT . toLType)) fsT+         rect' <- MaybeT $ toLType rect+         lift $ defineHCompForFields project name params fsT' fns rect'+++-- invariant: resulting tel Γ is such that Γ = ... , (φ : I), (a0 : ...)+--            where a0 has type matching the arguments of primTrans.+defineTranspForFields+  :: (Maybe Term)            -- ^ PathCons, Δ.Φ ⊢ u : R δ+  -> (Term -> QName -> Term) -- ^ how to apply a "projection" to a term+  -> QName       -- ^ some name, e.g. record name+  -> Telescope   -- ^ param types Δ+  -> Tele (Dom CType)   -- ^ fields' types Δ ⊢ Φ+  -> [Arg QName] -- ^ fields' names+  -> Type        -- ^ record type Δ ⊢ T+  -> TCM ((QName, Telescope, Type, [Dom Type], [Term]), Substitution)+     -- ^ @((name, tel, rtype, clause_types, bodies), sigma)@+     --   name: name of transport function for this constructor/record. clauses still missing.+     --   tel: Ξ telescope for the RHS, Ξ ⊃ (Δ^I, φ : I), also Ξ ⊢ us0 : Φ[δ 0]+     --   rtype: Ξ ⊢ T' := T[δ 1]+     --   clause_types: Ξ ⊢ Φ' := Φ[δ 1]+     --   bodies: Ξ ⊢ us1 : Φ'+     --   sigma:  Ξ, i : I ⊢ σ : Δ.Φ -- line [δ 0,us0] ≡ [δ 0,us1]+defineTranspForFields pathCons applyProj name params fsT fns rect = do+  interval <- primIntervalType+  let deltaI = expTelescope interval params+  iz <- primIZero+  io <- primIOne+  imin <- getPrimitiveTerm builtinIMin+  imax <- getPrimitiveTerm builtinIMax+  ineg <- getPrimitiveTerm builtinINeg+  transp <- getPrimitiveTerm builtinTrans+  -- por <- getPrimitiveTerm "primPOr"+  -- one <- primItIsOne+  reportSDoc "trans.rec" 20 $ pretty params+  reportSDoc "trans.rec" 20 $ pretty deltaI+  reportSDoc "trans.rec" 10 $ pretty fsT++  let thePrefix = "transp-"+  theName <- freshAbstractQName'_ $ thePrefix ++ P.prettyShow (A.qnameName name)++  reportSLn "trans.rec" 5 $ ("Generated name: " ++ show theName ++ " " ++ showQNameId theName)++  theType <- (abstract deltaI <$>) $ runNamesT [] $ do+              rect' <- open (runNames [] $ bind "i" $ \ x -> let _ = x `asTypeOf` pure (undefined :: Term) in+                                                             pure rect')+              nPi' "phi" primIntervalType $ \ phi ->+               (absApp <$> rect' <*> pure iz) --> (absApp <$> rect' <*> pure io)++  reportSDoc "trans.rec" 20 $ prettyTCM theType+  reportSDoc "trans.rec" 60 $ text $ "sort = " ++ show (getSort rect')++  lang <- getLanguage+  fun  <- emptyFunctionData+  noMutualBlock $ addConstant theName $+    (defaultDefn defaultArgInfo theName theType lang+       (FunctionDefn fun{ _funTerminates = Just True+                        , _funIsKanOp    = Just name+                        }))+      { defNoCompilation = True }+  -- ⊢ Γ = gamma = (δ : Δ^I) (φ : I) (u0 : R (δ i0))+  -- Γ ⊢     rtype = R (δ i1)+  TelV gamma rtype <- telView theType+++  let+      -- (γ : Γ) ⊢ transpR γ : rtype+      theTerm = Def theName [] `apply` teleArgs gamma++      -- (γ : Γ) ⊢ (flatten Φ[δ i1])[n ↦ f_n (transpR γ)]+      clause_types = parallelS [theTerm `applyProj` (unArg fn)+                               | fn <- reverse fns] `applySubst`+                       flattenTel (singletonS 0 io `applySubst` fsT') -- Γ, Φ[δ i1] ⊢ flatten Φ[δ i1]++      -- Γ, i : I ⊢ [δ i] : Δ+      delta_i = (liftS 1 (raiseS (size gamma - size deltaI)) `composeS` sub params) -- Defined but not used++      -- Γ, i : I ⊢ Φ[δ i]+      fsT' = (liftS 1 (raiseS (size gamma - size deltaI)) `composeS` sub params)  `applySubst`+               fsT -- Δ ⊢ Φ+      lam_i = Lam defaultArgInfo . Abs "i"++++      -- (δ , φ , u0) : Γ ⊢ φ : I+      -- the_phi = var 1+      -- -- (δ , φ , u0) : Γ ⊢ u0 : R (δ i0)+      -- the_u0  = var 0++      -- Γ' = (δ : Δ^I, φ : I)+      gamma' = telFromList $ take (size gamma - 1) $ telToList gamma++      -- δ : Δ^I, φ : F ⊢ [δ 0] : Δ+      d0 :: Substitution+      d0 = wkS 1 -- Δ^I, φ : F ⊢ Δ+                       (consS iz IdS `composeS` sub params) -- Δ^I ⊢ Δ+                                 -- Δ^I , i:I ⊢ sub params : Δ++      -- Ξ , Ξ ⊢ θ : Γ, Ξ ⊢ φ, Ξ ⊢ u : R (δ i0), Ξ ⊢ us : Φ[δ i0]+      (tel,theta,the_phi,the_u0, the_fields) =+        case pathCons of+          -- (δ : Δ).Φ ⊢ u : R δ+          Just u -> (abstract gamma' (d0 `applySubst` fmap (fmap fromCType) fsT) -- Ξ = δ : Δ^I, φ : F, _ : Φ[δ i0]+                    , (liftS (size fsT) d0 `applySubst` u) `consS` raiseS (size fsT)+                    , raise (size fsT) (var 0)+                    , (liftS (size fsT) d0 `applySubst` u)+                    , drop (size gamma') $ map unArg $ teleArgs tel)+          Nothing -> (gamma, IdS, var 1, var 0, map (\ fname -> var 0 `applyProj` unArg fname) fns )++      fsT_tel = (liftS 1 (raiseS (size tel - size deltaI)) `composeS` sub params) `applySubst` fsT++      iMin x y = imin `apply` [argN x, argN y]+      iMax x y = imax `apply` [argN x, argN y]+      iNeg x = ineg `apply` [argN x]++      -- .. ⊢ field : filled_ty' i0+      mkBody (field, filled_ty') = do+        let+          filled_ty = lam_i $ (unEl . fromCType . unDom) filled_ty'+          -- Γ ⊢ l : I -> Level of filled_ty+        -- sort <- reduce $ getSort $ unDom filled_ty'+        case unDom filled_ty' of+          LType (LEl l _) -> do+            let lvl = lam_i $ Level l+            return $ runNames [] $ do+             lvl <- open lvl+             phi <- open the_phi+             field <- open field+             pure transp <#> lvl <@> pure filled_ty+                                 <@> phi+                                 <@> field+          -- interval arg+          ClosedType{}  ->+            return $ runNames [] $ do+              field <- open field+              field+  let+        -- ' Ξ , i : I ⊢ τ = [(\ j → δ (i ∧ j)), φ ∨ ~ i, u] : Ξ+        tau = parallelS $ us ++ (phi `iMax` iNeg (var 0))+                        : map (\ d -> Lam defaultArgInfo $ Abs "i" $ raise 1 d `apply` [argN $ (iMin (var 0) (var 1))]) ds+         where+          -- Ξ, i : I+          (us, phi:ds) = splitAt (size tel - size gamma') $ reverse (raise 1 (map unArg (teleArgs tel)))++  let+    go acc [] = return []+    go acc ((fname,field_ty) : ps) = do+      -- Ξ, i : I, Φ[δ i]|_f ⊢ Φ_f = field_ty+      -- Ξ ⊢ b : field_ty [i := i1][acc]+      -- Ξ ⊢ parallesS acc : Φ[δ i1]|_f+      -- Ξ , i : I ⊢ τ = [(\ j → δ (i ∨ j), φ ∨ ~ i, us] : Ξ+      -- Ξ , i : I ⊢ parallesS (acc[τ]) : Φ[δ i1]|_f+      -- Ξ, i : I ⊢ field_ty [parallesS (acc[τ])]+      let+        filled_ty = parallelS (tau `applySubst` acc) `applySubst` field_ty+      b <- mkBody (fname,filled_ty)+      bs <- go (b : acc) ps+      return $ b : bs++  bodys <- go [] (zip the_fields (map (fmap snd) $ telToList fsT_tel)) -- ∀ f.  Ξ, i : I, Φ[δ i]|_f ⊢ Φ[δ i]_f+  let+    -- Ξ, i : I ⊢ ... : Δ.Φ+    theSubst = reverse (tau `applySubst` bodys) ++# (liftS 1 (raiseS (size tel - size deltaI)) `composeS` sub params)+  return $ ((theName, tel, theta `applySubst` rtype, map (fmap fromCType) clause_types, bodys), theSubst)+  where+    -- record type in 'exponentiated' context+    -- (params : Δ^I), i : I |- T[params i]+    rect' = sub params `applySubst` rect+    -- Δ^I, i : I |- sub Δ : Δ+    sub tel = expS $ size tel++-- invariant: resulting tel Γ is such that Γ = (δ : Δ), (φ : I), (u : ...), (a0 : R δ))+--            where u and a0 have types matching the arguments of primHComp.+defineHCompForFields+  :: (Term -> QName -> Term) -- ^ how to apply a "projection" to a term+  -> QName       -- ^ some name, e.g. record name+  -> Telescope   -- ^ param types Δ+  -> Tele (Dom LType)   -- ^ fields' types Δ ⊢ Φ+  -> [Arg QName] -- ^ fields' names+  -> LType        -- ^ record type (δ : Δ) ⊢ R[δ]+  -> TCM ((QName, Telescope, Type, [Dom Type], [Term]),Substitution)+defineHCompForFields applyProj name params fsT fns rect = do+  interval <- primIntervalType+  let delta = params+  iz <- primIZero+  io <- primIOne+  imin <- getPrimitiveTerm builtinIMin+  imax <- getPrimitiveTerm builtinIMax+  tIMax <- getPrimitiveTerm builtinIMax+  ineg <- getPrimitiveTerm builtinINeg+  hcomp <- getPrimitiveTerm builtinHComp+  transp <- getPrimitiveTerm builtinTrans+  por <- getPrimitiveTerm builtinPOr+  one <- primItIsOne+  reportSDoc "comp.rec" 20 $ text $ show params+  reportSDoc "comp.rec" 20 $ text $ show delta+  reportSDoc "comp.rec" 10 $ text $ show fsT++  let thePrefix = "hcomp-"+  theName <- freshAbstractQName'_ $ thePrefix ++ P.prettyShow (A.qnameName name)++  reportSLn "hcomp.rec" 5 $ ("Generated name: " ++ show theName ++ " " ++ showQNameId theName)++  theType <- (abstract delta <$>) $ runNamesT [] $ do+              rect <- open $ fromLType rect+              nPi' "phi" primIntervalType $ \ phi ->+               nPi' "i" primIntervalType (\ i ->+                pPi' "o" phi $ \ _ -> rect) -->+               rect --> rect++  reportSDoc "hcomp.rec" 20 $ prettyTCM theType+  reportSDoc "hcomp.rec" 60 $ text $ "sort = " ++ show (lTypeLevel rect)++  lang <- getLanguage+  fun  <- emptyFunctionData+  noMutualBlock $ addConstant theName $+    (defaultDefn defaultArgInfo theName theType lang+       (FunctionDefn fun{ _funTerminates = Just True+                        , _funIsKanOp    = Just name+                        }))+      { defNoCompilation = True }+  --   ⊢ Γ = gamma = (δ : Δ) (φ : I) (_ : (i : I) -> Partial φ (R δ)) (_ : R δ)+  -- Γ ⊢     rtype = R δ+  TelV gamma rtype <- telView theType++  let -- Γ ⊢ R δ+      drect_gamma = raiseS (size gamma - size delta) `applySubst` rect++  reportSDoc "hcomp.rec" 60 $ text $ "sort = " ++ show (lTypeLevel drect_gamma)++  let++      -- (γ : Γ) ⊢ hcompR γ : rtype+      compTerm = Def theName [] `apply` teleArgs gamma++      -- (δ, φ, u, u0) : Γ ⊢ φ : I+      the_phi = var 2+      -- (δ, φ, u, u0) : Γ ⊢ u : (i : I) → [φ] → R (δ i)+      the_u   = var 1+      -- (δ, φ, u, u0) : Γ ⊢ u0 : R (δ i0)+      the_u0  = var 0++      -- ' (δ, φ, u, u0) : Γ ⊢ fillR Γ : (i : I) → rtype[ δ ↦ (\ j → δ (i ∧ j))]+      fillTerm = runNames [] $ do+        rect   <- open . unEl  . fromLType  $ drect_gamma+        lvl    <- open . Level . lTypeLevel $ drect_gamma+        params <- mapM open $ take (size delta) $ teleArgs gamma+        phi    <- open the_phi+        w      <- open the_u+        w0     <- open the_u0+        -- (δ : Δ, φ : I, w : .., w0 : R δ) ⊢+        -- ' fillR Γ = λ i → hcompR δ (φ ∨ ~ i) (\ j → [ φ ↦ w (i ∧ j) , ~ i ↦ w0 ]) w0+        --           = hfillR δ φ w w0+        lam "i" $ \ i -> do+          args <- sequence params+          psi  <- pure imax <@> phi <@> (pure ineg <@> i)+          u <- lam "j" (\ j -> pure por <#> lvl+                                        <@> phi+                                        <@> (pure ineg <@> i)+                                        <#> lam "_" (\ o -> rect)+                                        <@> (w <@> (pure imin <@> i <@> j))+                                        <@> lam "_" (\ o -> w0) -- TODO wait for i = 0+                       )+          u0 <- w0+          pure $ Def theName [] `apply` (args ++ [argN psi, argN u, argN u0])++      -- (γ : Γ) ⊢ (flatten Φ)[n ↦ f_n (compR γ)]+      clause_types = parallelS [compTerm `applyProj` (unArg fn)+                               | fn <- reverse fns] `applySubst`+                       flattenTel (raiseS (size gamma - size delta) `applySubst` fsT) -- Γ, Φ ⊢ flatten Φ+      -- Δ ⊢ Φ = fsT+      -- Γ, i : I ⊢ Φ'+      fsT' = raiseS ((size gamma - size delta) + 1) `applySubst` fsT++      -- Γ, i : I ⊢ (flatten Φ')[n ↦ f_n (fillR Γ i)]+      filled_types = parallelS [raise 1 fillTerm `apply` [argN $ var 0] `applyProj` (unArg fn)+                               | fn <- reverse fns] `applySubst`+                       flattenTel fsT' -- Γ, i : I, Φ' ⊢ flatten Φ'+++  comp <- do+        let+          imax i j = pure tIMax <@> i <@> j+        let forward la bA r u = pure transp <#> lam "i" (\ i -> la <@> (i `imax` r))+                                            <@> lam "i" (\ i -> bA <@> (i `imax` r))+                                            <@> r+                                            <@> u+        return $ \ la bA phi u u0 ->+          pure hcomp <#> (la <@> pure io) <#> (bA <@> pure io) <#> phi+                      <@> lam "i" (\ i -> ilam "o" $ \ o ->+                              forward la bA i (u <@> i <..> o))+                      <@> forward la bA (pure iz) u0+  let+      mkBody (fname, filled_ty') = do+        let+          proj t = (`applyProj` unArg fname) <$> t+          filled_ty = Lam defaultArgInfo (Abs "i" $ (unEl . fromLType . unDom) filled_ty')+          -- Γ ⊢ l : I -> Level of filled_ty+        l <- reduce $ lTypeLevel $ unDom filled_ty'+        let lvl = Lam defaultArgInfo (Abs "i" $ Level l)+        return $ runNames [] $ do+             lvl       <- open lvl+             phi       <- open the_phi+             w         <- open the_u+             w0        <- open the_u0+             filled_ty <- open filled_ty++             comp lvl+                  filled_ty+                  phi+                  (lam "i" $ \ i -> ilam "o" $ \ o -> proj $ w <@> i <..> o) -- TODO wait for phi = 1+                  (proj w0)++  reportSDoc "hcomp.rec" 60 $ text $ "filled_types sorts:" ++ show (map (getSort . fromLType . unDom) filled_types)++  bodys <- mapM mkBody (zip fns filled_types)+  return $ ((theName, gamma, rtype, map (fmap fromLType) clause_types, bodys),IdS)+++getGeneralizedParameters :: Set Name -> QName -> TCM [Maybe Name]+getGeneralizedParameters gpars name | Set.null gpars = return []+getGeneralizedParameters gpars name = do+  -- Drop the named parameters that shouldn't be in scope (if the user+  -- wrote a split data type)+  let inscope x = x <$ guard (Set.member x gpars)+  map (>>= inscope) . defGeneralizedParams <$> (instantiateDef =<< getConstInfo name)++-- | Bind the named generalized parameters.+bindGeneralizedParameters :: [Maybe Name] -> Type -> (Telescope -> Type -> TCM a) -> TCM a+bindGeneralizedParameters [] t ret = ret EmptyTel t+bindGeneralizedParameters (name : names) t ret =+  case unEl t of+    Pi a b -> ext $ bindGeneralizedParameters names (unAbs b) $ \ tel t -> ret (ExtendTel a (tel <$ b)) t+      where+        ext | Just x <- name = addContext (x, a)+            | otherwise      = addContext (absName b, a)+    _      -> __IMPOSSIBLE__++-- | Bind the parameters of a datatype.+--+--   We allow omission of hidden parameters at the definition site.+--   Example:+--   @+--     data D {a} (A : Set a) : Set a+--     data D A where+--       c : A -> D A+--   @++bindParameters+  :: Int            -- ^ Number of parameters+  -> [A.LamBinding] -- ^ Bindings from definition site.+  -> Type           -- ^ Pi-type of bindings coming from signature site.+  -> (Telescope -> Type -> TCM a)+     -- ^ Continuation, accepting parameter telescope and rest of type.+     --   The parameters are part of the context when the continutation is invoked.+  -> TCM a++bindParameters 0 [] a ret = ret EmptyTel a++bindParameters 0 (par : _) _ _ = setCurrentRange par $+  typeError $ UnexpectedParameter par++bindParameters npars [] t ret =+  case unEl t of+    Pi a b | not (visible a) -> do+              x <- freshName_ (absName b)+              bindParameter npars [] x a b ret+           | otherwise ->+              typeError $ ExpectedBindingForParameter a b+    _ -> __IMPOSSIBLE__++bindParameters npars par@(A.DomainFull (A.TBind _ _ xs e) : bs) a ret =+  setCurrentRange par $+  typeError $ UnexpectedTypeSignatureForParameter xs++bindParameters _ (A.DomainFull A.TLet{} : _) _ _ = __IMPOSSIBLE__++bindParameters _ (par@(A.DomainFree _ arg) : ps) _ _+  | getModality arg /= defaultModality = setCurrentRange par $+      typeError $ UnexpectedModalityAnnotationInParameter par++bindParameters npars ps0@(par@(A.DomainFree _ arg) : ps) t ret = do+  let x          = namedArg arg+      TelV tel _ = telView' t+  case insertImplicit arg $ telToList tel of+    NoInsertNeeded -> continue ps $ A.unBind $ A.binderName x+    ImpInsert _    -> continue ps0 =<< freshName_ (absName b)+    BadImplicits   -> setCurrentRange par $+      typeError $ UnexpectedParameter par+    NoSuchName x   -> setCurrentRange par $+      typeError $ NoParameterOfName x+  where+    Pi dom@(Dom{domInfo = info', unDom = a}) b = unEl t -- TODO:: Defined but not used: info', a+    continue ps x = bindParameter npars ps x dom b ret++bindParameter :: Int -> [A.LamBinding] -> Name -> Dom Type -> Abs Type -> (Telescope -> Type -> TCM a) -> TCM a+bindParameter npars ps x a b ret =+  addContext (x, a) $+    bindParameters (npars - 1) ps (absBody b) $ \ tel s ->+      ret (ExtendTel a $ Abs (nameToArgName x) tel) s++-- | Check that the arguments to a constructor fits inside the sort of the datatype.+--   The third argument is the type of the constructor.+--+--   When @--without-K@ is active and the type is fibrant the+--   procedure also checks that the type is usable at the current+--   modality. See #4784 and #5434.+--+--   As a side effect, return the arity of the constructor.++fitsIn :: DataOrRecord_ -> QName -> UniverseCheck -> [IsForced] -> Type -> Sort -> TCM Int+fitsIn dataOrRecord con uc forceds conT s = do+  reportSDoc "tc.data.fits" 10 $+    sep [ "does" <+> prettyTCM conT+        , "of sort" <+> prettyTCM (getSort conT)+        , "fit in" <+> prettyTCM s <+> "?"+        ]+  -- The code below would be simpler, but doesn't allow datatypes+  -- to be indexed by the universe level.+  -- s' <- instantiateFull (getSort t)+  -- noConstraints $ s' `leqSort` s++  whenM withoutKOption $ do+    q <- viewTC eQuantity+    -- Don't want to check polarities for the constructor's type,+    -- only for its argument telescope!+    applyPolarityToContext (withStandardLock UnusedPolarity) $+      usableAtModality' (Just s) ConstructorType (setQuantity q unitModality) (unEl conT)++  li <- optLargeIndices <$> pragmaOptions+  -- To allow propositional squash in data constructors, we turn @Prop ℓ@ into @Set ℓ@+  -- for the purpose of checking the sort of the constructor.+  -- This would be invalid for record constructors as we could unsquash+  -- by projecting out the squashed data.+  fitsIn' li forceds conT s $ applyWhen (dataOrRecord == IsData) propToType s+  where+  fitsIn' ::+       Bool        -- Are large indices allowed?+    -> [IsForced]  -- Which constructor arguments are forced?+    -> Type        -- Type of the constructor.+    -> Sort        -- Original sort of the data or record type.+    -> Sort        -- For @data@, prop-to-type converted sort.+    -> TCM Int     -- Constructor arity computed from the type.+  fitsIn' li forceds t s0 s = do+    vt <- do+      t <- pathViewAsPi t+      return $ case t of+                    Left (a,b)     -> Just (True ,a,b)+                    Right (El _ t) | Pi a b <- t+                                   -> Just (False,a,b)+                    _              -> Nothing+    case vt of+      Just (isPath, dom, b) -> do+        polarity <- optPolarity <$> pragmaOptions+        -- When the --polarity option is enabled, the type of+        -- every constructor argument is re-checked using the internal+        -- type checker, to ensure that their usage of datatype parameters is+        -- consistent with polarity annotations (of the parameters).+        -- This may impact type checking performance, as the internal checker+        -- does more work than just checking polarity.+        -- A simpler check dedicated to polarity could be implemented,+        -- but would likely lead to duplicated logic.+        -- For further discussion on why this check is necessary, see:+        -- https://github.com/agda/agda/pull/6385#issuecomment-1349672456+        when polarity $ do+          arg <- instantiateFull (unEl (unDom dom))+          reportSDoc "tc.polarity" 40 $+            sep [ "checking constructor domain"+                , prettyTCM (unEl $ unDom dom)+                , "("+                , prettyTCM (show arg)+                , ")"+                , "against sort"+                , prettyTCM (getSort dom)+                ]+          checkInternal arg CmpLeq (sort (getSort dom))+        let+          (forced, forceds') = nextIsForced forceds+          isf = isForced forced++        unless (isf && li) $ do+          sa <- reduce $ getSort dom+          unless (isPath || uc == NoUniverseCheck || sa == SizeUniv) $+            traceCall (CheckConArgFitsIn con isf (unDom dom) s) $+            fitSort sa s0 s++        addContext (absName b, dom) $ do+          succ <$> fitsIn' li forceds' (absBody b) (raise 1 s0) (raise 1 s)+      _ -> do+        fitSort (getSort t) s0 s+        return 0+  -- catch hard error from sort comparison to turn it into a soft error+  fitSort sa s0 s = leqSort sa s `catchError` \ err ->+    warning $ ConstructorDoesNotFitInData dataOrRecord con sa s0 err  -- | When --without-K is enabled, we should check that the sorts of --   the index types fit into the sort of the datatype.
+ src/full/Agda/TypeChecking/Rules/Data.hs-boot view
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -Wunused-imports #-}++module Agda.TypeChecking.Rules.Data where++import Agda.Syntax.Internal         ( QName, Sort )+import Agda.TypeChecking.Monad.Base ( TCM )++checkDataSort :: QName -> Sort -> TCM ()
src/full/Agda/TypeChecking/Rules/Decl.hs view
@@ -1,16 +1,16 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ {-# LANGUAGE NondecreasingIndentation #-}  module Agda.TypeChecking.Rules.Decl where  import Prelude hiding ( null ) -import Control.Monad import Control.Monad.Writer (tell)  import Data.Either (partitionEithers) import qualified Data.Foldable as Fold-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet+import qualified Data.Map.Strict as MapS import Data.Maybe import qualified Data.Set as Set import Data.Set (Set)@@ -24,6 +24,8 @@ import qualified Agda.Syntax.Info as Info import Agda.Syntax.Position import Agda.Syntax.Common+import Agda.Syntax.Common.Pretty (prettyShow)+import Agda.Syntax.Concrete (pattern NoWhere_) import Agda.Syntax.Literal import Agda.Syntax.Scope.Base ( KindOfName(..) ) @@ -36,7 +38,7 @@ import Agda.TypeChecking.IApplyConfluence import Agda.TypeChecking.Generalize import Agda.TypeChecking.Injectivity-import Agda.TypeChecking.Irrelevance+import Agda.TypeChecking.InstanceArguments import Agda.TypeChecking.Level.Solve import Agda.TypeChecking.Positivity import Agda.TypeChecking.Positivity.Occurrence@@ -64,14 +66,17 @@  import Agda.Termination.TermCheck +import Agda.Utils.Function ( applyUnless, applyWhen ) import Agda.Utils.Functor import Agda.Utils.Lens+import Agda.Utils.List1 ( pattern (:|) )+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Pretty (prettyShow) import Agda.Utils.Size import Agda.Utils.Update+import qualified Agda.Syntax.Common.Pretty as P import qualified Agda.Utils.SmallSet as SmallSet  import Agda.Utils.Impossible@@ -79,14 +84,16 @@ -- | Cached checkDecl checkDeclCached :: A.Declaration -> TCM () checkDeclCached d@A.ScopedDecl{} = checkDecl d-checkDeclCached d@(A.Section _ mname (A.GeneralizeTel _ tbinds) _) = do+checkDeclCached+  d@(A.Section _ erased mname (A.GeneralizeTel _ tbinds) _) = do   e <- readFromCachedLog  -- Can ignore the set of generalizable vars (they occur in the telescope)   reportSLn "cache.decl" 10 $ "checkDeclCached: " ++ show (isJust e)   case e of-    Just (EnterSection mname' tbinds', _)-      | mname == mname' && tbinds == tbinds' -> return ()+    Just (EnterSection erased' mname' tbinds', _)+      | erased == erased' && mname == mname' && tbinds == tbinds' ->+        return ()     _ -> cleanCachedLog-  writeToCurrentLog $ EnterSection mname tbinds+  writeToCurrentLog $ EnterSection erased mname tbinds   checkDecl d   readFromCachedLog >>= \case     Just (LeaveSection mname', _) | mname == mname' -> return ()@@ -149,16 +156,16 @@       A.Field{}                -> typeError FieldOutsideRecord       A.Primitive i x e        -> meta $ checkPrimitive i x e       A.Mutual i ds            -> mutual i ds $ checkMutual i ds-      A.Section _r x tel ds    -> meta $ checkSection x tel ds-      A.Apply i x modapp ci _adir -> meta $ checkSectionApplication i x modapp ci-      A.Import i x _adir       -> none $ checkImport i x+      A.Section _r er x tel ds -> meta $ checkSection er x tel ds+      A.Apply i er x mapp ci d -> meta $ checkSectionApplication i er x mapp ci d+      A.Import _ _ dir         -> none $ checkImportDirective dir       A.Pragma i p             -> none $ checkPragma i p       A.ScopedDecl scope ds    -> none $ setScope scope >> mapM_ checkDeclCached ds-      A.FunDef i x delayed cs  -> impossible $ check x i $ checkFunDef delayed i x cs+      A.FunDef i x cs          -> impossible $ check x i $ checkFunDef i x cs       A.DataDef i x uc ps cs   -> impossible $ check x i $ checkDataDef i x uc ps cs       A.RecDef i x uc dir ps tel cs -> impossible $ check x i $ do                                     checkRecDef i x uc dir ps tel cs-                                    blockId <- mutualBlockOf x+                                    blockId <- defMutual <$> getConstInfo x                                      -- Andreas, 2016-10-01 testing whether                                     -- envMutualBlock is set correctly.@@ -173,8 +180,8 @@                                           ]                                      return (blockId, Set.singleton x)-      A.DataSig i x ps t       -> impossible $ checkSig DataName i x ps t-      A.RecSig i x ps t        -> none $ checkSig RecName i x ps t+      A.DataSig i er x ps t    -> impossible $ checkSig DataName i er x ps t+      A.RecSig i er x ps t     -> none $ checkSig RecName i er x ps t                                   -- A record signature is always followed by a                                   -- record definition. Metas should not be                                   -- frozen until after the definition has been@@ -182,7 +189,8 @@                                   -- immediately after the last field. Perhaps                                   -- they should be (unless we're in a mutual                                   -- block).-      A.Open{}                 -> none $ return ()+      A.Open _ _ dir           -> none $ checkImportDirective dir+      A.UnfoldingDecl{}        -> none $ return ()       A.PatternSynDef{}        -> none $ return ()                                   -- Open and PatternSynDef are just artifacts                                   -- from the concrete syntax, retained for@@ -194,6 +202,9 @@       -- TODO: Benchmarking for unquote.       A.UnquoteDecl mi is xs e -> checkMaybeAbstractly is $ checkUnquoteDecl mi is xs e       A.UnquoteDef is xs e     -> impossible $ checkMaybeAbstractly is $ checkUnquoteDef is xs e+      A.UnquoteData is x uc js cs e -> checkMaybeAbstractly (is ++ js) $ do+        reportSDoc "tc.unquote.data" 20 $ "Checking unquoteDecl data" <+> prettyTCM x+        Nothing <$ unquoteTop (x:cs) e      whenNothingM (asksTC envMutualBlock) $ do @@ -201,34 +212,36 @@       highlight_ DontHightlightModuleContents d        -- Defaulting of levels (only when --cumulativity)-      whenM (optCumulativity <$> pragmaOptions) $ defaultLevelsToZero metas+      whenM (optCumulativity <$> pragmaOptions) $+        defaultLevelsToZero (openMetas metas)        -- Post-typing checks.-      whenJust finalChecks $ \ theMutualChecks -> do+      whenJust finalChecks \theMutualChecks -> do         reportSLn "tc.decl" 20 $ "Attempting to solve constraints before freezing."-        wakeupConstraints_   -- solve emptiness and instance constraints+        locallyTCState stInstanceHack (const True) $+          wakeupConstraints_   -- solve emptiness and instance constraints+         checkingWhere <- asksTC envCheckingWhere-        solveSizeConstraints $ if checkingWhere then DontDefaultToInfty else DefaultToInfty+        solveSizeConstraints $ if checkingWhere /= NoWhere_ then DontDefaultToInfty else DefaultToInfty         wakeupConstraints_   -- Size solver might have unblocked some constraints+         case d of-            A.Generalize{} -> pure ()-            _ -> do-              reportSLn "tc.decl" 20 $ "Freezing all metas."-              void $ freezeMetas metas+          A.Generalize{} -> pure ()+          _ -> do+            reportSLn "tc.decl" 20 $ "Freezing all open metas."+            void $ freezeMetas (openMetas metas)          theMutualChecks      where -    -- check record or data type signature-    checkSig kind i x gtel t = checkTypeSignature' (Just gtel) $-      A.Axiom kind i defaultArgInfo Nothing x t-     -- Switch maybe to abstract mode, benchmark, and debug print bracket.     check :: forall m i a           . ( MonadTCEnv m, MonadPretty m, MonadDebug m             , MonadBench m, Bench.BenchPhase m ~ Phase-            , AnyIsAbstract i )+            , AnyIsAbstract i+            , AllAreOpaque i+            )           => QName -> i -> m a -> m a     check x i m = Bench.billTo [Bench.Definition x] $ do       reportSDoc "tc.decl" 5 $ ("Checking" <+> prettyTCM x) <> "."@@ -238,9 +251,16 @@       return r      -- Switch to AbstractMode if any of the i is AbstractDef.-    checkMaybeAbstractly :: forall m i a . ( MonadTCEnv m , AnyIsAbstract i )+    checkMaybeAbstractly :: forall m i a . ( MonadTCEnv m, AnyIsAbstract i, AllAreOpaque i )                          => i -> m a -> m a-    checkMaybeAbstractly = localTC . set lensIsAbstract . anyIsAbstract+    checkMaybeAbstractly abs cont = do+      let+        k1 = localTC (set lensIsAbstract (anyIsAbstract abs))+      k2 <- case jointOpacity abs of+        UniqueOpaque i     -> pure $ localTC $ \env -> env { envCurrentOpaqueId = Just i }+        NoOpaque           -> pure id+        DifferentOpaque hs -> __IMPOSSIBLE__+      k1 (k2 cont)  -- Some checks that should be run at the end of a mutual block. The -- set names contains the names defined in the mutual block.@@ -297,7 +317,7 @@   -- qccs: compiled clauses of definitions   (rs, qccs) <- partitionEithers . catMaybes <$> mapM classify qs   unless (null rs) $ forM_ qccs $ \(q,cc) -> do-    (cc, recordExpressionBecameCopatternLHS) <- runChangeT $ translateCompiledClauses cc+    (cc, recordExpressionBecameCopatternLHS) <- runChangeT $ translateCompiledClauses q cc     modifySignature $ updateDefinition q       $ updateTheDef (updateCompiledClauses $ const $ Just cc)       . updateDefCopatternLHS (|| recordExpressionBecameCopatternLHS)@@ -308,7 +328,7 @@     case theDef def of       Record{ recEtaEquality' = Inferred YesEta } -> return $ Just $ Left q       Function-        { funProjection = Nothing+        { funProjection = Left MaybeProjection             -- Andreas, 2017-08-10, issue #2664:             -- Do not record pattern translate record projection definitions!         , funCompiled   = Just cc@@ -336,7 +356,7 @@   lzero <- primLevelZero   let vArg = defaultArg       hArg = setHiding Hidden . vArg-  m    <- applyQuantityToContext zeroQuantity $+  m    <- applyQuantityToJudgement zeroQuantity $             checkExpr e $ El (mkType 0) $ apply tcm [hArg lzero, vArg unit]   res  <- runUnquoteM $ tell xs >> evalTCM m   case res of@@ -384,6 +404,10 @@ --   mutual block we have. Hence the flag. highlight_ :: HighlightModuleContents -> A.Declaration -> TCM () highlight_ hlmod d = do+  reportSDoc "tc.decl" 45 $+    text "Highlighting a declaration with the following spine:"+      $$+    text (show $ A.declarationSpine d)   let highlight d = generateAndPrintSyntaxInfo d Full True   Bench.billTo [Bench.Highlighting] $ case d of     A.Axiom{}                -> highlight d@@ -399,14 +423,17 @@     A.DataSig{}              -> highlight d     A.Open{}                 -> highlight d     A.PatternSynDef{}        -> highlight d+    A.UnfoldingDecl{}        -> highlight d     A.Generalize{}           -> highlight d     A.UnquoteDecl{}          -> highlight d     A.UnquoteDef{}           -> highlight d-    A.Section i x tel ds     -> do-      highlight (A.Section i x tel [])+    A.UnquoteData{}          -> highlight d+    A.Section i er x tel ds  -> do+      highlight (A.Section i er x tel [])       when (hlmod == DoHighlightModuleContents) $ mapM_ (highlight_ hlmod) (deepUnscopeDecls ds)     A.RecSig{}               -> highlight d-    A.RecDef i x uc dir ps tel cs -> highlight (A.RecDef i x uc dir A.noDataDefParams dummy cs)+    A.RecDef i x uc dir ps tel cs ->+      highlight (A.RecDef i x uc dir ps dummy cs)       -- The telescope has already been highlighted.       where       -- Andreas, 2016-01-22, issue 1790@@ -427,7 +454,7 @@   reportSLn "tc.decl" 20 $ "checkDecl: checking termination..."   -- If there are some termination errors, we throw a warning.   -- The termination checker already marked non-terminating functions as such.-  unlessNullM (termDecl d) $ \ termErrs -> do+  List1.unlessNullM (termDecl d) \ termErrs -> do     warning $ TerminationIssue termErrs  -- | Check a set of mutual names for positivity.@@ -441,17 +468,6 @@   -- positivity check, so it needs happen after the positivity check.   computePolarity $ Set.toList names --- | Check that all coinductive records are actually recursive.---   (Otherwise, one can implement invalid recursion schemes just like---   for the old coinduction.)-checkCoinductiveRecords :: [A.Declaration] -> TCM ()-checkCoinductiveRecords ds = forM_ ds $ \case-  A.RecDef _ q _ dir _ _ _-    | Just (Ranged r CoInductive) <- recInductive dir -> setCurrentRange r $ do-    unlessM (isRecursiveRecord q) $ typeError $ GenericError $-      "Only recursive records can be coinductive"-  _ -> return ()- -- | Check a set of mutual names for constructor-headedness. checkInjectivity_ :: Set QName -> TCM () checkInjectivity_ names = Bench.billTo [Bench.Injectivity] $ do@@ -519,15 +535,20 @@  -- | Freeze metas created by given computation if in abstract mode. whenAbstractFreezeMetasAfter :: A.DefInfo -> TCM a -> TCM a-whenAbstractFreezeMetasAfter Info.DefInfo{ defAccess, defAbstract} m = do-  if defAbstract /= AbstractDef then m else do+whenAbstractFreezeMetasAfter Info.DefInfo{defAccess, defAbstract, defOpaque} m = do+  if (defAbstract == ConcreteDef && defOpaque == TransparentDef) then m else do     (a, ms) <- metasCreatedBy m+     reportSLn "tc.decl" 20 $ "Attempting to solve constraints before freezing."-    wakeupConstraints_   -- solve emptiness and instance constraints-    xs <- freezeMetas ms+    locallyTCState stInstanceHack (const True) $+      wakeupConstraints_   -- solve emptiness and instance constraints+    xs <- freezeMetas (openMetas ms)+     reportSDoc "tc.decl.ax" 20 $ vcat-      [ "Abstract type signature produced new metas: " <+> sep (map prettyTCM $ IntMap.keys ms)-      , "We froze the following ones of these:       " <+> sep (map prettyTCM $ IntSet.toList xs)+      [ "Abstract type signature produced new open metas: " <+>+        sep (map prettyTCM $ MapS.keys (openMetas ms))+      , "We froze the following ones of these:            " <+>+        sep (map prettyTCM $ Set.toList xs)       ]     return a @@ -551,40 +572,45 @@       ]      lang <- getLanguage-    addConstant x $ (defaultDefn info x tGen lang GeneralizableVar)-                    { defArgGeneralizable = SomeGeneralizableArgs n }-+    addConstant x $ defaultDefn info x tGen lang $+      GeneralizableVar $ SomeGeneralizableArgs n  -- | Type check an axiom. checkAxiom :: KindOfName -> A.DefInfo -> ArgInfo ->-              Maybe [Occurrence] -> QName -> A.Expr -> TCM ()+              Maybe PragmaPolarities -> QName -> A.Expr -> TCM () checkAxiom = checkAxiom' Nothing  -- | Data and record type signatures need to remember the generalized --   parameters for when checking the corresponding definition, so for these we --   pass in the parameter telescope separately. checkAxiom' :: Maybe A.GeneralizeTelescope -> KindOfName -> A.DefInfo -> ArgInfo ->-               Maybe [Occurrence] -> QName -> A.Expr -> TCM ()+               Maybe PragmaPolarities -> QName -> A.Expr -> TCM () checkAxiom' gentel kind i info0 mp x e = whenAbstractFreezeMetasAfter i $ defaultOpenLevelsToZero $ do   -- Andreas, 2016-07-19 issues #418 #2102:   -- We freeze metas in type signatures of abstract definitions, to prevent   -- leakage of implementation details. +  -- If the axiom is erased, then hard compile-time mode is entered.+  setHardCompileTimeModeIfErased' info0 $ do+   -- Andreas, 2012-04-18  if we are in irrelevant context, axioms are irrelevant   -- even if not declared as such (Issue 610).-  -- Andreas, 2019-06-17  also for erasure (issue #3855).-  rel <- max (getRelevance info0) <$> asksTC getRelevance-  q   <- asksTC getQuantity <&> \case-    q@Quantity0{} -> q-    _ -> getQuantity info0+  rel <- max (getRelevance info0) <$> viewTC eRelevance    -- Andrea, 2019-07-16 Cohesion is purely based on left-division, it   -- does not take envModality into account.   let c = getCohesion info0-  let mod  = Modality rel q c+  let p = getModalPolarity info0+  let mod  = Modality rel (getQuantity info0) c p   let info = setModality mod info0-  applyCohesionToContext c $ do +  -- For now, top-level polarity annotations are forbidden+  when (p /= defaultPolarity) $ warning $ TopLevelPolarity x p++  polarityEnabled <- optPolarity <$> pragmaOptions++  applyWhen polarityEnabled (applyPolarityToContext p) $ applyCohesionToContext c $ do+   reportSDoc "tc.decl.ax" 20 $ sep     [ text $ "checking type signature"     , nest 2 $ (prettyTCM mod <> prettyTCM x) <+> ":" <+> prettyTCM e@@ -594,7 +620,7 @@   (genParams, npars, t) <- workOnTypes $ case gentel of         Nothing     -> ([], 0,) <$> isType_ e         Just gentel ->-          checkGeneralizeTelescope gentel $ \ genParams ptel -> do+          checkGeneralizeTelescope Nothing gentel $ \ genParams ptel -> do             t <- workOnTypes $ isType_ e             return (genParams, size ptel, abstract ptel t) @@ -615,43 +641,66 @@   -- modules!   when (kind == AxiomName) $ do     whenM ((== SizeUniv) <$> do reduce $ getSort t) $ do-      whenM ((> 0) <$> getContextSize) $ do-        typeError $ GenericError $ "We don't like postulated sizes in parametrized modules."+      whenM ((> 0) <$> getContextSize) $ typeError PostulatedSizeInModule -  -- Ensure that polarity pragmas do not contain too many occurrences.-  (occs, pols) <- case mp of-    Nothing   -> return ([], [])-    Just occs -> do-      TelV tel _ <- telView t-      let n = length (telToList tel)-      when (n < length occs) $-        typeError $ TooManyPolarities x n-      let pols = map polFromOcc occs-      reportSLn "tc.polarity.pragma" 10 $-        "Setting occurrences and polarity for " ++ prettyShow x ++ ":\n  " ++-        prettyShow occs ++ "\n  " ++ prettyShow pols-      return (occs, pols)+  -- get explicitely specified occurences (by looking at polarity annotations, if enabled)+  eoccs <-+    if polarityEnabled+      then do+        args <- telToList . theTel <$> telView t+        return $ fmap (modalPolarityToOccurrence . modPolarityAnn . getModalPolarity) args+      else return [] +  -- Lucas, 2022-11-30: If this is a datatype, forbid polarity annotations for indices+  when (kind == DataName && any (/= Mixed) (drop npars eoccs)) $+    typeError DatatypeIndexPolarity +  occs <- case mp of+    Nothing -> return eoccs+    Just occs1 -> do+      -- If any polarity retrieved from the type is not Mixed, it means an explicit+      -- annotation was given, so we throw an error because the pragma shouldn't be used+      when (any (/= Mixed) eoccs) $ typeError (ExplicitPolarityVsPragma x)++      -- Ensure that polarity pragmas do not contain too many occurrences.+      let occs = List1.toList occs1+      let m = length occs+      TelV tel _core <- telViewUpTo m t+      let n = size tel+      when (n < m) do+        -- Andreas, 2025-05-03, #7851+        -- ifBlocked _core  then the warning might be spurious.+        -- However, postponing this check seems like an overkill.+        warning $ TooManyPolarities x $+          List1.fromListSafe __IMPOSSIBLE__ $ drop n occs++      return $ map rangedThing occs+   -- Set blocking tag to MissingClauses if we still expect clauses   let blk = case kind of-        FunName   -> NotBlocked MissingClauses   ()-        MacroName -> NotBlocked MissingClauses   ()+        FunName   -> NotBlocked (MissingClauses x) ()+        MacroName -> NotBlocked (MissingClauses x) ()         _         -> NotBlocked ReallyNotBlocked ()    -- Not safe. See Issue 330   -- t <- addForcingAnnotations t    lang <- getLanguage+  funD <- emptyFunctionData+   let defn = defaultDefn info x t lang $         case kind of   -- #4833: set abstract already here so it can be inherited by with functions-          FunName   -> emptyFunction{ funAbstr = Info.defAbstract i }-          MacroName -> set funMacro True emptyFunction{ funAbstr = Info.defAbstract i }+          FunName   -> fun+          MacroName -> set funMacro True fun           DataName  -> DataOrRecSig npars           RecName   -> DataOrRecSig npars           AxiomName -> defaultAxiom     -- Old comment: NB: used also for data and record type sigs           _         -> __IMPOSSIBLE__+        where+          fun = FunctionDefn $ set funAbstr_ (Info.defAbstract i) funD{ _funOpaque = Info.defOpaque i } +  let pols = map polFromOcc occs+   addConstant x =<< do     useTerPragma $ defn         { defArgOccurrences    = occs@@ -660,6 +709,10 @@         , defBlocked           = blk         } +  reportSLn "tc.polarity" 10 $+    "Setting occurrences and polarity for " ++ prettyShow x ++ ":\n  " +++    prettyShow occs ++ "\n  " ++ prettyShow pols+   -- Add the definition to the instance table, if needed   case Info.defInstance i of     InstanceDef _r -> setCurrentRange x $ addTypedInstance x t@@ -671,7 +724,7 @@     -- Andreas, 2016-06-21, issue #2054     -- Do not default size metas to ∞ in local type signatures     checkingWhere <- asksTC envCheckingWhere-    solveSizeConstraints $ if checkingWhere then DontDefaultToInfty else DefaultToInfty+    solveSizeConstraints $ if checkingWhere /= NoWhere_ then DontDefaultToInfty else DefaultToInfty  -- | Type check a primitive function declaration. checkPrimitive :: A.DefInfo -> QName -> Arg A.Expr -> TCM ()@@ -681,88 +734,122 @@     -- Certain "primitive" functions are BUILTIN rather than     -- primitive.     let builtinPrimitives =-          [ "primNatPlus"-          , "primNatMinus"-          , "primNatTimes"-          , "primNatDivSucAux"-          , "primNatModSucAux"-          , "primNatEquality"-          , "primNatLess"-          , "primLevelZero"-          , "primLevelSuc"-          , "primLevelMax"-          , "primSetOmega"-          , "primStrictSet"-          , "primStrictSetOmega"+          [ PrimNatPlus+          , PrimNatMinus+          , PrimNatTimes+          , PrimNatDivSucAux+          , PrimNatModSucAux+          , PrimNatEquality+          , PrimNatLess+          , PrimLevelZero+          , PrimLevelSuc+          , PrimLevelMax           ]     when (name `elem` builtinPrimitives) $ do-      reportSDoc "tc.prim" 20 $ text name <+> "is a BUILTIN, not a primitive!"-      typeError $ NoSuchPrimitiveFunction name+      reportSDoc "tc.prim" 20 $ pretty name <+> "is a BUILTIN, not a primitive!"+      typeError $ NoSuchPrimitiveFunction (getBuiltinId name)     t <- isType_ e     noConstraints $ equalType t t'     let s  = prettyShow $ qnameName x-    -- Checking the modality. Currently all primitives require default-    -- modalities, and likely very few will have different modalities in the-    -- future. Thus, rather than, the arguably nicer solution of adding a-    -- modality to PrimImpl we simply check the few special primitives here.+    -- Checking the ArgInfo. Currently all primitive definitions require default+    -- ArgInfos, and likely very few will have different ArgInfos in the+    -- future. Thus, rather than, the arguably nicer solution of adding an+    -- ArgInfo to PrimImpl we simply check the few special primitives here.     let expectedInfo =-          case name of-            -- Currently no special primitives-            _ -> defaultArgInfo-    unless (info == expectedInfo) $ typeError $ WrongModalityForPrimitive name info expectedInfo-    bindPrimitive s pf-    addConstant' x info x t $-        Primitive { primAbstr    = Info.defAbstract i-                  , primName     = s-                  , primClauses  = []-                  , primInv      = NotInjective-                  , primCompiled = Nothing }+          -- Currently no special primitives+          -- case name of _ ->+                        defaultArgInfo+    unless (info == expectedInfo) $+      typeError $ WrongArgInfoForPrimitive name info expectedInfo+    bindPrimitive name pf+    lang <- getLanguage+    addConstant x+      (defaultDefn info x t lang Primitive+        { primAbstr    = Info.defAbstract i+        , primOpaque   = TransparentDef+        , primName     = name+        , primClauses  = []+        , primInv      = NotInjective+        , primCompiled = Nothing })+      { defArgOccurrences = primFunArgOccurrences pf }  -- | Check a pragma. checkPragma :: Range -> A.Pragma -> TCM ()-checkPragma r p =+checkPragma r p = do+    let uselessPragma = warning . UselessPragma r     traceCall (CheckPragma r p) $ case p of         A.BuiltinPragma rb x-          | isUntypedBuiltin b -> return ()-          | otherwise          -> bindBuiltin b x+          | any isUntypedBuiltin b -> return ()+          | Just b' <- b -> bindBuiltin b' x+          | otherwise -> typeError $ NoSuchBuiltinName ident+          where+            ident = rangedThing rb+            b = builtinById ident+        A.BuiltinNoDefPragma rb _kind x+          | Just b' <- builtinById b -> bindBuiltinNoDef b' x+          | otherwise -> typeError $ NoSuchBuiltinName b           where b = rangedThing rb-        A.BuiltinNoDefPragma b _kind x -> bindBuiltinNoDef (rangedThing b) x         A.RewritePragma _ qs -> addRewriteRules qs         A.CompilePragma b x s -> do           -- Check that x resides in the same module (or a child) as the pragma.           x' <- defName <$> getConstInfo x  -- Get the canonical name of x.-          unlessM ((x' `isInModule`) <$> currentModule) $-            typeError $ GenericError $+          ifM ((x' `isInModule`) <$> currentModule)+            {- then -} (addPragma (rangedThing b) x s)+            {- else -} $ uselessPragma               "COMPILE pragmas must appear in the same module as their corresponding definitions,"-          addPragma (rangedThing b) x s+         A.StaticPragma x -> do-          def <- getConstInfo x+          def <- ignoreAbstractMode $ getConstInfo x           case theDef def of             Function{} -> markStatic x-            _          -> typeError $ GenericError "STATIC directive only works on functions"+            _          -> uselessPragma "STATIC directive only applies to functions"         A.InjectivePragma x -> markInjective x+        A.InjectiveForInferencePragma x -> do+          def <- ignoreAbstractMode $ getConstInfo x+          case theDef def of+            Function{} -> markFirstOrder x+            _ -> uselessPragma "INJECTIVE_FOR_INFERENCE directive only applies to functions"+        A.NotProjectionLikePragma qn -> do+          def <- ignoreAbstractMode $ getConstInfo qn+          case theDef def of+            it@Function{} ->+              modifyGlobalDefinition qn $ \def -> def { theDef = it { funProjection = Left NeverProjection } }+            _ -> uselessPragma "NOT_PROJECTION_LIKE directive only applies to functions"         A.InlinePragma b x -> do-          def <- getConstInfo x+          def <- ignoreAbstractMode $ getConstInfo x           case theDef def of             Function{} -> markInline b x-            _          -> typeError $ GenericError $ sINLINE ++ " directive only works on functions"-              where sINLINE = if b then "INLINE" else "NOINLINE"-        A.OptionsPragma{} -> typeError $ GenericError $ "OPTIONS pragma only allowed at beginning of file, before top module declaration"+            d@Constructor{ conSrcCon } | copatternMatchingAllowed conSrcCon+              -> modifyGlobalDefinition x $ set lensTheDef d{ conInline = b }+            _ -> uselessPragma $ P.text $ applyUnless b ("NO" ++) "INLINE directive only works on functions or constructors of records that allow copattern matching"+        A.OptionsPragma{} -> uselessPragma $ "OPTIONS pragma only allowed at beginning of file, before top module declaration"         A.DisplayPragma f ps e -> checkDisplayPragma f ps e-        A.EtaPragma r -> do-          let noRecord = typeError $ GenericError $-                "ETA pragma is only applicable to coinductive records"-          caseMaybeM (isRecord r) noRecord $ \case-            Record{ recInduction = ind, recEtaEquality' = eta } -> do-              unless (ind == Just CoInductive) $ noRecord-              if | Specified NoEta{} <- eta -> typeError $ GenericError $-                     "ETA pragma conflicts with no-eta-equality declaration"-                 | otherwise -> return ()-            _ -> __IMPOSSIBLE__-          modifySignature $ updateDefinition r $ updateTheDef $ \case-            def@Record{} -> def { recEtaEquality' = Specified YesEta }-            _ -> __IMPOSSIBLE__ +        A.OverlapPragma q new -> do+          ifNotM ((q `isInModule`) <$> currentModule)+            (uselessPragma =<< fsep (+              pwords "This" ++ [pretty new] +++              pwords "pragma must appear in the same module as the definition of" +++              [prettyTCM q]))++            {- else -} do++          def <- getConstInfo q+          case defInstance def of+            Just i@InstanceInfo{ instanceOverlap = DefaultOverlap } ->+              modifyGlobalDefinition q \x -> x { defInstance = Just i{ instanceOverlap = new } }+            Just InstanceInfo{ instanceOverlap = old } -> typeError $ DuplicateOverlapPragma q old new+            Nothing -> uselessPragma =<< pretty new <+> "pragma can only be applied to instances"++        A.EtaPragma q -> isRecord q >>= \case+            Nothing -> noRecord+            Just RecordData{ _recInduction = ind, _recEtaEquality' = eta }+              | ind /= Just CoInductive  -> noRecord+              | Specified NoEta{} <- eta -> uselessPragma "ETA pragma conflicts with no-eta-equality declaration"+              | otherwise -> modifyRecEta q $ const $ Specified YesEta+          where+            noRecord = uselessPragma "ETA pragma is only applicable to coinductive records"+ -- | Type check a bunch of mutual inductive recursive definitions. -- -- All definitions which have so far been assigned to the given mutual@@ -781,6 +868,15 @@    (blockId, ) . mutualNames <$> lookupMutualBlock blockId +    -- check record or data type signature+checkSig ::+  KindOfName -> A.DefInfo -> Erased -> QName -> A.GeneralizeTelescope ->+  A.Expr -> TCM ()+checkSig kind i erased x gtel t =+  checkTypeSignature' (Just gtel) $+  A.Axiom kind i (setQuantity (asQuantity erased) defaultArgInfo)+    Nothing x t+ -- | Type check the type signature of an inductive or recursive definition. checkTypeSignature :: A.TypeSignature -> TCM () checkTypeSignature = checkTypeSignature' Nothing@@ -806,8 +902,11 @@  -- | Type check a module. -checkSection :: ModuleName -> A.GeneralizeTelescope -> [A.Declaration] -> TCM ()-checkSection x tel ds = newSection x tel $ mapM_ checkDeclCached ds+checkSection ::+  Erased -> ModuleName -> A.GeneralizeTelescope -> [A.Declaration] ->+  TCM ()+checkSection e x tel ds =+  newSection e x tel $ mapM_ checkDeclCached ds   -- | Helper for 'checkSectionApplication'.@@ -818,62 +917,78 @@ --   Returns the remaining module parameters as an open telescope. --   Warning: the returned telescope is /not/ the final result, --   an actual instantiation of the parameters does not occur.-checkModuleArity-  :: ModuleName           -- ^ Name of applied module.+checkModuleArity ::+     ModuleName           -- ^ Name of applied module.   -> Telescope            -- ^ The module parameters.-  -> [NamedArg A.Expr]  -- ^ The arguments this module is applied to.+  -> [NamedArg A.Expr]    -- ^ The arguments this module is applied to.   -> TCM Telescope        -- ^ The remaining module parameters (has free de Bruijn indices!).-checkModuleArity m tel args = check tel args-  where-    bad = typeError $ ModuleArityMismatch m tel args+checkModuleArity m tel = \case+  []   -> return tel+  a:as -> check1 tel a as+    where+    bad = typeError $ ModuleArityMismatch m tel (Left (a :| as))      check :: Telescope -> [NamedArg A.Expr] -> TCM Telescope     check tel []             = return tel-    check EmptyTel (_:_)     = bad-    check (ExtendTel dom@Dom{domInfo = info} btel) args0@(Arg info' arg : args) =+    check tel (a : as)       = check1 tel a as++    check1 :: Telescope -> NamedArg A.Expr -> [NamedArg A.Expr] -> TCM Telescope+    check1 EmptyTel _ _ = bad+    check1 (ExtendTel dom@Dom{domInfo = info} btel) arg0@(Arg info' arg) args = do       let name = bareNameOf arg           my   = bareNameOf dom-          tel  = absBody btel in+          tel  = absBody btel       case (argInfoHiding info, argInfoHiding info', name) of-        (Instance{}, NotHidden, _)        -> check tel args0-        (Instance{}, Hidden, _)           -> check tel args0-        (Instance{}, Instance{}, Nothing) -> check tel args+        (Instance{}, NotHidden, _)        -> check1 tel arg0 args+        (Instance{}, Hidden, _)           -> check1 tel arg0 args+        (Instance{}, Instance{}, Nothing) -> check  tel args         (Instance{}, Instance{}, Just x)-          | Just x == my                  -> check tel args-          | otherwise                     -> check tel args0-        (Hidden, NotHidden, _)            -> check tel args0-        (Hidden, Instance{}, _)           -> check tel args0-        (Hidden, Hidden, Nothing)         -> check tel args+          | Just x == my                  -> check  tel args+          | otherwise                     -> check1 tel arg0 args+        (Hidden, NotHidden, _)            -> check1 tel arg0 args+        (Hidden, Instance{}, _)           -> check1 tel arg0 args+        (Hidden, Hidden, Nothing)         -> check  tel args         (Hidden, Hidden, Just x)-          | Just x == my                  -> check tel args-          | otherwise                     -> check tel args0-        (NotHidden, NotHidden, _)         -> check tel args+          | Just x == my                  -> check  tel args+          | otherwise                     -> check1 tel arg0 args+        (NotHidden, NotHidden, _)         -> check  tel args         (NotHidden, Hidden, _)            -> bad         (NotHidden, Instance{}, _)        -> bad  -- | Check an application of a section. checkSectionApplication   :: Info.ModuleInfo+  -> Erased              -- ^ Should \"everything\" be treated as+                         --   erased?   -> ModuleName          -- ^ Name @m1@ of module defined by the module macro.   -> A.ModuleApplication -- ^ The module macro @λ tel → m2 args@.   -> A.ScopeCopyInfo     -- ^ Imported names and modules+  -> A.ImportDirective   -> TCM ()-checkSectionApplication i m1 modapp copyInfo =-  traceCall (CheckSectionApplication (getRange i) m1 modapp) $-  -- A section application is type-checked in a non-erased context-  -- (#5410).-  localTC (over eQuantity $ mapQuantity (`addQuantity` topQuantity)) $-  checkSectionApplication' i m1 modapp copyInfo+checkSectionApplication i er m1 modapp copyInfo dir =+  traceCall (CheckSectionApplication (getRange i) er m1 modapp) $ do+  checkImportDirective dir+  -- A (non-erased) section application is type-checked in a+  -- non-erased context (#5410), except if hard compile-time mode is+  -- enabled (#4743).+  setRunTimeModeUnlessInHardCompileTimeMode $+    checkSectionApplication' i er m1 modapp copyInfo  -- | Check an application of a section. (Do not invoke this procedure -- directly, use 'checkSectionApplication'.) checkSectionApplication'   :: Info.ModuleInfo+  -> Erased   -> ModuleName          -- ^ Name @m1@ of module defined by the module macro.   -> A.ModuleApplication -- ^ The module macro @λ tel → m2 args@.   -> A.ScopeCopyInfo     -- ^ Imported names and modules   -> TCM ()-checkSectionApplication' i m1 (A.SectionApp ptel m2 args) copyInfo = do+checkSectionApplication'+  i er m1 (A.SectionApp ptel m2 args) copyInfo = do+  -- If the section application is erased, then hard compile-time mode+  -- is entered.+  warnForPlentyInHardCompileTimeMode er+  setHardCompileTimeModeIfErased er $ do   -- Module applications can appear in lets, in which case we treat   -- lambda-bound variables as additional parameters to the module.   extraParams <- do@@ -905,17 +1020,31 @@     etaTel <- checkModuleArity m2 tel' args     -- Take the module parameters that will be instantiated by @args@.     let tel'' = telFromList $ take (size tel' - size etaTel) $ telToList tel'-    reportSDoc "tc.mod.apply" 15 $ vcat-      [ "applying section" <+> prettyTCM m2-      , nest 2 $ "args =" <+> sep (map prettyA args)-      , nest 2 $ "ptel =" <+> escapeContext impossible (size ptel) (prettyTCM ptel)-      , nest 2 $ "tel  =" <+> prettyTCM tel-      , nest 2 $ "tel' =" <+> prettyTCM tel'-      , nest 2 $ "tel''=" <+> prettyTCM tel''-      , nest 2 $ "eta  =" <+> escapeContext impossible (size ptel) (addContext tel'' $ prettyTCM etaTel)-      ]+    reportSDoc "tc.mod.apply" 15 $+        "applying section" <+> prettyTCM m2+    reportSDoc "tc.mod.apply" 15 $+        nest 2 $ "args =" <+> sep (map prettyA args)+    reportSDoc "tc.mod.apply" 15 $+        nest 2 $ "ptel =" <+> escapeContext impossible (size ptel) (prettyTCM ptel)+    reportSDoc "tc.mod.apply" 15 $+        nest 2 $ "tel  =" <+> prettyTCM tel+    reportSDoc "tc.mod.apply" 15 $+        nest 2 $ "tel' =" <+> prettyTCM tel'+    reportSDoc "tc.mod.apply" 15 $+        nest 2 $ "tel''=" <+> prettyTCM tel''+    reportSDoc "tc.mod.apply" 15 $+        nest 2 $ "eta  =" <+> escapeContext impossible (size ptel) (addContext tel'' $ prettyTCM etaTel)+     -- Now, type check arguments.-    ts <- noConstraints (checkArguments_ CmpEq DontExpandLast (getRange i) args tel') >>= \case+    -- Andreas, 2024-12-06: We fake a head A.Expr for the application.+    let+      hd = A.Def $ mnameToQName m2+      -- Amy, 2025-04-16, issue #7799: for parity with checking+      -- declaration right-hand-sides we have to check section+      -- applications with the 'instance hack' enabled.+      k = locallyTCState stInstanceHack (const True) . noConstraints++    ts <- k (checkArguments_ CmpEq DontExpandLast hd args tel') >>= \case       (ts', etaTel') | (size etaTel == size etaTel')                      , Just ts <- allApplyElims ts' -> return ts       _ -> __IMPOSSIBLE__@@ -941,7 +1070,10 @@     addContext (KeepNames aTel) $       applySection m1 (ptel `abstract` aTel) m2 (raise n args ++ etaArgs) copyInfo -checkSectionApplication' i m1 (A.RecordModuleInstance x) copyInfo = do+checkSectionApplication' _ Erased{} _ A.RecordModuleInstance{} _ =+  __IMPOSSIBLE__+checkSectionApplication'+  i NotErased{} m1 (A.RecordModuleInstance x) copyInfo = do   let name = mnameToQName x   tel' <- lookupSection x   vs   <- moduleParamsToApply x@@ -979,8 +1111,7 @@     [ nest 2 $ "vs      =" <+> text (show vs)     -- , nest 2 $ "args    =" <+> text (show args)     ]-  when (tel == EmptyTel) $-    typeError $ GenericError $ prettyShow (qnameToConcrete name) ++ " is not a parameterised section"+  when (tel == EmptyTel) $ typeError $ ModuleArityMismatch x EmptyTel (Right vs)    addContext telInst $ do     vs <- moduleParamsToApply x@@ -995,10 +1126,13 @@     addSection m1     applySection m1 telInst x (vs ++ args) copyInfo --- | Type check an import declaration. Actually doesn't do anything, since all---   the work is done when scope checking.-checkImport :: Info.ModuleInfo -> ModuleName -> TCM ()-checkImport i x = return ()+-- | Checks that @open public@ is not used in hard compile-time mode.+checkImportDirective :: A.ImportDirective -> TCM ()+checkImportDirective dir = do+  hard <- viewTC eHardCompileTimeMode+  when (hard && isJust (publicOpen dir)) $ typeError $ NotSupported $+    "open public in hard compile-time mode " +++    "(for instance in erased modules)"  ------------------------------------------------------------------------ -- * Debugging@@ -1029,18 +1163,21 @@       A.UnquoteDecl  {} -> "UnquoteDecl"       A.ScopedDecl   {} -> "ScopedDecl"       A.UnquoteDef   {} -> "UnquoteDef"+      A.UnquoteData  {} -> "UnquoteDecl data"+      A.UnfoldingDecl{} -> "UnfoldingDecl"  debugPrintDecl :: A.Declaration -> TCM () debugPrintDecl d = do     verboseS "tc.decl" 45 $ do       reportSLn "tc.decl" 45 $ "checking a " ++ showHead d       case d of-        A.Section info mname tel ds -> do+        A.Section info erased mname tel ds -> do           reportSLn "tc.decl" 45 $             "section " ++ prettyShow mname ++ " has "               ++ show (length $ A.generalizeTel tel) ++ " parameters and "               ++ show (length ds) ++ " declarations"-          reportSDoc "tc.decl" 45 $ prettyA $ A.Section info mname tel []+          reportSDoc "tc.decl" 45 $+            prettyA $ A.Section info erased mname tel []           forM_ ds $ \ d -> do             reportSDoc "tc.decl" 45 $ prettyA d         _ -> return ()
src/full/Agda/TypeChecking/Rules/Decl.hs-boot view
@@ -1,10 +1,17 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Rules.Decl where  import Agda.Syntax.Info (ModuleInfo) import Agda.Syntax.Abstract+import Agda.Syntax.Common+import Agda.Syntax.Scope.Base import Agda.TypeChecking.Monad.Base (TCM)  checkDecls :: [Declaration] -> TCM () checkDecl  :: Declaration -> TCM ()-checkSectionApplication :: ModuleInfo -> ModuleName -> ModuleApplication -> ScopeCopyInfo -> TCM ()+checkSig   :: KindOfName -> DefInfo -> Erased -> QName ->+              GeneralizeTelescope -> Expr -> TCM ()+checkSectionApplication ::+  ModuleInfo -> Erased -> ModuleName -> ModuleApplication ->+  ScopeCopyInfo -> ImportDirective -> TCM ()
src/full/Agda/TypeChecking/Rules/Def.hs view
@@ -8,17 +8,20 @@ import Control.Monad.Except ( MonadError(..) )  import Data.Bifunctor-import Data.Function+import Data.Function (on) import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import qualified Data.List as List import Data.Maybe-import Data.Semigroup (Semigroup((<>)))+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Semigroup ( sconcat )  import Agda.Interaction.Options  import Agda.Syntax.Common import qualified Agda.Syntax.Concrete as C+import qualified Agda.Syntax.Concrete.Pretty as C import Agda.Syntax.Position import Agda.Syntax.Abstract.Pattern as A import qualified Agda.Syntax.Abstract as A@@ -31,7 +34,7 @@  import Agda.TypeChecking.Monad import qualified Agda.TypeChecking.Monad.Benchmark as Bench-import Agda.TypeChecking.Warnings ( warning, genericWarning )+import Agda.TypeChecking.Warnings ( warning )  import Agda.TypeChecking.Constraints import Agda.TypeChecking.Conversion@@ -46,18 +49,20 @@ import Agda.TypeChecking.Telescope import Agda.TypeChecking.Telescope.Path import Agda.TypeChecking.Injectivity-import Agda.TypeChecking.Irrelevance+import Agda.TypeChecking.InstanceArguments import Agda.TypeChecking.SizedTypes.Solve import Agda.TypeChecking.Rewriting.Confluence import Agda.TypeChecking.CompiledClause (CompiledClauses'(..), hasProjectionPatterns) import Agda.TypeChecking.CompiledClause.Compile import Agda.TypeChecking.Primitive hiding (Nat)+import Agda.TypeChecking.RecordPatterns ( recordRHSToCopatterns ) import Agda.TypeChecking.Sort  import Agda.TypeChecking.Rules.Term import Agda.TypeChecking.Rules.LHS                 ( checkLeftHandSide, LHSResult(..), bindAsPatterns ) import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl ( checkDecls ) +import Agda.Utils.Function ( applyWhen, applyWhenM ) import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List@@ -67,10 +72,12 @@ import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Permutation-import Agda.Utils.Pretty ( prettyShow )-import qualified Agda.Utils.Pretty as P+import Agda.Syntax.Common.Pretty ( prettyShow )+import qualified Agda.Syntax.Common.Pretty as P+import Agda.Utils.Singleton import Agda.Utils.Size import qualified Agda.Utils.SmallSet as SmallSet+import Agda.Utils.Update  import Agda.Utils.Impossible @@ -78,41 +85,43 @@ -- * Definitions by pattern matching --------------------------------------------------------------------------- -checkFunDef :: Delayed -> A.DefInfo -> QName -> [A.Clause] -> TCM ()-checkFunDef delayed i name cs = do+checkFunDef :: A.DefInfo -> QName -> [A.Clause] -> TCM ()+checkFunDef i name cs = do         -- Reset blocking tag (in case a previous attempt was blocked)         modifySignature $ updateDefinition name $ updateDefBlocked $ const $-          NotBlocked MissingClauses ()+          NotBlocked (MissingClauses name) ()         -- Get the type and relevance of the function         def <- instantiateDef =<< getConstInfo name         let t    = defType def         let info = getArgInfo def++        -- If the function is erased, then hard compile-time mode is+        -- entered.+        setHardCompileTimeModeIfErased' info $ do+         case isAlias cs t of  -- #418: Don't use checkAlias for abstract definitions, since the type                               -- of an abstract function must not be informed by its definition.           Just (e, mc, x)-            | Info.defAbstract i /= AbstractDef ->+            | Info.defAbstract i == ConcreteDef, Info.defOpaque i == TransparentDef ->               traceCall (CheckFunDefCall (getRange i) name cs True) $ do                 -- Andreas, 2012-11-22: if the alias is in an abstract block                 -- it has been frozen.  We unfreeze it to enable type inference.                 -- See issue 729.                 -- Ulf, 2021-02-09: also unfreeze metas in the sort of this type                 whenM (isFrozen x) $ do-                  xs <- allMetasList . jMetaType . mvJudgement <$> lookupMeta x+                  xs <- allMetasList . jMetaType . mvJudgement <$> lookupLocalMeta x                   mapM_ unfreezeMeta (x : xs)-                checkAlias t info delayed i name e mc+                checkAlias t info i name e mc             | otherwise -> do -- Warn about abstract alias (will never work!)               -- Ulf, 2021-11-18, #5620: Don't warn if the meta is solved. A more intuitive solution               -- would be to not treat definitions with solved meta types as aliases, but in mutual               -- blocks you might actually have solved the type of an alias by the time you get to               -- the definition. See test/Succeed/SizeInfinity.agda for an example where this               -- happens.-              whenM (isOpenMeta . mvInstantiation <$> lookupMeta x) $-                setCurrentRange i $ genericWarning =<<-                  "Missing type signature for abstract definition" <+> (prettyTCM name <> ".") $$-                  fsep (pwords "Types of abstract definitions are never inferred since this would leak" ++-                        pwords "information that should be abstract.")-              checkFunDef' t info delayed Nothing Nothing i name cs-          _ -> checkFunDef' t info delayed Nothing Nothing i name cs+              whenM (isOpenMeta <$> lookupMetaInstantiation x) $+                setCurrentRange i $ warning $ MissingTypeSignatureForOpaque name (Info.defOpaque i)+              checkFunDef' t info Nothing Nothing i name cs+          _ -> checkFunDef' t info Nothing Nothing i name cs          -- If it's a macro check that it ends in Term → TC ⊤         let ismacro = isMacro . theDef $ def@@ -121,7 +130,7 @@         reportSDoc "tc.def" 20 $ vcat $           [ "checking function definition got stuck on: " <+> pretty blocker ]         modifySignature $ updateDefinition name $ updateDefBlocked $ const $ Blocked blocker ()-        addConstraint blocker $ CheckFunDef delayed i name cs err+        addConstraint blocker $ CheckFunDef i name cs err  checkMacroType :: Type -> TCM () checkMacroType t = do@@ -131,8 +140,7 @@       resType = abstract (telFromList (drop (length telList - 1) telList)) tr   expectedType <- el primAgdaTerm --> el (primAgdaTCM <#> primLevelZero <@> primUnit)   equalType resType expectedType-    `catchError` \ _ -> typeError . GenericDocError =<< sep [ "Result type of a macro must be"-                                                            , nest 2 $ prettyTCM expectedType ]+    `catchError` \ _ -> typeError $ MacroResultTypeMismatch expectedType  -- | A single clause without arguments and without type signature is an alias. isAlias :: [A.Clause] -> Type -> Maybe (A.Expr, Maybe C.Expr, MetaId)@@ -151,13 +159,13 @@     trivialClause _ = Nothing  -- | Check a trivial definition of the form @f = e@-checkAlias :: Type -> ArgInfo -> Delayed -> A.DefInfo -> QName -> A.Expr -> Maybe C.Expr -> TCM ()-checkAlias t ai delayed i name e mc =+checkAlias :: Type -> ArgInfo -> A.DefInfo -> QName -> A.Expr -> Maybe C.Expr -> TCM ()+checkAlias t ai i name e mc =   let clause = A.Clause { clauseLHS          = A.SpineLHS (LHSInfo (getRange i) NoEllipsis) name []                         , clauseStrippedPats = []                         , clauseRHS          = A.RHS e mc                         , clauseWhereDecls   = A.noWhereDecls-                        , clauseCatchall     = False } in+                        , clauseCatchall     = empty } in   atClause name 0 t Nothing clause $ do   reportSDoc "tc.def.alias" 10 $ "checkAlias" <+> vcat     [ text (prettyShow name) <+> colon  <+> prettyTCM t@@ -179,37 +187,35 @@     -- (test/succeed/Issue655.agda)    -- compute body modification for irrelevant definitions, see issue 610-  let bodyMod = case getRelevance ai of-        Irrelevant -> dontCare-        _          -> id+  let bodyMod = applyWhen (isIrrelevant ai) dontCare    -- Add the definition-  addConstant' name ai name t-                   $ set funMacro (Info.defMacro i == MacroDef) $-                     emptyFunction-                      { funClauses = [ Clause  -- trivial clause @name = v@-                          { clauseLHSRange  = getRange i-                          , clauseFullRange = getRange i-                          , clauseTel       = EmptyTel-                          , namedClausePats = []-                          , clauseBody      = Just $ bodyMod v-                          , clauseType      = Just $ Arg ai t-                          , clauseCatchall  = False-                          , clauseExact     = Just True-                          , clauseRecursive = Nothing   -- we don't know yet-                          , clauseUnreachable = Just False-                          , clauseEllipsis = NoEllipsis-                          } ]-                      , funCompiled = Just $ Done [] $ bodyMod v-                      , funSplitTree = Just $ SplittingDone 0-                      , funDelayed  = delayed-                      , funAbstr    = Info.defAbstract i-                      }+  fun <- emptyFunctionData+  addConstant' name ai t $ FunctionDefn $+    set funMacro_ (Info.defMacro i == MacroDef) $+    set funAbstr_ (Info.defAbstract i) $+      fun { _funClauses   = [ Clause  -- trivial clause @name = v@+              { clauseLHSRange    = getRange i+              , clauseFullRange   = getRange i+              , clauseTel         = EmptyTel+              , namedClausePats   = []+              , clauseBody        = Just $ bodyMod v+              , clauseType        = Just $ Arg ai t+              , clauseCatchall    = empty+              , clauseRecursive   = Nothing   -- we don't know yet+              , clauseUnreachable = Just False+              , clauseEllipsis    = NoEllipsis+              , clauseWhereModule = Nothing+              } ]+          , _funCompiled  = Just $ Done [] $ bodyMod v+          , _funSplitTree = Just $ SplittingDone 0+          , _funOpaque    = Info.defOpaque i+          }    -- Andreas, 2017-01-01, issue #2372:   -- Add the definition to the instance table, if needed, to update its type.   case Info.defInstance i of-    InstanceDef _r -> setCurrentRange name $ addTypedInstance name t+    InstanceDef _r -> setCurrentRange name $ readdTypedInstance name t       -- Put highlighting on the name only;       -- @(getRange (r, name))@ does not give good results.     NotInstanceDef -> pure ()@@ -220,7 +226,6 @@ -- | Type check a definition by pattern matching. checkFunDef' :: Type             -- ^ the type we expect the function to have              -> ArgInfo          -- ^ is it irrelevant (for instance)-             -> Delayed          -- ^ are the clauses delayed (not unfolded willy-nilly)              -> Maybe ExtLamInfo -- ^ does the definition come from an extended lambda                                  --   (if so, we need to know some stuff about lambda-lifted args)              -> Maybe QName      -- ^ is it a with function (if so, what's the name of the parent function)@@ -228,22 +233,24 @@              -> QName            -- ^ the name of the function              -> [A.Clause]       -- ^ the clauses to check              -> TCM ()-checkFunDef' t ai delayed extlam with i name cs =-  checkFunDefS t ai delayed extlam with i name Nothing cs+checkFunDef' t ai extlam with i name cs =+  checkFunDefS t ai extlam with i name Nothing cs  -- | Type check a definition by pattern matching. checkFunDefS :: Type             -- ^ the type we expect the function to have              -> ArgInfo          -- ^ is it irrelevant (for instance)-             -> Delayed          -- ^ are the clauses delayed (not unfolded willy-nilly)              -> Maybe ExtLamInfo -- ^ does the definition come from an extended lambda                                  --   (if so, we need to know some stuff about lambda-lifted args)              -> Maybe QName      -- ^ is it a with function (if so, what's the name of the parent function)              -> A.DefInfo        -- ^ range info              -> QName            -- ^ the name of the function-             -> Maybe Substitution -- ^ substitution (from with abstraction) that needs to be applied to module parameters+             -> Maybe (Substitution, Map Name LetBinding)+                                 -- ^ substitution (from with abstraction) that needs to be applied+                                 --   to module parameters, and let-bindings inherited from parent+                                 --   clause              -> [A.Clause]       -- ^ the clauses to check              -> TCM ()-checkFunDefS t ai delayed extlam with i name withSub cs = do+checkFunDefS t ai extlam with i name withSubAndLets cs = do      traceCall (CheckFunDefCall (getRange i) name cs True) $ do         reportSDoc "tc.def.fun" 10 $@@ -270,9 +277,9 @@         -- Check the clauses         cs <- traceCall NoHighlighting $ do -- To avoid flicker.           forM (zip cs [0..]) $ \ (c, clauseNo) -> do-            atClause name clauseNo t withSub c $ do+            atClause name clauseNo t (fst <$> withSubAndLets) c $ do               (c,b) <- applyModalityToContextFunBody ai $ do-                checkClause t withSub c+                checkClause t withSubAndLets c               -- Andreas, 2013-11-23 do not solve size constraints here yet               -- in case we are checking the body of an extended lambda.               -- 2014-04-24: The size solver requires each clause to be@@ -286,9 +293,9 @@          (cs, CPC isOneIxs) <- return $ (second mconcat . unzip) cs +        -- If there is a partial match ("system"), no proper (co)pattern matching is allowed.         let isSystem = not . null $ isOneIxs--        canBeSystem <- do+        when isSystem do           -- allow VarP and ConP i0/i1 fallThrough = yes, DotP           let pss = map namedClausePats cs               allowed = \case@@ -297,18 +304,12 @@                 ConP _ cpi [] | conPFallThrough cpi -> True                 DotP{} -> True                 _      -> False-          return $! all (allowed . namedArg) (concat pss)-        when isSystem $ unless canBeSystem $-          typeError $ GenericError "no pattern matching or path copatterns in systems!"-+          unless (all (all $ allowed . namedArg) pss) $+            typeError PatternInSystem          reportSDoc "tc.def.fun" 70 $ inTopContext $ do           sep $ "checked clauses:" : map (nest 2 . text . show) cs -        -- After checking, remove the clauses again.-        -- (Otherwise, @checkInjectivity@ loops for issue 801).-        modifyFunClauses name (const [])-         reportSDoc "tc.cc" 25 $ inTopContext $ do           sep [ "clauses before injectivity test"               , nest 2 $ prettyTCM $ map (QNamed name) cs  -- broken, reify (QNamed n cl) expect cl to live at top level@@ -319,9 +320,8 @@               ]          -- Needed to calculate the proper fullType below.-        -- Also: issue #4173, allow splitting on erased arguments in erased definitions-        -- in the coverage checker.-        applyCohesionToContext ai $ applyQuantityToContext ai $ do+        applyWhenM (optPolarity <$> pragmaOptions) (applyPolarityToContext ai) $+          applyCohesionToContext ai $ do          -- Systems have their own coverage and "coherence" check, we         -- also add an absurd clause for the cases not needed.@@ -332,26 +332,53 @@                  let c = Clause                        { clauseFullRange = noRange                        , clauseLHSRange  = noRange-                       , clauseTel = tel+                       , clauseTel       = tel                        , namedClausePats = teleNamedArgs tel-                       , clauseBody = Nothing-                       , clauseType = Just (defaultArg t)-                       , clauseCatchall = False-                       , clauseExact     = Just True-                       , clauseRecursive = Just False+                       , clauseBody      = Nothing+                       , clauseType      = Just (defaultArg t)+                       , clauseCatchall    = empty+                       , clauseRecursive   = Just False                        , clauseUnreachable = Just False-                       , clauseEllipsis = NoEllipsis+                       , clauseEllipsis    = NoEllipsis+                       , clauseWhereModule = Nothing                        }                  return (cs ++ [c], pure sys) +        -- The macro or inline tags might be on the type signature+        info <- getConstInfo name+        let+          ismacro  = isMacro (theDef info)+          isinline = isInlineFun (theDef info)+         -- Annotate the clauses with which arguments are actually used.         cs <- instantiateFull {- =<< mapM rebindClause -} cs+         -- Andreas, 2010-11-12         -- rebindClause is the identity, and instantiateFull eta-contracts         -- removing this eta-contraction fixes issue 361         -- however, Data.Star.Decoration.gmapAll no longer type-checks         -- possibly due to missing eta-contraction!? +        -- Inline copattern record constructors on demand, unless the+        -- function is marked inline.+        cs <- if isinline then pure cs else concat <$> do+          forM cs $ \ cl -> do+            (cls, nonExactSplit) <- runChangeT $ recordRHSToCopatterns cl+            when nonExactSplit do+              -- If we inlined a non-eta constructor,+              -- issue a warning that the clause does not hold as definitional equality.+              warning $ InlineNoExactSplit name cl+            return cls++        -- After checking, remove the clauses again.+        -- (Otherwise, @checkInjectivity@ loops for issue 801).+        --+        -- Amy, 2025-04-03: We can't remove the clauses before doing+        -- record→copattern translation, since we might need the+        -- previous clauses to come up with the types of the projected+        -- fields; see 'test/Succeed/IApplyRecConstrInline'.+        modifyFunClauses name (const [])+         -- Check if the function is injective.         -- Andreas, 2015-07-01 we do it here in order to resolve metas         -- in mutual definitions, e.g. the U/El definition in succeed/Issue439.agda@@ -401,32 +428,39 @@               , nest 2 $ pretty cc               ] -        -- The macro tag might be on the type signature-        ismacro <- isMacro . theDef <$> getConstInfo name-         covering <- funCovering . theDef <$> getConstInfo name          -- Add the definition         inTopContext $ addConstant name =<< do++          reportSDoc "tc.def.fun.clauses" 15 $ inTopContext $ do+            vcat [ "final clauses for" <+> prettyTCM name <+>  ":"+                 , nest 2 $ vcat $ map (prettyTCM . QNamed name) cs+                 ]+           -- If there was a pragma for this definition, we can set the           -- funTerminates field directly.-          defn <- autoInline $-             set funMacro (ismacro || Info.defMacro i == MacroDef) $-             emptyFunction-             { funClauses        = cs-             , funCompiled       = Just cc-             , funSplitTree      = mst-             , funDelayed        = delayed-             , funInv            = inv-             , funAbstr          = Info.defAbstract i-             , funExtLam         = (\ e -> e { extLamSys = sys }) <$> extlam-             , funWith           = with-             , funCovering       = covering+          --+          -- Amy, 2025-04-03: If the function was marked INLINE before+          -- the clauses were checked the result should also be INLINE.+          fun  <- emptyFunctionData+          defn <- autoInline $ set funInline isinline $ FunctionDefn $+           set funMacro_ (ismacro || Info.defMacro i == MacroDef) $+           set funAbstr_ (Info.defAbstract i) $+           fun+             { _funClauses        = cs+             , _funCompiled       = Just cc+             , _funSplitTree      = mst+             , _funInv            = inv+             , _funOpaque         = Info.defOpaque i+             , _funExtLam         = (\ e -> e { extLamSys = sys }) <$> extlam+             , _funWith           = with+             , _funCovering       = covering              }           lang <- getLanguage           useTerPragma $             updateDefCopatternLHS (const $ hasProjectionPatterns cc) $-            defaultDefn ai name fullType lang defn+            (defaultDefn ai name fullType lang defn)          reportSDoc "tc.def.fun" 10 $ do           sep [ "added " <+> prettyTCM name <+> ":"@@ -468,15 +502,18 @@  -- | Insert some names into the with-clauses LHS of the given RHS. -- (Used for the inspect idiom)-insertNames :: [Arg (Maybe A.BindName)] -> A.RHS -> A.RHS+insertNames :: List1 (Arg (Maybe A.BindName)) -> A.RHS -> A.RHS insertNames = mapLHSCores . insertInspects -insertInspects :: [Arg (Maybe A.BindName)] -> A.LHSCore -> A.LHSCore+insertInspects :: List1 (Arg (Maybe A.BindName)) -> A.LHSCore -> A.LHSCore insertInspects ps = \case   A.LHSWith core wps [] ->-    let ps' = map (fmap $ fmap patOfName) ps in-    A.LHSWith core (insertIn ps' wps) []-  _ -> __IMPOSSIBLE__+    let ps' = fmap (fmap $ fmap patOfName) ps in+    A.LHSWith core (List1.fromListSafe __IMPOSSIBLE__ $ insertIn (List1.toList ps') (List1.toList wps)) []+  -- Andreas, AIM XXXV, 2022-05-09, issue #5728:+  -- Cases other than LHSWith actually do not make sense, but let them+  -- through to get a proper error later.+  lhs -> lhs    where @@ -487,43 +524,44 @@              -> [Arg a] -> [Arg a]     insertIn []                 wps  = wps     insertIn (Arg info nm : ps) (w : wps) | visible info =-      w : (maybe [] pure nm) ++ insertIn ps wps+      w : maybeToList nm ++ insertIn ps wps     insertIn (Arg info nm : ps) wps       | notVisible info =-          (maybe [] pure nm) ++ insertIn ps wps+          maybeToList nm ++ insertIn ps wps     insertIn _ _ = __IMPOSSIBLE__   -- | Insert some with-patterns into the with-clauses LHS of the given RHS. -- (Used for @rewrite@)-insertPatterns :: [Arg A.Pattern] -> A.RHS -> A.RHS+insertPatterns :: List1 (Arg A.Pattern) -> A.RHS -> A.RHS insertPatterns pats = mapLHSCores (insertPatternsLHSCore pats)  -- | Insert with-patterns before the trailing with patterns. -- If there are none, append the with-patterns.-insertPatternsLHSCore :: [Arg A.Pattern] -> A.LHSCore -> A.LHSCore+insertPatternsLHSCore :: List1 (Arg A.Pattern) -> A.LHSCore -> A.LHSCore insertPatternsLHSCore pats = \case-  A.LHSWith core wps [] -> A.LHSWith core (pats ++ wps) []+  A.LHSWith core wps [] -> A.LHSWith core (pats <> wps) []   core                  -> A.LHSWith core pats []  -- | Parameters for creating a @with@-function. data WithFunctionProblem   = NoWithFunction   | WithFunction-    { wfParentName :: QName                             -- ^ Parent function name.-    , wfName       :: QName                             -- ^ With function name.-    , wfParentType :: Type                              -- ^ Type of the parent function.-    , wfParentTel  :: Telescope                         -- ^ Context of the parent patterns.-    , wfBeforeTel  :: Telescope                         -- ^ Types of arguments to the with function before the with expressions (needed vars).-    , wfAfterTel   :: Telescope                         -- ^ Types of arguments to the with function after the with expressions (unneeded vars).-    , wfExprs      :: [Arg (Term, EqualityView)]        -- ^ With and rewrite expressions and their types.-    , wfRHSType    :: Type                              -- ^ Type of the right hand side.-    , wfParentPats :: [NamedArg DeBruijnPattern]        -- ^ Parent patterns.-    , wfParentParams :: Nat                             -- ^ Number of module parameters in parent patterns-    , wfPermSplit  :: Permutation                       -- ^ Permutation resulting from splitting the telescope into needed and unneeded vars.-    , wfPermParent :: Permutation                       -- ^ Permutation reordering the variables in the parent pattern.-    , wfPermFinal  :: Permutation                       -- ^ Final permutation (including permutation for the parent clause).-    , wfClauses    :: [A.Clause]                        -- ^ The given clauses for the with function-    , wfCallSubst :: Substitution                       -- ^ Subtsitution to generate call for the parent.+    { wfParentName   :: QName                            -- ^ Parent function name.+    , wfName         :: QName                            -- ^ With function name.+    , wfParentType   :: Type                             -- ^ Type of the parent function.+    , wfParentTel    :: Telescope                        -- ^ Context of the parent patterns.+    , wfBeforeTel    :: Telescope                        -- ^ Types of arguments to the with function before the with expressions (needed vars).+    , wfAfterTel     :: Telescope                        -- ^ Types of arguments to the with function after the with expressions (unneeded vars).+    , wfExprs        :: List1 (Arg (Term, EqualityView)) -- ^ With and rewrite expressions and their types.+    , wfRHSType      :: Type                             -- ^ Type of the right hand side.+    , wfParentPats   :: [NamedArg DeBruijnPattern]       -- ^ Parent patterns.+    , wfParentParams :: Nat                              -- ^ Number of module parameters in parent patterns+    , wfPermSplit    :: Permutation                      -- ^ Permutation resulting from splitting the telescope into needed and unneeded vars.+    , wfPermParent   :: Permutation                      -- ^ Permutation reordering the variables in the parent pattern.+    , wfPermFinal    :: Permutation                      -- ^ Final permutation (including permutation for the parent clause).+    , wfClauses      :: List1 A.Clause                   -- ^ The given clauses for the with function+    , wfCallSubst    :: Substitution                     -- ^ Substitution to generate call for the parent.+    , wfLetBindings  :: Map Name LetBinding              -- ^ The let-bindings in scope of the parent (in the parent context).     }  checkSystemCoverage@@ -590,7 +628,7 @@              initWithDefault __IMPOSSIBLE__ $ List.tails pcs) $ \ ((phi1,cl1):pcs') -> do         forM_ pcs' $ \ (phi2,cl2) -> do           phi12 <- reduce (imin `apply` [argN phi1, argN phi2])-          forallFaceMaps phi12 (\ _ _ -> __IMPOSSIBLE__) $ \ sigma -> do+          forallFaceMaps phi12 (\ _ _ -> __IMPOSSIBLE__) $ \_ sigma -> do             let args = sigma `applySubst` teleArgs gamma                 t' = sigma `applySubst` t                 fromReduced (YesReduction _ x) = x@@ -600,7 +638,7 @@                   TelV delta _ <- telViewUpTo extra t'                   fmap (abstract delta) $ addContext delta $ do                     fmap fromReduced $ runReduceM $-                      appDef' (Def f []) [cl] [] (map notReduced $ raise (size delta) args ++ teleArgs delta)+                      appDef' f (Def f []) [cl] [] (map notReduced $ raise (size delta) args ++ teleArgs delta)             v1 <- body cl1             v2 <- body cl2             equalTerm t' v1 v2@@ -651,26 +689,35 @@ checkClauseLHS :: Type -> Maybe Substitution -> A.SpineClause -> (LHSResult -> TCM a) -> TCM a checkClauseLHS t withSub c@(A.Clause lhs@(A.SpineLHS i x aps) strippedPats rhs0 wh catchall) ret = do     reportSDoc "tc.lhs.top" 30 $ "Checking clause" $$ prettyA c-    unlessNull (trailingWithPatterns aps) $ \ withPats -> do-      typeError $ UnexpectedWithPatterns $ map namedArg withPats+    () <- List1.unlessNull (trailingWithPatterns aps) $ \ withPats -> do+      typeError $ UnexpectedWithPatterns $ fmap namedArg withPats     traceCall (CheckClause t c) $ do       aps <- expandPatternSynonyms aps       unless (null strippedPats) $ reportSDoc "tc.lhs.top" 50 $         "strippedPats:" <+> vcat [ prettyA p <+> "=" <+> prettyTCM v <+> ":" <+> prettyTCM a | A.ProblemEq p v a <- strippedPats ]       closed_t <- flip abstract t <$> getContextTelescope-      checkLeftHandSide (CheckLHS lhs) (Just x) aps t withSub strippedPats ret+      checkLeftHandSide (CheckLHS lhs) (getRange lhs) (Just x) aps t withSub strippedPats ret  -- | Type check a function clause.  checkClause   :: Type          -- ^ Type of function defined by this clause.-  -> Maybe Substitution  -- ^ Module parameter substitution arising from with-abstraction.+  -> Maybe (Substitution, Map Name LetBinding)  -- ^ Module parameter substitution arising from with-abstraction, and inherited let-bindings.   -> A.SpineClause -- ^ Clause.-  -> TCM (Clause,ClausesPostChecks)  -- ^ Type-checked clause+  -> TCM (Clause, ClausesPostChecks)  -- ^ Type-checked clause -checkClause t withSub c@(A.Clause lhs@(A.SpineLHS i x aps) strippedPats rhs0 wh catchall) = do-  cxtNames <- reverse . map (fst . unDom) <$> getContext-  checkClauseLHS t withSub c $ \ lhsResult@(LHSResult npars delta ps absurdPat trhs patSubst asb psplit) -> do+checkClause t withSubAndLets c@(A.Clause lhs@(A.SpineLHS i x aps) strippedPats rhs0 wh catchall) = do+  let withSub       = fst <$> withSubAndLets+  cxtNames <- getContextNames+  checkClauseLHS t withSub c $ \ lhsResult@(LHSResult npars delta ps absurdPat trhs patSubst asb psplit ixsplit) -> do++    let installInheritedLets k+          | Just (withSub, lets) <- withSubAndLets = do+            lets' <- traverse makeOpen $ applySubst (patSubst `composeS` withSub) lets+            locallyTC eLetBindings (lets' <>) k+          | otherwise = k++    installInheritedLets $ do         -- Note that we might now be in irrelevant context,         -- in case checkLeftHandSide walked over an irrelevant projection pattern. @@ -692,7 +739,7 @@         let rhs = updateRHS rhs0             updateRHS rhs@A.RHS{}               = rhs             updateRHS rhs@A.AbsurdRHS{}         = rhs-            updateRHS (A.WithRHS q es cs)       = A.WithRHS q es (map updateClause cs)+            updateRHS (A.WithRHS q es cs)       = A.WithRHS q es $ fmap updateClause cs             updateRHS (A.RewriteRHS qes spats rhs wh) =               A.RewriteRHS qes (applySubst patSubst spats) (updateRHS rhs) wh @@ -715,7 +762,7 @@               [ "double checking rhs"               , nest 2 (prettyTCM v <+> " : " <+> prettyTCM (unArg trhs))               ]-            nonConstraining $ checkInternal v CmpLeq $ unArg trhs+            noConstraints $ withFrozenMetas $ checkInternal v CmpLeq $ unArg trhs           Nothing -> return ()          reportSDoc "tc.lhs.top" 10 $ vcat@@ -737,31 +784,13 @@             ]           ] -        -- check naturality wrt the interval.-        let-          -- TODO:: Defined but not used-          iApplyVars :: [NamedArg DeBruijnPattern] -> [(Int, (Term,Term))]-          iApplyVars ps = flip concatMap (map namedArg ps) $ \case-                             IApplyP _ t u x -> [(dbPatVarIndex x,(t,u))]-                             VarP{} -> []-                             ProjP{}-> []-                             LitP{} -> []-                             DotP{} -> []-                             DefP _ _ ps -> iApplyVars ps-                             ConP _ _ ps -> iApplyVars ps-         -- compute body modification for irrelevant definitions, see issue 610-        rel <- asksTC getRelevance-        let bodyMod body = case rel of-              Irrelevant -> dontCare <$> body-              _          -> body+        rel <- viewTC eRelevance+        let bodyMod = applyWhen (isIrrelevant rel) (fmap dontCare)          -- absurd clauses don't define computational behaviour, so it's fine to         -- treat them as catchalls.-        let catchall' = catchall || isNothing body--        -- absurd clauses are not exact-        let exact = if isNothing body then Just False else Nothing -- we don't know yet+        let catchall' = if isNothing body then YesCatchall empty else catchall          return $ (, CPC psplit)           Clause { clauseLHSRange  = getRange i@@ -771,10 +800,10 @@                  , clauseBody      = bodyMod body                  , clauseType      = Just trhs                  , clauseCatchall  = catchall'-                 , clauseExact       = exact                  , clauseRecursive   = Nothing -- we don't know yet                  , clauseUnreachable = Nothing -- we don't know yet-                 , clauseEllipsis  = lhsEllipsis i+                 , clauseEllipsis    = lhsEllipsis i+                 , clauseWhereModule = A.whereModule wh                  }  @@ -802,7 +831,7 @@   -> A.RHS                   -- ^ Rhs to check.   -> TCM (Maybe Term, WithFunctionProblem)                                               -- Note: the as-bindings are already bound (in checkClause)-checkRHS i x aps t lhsResult@(LHSResult _ delta ps absurdPat trhs _ _asb _) rhs0 =+checkRHS i x aps t lhsResult@(LHSResult _ delta ps absurdPat trhs _ _asb _ _) rhs0 =   handleRHS rhs0 where    handleRHS :: A.RHS -> TCM (Maybe Term, WithFunctionProblem)@@ -819,30 +848,29 @@     -- one we complain, ignore it and return the same @(Nothing, NoWithFunction)@     -- as the case dealing with @A.AbsurdRHS@.     mv <- if absurdPat-          then do-            ps <- instantiateFull ps-            Nothing <$ setCurrentRange e (warning $ AbsurdPatternRequiresNoRHS ps)+          then Nothing <$ do setCurrentRange e $ warning AbsurdPatternRequiresAbsentRHS           else Just <$> checkExpr e (unArg trhs)     return (mv, NoWithFunction)    -- Absurd case: no right hand side   noRHS :: TCM (Maybe Term, WithFunctionProblem)   noRHS = do-    unless absurdPat $ typeError $ NoRHSRequiresAbsurdPattern aps+    unless absurdPat $ typeError AbsentRHSRequiresAbsurdPattern     return (Nothing, NoWithFunction)    -- With case: @f xs with {a} in eqa | b in eqb | {{c}} | ...; ... | ps1 = rhs1; ... | ps2 = rhs2; ...@   -- We need to modify the patterns `ps1, ps2, ...` in the user-provided clauses   -- to insert the {eqb} names so that the equality proofs are available on the various RHS.-  withRHS :: QName         -- name of the with-function-          -> [A.WithExpr]  -- @[{a} in eqa, b in eqb, {{c}}, ...]@-          -> [A.Clause]    -- @[(ps1 = rhs1), (ps2 = rhs), ...]@-          -> TCM (Maybe Term, WithFunctionProblem)+  withRHS ::+       QName             -- name of the with-function+    -> List1 A.WithExpr  -- @[{a} in eqa, b in eqb, {{c}}, ...]@+    -> List1 A.Clause    -- @[(ps1 = rhs1), (ps2 = rhs), ...]@+    -> TCM (Maybe Term, WithFunctionProblem)   withRHS aux es cs = do      reportSDoc "tc.with.top" 15 $ vcat       [ "TC.Rules.Def.checkclause reached A.WithRHS"-      , sep $ prettyA aux : map (parens . prettyA . namedThing) es+      , sep $ prettyA aux <| fmap (parens . prettyA . namedThing) es       ]     reportSDoc "tc.with.top" 20 $ do       nfv <- getCurrentModuleFreeVars@@ -860,7 +888,7 @@                 Nothing -> OtherType ty                 Just{}  -> IdiomType ty -    let names = map (\ (Named nm e) -> nm <$ e) es+    let names = fmap (\ (Named nm e) -> nm <$ e) es     cs <- forM cs $ \ c@(A.Clause (A.LHS i core) eqs rhs wh b) -> do       let rhs'  = insertNames    names rhs       let core' = insertInspects names core@@ -890,15 +918,22 @@     Rewrite ((qname, eq) :| qes) ->       rewriteEqnRHS qname eq $         List1.ifNull qes {-then-} rs {-else-} $ \ qes -> Rewrite qes : rs-    Invert qname pes -> invertEqnRHS qname (List1.toList pes) rs+    Invert qname pes -> invertEqnRHS qname pes rs+    LeftLet pes -> usingEqnRHS pes rs      where +    -- @using@ clauses+    usingEqnRHS :: List1 (A.Pattern, A.Expr) -> [A.RewriteEqn] -> TCM (Maybe Term, WithFunctionProblem)+    usingEqnRHS pes rs = do+      let letBindings = for (List1.toList pes) $ \(p, e) -> A.LetPatBind (LetRange (getRange e)) p e+      checkLetBindings' letBindings $ rewriteEqnsRHS rs strippedPats rhs wh+     -- @invert@ clauses-    invertEqnRHS :: QName -> [Named A.BindName (A.Pattern,A.Expr)] -> [A.RewriteEqn] -> TCM (Maybe Term, WithFunctionProblem)+    invertEqnRHS :: QName -> List1 (Named A.BindName (A.Pattern,A.Expr)) -> [A.RewriteEqn] -> TCM (Maybe Term, WithFunctionProblem)     invertEqnRHS qname pes rs = do -      let (npats, es) = unzipWith (\ (Named nm (p , e)) -> (Named nm p, Named nm e)) pes+      let (npats, es) = List1.unzipWith (\ (Named nm (p , e)) -> (Named nm p, Named nm e)) pes       -- Infer the types of the with expressions       vtys <- forM es $ \ (Named nm we) -> do         (e, ty) <- inferExprForWith (defaultArg we)@@ -906,10 +941,8 @@           Nothing -> OtherType ty           Just{}  -> IdiomType ty -      let pats = concatMap (map defaultArg) $-            for npats $ \ (Named nm p) -> case nm of-              Nothing -> [p]-              Just n  -> [p, A.VarP n]+      let pats = fmap defaultArg $ sconcat $+            for npats $ \ (Named nm p) -> p :| maybe [] (\ n -> [A.VarP n]) nm        -- Andreas, 2016-04-14, see also Issue #1796       -- Run the size constraint solver to improve with-abstraction@@ -923,13 +956,13 @@           -- Andreas, 2014-03-05 kill range of copied patterns           -- since they really do not have a source location.           cl = A.Clause (A.LHS i $ insertPatternsLHSCore pats $ A.LHSHead x $ killRange aps)-                 strippedPats rhs'' outerWhere False+                 strippedPats rhs'' outerWhere empty        reportSDoc "tc.invert" 60 $ vcat         [ text "invert"         , "  rhs' = " <> (text . show) rhs'         ]-      checkWithRHS x qname t lhsResult vtys [cl]+      checkWithRHS x qname t lhsResult vtys $ singleton cl      -- @rewrite@ clauses     rewriteEqnRHS@@ -953,7 +986,7 @@            -- 1. rewriting with a reflexive equality to happen rarely,            -- 2. especially with ?-holes in the rewrite expression            -- 3. and a large overall number of ?s.-           let sameIP = (==) `on` (^.stInteractionPoints)+           let sameIP = (==) `on` (^. stInteractionPoints)            when (sameIP st st') $ putTC st            handleRHS $ A.RewriteRHS rs strippedPats rhs wh @@ -961,6 +994,10 @@        (proof, eqt) <- inferExpr eq +      -- Andreas, 2024-02-27, issue #7150+      -- trigger instance search to resolve instances in rewrite-expression+      solveAwakeConstraints+       -- Andreas, 2016-04-14, see also Issue #1796       -- Run the size constraint solver to improve with-abstraction       -- in case the with-expression contains size metas.@@ -970,15 +1007,13 @@       -- and extract lhs, rhs, and their type.        t' <- reduce =<< instantiateFull eqt-      (eqt,rewriteType,rewriteFrom,rewriteTo) <- equalityView t' >>= \case-        eqt@(EqualityType _s _eq _params (Arg _ dom) a b) -> do+      (eqt, rewriteType, rewriteFrom, rewriteTo) <- equalityView (getRange eq) t' >>= \case+        eqt@(EqualityType _r _s _eq _params (Arg _ dom) a b) -> do           s <- sortOf dom           return (eqt, El s dom, unArg a, unArg b)           -- Note: the sort _s of the equality need not be the sort of the type @dom@!-        OtherType{} -> typeError . GenericDocError =<< do-          "Cannot rewrite by equation of type" <+> prettyTCM t'-        IdiomType{} -> typeError . GenericDocError =<< do-          "Cannot rewrite by equation of type" <+> prettyTCM t'+        OtherType{} -> typeError $ CannotRewriteByNonEquation t'+        IdiomType{} -> typeError $ CannotRewriteByNonEquation t'        reflPat <- getReflPattern @@ -990,8 +1025,8 @@        (pats', withExpr, withType) <- do         ifM isReflexive-          {-then-} (return ([ reflPat ]                    , proof, OtherType t'))-          {-else-} (return ([ A.WildP patNoRange, reflPat ], proof, eqt))+          {-then-} (return (                      reflPat :| [], proof, OtherType t'))+          {-else-} (return (A.WildP patNoRange <| reflPat :| [], proof, eqt))       let pats = defaultArg <$> pats'        let rhs' = insertPatterns pats rhs@@ -1001,24 +1036,24 @@           -- Andreas, 2014-03-05 kill range of copied patterns           -- since they really do not have a source location.           cl = A.Clause (A.LHS i $ insertPatternsLHSCore pats $ A.LHSHead x $ killRange aps)-                 strippedPats rhs'' outerWhere False+                 strippedPats rhs'' outerWhere empty        reportSDoc "tc.rewrite" 60 $ vcat         [ text "rewrite"         , "  rhs' = " <> (text . show) rhs'         ]-      checkWithRHS x qname t lhsResult [defaultArg (withExpr, withType)] [cl]+      checkWithRHS x qname t lhsResult (singleton $ defaultArg (withExpr, withType)) $ singleton cl  checkWithRHS   :: QName                             -- ^ Name of function.   -> QName                             -- ^ Name of the with-function.   -> Type                              -- ^ Type of function.   -> LHSResult                         -- ^ Result of type-checking patterns-  -> [Arg (Term, EqualityView)]        -- ^ Expressions and types of with-expressions.-  -> [A.Clause]                        -- ^ With-clauses to check.+  -> List1 (Arg (Term, EqualityView))  -- ^ Expressions and types of with-expressions.+  -> List1 A.Clause                    -- ^ With-clauses to check.   -> TCM (Maybe Term, WithFunctionProblem)                                 -- Note: as-bindings already bound (in checkClause)-checkWithRHS x aux t (LHSResult npars delta ps _absurdPat trhs _ _asb _) vtys0 cs =+checkWithRHS x aux t (LHSResult npars delta ps _absurdPat trhs _ _asb _ _) vtys0 cs =   verboseBracket "tc.with.top" 25 "checkWithRHS" $ do     Bench.billTo [Bench.Typing, Bench.With] $ do         withArgs <- withArguments vtys0@@ -1026,13 +1061,13 @@          reportSDoc "tc.with.top" 30 $ vcat $           -- declared locally because we do not want to use the unzip'd thing!-          let (vs, as) = unzipWith unArg vtys0 in+          let (vs, as) = List1.unzipWith unArg vtys0 in           [ "vs (before normalization) =" <+> prettyTCM vs           , "as (before normalization) =" <+> prettyTCM as           ]         reportSDoc "tc.with.top" 45 $ vcat $           -- declared locally because we do not want to use the unzip'd thing!-          let (vs, as) = unzipWith unArg vtys0 in+          let (vs, as) = List1.unzipWith unArg vtys0 in           [ "vs (before norm., raw) =" <+> pretty vs           ]         vtys0 <- normalise vtys0@@ -1044,7 +1079,7 @@           ]         reportSDoc "tc.with.top" 25 $ vcat $           -- declared locally because we do not want to use the unzip'd thing!-          let (vs, as) = unzipWith unArg vtys0 in+          let (vs, as) = List1.unzipWith unArg vtys0 in           [ "vs     =" <+> prettyTCM vs           , "as     =" <+> prettyTCM as           , "perm   =" <+> text (show perm)@@ -1079,42 +1114,47 @@             -- Then permute the rest and grab those needed to for the with arguments             (us1, us2)  = splitAt (size delta1) $ permute perm' us1'             -- Now stuff the with arguments in between and finish with the remaining variables-            argsS = parallelS $ reverse $ us0 ++ us1 ++ map unArg withArgs ++ us2+            argsS = parallelS $ reverse $ us0 ++ us1 ++ map unArg (List1.toList withArgs) ++ us2             v         = Nothing -- generated by checkWithFunction         -- Andreas, 2013-02-26 add with-name to signature for printing purposes         addConstant aux =<< do           lang <- getLanguage-          useTerPragma $-            defaultDefn defaultArgInfo aux __DUMMY_TYPE__ lang+          useTerPragma =<<+            defaultDefn defaultArgInfo aux __DUMMY_TYPE__ lang <$>               emptyFunction          reportSDoc "tc.with.top" 20 $ vcat $-          let (vs, as) = unzipWith unArg vtys in-          [ "    with arguments" <+> do escapeContext impossible (size delta) $ addContext delta1 $ prettyList (map prettyTCM vs)-          , "             types" <+> do escapeContext impossible (size delta) $ addContext delta1 $ prettyList (map prettyTCM as)+          let (vs, as) = List1.unzipWith unArg vtys in+          -- Andreas, 2025-04-07, escapeContext impossible Δ leads to crash if e.g. vs has metas defined in Δ.+          -- Thus, we use unsafeEscapeContext instead.+          [ "    with arguments" <+> do unsafeEscapeContext (size delta) $ addContext delta1 $ prettyList (fmap prettyTCM vs)+          , "             types" <+> do unsafeEscapeContext (size delta) $ addContext delta1 $ prettyList (fmap prettyTCM as)           , "           context" <+> (prettyTCM =<< getContextTelescope)           , "             delta" <+> do escapeContext impossible (size delta) $ prettyTCM delta           , "            delta1" <+> do escapeContext impossible (size delta) $ prettyTCM delta1           , "            delta2" <+> do escapeContext impossible (size delta) $ addContext delta1 $ prettyTCM delta2           ] -        return (v, WithFunction x aux t delta delta1 delta2 vtys t' ps npars perm' perm finalPerm cs argsS)+        -- Only inherit user-written let bindings from parent clauses. Others, like @-patterns,+        -- should not be carried over.+        lets <- Map.filter ((== UserWritten) . letOrigin) <$> (traverse getOpen =<< viewTC eLetBindings) +        return (v, WithFunction x aux t delta delta1 delta2 vtys t' ps npars perm' perm finalPerm cs argsS lets)+ -- | Invoked in empty context. checkWithFunction :: [Name] -> WithFunctionProblem -> TCM (Maybe Term) checkWithFunction _ NoWithFunction = return Nothing-checkWithFunction cxtNames (WithFunction f aux t delta delta1 delta2 vtys b qs npars perm' perm finalPerm cs argsS) = do-+checkWithFunction cxtNames (WithFunction f aux t delta delta1 delta2 vtys b qs npars perm' perm finalPerm cs argsS lets) = do   let -- Δ₁ ws Δ₂ ⊢ withSub : Δ′    (where Δ′ is the context of the parent lhs)       withSub :: Substitution-      withSub = let as = map (snd . unArg) vtys in+      withSub = let as = fmap (snd . unArg) vtys in                 liftS (size delta2) (wkS (countWithArgs as) idS)                 `composeS` renaming impossible (reverseP perm')    reportSDoc "tc.with.top" 10 $ vcat     [ "checkWithFunction"     , nest 2 $ vcat $-      let (vs, as) = unzipWith unArg vtys in+      let (vs, as) = List1.unzipWith unArg vtys in       [ "delta1 =" <+> prettyTCM delta1       , "delta2 =" <+> addContext delta1 (prettyTCM delta2)       , "t      =" <+> prettyTCM t@@ -1137,17 +1177,21 @@   let reds = SmallSet.fromList [ProjectionReductions]   delta1 <- modifyAllowedReductions (const reds) $ normalise delta1 +  -- Amy, 2025-05-14: (InstanceHack) we have to flush instances that may+  -- come from previous clauses, see #7882.+  flushInstanceConstraints+   -- Generate the type of the with function-  (withFunType, n) <- do+  (withFunType, (nwithargs, nwithpats)) <- do     let ps = renaming impossible (reverseP perm') `applySubst` qs     reportSDoc "tc.with.bndry" 40 $ addContext delta1 $ addContext delta2                                   $ text "ps =" <+> pretty ps     let vs = iApplyVars ps-    bndry <- if null vs then return [] else do+    bndry <- if null vs then return empty else do       iz <- primIZero       io <- primIOne       let tm = Def f (patternsToElims ps)-      return [(i,(inplaceS i iz `applySubst` tm, inplaceS i io `applySubst` tm)) | i <- vs]+      return $ Boundary [(i,(inplaceS i iz `applySubst` tm, inplaceS i io `applySubst` tm)) | i <- vs]     reportSDoc "tc.with.bndry" 40 $ addContext delta1 $ addContext delta2                                   $ text "bndry =" <+> pretty bndry     withFunctionType delta1 vtys delta2 b bndry@@ -1155,7 +1199,7 @@   reportSDoc "tc.with.type" 50 $ sep [ "with-function type:", nest 2 $ pretty withFunType ]    call_in_parent <- do-    (TelV tel _,bs) <- telViewUpToPathBoundaryP (n + size delta) withFunType+    (TelV tel _,bs) <- telViewUpToPathBoundary' (nwithargs + size delta) withFunType     return $ argsS `applySubst` Def aux (teleElims tel bs)    reportSDoc "tc.with.top" 20 $ addContext delta $ "with function call" <+> prettyTCM call_in_parent@@ -1165,10 +1209,15 @@   setCurrentRange cs $     traceCall NoHighlighting $   -- To avoid flicker.     traceCall (CheckWithFunctionType withFunType) $-    checkType withFunType+    -- Jesper, 2024-07-10, issue #6841:+    -- Having an ill-typed type can lead to problems in the+    -- coverage checker, so we ensure there are no constraints here.+    noConstraints $ checkType withFunType +  reportSLn "tc.with.top" 20 "creating with display form..."+   -- With display forms are closed-  df <- inTopContext $ makeOpen =<< withDisplayForm f aux delta1 delta2 n qs perm' perm+  df <- inTopContext $ makeOpen =<< withDisplayForm f aux delta1 delta2 nwithargs qs perm' perm    reportSLn "tc.with.top" 20 "created with display form" @@ -1181,8 +1230,9 @@         ]   addConstant aux =<< do     lang <- getLanguage+    fun  <- emptyFunction     useTerPragma $-      (defaultDefn defaultArgInfo aux withFunType lang emptyFunction)+      (defaultDefn defaultArgInfo aux withFunType lang fun)         { defDisplay = [df] }   -- solveSizeConstraints -- Andreas, 2012-10-16 does not seem necessary @@ -1197,16 +1247,17 @@     -- Construct the body for the with function-  cs <- return $ map (A.lhsToSpine) cs-  cs <- buildWithFunction cxtNames f aux t delta qs npars withSub finalPerm (size delta1) n cs-  cs <- return $ map (A.spineToLhs) cs+  cs <- return $ fmap (A.lhsToSpine) cs+  cs <- buildWithFunction cxtNames f aux t delta qs npars withSub finalPerm (size delta1) nwithpats cs+  cs <- return $ fmap (A.spineToLhs) cs    -- #4833: inherit abstract mode from parent   abstr <- defAbstract <$> ignoreAbstractMode (getConstInfo f)    -- Check the with function   let info = Info.mkDefInfo (nameConcrete $ qnameName aux) noFixity' PublicAccess abstr (getRange cs)-  checkFunDefS withFunType defaultArgInfo NotDelayed Nothing (Just f) info aux (Just withSub) cs+  ai <- defArgInfo <$> getConstInfo f+  checkFunDefS withFunType ai Nothing (Just f) info aux (Just (withSub, lets)) $ List1.toList cs   return $ Just $ call_in_parent  -- | Type check a where clause.@@ -1214,35 +1265,42 @@   :: A.WhereDeclarations -- ^ Where-declarations to check.   -> TCM a               -- ^ Continuation.   -> TCM a-checkWhere wh@(A.WhereDecls whmod ds) ret = do-  ensureNoNamedWhereInRefinedContext whmod-  loop ds-  where-    loop = \case+checkWhere wh@(A.WhereDecls whmod whNamed mds) ret = do+  when (not whNamed) $ ensureNoNamedWhereInRefinedContext whmod+  case mds of       Nothing -> ret-      -- [A.ScopedDecl scope ds] -> withScope_ scope $ loop ds  -- IMPOSSIBLE-      Just (A.Section _ m tel ds) -> newSection m tel $ do-          localTC (\ e -> e { envCheckingWhere = True }) $ do-            checkDecls ds-            ret-      _ -> __IMPOSSIBLE__+      Just (A.Section _ e m tel ds) -> do +        -- Andreas, 2025-06-14, issue #7943.+        -- If we are in erased context, mark the module as erased.+        e <- case e of+          NotErased oo -> do+            asksTC envQuantity >>= \case+              Quantity0 o -> do+                unless (oo == QωInferred) $+                  setCurrentRange oo $ warning $ PlentyInHardCompileTimeMode oo+                pure $ Erased o+              Quantityω{} -> pure e+              Quantity1{} -> __IMPOSSIBLE__+          Erased{}      -> pure e++        localTC whereEnv $ newSection e m tel $ checkDecls ds+        -- Andreas, 2025-06-14, issue #7944+        -- We need to check the body in its original erasure status.+        withCurrentModule m ret+      _ -> __IMPOSSIBLE__+  where+    whereEnv e = e+      { envCheckingWhere       = if whNamed then C.SomeWhere_ else C.AnyWhere_+      }     -- #2897: We can't handle named where-modules in refined contexts.     ensureNoNamedWhereInRefinedContext Nothing = return ()     ensureNoNamedWhereInRefinedContext (Just m) = traceCall (CheckNamedWhere m) $ do       args <- map unArg <$> (moduleParamsToApply =<< currentModule)-      unless (isWeakening args) $ -- weakened contexts are fine-        genericDocError =<< do-          names <- map (argNameToString . fst . unDom) . telToList <$>-                    (lookupSection =<< currentModule)-          let pr x v = text (x ++ " =") <+> prettyTCM v-          vcat-            [ fsep (pwords $ "Named where-modules are not allowed when module parameters have been refined by pattern matching. " ++-                             "See https://github.com/agda/agda/issues/2897.")-            , text $ "In this case the module parameter" ++-                     (if not (null args) then "s have" else " has") ++-                     " been refined to"-            , nest 2 $ vcat (zipWith pr names args) ]+      unless (isWeakening args) $ do -- weakened contexts are fine+        names <- map (argNameToString . fst . unDom) . telToList <$>+                (lookupSection =<< currentModule)+        typeError $ NamedWhereModuleInRefinedContext args names       where         isWeakening [] = True         isWeakening (Var i [] : args) = isWk (i - 1) args@@ -1255,12 +1313,17 @@  -- | Enter a new section during type-checking. -newSection :: ModuleName -> A.GeneralizeTelescope -> TCM a -> TCM a-newSection m gtel@(A.GeneralizeTel _ tel) cont = do+newSection ::+  Erased -> ModuleName -> A.GeneralizeTelescope -> TCM a -> TCM a+newSection e m gtel@(A.GeneralizeTel _ tel) cont = do+  -- If the section is erased, then hard compile-time mode is entered.+  warnForPlentyInHardCompileTimeMode e+  setHardCompileTimeModeIfErased e $ do   reportSDoc "tc.section" 10 $-    "checking section" <+> prettyTCM m <+> fsep (map prettyA tel)+    "checking section" <+> (prettyErased e <$> prettyTCM m) <+>+    fsep (map prettyA tel) -  checkGeneralizeTelescope gtel $ \ _ tel' -> do+  checkGeneralizeTelescope (Just m) gtel $ \ _ tel' -> do     reportSDoc "tc.section" 10 $       "adding section:" <+> prettyTCM m <+> text (show (size tel')) @@ -1276,4 +1339,4 @@ atClause :: QName -> Int -> Type -> Maybe Substitution -> A.SpineClause -> TCM a -> TCM a atClause name i t sub cl ret = do   clo <- buildClosure ()-  localTC (\ e -> e { envClause = IPClause name i t sub cl clo [] }) ret+  localTC (\ e -> e { envClause = IPClause name i t sub cl clo }) ret
src/full/Agda/TypeChecking/Rules/Def.hs-boot view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wunused-imports #-}+ module Agda.TypeChecking.Rules.Def where  import Agda.Syntax.Abstract as A@@ -5,10 +7,11 @@ import Agda.TypeChecking.Monad import qualified Agda.Syntax.Internal as I -checkFunDef :: Delayed -> DefInfo -> QName -> [Clause] -> TCM ()+checkFunDef :: DefInfo -> QName -> [Clause] -> TCM () -checkFunDef' :: I.Type -> ArgInfo -> Delayed -> Maybe ExtLamInfo -> Maybe QName -> DefInfo -> QName -> [Clause] -> TCM ()+checkFunDef' :: I.Type -> ArgInfo -> Maybe ExtLamInfo -> Maybe QName -> DefInfo -> QName -> [Clause] -> TCM () -newSection :: ModuleName -> A.GeneralizeTelescope -> TCM a -> TCM a+newSection ::+   Erased -> ModuleName -> A.GeneralizeTelescope -> TCM a -> TCM a  useTerPragma :: Definition -> TCM Definition
src/full/Agda/TypeChecking/Rules/Display.hs view
@@ -1,7 +1,8 @@+{-# OPTIONS_GHC -Wunused-imports #-}  module Agda.TypeChecking.Rules.Display (checkDisplayPragma) where -import qualified Data.List.NonEmpty as NonEmpty+import Control.Monad.Except import Control.Monad.State import Data.Maybe @@ -14,115 +15,150 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Warnings (warning) -import Agda.Utils.Pretty (prettyShow)+import Agda.Syntax.Common.Pretty (prettyShow, render)  import Agda.Utils.Impossible +-- | Add display pragma if well-formed.+--   Otherwise, throw 'InvalidDisplayForm' warning and ignore it.+-- checkDisplayPragma :: QName -> [NamedArg A.Pattern] -> A.Expr -> TCM () checkDisplayPragma f ps e = do-  df <- inTopContext $ do-          pappToTerm f id ps $ \ n args -> do-            -- pappToTerm puts Var 0 for every variable. We get to know how many there were (n) so-            -- now we can renumber them with decreasing deBruijn indices.-            let lhs = renumberElims (n - 1) $ map I.Apply args-            v <- exprToTerm e-            return $ Display n lhs (DTerm v)-  reportSLn "tc.display.pragma" 20 $ "Adding display form for " ++ prettyShow f ++ "\n  " ++ show df-  addDisplayForm f df+  res <- inTopContext $ runExceptT do+    pappToTerm f id ps \n args -> do+      -- pappToTerm puts Var 0 for every variable. We get to know how many there were (n) so+      -- now we can renumber them with decreasing deBruijn indices.+      let lhs = renumberElims (n - 1) args+      Display n lhs . DTerm <$> exprToTerm e+  case res of+    Left reason -> warning $ InvalidDisplayForm f reason+    Right df -> do+      reportSLn "tc.display.pragma" 20 $ "Adding display form for " ++ prettyShow f+      reportSLn "tc.display.pragma" 90 $ ": \n  " ++ show df+      addDisplayForm f df ---UNUSED Liang-Ting 2019-07-16----- Compute a left-hand side for a display form. Inserts implicits, but no type----- checking so does the wrong thing if implicitness is computed. Binds variables.---displayLHS :: Telescope -> [NamedArg A.Pattern] -> (Int -> [Term] -> TCM a) -> TCM a---displayLHS tel ps ret = patternsToTerms tel ps $ \n vs -> ret n (map unArg vs)+-- | The monad to check display forms.+--   The 'String' contains the reason to reject the display form.+--+type M = ExceptT String TCM -type ToTm = StateT Nat TCM+-- | Helper data type to record whether a pattern on the LHS contributed+-- a 'Proj' elimination or an 'Apply' elimination.+data ProjOrApp = IsProj QName | IsApp Term -patternsToTerms :: Telescope -> [NamedArg A.Pattern] -> (Int -> Args -> TCM a) -> TCM a-patternsToTerms _ [] ret = ret 0 []-patternsToTerms EmptyTel (p : ps) ret =-  patternToTerm (namedArg p) $ \n v ->-  patternsToTerms EmptyTel ps     $ \m vs -> ret (n + m) (inheritHiding p v : vs)-patternsToTerms (ExtendTel a tel) (p : ps) ret-  -- Andreas, 2019-07-22, while #3353: we should use domName, not absName !!-  -- WAS: -- | sameHiding p a, visible p || maybe True (absName tel ==) (bareNameOf p) =  -- no ArgName or same as p-  | fromMaybe __IMPOSSIBLE__ $ fittingNamedArg p a =-      patternToTerm (namedArg p) $ \n v ->-      patternsToTerms (unAbs tel) ps  $ \m vs -> ret (n + m) (inheritHiding p v : vs)-  | otherwise =-      bindWild $ patternsToTerms (unAbs tel) (p : ps) $ \n vs ->-      ret (1 + n) (inheritHiding a (Var 0 []) : vs)+var0 :: ProjOrApp+var0 = IsApp (var 0) -inheritHiding :: LensHiding a => a -> b -> Arg b-inheritHiding a b = setHiding (getHiding a) (defaultArg b)+patternsToTerms0 :: [NamedArg A.Pattern] -> (Int -> Elims -> M a) -> M a+patternsToTerms0 []       ret = ret 0 []+patternsToTerms0 (p : ps) ret =+  patternToTerm (namedArg p) \ n v ->+  patternsToTerms0 ps \ m vs ->+  ret (n + m) (inheritHiding p v : vs) -pappToTerm :: QName -> (Args -> b) -> [NamedArg A.Pattern] -> (Int -> b -> TCM a) -> TCM a+{-# SPECIALIZE patternsToTerms :: ListTel -> [NamedArg A.Pattern] -> (Int -> Elims -> M a) -> M a #-}+patternsToTerms :: (LensNamed dom, NameOf dom ~ NamedName, LensHiding dom)+  => [dom] -> [NamedArg A.Pattern] -> (Int -> Elims -> M a) -> M a+patternsToTerms []        ps ret = patternsToTerms0 ps ret+patternsToTerms (a : tel) ps ret+  | shouldInsertArg =+      bindWild $ patternsToTerms tel ps \ n vs ->+      ret (1 + n) (inheritHiding a var0 : vs)+  where+    shouldInsertArg = case ps of+      [] -> notVisible a+      p : ps -> not $ fromMaybe __IMPOSSIBLE__ $ fittingNamedArg p a+patternsToTerms (a : tel) [] ret = ret 0 []+patternsToTerms (a : tel) (p : ps) ret =+    patternToTerm (namedArg p) \ n v ->+    patternsToTerms tel ps \ m vs ->+    ret (n + m) (inheritHiding p v : vs)++inheritHiding :: LensHiding a => a -> ProjOrApp -> Elim+inheritHiding a (IsProj q) = Proj ProjSystem q+inheritHiding a (IsApp t) = Apply (setHiding (getHiding a) (defaultArg t))++pappToTerm :: QName -> (Elims -> b) -> [NamedArg A.Pattern] -> (Int -> b -> M a) -> M a pappToTerm x f ps ret = do   def <- getConstInfo x   TelV tel _ <- telView $ defType def-  let dropTel n = telFromList . drop n . telToList-      pars =-        case theDef def of-          Constructor { conPars = p } -> p-          Function { funProjection = Just Projection{projIndex = i} }-            | i > 0 -> i - 1-          _ -> 0--  patternsToTerms (dropTel pars tel) ps $ \ n vs -> ret n (f vs)+  let pars = droppedPars def+  patternsToTerms (drop pars $ telToList tel) ps \ n vs -> ret n (f vs) -patternToTerm :: A.Pattern -> (Nat -> Term -> TCM a) -> TCM a+patternToTerm :: A.Pattern -> (Nat -> ProjOrApp -> M a) -> M a patternToTerm p ret =   case p of-    A.VarP A.BindName{unBind = x}   -> bindVar x $ ret 1 (Var 0 [])+    A.VarP A.BindName{unBind = x}   -> bindVar x $ ret 1 var0     A.ConP _ cs ps-      | Just c <- getUnambiguous cs -> pappToTerm c (Con (ConHead c IsData Inductive []) ConOCon . map Apply) ps ret+      | Just c <- getUnambiguous cs -> pappToTerm c (Con (ConHead c IsData Inductive []) ConOCon) ps \ n t -> ret n (IsApp t)       | otherwise                   -> ambigErr "constructor" cs     A.ProjP _ _ ds-      | Just d <- getUnambiguous ds -> ret 0 (Def d [])+      | Just d <- getUnambiguous ds -> ret 0 $ IsProj d       | otherwise                   -> ambigErr "projection" ds     A.DefP _ fs ps-      | Just f <- getUnambiguous fs -> pappToTerm f (Def f . map Apply) ps ret+      | Just f <- getUnambiguous fs -> pappToTerm f (Def f) ps \ n t -> ret n (IsApp t)       | otherwise                   -> ambigErr "DefP" fs-    A.LitP _ l                      -> ret 0 $ Lit l-    A.WildP _                       -> bindWild $ ret 1 (Var 0 [])-    _ -> genericDocError =<< vcat [ "Pattern not allowed in DISPLAY pragma:", prettyA p ]+    A.LitP _ l                      -> ret 0 $ IsApp $ Lit l+    A.WildP _                       -> bindWild $ ret 1 var0+    A.AsP{}                         -> failP "an @-pattern"+    A.DotP{}                        -> failP "a dot pattern"+    A.AbsurdP{}                     -> failP "an absurd pattern"+    A.PatternSynP{}                 -> __IMPOSSIBLE__+    A.RecP{}                        -> failP "a record pattern"+    A.EqualP{}                      -> failP "a system pattern"+    A.WithP{}                       -> __IMPOSSIBLE__   where+    fail = throwError . ("its left-hand side contains " ++)+    failP s = fail . (s ++) . (": " ++) . render =<< prettyA p     ambigErr thing (AmbQ xs) =-      genericDocError =<< do-        text ("Ambiguous " ++ thing ++ ":") <?>+      fail . render =<< do+        text ("an ambiguous " ++ thing ++ ":") <?>           fsep (punctuate comma (fmap pretty xs)) -bindWild :: TCM a -> TCM a+bindWild :: M a -> M a bindWild ret = do   x <- freshNoName_   bindVar x ret -bindVar :: Name -> TCM a -> TCM a+bindVar :: Name -> M a -> M a bindVar x ret = addContext x ret -exprToTerm :: A.Expr -> TCM Term+exprToTerm :: A.Expr -> M Term exprToTerm e =   case unScope e of-    A.Var x  -> fst <$> getVarInfo x-    A.Def f  -> pure $ Def f []-    A.Con c  -> pure $ Con (ConHead (headAmbQ c) IsData Inductive []) ConOCon [] -- Don't care too much about ambiguity here-    A.Lit _ l  -> pure $ Lit l-    A.App _ e arg  -> apply <$> exprToTerm e <*> ((:[]) . inheritHiding arg <$> exprToTerm (namedArg arg))+    A.Var x          -> fst <$> getVarInfo x+    A.Def' f NoSuffix-> pure $ Def f []+    A.Def'{}         -> fail "suffix"+    A.Con c          -> pure $ Con (ConHead (headAmbQ c) IsData Inductive []) ConOCon [] -- Don't care too much about ambiguity here+    A.Lit _ l        -> pure $ Lit l+    A.App _ e arg    -> applyE <$> exprToTerm e <*> ((:[]) . inheritHiding arg . IsApp <$> exprToTerm (namedArg arg)) -    A.Proj _ f -> pure $ Def (headAmbQ f) []   -- only for printing so we don't have to worry too much here-    A.PatternSyn f -> pure $ Def (headAmbQ f) []-    A.Macro f      -> pure $ Def f []+    A.Proj _ f       -> pure $ Def (headAmbQ f) []   -- only for printing so we don't have to worry too much here+    A.PatternSyn f   -> pure $ Def (headAmbQ f) []+    A.Macro f        -> pure $ Def f [] -    A.WithApp{}      -> notAllowed "with application"-    A.QuestionMark{} -> notAllowed "holes"-    A.Underscore{}   -> notAllowed "metavariables"-    A.Lam{}          -> notAllowed "lambdas"-    A.AbsurdLam{}    -> notAllowed "lambdas"-    A.ExtendedLam{}  -> notAllowed "lambdas"-    _                -> typeError $ GenericError $ "TODO: exprToTerm " ++ show e+    A.WithApp{}      -> fail "with application"+    A.QuestionMark{} -> fail "hole"+    A.Underscore{}   -> fail "metavariable"+    A.Dot{}          -> fail "dotted expression"+    A.Lam{}          -> fail "lambda"+    A.AbsurdLam{}    -> fail "lambda"+    A.ExtendedLam{}  -> fail "lambda"+    A.Fun{}          -> fail "function type"+    A.Pi{}           -> fail "function type"+    A.Generalized{}  -> __IMPOSSIBLE__+    A.Let{}          -> fail "let"+    A.Rec{}          -> fail "record"+    A.RecUpdate{}    -> fail "record update"+    A.ScopedExpr{}   -> __IMPOSSIBLE__+    A.Quote{}        -> fail "quotation"+    A.QuoteTerm{}    -> fail "quotation"+    A.Unquote{}      -> fail "unquote"+    A.DontCare{}     -> __IMPOSSIBLE__   where-    notAllowed s = typeError $ GenericError $ "Not allowed in DISPLAY pragma right-hand side: " ++ s+    fail = throwError . ("its right-hand side contains a " ++)  renumberElims :: Nat -> Elims -> Elims renumberElims n es = evalState (renumbers es) n
src/full/Agda/TypeChecking/Rules/LHS.hs view
@@ -5,7 +5,7 @@   , LHSResult(..)   , bindAsPatterns   , IsFlexiblePattern(..)-  , DataOrRecord(..)+  , DataOrRecord   , checkSortOfSplitVar   ) where @@ -14,10 +14,9 @@ import Data.Function (on) import Data.Maybe -import Control.Arrow (left, second)-import Control.Monad-import Control.Monad.Except-import Control.Monad.Reader+import Control.Arrow (left)+import Control.Monad.Except       ( MonadError(..), ExceptT(..), runExceptT )+import Control.Monad.Reader       ( MonadReader(..), asks, runReaderT ) import Control.Monad.Writer       ( MonadWriter(..), runWriterT ) import Control.Monad.Trans.Maybe @@ -35,13 +34,13 @@ import Agda.Interaction.Options import Agda.Interaction.Options.Lenses -import Agda.Syntax.Internal as I hiding (DataOrRecord(..))+import Agda.Syntax.Internal as I hiding (DataOrRecord) import Agda.Syntax.Internal.Pattern import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Views (asView, deepUnscope) import Agda.Syntax.Concrete (FieldAssignment'(..),LensInScope(..)) import Agda.Syntax.Common as Common-import Agda.Syntax.Info as A+import qualified Agda.Syntax.Info as A import Agda.Syntax.Literal import Agda.Syntax.Position @@ -63,17 +62,18 @@ import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records hiding (getRecordConstructor) import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Sort import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope import Agda.TypeChecking.Telescope.Path import Agda.TypeChecking.Primitive hiding (Nat)+import Agda.TypeChecking.Warnings (warning)  import {-# SOURCE #-} Agda.TypeChecking.Rules.Term (checkExpr, isType_) import Agda.TypeChecking.Rules.LHS.Problem import Agda.TypeChecking.Rules.LHS.ProblemRest import Agda.TypeChecking.Rules.LHS.Unify import Agda.TypeChecking.Rules.LHS.Implicit-import Agda.TypeChecking.Rules.Data  import Agda.Utils.CallStack ( HasCallStack, withCallerCallStack ) import Agda.Utils.Function@@ -81,25 +81,27 @@ import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.List1 (List1, pattern (:|))-import qualified Agda.Utils.List  as List+import Agda.Utils.List2 (pattern List2) import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Pretty (prettyShow)+import qualified Agda.Syntax.Common.Pretty as P+import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Tuple  import Agda.Utils.Impossible+import Agda.TypeChecking.Free (freeIn) ---UNUSED Liang-Ting Chen 2019-07-16----- | Compute the set of flexible patterns in a list of patterns. The result is-----   the deBruijn indices of the flexible patterns.---flexiblePatterns :: [NamedArg A.Pattern] -> TCM FlexibleVars---flexiblePatterns nps = do---  forMaybeM (zip (downFrom $ length nps) nps) $ \ (i, Arg ai p) -> do---    runMaybeT $ (\ f -> FlexibleVar (getHiding ai) (getOrigin ai) f (Just i) i) <$> maybeFlexiblePattern p+-- | Extra read-only state for the LHS checker.+--+data LHSContext = LHSContext+  { lhsRange       :: Range  -- ^ The range of the whole lhs of a clause.+  , lhsContextSize :: Nat    -- ^ Original size of the context in which the lhs checker runs.+  }  -- | A pattern is flexible if it is dotted or implicit, or a record pattern --   with only flexible subpatterns.@@ -129,7 +131,6 @@         ifM (isNothing <$> isRecordConstructor c) (return OtherFlex) {-else-}             (maybeFlexiblePattern qs)       A.LitP{}  -> return OtherFlex-      A.AnnP _ _ p -> maybeFlexiblePattern p       _ -> mzero  instance IsFlexiblePattern (I.Pattern' a) where@@ -193,15 +194,11 @@     updates = concat <.> traverse update      update :: ProblemEq -> TCM [ProblemEq]-    update eq@(ProblemEq A.WildP{} _ _) = return []-    update eq@(ProblemEq p@A.ProjP{} _ _) = typeError $ IllformedProjectionPattern p+    update eq@(ProblemEq A.WildP{} _ _) = return [eq]+    update eq@(ProblemEq p@A.ProjP{} _ _) = typeError $ IllformedProjectionPatternAbstract p     update eq@(ProblemEq p@(A.AsP info x p') v a) =       (ProblemEq (A.VarP x) v a :) <$> update (ProblemEq p' v a) -    update eq@(ProblemEq p@(A.AnnP _ _ A.WildP{}) v a) = return [eq]-    update eq@(ProblemEq p@(A.AnnP info ty p') v a) =-      (ProblemEq (A.AnnP info ty (A.WildP patNoRange)) v a :) <$> update (ProblemEq p' v a)-     update eq@(ProblemEq p v a) = reduce v >>= constructorForm >>= \case       Con c ci es -> do         let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es@@ -219,7 +216,6 @@         p <- expandLitPattern p         case p of           A.AsP{} -> __IMPOSSIBLE__-          A.AnnP{} -> __IMPOSSIBLE__           A.ConP cpi ambC ps -> do             (c',_) <- disambiguateConstructor ambC d pars @@ -234,29 +230,20 @@               "insertImplicitPatternsT returned" <+> fsep (map prettyA ps)              -- Check argument count and hiding (not just count: #3074)-            let checkArgs [] [] = return ()-                checkArgs (p : ps) (v : vs)-                  | getHiding p == getHiding v = checkArgs ps vs-                  | otherwise                  = setCurrentRange p $ genericDocError =<< do-                      fsep $ pwords ("Expected an " ++ which (getHiding v) ++ " argument " ++-                                     "instead of "  ++ which (getHiding p) ++ " argument") ++-                             [ prettyA p ]-                  where which NotHidden  = "explicit"-                        which Hidden     = "implicit"-                        which Instance{} = "instance"-                checkArgs [] vs = genericDocError =<< do-                    fsep $ pwords "Too few arguments to constructor" ++ [prettyTCM c <> ","] ++-                           pwords ("expected " ++ show n ++ " more explicit "  ++ arguments)-                  where n = length (filter visible vs)-                        arguments | n == 1    = "argument"-                                  | otherwise = "arguments"-                checkArgs (p : _) [] = setCurrentRange p $ genericDocError =<< do-                  fsep $ pwords "Too many arguments to constructor" ++ [prettyTCM c]-            checkArgs ps vs+            let checkArgs [] [] _ _ = return ()+                checkArgs (p : ps) (v : vs) nExpected nActual+                  | getHiding p == getHiding v = checkArgs ps vs (nExpected + 1) (nActual + 1)+                  | otherwise                  = setCurrentRange p $ typeError WrongHidingInLHS+                checkArgs [] vs nExpected nActual = typeError $+                  WrongNumberOfConstructorArguments (conName c) (nExpected + length vs) nActual+                checkArgs (p : ps) [] nExpected nActual = setCurrentRange p $ typeError $+                  WrongNumberOfConstructorArguments (conName c) nExpected (nActual + 1 + (length ps)) +            checkArgs ps vs 0 0+             updates $ zipWith3 ProblemEq (map namedArg ps) (map unArg vs) bs -          A.RecP pi fs -> do+          A.RecP _ _ fs -> do             axs <- map argFromDom . recFields . theDef <$> getConstInfo d              -- Andreas, 2018-09-06, issue #3122.@@ -268,7 +255,7 @@              -- In fs omitted explicit fields are replaced by underscores,             -- and the fields are put in the correct order.-            ps <- insertMissingFieldsFail d (const $ A.WildP patNoRange) fs cxs+            ps <- insertMissingFieldsFail d (const $ A.WildP empty) fs cxs              -- We also need to insert missing implicit or instance fields.             ps <- insertImplicitPatterns ExpandLast ps ctel@@ -317,7 +304,6 @@     isSolved A.AbsurdP{}     = True     -- recursive cases     isSolved (A.AsP _ _ p)   = isSolved p-    isSolved (A.AnnP _ _ p)  = isSolved p     -- impossible:     isSolved A.ProjP{}       = __IMPOSSIBLE__     isSolved A.DefP{}        = __IMPOSSIBLE__@@ -340,7 +326,6 @@    A.DotP        {} -> return ()    A.EqualP      {} -> return ()    A.AsP _ _ p      -> noShadowingOfConstructors $ problem { problemInPat = p }-   A.AnnP _ _ p     -> noShadowingOfConstructors $ problem { problemInPat = p }    A.ConP        {} -> __IMPOSSIBLE__    A.RecP        {} -> __IMPOSSIBLE__    A.ProjP       {} -> __IMPOSSIBLE__@@ -359,46 +344,43 @@       , nest 2 $ "position of variable =" <+> (text . show) (getRange x)       ]     reportSDoc "tc.lhs.shadow" 70 $ nest 2 $ "a =" <+> pretty a-    a <- reduce a-    case a of-      Def t _ -> do-        d <- theDef <$> getConstInfo t-        case d of-          Datatype { dataCons = cs } -> do-            case filter ((A.nameConcrete x ==) . A.nameConcrete . A.qnameName) cs of-              []      -> return ()-              (c : _) -> setCurrentRange x $-                typeError $ PatternShadowsConstructor (nameConcrete x) c-          AbstractDefn{} -> return ()++    -- Get a conflicting data or record constructor, if any.+    mc <- runMaybeT do++      -- Is the type of the pattern variable a data or pattern record type?+      a  <- lift $ reduce a+      (d, dr) <- MaybeT $ isDataOrRecord a+      guard $ patternMatchingAllowed dr++      -- Look for a constructor with the same name as the pattern variable.+      cs <- lift $ getConstructors d+      MaybeT $ pure $ List.find ((A.nameConcrete x ==) . A.nameConcrete . A.qnameName) cs++    -- Alert if there is a constructor of the same name.+    whenJust mc \ c -> setCurrentRange x $+      warning $ PatternShadowsConstructor (nameConcrete x) c+    --+    -- Andreas, 2023-09-08, issue #6829:+    -- I rewrote the code originally dating from 2009, commit:+    -- https://github.com/agda/agda/commit/5d5095ba080b04f16867d4ed5af4ba7091f1a773+    -- The code survived for almost 15 years, but it slept through the advent+    -- of matchable record constructors in 2010 (Agda 2.2.8):+    -- https://github.com/agda/agda/blob/283730b392d7c21c54b53b0f486802ec143e4af7/doc/release-notes/2.2.8.md#L7-L9+    -- Here are comments on the last version of the code I'd like to preserve,+    -- as they reflect some considerations and design decisions:+    --             -- Abstract constructors cannot be brought into scope,             -- even by a bigger import list.             -- Thus, they cannot be confused with variables.             -- Alternatively, we could do getConstInfo in ignoreAbstractMode,             -- then Agda would complain if a variable shadowed an abstract constructor.-          Axiom       {} -> return ()-          DataOrRecSig{} -> return ()-          Function    {} -> return ()-          Record      {} -> return ()-          Constructor {} -> __IMPOSSIBLE__-          GeneralizableVar{} -> __IMPOSSIBLE__           -- TODO: in the future some stuck primitives might allow constructors-          Primitive   {} -> return ()-          PrimitiveSort{} -> return ()-      Var   {} -> return ()-      Pi    {} -> return ()-      Sort  {} -> return ()-      MetaV {} -> return ()       -- TODO: If the type is a meta-variable, should the test be       -- postponed? If there is a problem, then it will be caught when       -- the completed module is type checked, so it is safe to skip       -- the test here. However, users may be annoyed if they get an       -- error in code which has already passed the type checker.-      Lam   {} -> __IMPOSSIBLE__-      Lit   {} -> __IMPOSSIBLE__-      Level {} -> __IMPOSSIBLE__-      Con   {} -> __IMPOSSIBLE__-      DontCare{} -> __IMPOSSIBLE__-      Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s  -- | Check that a dot pattern matches it's instantiation. checkDotPattern :: DotPattern -> TCM ()@@ -468,26 +450,26 @@     transfer :: A.Pattern -> DeBruijnPattern -> TCM DeBruijnPattern     transfer p q = case (asView p , q) of -      ((asB , anns , A.ConP pi _ ps) , ConP c (ConPatternInfo i r ft mb l) qs) -> do+      ((asB , A.ConP pi _ ps) , ConP c (ConPatternInfo i r ft mb l) qs) -> do         let cpi = ConPatternInfo (PatternInfo PatOCon asB) r ft mb l         ConP c cpi <$> transfers ps qs -      ((asB , anns , A.RecP pi fs) , ConP c (ConPatternInfo i r ft mb l) qs) -> do+      ((asB , A.RecP _kwr pi fs) , ConP c (ConPatternInfo i r ft mb l) qs) -> do         let Def d _  = unEl $ unArg $ fromMaybe __IMPOSSIBLE__ mb             axs = map (nameConcrete . qnameName . unArg) (conFields c) `withArgsFrom` qs             cpi = ConPatternInfo (PatternInfo PatORec asB) r ft mb l-        ps <- insertMissingFieldsFail d (const $ A.WildP patNoRange) fs axs+        ps <- insertMissingFieldsFail d (const $ A.WildP empty) fs axs         ConP c cpi <$> transfers ps qs -      ((asB , anns , p) , ConP c (ConPatternInfo i r ft mb l) qs) -> do+      ((asB , p) , ConP c (ConPatternInfo i r ft mb l) qs) -> do         let cpi = ConPatternInfo (PatternInfo (patOrig p) asB) r ft mb l         return $ ConP c cpi qs -      ((asB , anns , p) , VarP _ x) -> return $ VarP (PatternInfo (patOrig p) asB) x+      ((asB , p) , VarP _ x) -> return $ VarP (PatternInfo (patOrig p) asB) x -      ((asB , anns , p) , DotP _ u) -> return $ DotP (PatternInfo (patOrig p) asB) u+      ((asB , p) , DotP _ u) -> return $ DotP (PatternInfo (patOrig p) asB) u -      ((asB , anns , p) , LitP _ l) -> return $ LitP (PatternInfo (patOrig p) asB) l+      ((asB , p) , LitP _ l) -> return $ LitP (PatternInfo (patOrig p) asB) l        _ -> return q @@ -505,7 +487,6 @@     patOrig A.DefP{}        = __IMPOSSIBLE__     patOrig A.PatternSynP{} = __IMPOSSIBLE__     patOrig A.WithP{}       = __IMPOSSIBLE__-    patOrig A.AnnP{}        = __IMPOSSIBLE__      matchingArgs :: NamedArg A.Pattern -> NamedArg DeBruijnPattern -> Bool     matchingArgs p q@@ -557,9 +538,6 @@               check (Map.insert x (u,unDom a) vars) eqs         A.AsP _ x p ->           check vars $ [ProblemEq (A.VarP x) u a, ProblemEq p u a] ++ eqs-        A.AnnP _ _ A.WildP{} -> continue-        A.AnnP r t p -> (ProblemEq (A.AnnP r t (A.WildP patNoRange)) u a:) <$>-          check vars (ProblemEq p u a : eqs)         A.WildP{}       -> continue         A.DotP{}        -> continue         A.AbsurdP{}     -> continue@@ -587,7 +565,7 @@     go cxt _ []        EmptyTel = return cxt     go cxt taken (x : xs) tel0@(ExtendTel a tel) = do         name <- maybe (dummyName taken $ absName tel) return x-        let e = (name,) <$> a+        let e = CtxVar name a         go (e : cxt) (name : taken) xs (absBody tel)      dummyName taken s =@@ -597,21 +575,20 @@ -- | Bind as patterns bindAsPatterns :: [AsBinding] -> TCM a -> TCM a bindAsPatterns []                ret = ret-bindAsPatterns (AsB x v a m : asb) ret = do+bindAsPatterns (AsB x v a : asb) ret = do   reportSDoc "tc.lhs.as" 10 $ "as pattern" <+> prettyTCM x <+>     sep [ ":" <+> prettyTCM a         , "=" <+> prettyTCM v         ]-  addLetBinding (setModality m defaultArgInfo) x v a $ bindAsPatterns asb ret+  addLetBinding' Inserted x v a $ bindAsPatterns asb ret  -- | Since with-abstraction can change the type of a variable, we have to --   recheck the stripped with patterns when checking a with function. recheckStrippedWithPattern :: ProblemEq -> TCM ()-recheckStrippedWithPattern (ProblemEq p v a) = checkInternal v CmpLeq (unDom a)-  `catchError` \_ -> typeError . GenericDocError =<< vcat-    [ "Ill-typed pattern after with abstraction: " <+> prettyA p-    , "(perhaps you can replace it by `_`?)"-    ]+recheckStrippedWithPattern (ProblemEq p v a)+  | A.WildP{} <- p = return ()+  | otherwise      = checkInternal v CmpLeq (unDom a)+      `catchError` \_ -> typeError $ IllTypedPatternAfterWithAbstraction p  -- | Result of checking the LHS of a clause. data LHSResult = LHSResult@@ -639,10 +616,12 @@     -- (Issue 2303).   , lhsPartialSplit :: IntSet     -- ^ have we done a partial split?+  , lhsIndexedSplit :: Bool+    -- ^ have we split on an indexed type?   }  instance InstantiateFull LHSResult where-  instantiateFull' (LHSResult n tel ps abs t sub as psplit) = LHSResult n+  instantiateFull' (LHSResult n tel ps abs t sub as psplit ixsplit) = LHSResult n     <$> instantiateFull' tel     <*> instantiateFull' ps     <*> instantiateFull' abs@@ -650,6 +629,7 @@     <*> instantiateFull' sub     <*> instantiateFull' as     <*> pure psplit+    <*> pure ixsplit  -- | Check a LHS. Main function. --@@ -660,6 +640,8 @@ checkLeftHandSide :: forall a.      Call      -- ^ Trace, e.g. 'CheckLHS' or 'CheckPattern'.+  -> Range+     -- ^ 'Range' of the entire left hand side, for error reporting.   -> Maybe QName      -- ^ The name of the definition we are checking.   -> [NamedArg A.Pattern]@@ -674,26 +656,26 @@   -> (LHSResult -> TCM a)      -- ^ Continuation.   -> TCM a-checkLeftHandSide call f ps a withSub' strippedPats =+checkLeftHandSide call lhsRng f ps a withSub' strippedPats =  Bench.billToCPS [Bench.Typing, Bench.CheckLHS] $  traceCallCPS call $ \ ret -> do    -- To allow module parameters to be refined by matching, we're adding the   -- context arguments as wildcard patterns and extending the type with the   -- context telescope.-  cxt <- map (setOrigin Inserted) . reverse <$> getContext-  let tel = telFromList' prettyShow cxt-      cps = [ unnamed . A.VarP . A.mkBindName . fst <$> argFromDom d-            | d <- cxt ]+  cxt <- map (setOrigin Inserted) <$> getContext+  let tel = contextToTel cxt+      cps = [ argFromDom dom $> unnamed (A.VarP $ A.mkBindName $ unDom dom)+            | (_,dom) <- contextVars cxt ]       eqs0 = zipWith3 ProblemEq (map namedArg cps) (map var $ downFrom $ size tel) (flattenTel tel)    let finalChecks :: LHSState a -> TCM a-      finalChecks (LHSState delta qs0 (Problem eqs rps _) b psplit) = do+      finalChecks (LHSState delta qs0 (Problem eqs rps _) b psplit ixsplit) = do          reportSDoc "tc.lhs.top" 20 $ vcat           [ "lhs: final checks with remaining equations"-          , nest 2 $ if null eqs then "(none)" else addContext delta $ vcat $ map prettyTCM eqs-          , "qs0 =" <+> addContext delta (prettyTCMPatternList qs0)+          , nest 4 $ if null eqs then "(none)" else addContext delta $ vcat $ map prettyTCM eqs+          , nest 2 $ "qs0 =" <+> addContext delta (prettyTCMPatternList qs0)           ]          unless (null rps) __IMPOSSIBLE__@@ -701,7 +683,30 @@         addContext delta $ do           mapM_ noShadowingOfConstructors eqs +          -- When working --without-K or --cubical-compatible, we have+          -- to check that the target type can be used at the “ambient”+          -- modality. For --cubical-compatible, this just improves an+          -- error message (printing the type rather than the generated+          -- RHS). For --without-K, it implements the same check without+          -- necessarily generating --cubical code.+          -- The reason for this check is that a clause+          --    foo : x ≡ y → ... → T y+          --    foo refl ... = ...+          -- in Cubical mode, gets elaborated to an extra clause of the+          -- form+          --    foo (transp p φ x) ... = transp (λ i → T (p i)) φ (foo x ...)+          -- (approximately), where T is the target type. That is: to+          -- implement the substitution T[y/x], we use an actual+          -- transport. See #5448.+         arity_a <- arityPiPath a++        reportSDoc "tc.lhs.top" 30 $ vcat+          [ nest 2 $ "a        =" <+> prettyTCM a+          , nest 2 $ "arity_a  =" <+> prettyTCM arity_a+          , nest 2 $ "withSub' =" <+> prettyTCM withSub'+          ]+         -- Compute substitution from the out patterns @qs0@         let notProj ProjP{} = False             notProj _       = True@@ -761,14 +766,14 @@             asb          = asb0 ++ asb1          -- Rename internal patterns with these names-        let makeVar     = maybe deBruijnVar $ debruijnNamedVar . nameToArgName+        let makeVar     = maybe deBruijnVar $ deBruijnNamedVar . nameToArgName             ren         = parallelS $ zipWith makeVar (reverse vars) [0..]          qs <- transferOrigins (cps ++ ps) $ applySubst ren qs0          let hasAbsurd = not . null $ absurds -        let lhsResult = LHSResult (length cxt) delta qs hasAbsurd b patSub asb (IntSet.fromList $ catMaybes psplit)+        let lhsResult = LHSResult (length cxt) delta qs hasAbsurd b patSub asb (IntSet.fromList $ catMaybes psplit) ixsplit          -- Debug output         reportSDoc "tc.lhs.top" 10 $@@ -779,11 +784,13 @@                  , "asb     = " <+> addContext delta (brackets $ fsep $ punctuate comma $ map prettyTCM asb)                  , "absurds = " <+> addContext delta (brackets $ fsep $ punctuate comma $ map prettyTCM absurds)                  , "qs      = " <+> addContext delta (prettyList $ map pretty qs)+                 , "b       = " <+> addContext delta (prettyTCM b)                  ]                ]         reportSDoc "tc.lhs.top" 30 $           nest 2 $ vcat                  [ "vars   = " <+> pretty vars+                 , "b      = " <+> pretty b                  ]         reportSDoc "tc.lhs.top" 20 $ nest 2 $ "withSub  = " <+> pretty withSub         reportSDoc "tc.lhs.top" 20 $ nest 2 $ "weakSub  = " <+> pretty weakSub@@ -822,9 +829,113 @@   let st = over (lhsProblem . problemEqs) (++ withEqs) st0    -- doing the splits:-  (result, block) <- unsafeInTopContext $ runWriterT $ (`runReaderT` (size cxt)) $ checkLHS f st+  let initLHSContext = LHSContext { lhsRange = lhsRng, lhsContextSize = size cxt }+  (result, block) <- unsafeInTopContext $ runWriterT $ (`runReaderT` initLHSContext) $ checkLHS f st   return result +-- | Check that this split will generate a modality-correct internal+-- clause when --cubical-compatible is used. This means that the type of+-- anything which might be transported must be modality-correct. This is+-- necessarily an approximate check. We assume that any argument which+-- (a) comes after and (b) mentions a dotted argument will be+-- transported, which is probably an overestimate.+conSplitModalityCheck ::+     Range+       -- ^ Range of the whole left hand side, for error reporting.+  -> Modality+       -- ^ Modality to check at.+  -> PatternSubstitution+      -- ^ Substitution resulting from index unification. @Γ ⊢ ρ : Δ'@,+      -- where @Δ'@ is the context we're in, and @Γ@ is the clause telescope+      -- before unification.+  -> Int       -- ^ Variable @x@ at which we split.+  -> Telescope -- ^ The telescope @Γ@ itself.+  -> Type      -- ^ Target type of the clause.+  -> TCM ()+conSplitModalityCheck lhsRng mod rho blocking gamma target = when (any ((/= defaultModality) . getModality) gamma) $ do+  reportSDoc "tc.lhs.top" 30 $ vcat+    [ "LHS modality check for modality: " <+> prettyTCM mod+    , "rho:    " <+> inTopContext (prettyTCM rho)+    , "gamma:  " <+> inTopContext (prettyTCM gamma)+    , "target: " <+> prettyTCM target+    , "target (raw): " <+> pretty target+    , "Δ'target: " <+> prettyTCM (applyPatSubst rho target)+    , "blocking:" <+> prettyTCM blocking+    ]+  whenJust (firstForced rho (length gamma)) \ ix -> do+      -- We've found a forced argument. This means that the unifier has+      -- decided to kill a unification variable, and any of its+      -- occurrences in the generated term will be replaced by an+      -- occurrence of a path, and any terms whose types mention that+      -- variable will be transported.+      let+        (gamma0, delta) = splitTelescopeAt (length gamma - ix) gamma+        name = inTopContext . addContext gamma . nameOfBV+        delta'target = applyPatSubst rho target+      reportSDoc "tc.lhs.top" 30 $ vcat+        [ "found forced argument!"+        , "forced: " <+> prettyTCM ix+        , "before: " <+> inTopContext (prettyTCM gamma0)+        , "after:  " <+> inTopContext (addContext gamma0 (prettyTCM delta))+        ]+      forced <- name ix+      forM_ (zip [ix - 1, ix - 2 ..] (telToList delta)) $ \(arg, d) -> do+        -- Example: The first argument after the first forced variable. So+        -- we have e.g.:+        --   Γ = Γ₀.x.Δ+        --   Δ' ⊢ ρ : Γ₀.x.Δ+        --   Γ₀ ⊢ x : Type+        -- but we need+        --   Δ' ⊢ x : Type,+        -- since Δ' is the context we are in. Then we have+        --   Γ ⊢ x[wkS |Δ|] : Type+        -- and consequently+        --   Δ' ⊢ x[wkS |Δ|][ρ] : Type+        let+          rho' = composeS rho (wkS (arg + 1) idS)+        ty' <- reduce (applyPatSubst rho' (unEl (snd (unDom d))))+        let+          -- It's actually rather tricky to know when, exactly, a+          -- transport will be needed in a position that forces an+          -- usable-at-modality check. Our current heuristic is:+          --+          -- The variable we're looking at has a fibrant type, with the+          -- first forced variable free.+          -- The variable appears free in the result type.+          docheck = and+            [ ix `freeIn` applySubst (wkS (arg + 1) idS) (unEl (snd (unDom d)))+            , arg /= blocking+            , arg `freeIn` target+            ]+        reportSDoc "tc.lhs.top" 30 $ vcat+          [ "arg:        " <+> pretty arg+          , "arg type:   " <+> prettyTCM (applySubst (wkS (arg + 1) idS) (unEl (snd (unDom d))))+          , "check       " <+> pretty docheck+          ]+        argn <- name arg+        when docheck $+          usableAtModality (IndexedClauseArg forced argn) mod ty'++  -- ALways check the target clause type. Specifically, we check it both+  -- in Δ' and in Γ. The check in Δ' will sometimes let slip by a+  -- quantity violation which is masked by an indexed match (recall that+  -- the unifier likes to replace @0-variables for @ω-variables). A+  -- concrete case where this happens is #5468. Check in Δ' first since+  -- that will have the forced variable names.+  setCurrentRange lhsRng do+    usableAtModality IndexedClause mod (unEl (applyPatSubst rho target))+    inTopContext $ addContext gamma $ usableAtModality IndexedClause mod (unEl target)+  where+    -- Find the first dotted pattern in the substitution. "First" =+    -- "earliest bound", so counts down from the length of the+    -- telescope.+    firstForced :: PatternSubstitution -> Int -> Maybe Int+    firstForced pat level+      | level >= 0 = case lookupS pat level of+        DotP{} -> Just level+        _ -> firstForced pat (level - 1)+      | otherwise = Nothing+ -- | Determine which splits should be tried. splitStrategy :: [ProblemEq] -> [ProblemEq] splitStrategy = filter shouldSplit@@ -842,7 +953,6 @@       A.AbsurdP{} -> False        A.AsP _ _ p  -> shouldSplit $ problem { problemInPat = p }-      A.AnnP _ _ p -> shouldSplit $ problem { problemInPat = p }        A.ProjP{}       -> __IMPOSSIBLE__       A.DefP{}        -> __IMPOSSIBLE__@@ -851,15 +961,14 @@   -- | The loop (tail-recursive): split at a variable in the problem until problem is solved-checkLHS-  :: forall tcm a. (MonadTCM tcm, PureTCM tcm, MonadWriter Blocked_ tcm, MonadError TCErr tcm, MonadTrace tcm, MonadReader Nat tcm)+checkLHS :: forall tcm a. (MonadTCM tcm, PureTCM tcm, MonadWriter Blocked_ tcm, MonadError TCErr tcm, MonadTrace tcm, MonadReader LHSContext tcm)   => Maybe QName      -- ^ The name of the definition we are checking.   -> LHSState a       -- ^ The current state.   -> tcm a checkLHS mf = updateModality checkLHS_ where     -- If the target type is irrelevant or in Prop,     -- we need to check the lhs in irr. cxt. (see Issue 939).- updateModality cont st@(LHSState tel ip problem target psplit) = do+ updateModality cont st@(LHSState tel ip problem target psplit _) = do       let m = getModality target       applyModalityToContext m $ do         cont $ over (lhsTel . listTel)@@ -867,9 +976,10 @@         -- Andreas, 2018-10-23, issue #3309         -- the modalities in the clause telescope also need updating. - checkLHS_ st@(LHSState tel ip problem target psplit) = do-  reportSDoc "lhs" 10 $ "tel is" <+> prettyTCM tel-  reportSDoc "lhs" 10 $ "ip is" <+> pretty ip+ checkLHS_ st@(LHSState tel ip problem target psplit ixsplit) = do+  reportSDoc "tc.lhs" 40 $ "tel is" <+> prettyTCM tel+  reportSDoc "tc.lhs" 40 $ "ip is" <+> pretty ip+  reportSDoc "tc.lhs" 40 $ "target is" <+> addContext tel (prettyTCM target)   if isSolvedProblem problem then     liftTCM $ (problem ^. problemCont) st   else do@@ -879,7 +989,7 @@      unlessM (optPatternMatching <$> getsTC getPragmaOptions) $       unless (problemAllVariables problem) $-        typeError $ GenericError $ "Pattern matching is disabled"+        typeError NeedOptionPatternMatching      let splitsToTry = splitStrategy $ problem ^. problemEqs @@ -919,17 +1029,16 @@       i <- liftTCM $ addContext tel $ ifJustM (isEtaVar v a) return $              softTypeError $ SplitOnNonVariable v a -      let pos = size tel - (i+1)+      let pos = size tel - (i + 1)           (delta1, tel'@(ExtendTel dom adelta2)) = splitTelescopeAt pos tel -- TODO:: tel' defined but not used -      p <- liftTCM $ expandLitPattern p+      p <- expandLitPattern p       let splitOnPat = \case             (A.LitP _ l)      -> splitLit delta1 dom adelta2 l             p@A.RecP{}        -> splitCon delta1 dom adelta2 p Nothing             p@(A.ConP _ c ps) -> splitCon delta1 dom adelta2 p $ Just c             p@(A.EqualP _ ts) -> splitPartial delta1 dom adelta2 ts             A.AsP _ _ p       -> splitOnPat p-            A.AnnP _ _ p      -> splitOnPat p              A.VarP{}        -> __IMPOSSIBLE__             A.WildP{}       -> __IMPOSSIBLE__@@ -965,13 +1074,11 @@         addContext tel $ disambiguateProjection h ambProjName target        unless comatchingAllowed $ do-        hardTypeError . GenericDocError =<< do-          liftTCM $ "Copattern matching is disabled for record" <+> prettyTCM recName+        hardTypeError $ ComatchingDisabledForRecord recName        -- Compute the new rest type by applying the projection type to 'self'.       -- Note: we cannot be in a let binding.-      f <- ifJust mf return $ hardTypeError $-             GenericError "Cannot use copatterns in a let binding"+      let f = fromMaybe __IMPOSSIBLE__ mf       let self = Def f $ patternsToElims ip       target' <- traverse (`piApplyM` self) projType @@ -980,8 +1087,8 @@                        Arg ai $ Named Nothing (ProjP orig projName)           ip'      = ip ++ [projP]           -- drop the projection pattern (already splitted)-          problem' = over problemRestPats tail problem-      liftTCM $ updateLHSState (LHSState tel ip' problem' target' psplit)+          problem' = over problemRestPats (drop 1) problem+      liftTCM $ updateLHSState (LHSState tel ip' problem' target' psplit ixsplit)       -- Split a Partial.@@ -1034,16 +1141,21 @@     --   sigma = fails because several substitutions [[1/i],[1/j]] correspond to phi     -- @ -    splitPartial :: Telescope     -- The types of arguments before the one we split on-                 -> Dom Type      -- The type of the argument we split on-                 -> Abs Telescope -- The types of arguments after the one we split on-                 -> [(A.Expr, A.Expr)] -- [(φ₁ = b1),..,(φn = bn)]-                 -> ExceptT TCErr tcm (LHSState a)+    splitPartial ::+         Telescope+            -- The types of arguments before the one we split on.+      -> Dom Type+            -- The type of the argument we split on.+      -> Abs Telescope+            -- The types of arguments after the one we split on.+      -> List1 (A.Expr, A.Expr)+            -- [(φ₁ = b1),..,(φn = bn)]+      -> ExceptT TCErr tcm (LHSState a)+     splitPartial delta1 dom adelta2 ts = do -      unless (domFinite dom) $ liftTCM $ addContext delta1 $-        softTypeError . GenericDocError =<<-        hsep [ "Not a finite domain:" , prettyTCM $ unDom dom ]+      unless (domIsFinite dom) $ liftTCM $ addContext delta1 $+        softTypeError $ SplitOnPartial dom        tInterval <- liftTCM $ primIntervalType @@ -1069,7 +1181,7 @@       --             newContext = Γ Ξ       --             cpSub = raiseS |Ξ|       ---      lhsCxtSize <- ask -- size of the context before checkLHS call.+      lhsCxtSize <- asks lhsContextSize -- size of the context before checkLHS call.       reportSDoc "tc.lhs.split.partial" 10 $ "lhsCxtSize =" <+> prettyTCM lhsCxtSize        newContext <- liftTCM $ computeLHSContext names delta1@@ -1078,40 +1190,28 @@       let cpSub = raiseS $ size newContext - lhsCxtSize        (gamma,sigma) <- liftTCM $ updateContext cpSub (const newContext) $ do-         ts <- forM ts $ \ (t,u) -> do+         ts <- forM ts $ \ (lhs, rhs) -> do                  reportSDoc "tc.lhs.split.partial" 10 $ "currentCxt =" <+> (prettyTCM =<< getContext)-                 reportSDoc "tc.lhs.split.partial" 10 $ text "t, u (Expr) =" <+> prettyTCM (t,u)-                 t <- checkExpr t tInterval-                 u <- checkExpr u tInterval+                 reportSDoc "tc.lhs.split.partial" 10 $ text "t, u (Expr) =" <+> prettyTCM (lhs, rhs)+                 t <- checkExpr lhs tInterval+                 u <- checkExpr rhs tInterval                  reportSDoc "tc.lhs.split.partial" 10 $ text "t, u        =" <+> pretty (t, u)-                 u <- intervalView =<< reduce u-                 case u of+                 reduce u >>= intervalView >>= \case                    IZero -> primINeg <@> pure t                    IOne  -> return t-                   _     -> typeError $ GenericError $ "Only 0 or 1 allowed on the rhs of face"+                   _     -> typeError $ ExpectedIntervalLiteral rhs          -- Example: ts = (i=0) (j=1) will result in phi = ¬ i & j-         phi <- case ts of-                   [] -> do-                     a <- reduce (unEl $ unDom dom)-                     -- builtinIsOne is defined, since this is a precondition for having Partial-                     isone <- fromMaybe __IMPOSSIBLE__ <$>  -- newline because of CPP-                       getBuiltinName' builtinIsOne-                     case a of-                       Def q [Apply phi] | q == isone -> return (unArg phi)-                       _           -> typeError . GenericDocError =<< do-                         prettyTCM a <+> " is not IsOne."--                   _  -> foldl (\ x y -> primIMin <@> x <@> y) primIOne (map pure ts)+         phi <- foldl (\ x y -> primIMin <@> x <@> y) primIOne (fmap pure ts)          reportSDoc "tc.lhs.split.partial" 10 $ text "phi           =" <+> prettyTCM phi          reportSDoc "tc.lhs.split.partial" 30 $ text "phi           =" <+> pretty phi          phi <- reduce phi          reportSDoc "tc.lhs.split.partial" 10 $ text "phi (reduced) =" <+> prettyTCM phi-         refined <- forallFaceMaps phi (\ bs m t -> typeError $ GenericError $ "face blocked on meta")-                            (\ sigma -> (,sigma) <$> getContextTelescope)+         refined <- forallFaceMaps phi (\ bs m t -> patternViolation m)+                            (\_ sigma -> (,sigma) <$> getContextTelescope)          case refined of            [(gamma,sigma)] -> return (gamma,sigma)-           []              -> typeError $ GenericError $ "The face constraint is unsatisfiable."-           _               -> typeError $ GenericError $ "Cannot have disjunctions in a face constraint."+           []              -> typeError FaceConstraintUnsatisfiable+           _               -> typeError FaceConstraintDisjunction       itisone <- liftTCM primItIsOne       -- substitute the literal in p1 and dpi       reportSDoc "tc.lhs.faces" 60 $ text $ show sigma@@ -1141,7 +1241,7 @@       -- Compute the new state       let problem' = set problemEqs eqs' problem       reportSDoc "tc.lhs.split.partial" 60 $ text (show problem')-      liftTCM $ updateLHSState (LHSState delta' ip' problem' target' (psplit ++ [Just o_n]))+      liftTCM $ updateLHSState (LHSState delta' ip' problem' target' (psplit ++ [Just o_n]) ixsplit)       splitLit :: Telescope      -- The types of arguments before the one we split on@@ -1174,13 +1274,16 @@       unlessM (splittableCohesion info) $         addContext delta1 $ softTypeError $ SplitOnUnusableCohesion dom +      unless (splittablePolarity (getModalPolarity info)) $+        addContext delta1 $ softTypeError $ SplitOnUnusablePolarity dom+       -- check that a is indeed the type of lit (otherwise fail softly)       -- if not, fail softly since it could be instantiated by a later split.-      suspendErrors $ equalType a =<< litType lit+      suspendErrors $ addContext delta1 $ equalType a =<< litType lit        -- Compute the new state       let problem' = set problemEqs eqs' problem-      liftTCM $ updateLHSState (LHSState delta' ip' problem' target' psplit)+      liftTCM $ updateLHSState (LHSState delta' ip' problem' target' psplit ixsplit)       splitCon :: Telescope      -- The types of arguments before the one we split on@@ -1223,20 +1326,34 @@       unlessM (splittableCohesion info) $         addContext delta1 $ softTypeError $ SplitOnUnusableCohesion dom +      unless (splittablePolarity (getModalPolarity info)) $+        addContext delta1 $ softTypeError $ SplitOnUnusablePolarity dom++      -- Should we attempt to compute a left inverse for this clause? When+      -- --cubical-compatible --flat-split is given, we don't generate a+      -- left inverse (at all). This means that, when the coverage checker+      -- gets to the clause this was in, it won't generate a (malformed!)+      -- transpX clause for @♭ matching.+      -- TODO(Amy): properly support transpX when @♭ stuff is in the+      -- context.+      let genTrx = boolToMaybe ((getCohesion info == Flat)) SplitOnFlat+       -- We should be at a data/record type-      (dr, d, pars, ixs) <- addContext delta1 $ isDataOrRecordType a+      (dr, d, s, pars, ixs) <- addContext delta1 $ isDataOrRecordType a       let isRec = case dr of             IsData{}   -> False             IsRecord{} -> True        checkMatchingAllowed d dr  -- No splitting on coinductive constructors.-      addContext delta1 $ checkSortOfSplitVar dr a delta2 (Just target) +      -- Issue #7503: use principal sort for checking if split is ok+      let a' = set lensSort s a+      addContext delta1 $ checkSortOfSplitVar dr a' delta2 (Just target)+       -- Jesper, 2019-09-13: if the data type we split on is a strict       -- set, we locally enable --with-K during unification.-      withKIfStrict <- reduce (getSort a) >>= \case-        SSet{} -> return $ locallyTC eSplitOnStrict $ const True-        _      -> return id+      withKIfStrict <- reduce (getSort a) <&> \ dsort ->+        applyWhen (isStrictDataSort dsort) $ locallyTC eSplitOnStrict $ const True        -- The constructor should construct an element of this datatype       (c :: ConHead, b :: Type) <- liftTCM $ addContext delta1 $ case ambC of@@ -1245,12 +1362,12 @@        -- Don't split on lazy (non-eta) constructor       case focusPat of-        A.ConP cpi _ _ | conPatLazy cpi == ConPatLazy ->+        A.ConP cpi _ _ | A.conPatLazy cpi == A.ConPatLazy ->           unlessM (isEtaRecord d) $ softTypeError $ ForcedConstructorNotInstantiated focusPat         _ -> return ()        -- The type of the constructor will end in an application of the datatype-      (TelV gamma (El _ ctarget), boundary) <- liftTCM $ telViewPathBoundaryP b+      (TelV gamma (El _ ctarget), boundary) <- liftTCM $ telViewPathBoundary b       let Def d' es' = ctarget           cixs = drop (size pars) $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es' @@ -1264,9 +1381,10 @@         A.ConP _ _ ps -> do           ps <- insertImplicitPatterns ExpandLast ps gamma           return $ useNamesFromPattern ps gamma-        A.RecP _ fs -> do-          axs <- map argFromDom . recordFieldNames . theDef <$> getConstInfo d-          ps <- insertMissingFieldsFail d (const $ A.WildP patNoRange) fs axs+        A.RecP _ _ fs -> do+          RecordDefn def <- theDef <$> getConstInfo d+          let axs = map argFromDom $ recordFieldNames def+          ps <- insertMissingFieldsFail d (const $ A.WildP empty) fs axs           ps <- insertImplicitPatterns ExpandLast ps gamma           return $ useNamesFromPattern ps gamma         _ -> __IMPOSSIBLE__@@ -1335,7 +1453,7 @@       -- Andrea 2019-07-17 propagate the Cohesion to the equation telescope       -- TODO: should we propagate the modality in general?       -- See also Coverage checking.-      da' <- do+      da' <- addContext delta1Gamma $ do              let updCoh = composeCohesion (getCohesion info)              TelV tel dt <- telView da'              return $ abstract (mapCohesion updCoh <$> tel) a@@ -1343,7 +1461,7 @@       let stuck b errs = softTypeError $ SplitError $             UnificationStuck b (conName c) (delta1 `abstract` gamma) cixs ixs' errs -      liftTCM (withKIfStrict $ unifyIndices delta1Gamma flex da' cixs ixs') >>= \case+      liftTCM (withKIfStrict $ unifyIndices genTrx delta1Gamma flex da' cixs ixs') >>= \case          -- Mismatch.  Report and abort.         NoUnify neg -> hardTypeError $ ImpossibleConstructor (conName c) neg@@ -1433,9 +1551,16 @@                      Quantity1{} -> __IMPOSSIBLE__                      Quantityω{} -> q +          unless (null ixs) $+            whenM (withoutKOption `or2M` cubicalCompatibleOption) $ do+              mod <- currentModality+              lhsRng <- asks lhsRange+              liftTCM $ addContext delta' $+                conSplitModalityCheck lhsRng mod rho (length delta2) tel (unArg target)+           -- if rest type reduces,           -- extend the split problem by previously not considered patterns-          st' <- liftTCM $ updateLHSState $ LHSState delta' ip' problem' target'' psplit+          st' <- liftTCM $ updateLHSState $ LHSState delta' ip' problem' target'' psplit (ixsplit || not (null ixs))            reportSDoc "tc.lhs.top" 12 $ sep             [ "new problem from rest"@@ -1455,9 +1580,8 @@   -> DataOrRecord  -- ^ Information about data or (co)inductive (no-)eta-equality record.   -> m () checkMatchingAllowed d = \case-  IsRecord ind eta-    | Just CoInductive <- ind -> typeError $-        GenericError "Pattern matching on coinductive types is not allowed"+  IsRecord InductionAndEta { recordInduction=ind, recordEtaEquality=eta }+    | Just CoInductive <- ind -> typeError SplitOnCoinductive     | not $ patternMatchingAllowed eta -> typeError $ SplitOnNonEtaRecord d     | otherwise -> return ()   IsData -> return ()@@ -1482,51 +1606,44 @@ hardTypeError :: (HasCallStack, MonadTCM m) => TypeError -> m a hardTypeError = withCallerCallStack $ \loc -> liftTCM . typeError' loc -data DataOrRecord-  = IsData-  | IsRecord-    { recordInduction   :: Maybe Induction-    , recordEtaEquality :: EtaEquality-    }-  deriving (Show)+type DataOrRecord = DataOrRecord' InductionAndEta  -- | Check if the type is a data or record type and return its name,---   definition, parameters, and indices. Fails softly if the type could become+--   definition, sort, parameters, and indices. Fails softly if the type could become --   a data/record type by instantiating a variable/metavariable, or fail hard --   otherwise. isDataOrRecordType   :: (MonadTCM m, PureTCM m)   => Type-  -> ExceptT TCErr m (DataOrRecord, QName, Args, Args)+  -> ExceptT TCErr m (DataOrRecord, QName, Sort, Args, Args)        -- ^ The 'Args' are parameters and indices.  isDataOrRecordType a0 = ifBlocked a0 blocked $ \case   ReallyNotBlocked -> \ a -> case unEl a of      -- Subcase: split type is a Def.-    Def d es -> liftTCM (theDef <$> getConstInfo d) >>= \case+    Def d es -> liftTCM (getConstInfo d) >>= \def -> case theDef def of -      Datatype{dataPars = np} -> do+      Datatype{dataPars = np, dataSort = s} -> do          whenM (isInterval a) $ hardTypeError =<< notData          let (pars, ixs) = splitAt np $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es-        return (IsData, d, pars, ixs)+        return (IsData, d, s, pars, ixs)        Record{ recInduction, recEtaEquality' } -> do         let pars = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-        return (IsRecord recInduction recEtaEquality', d, pars, [])+        s <- shouldBeSort =<< defType def `piApplyM` pars+        return (IsRecord InductionAndEta {recordInduction=recInduction, recordEtaEquality=recEtaEquality' }, d, s, pars, [])        -- Issue #2253: the data type could be abstract.-      AbstractDefn{} -> hardTypeError . GenericDocError =<< do-        liftTCM $ "Cannot split on abstract data type" <+> prettyTCM d+      AbstractDefn{} -> hardTypeError $ SplitOnAbstract d        -- the type could be an axiom       Axiom{} -> hardTypeError =<< notData        -- Can't match before we have the definition-      DataOrRecSig{} -> hardTypeError . GenericDocError =<< do-        liftTCM $ "Cannot split on data type" <+> prettyTCM d <+> "whose definition has not yet been checked"+      DataOrRecSig{} -> hardTypeError $ SplitOnUnchecked d        -- Issue #2997: the type could be a Def that does not reduce for some reason       -- (abstract, failed termination checking, NON_TERMINATING, ...)@@ -1601,14 +1718,14 @@ disambiguateProjection h ambD@(AmbQ ds) b = do   -- If the target is not a record type, that's an error.   -- It could be a meta, but since we cannot postpone lhs checking, we crash here.-  caseMaybeM (liftTCM $ isRecordType $ unArg b) notRecord $ \(r, vs, def) -> case def of-    Record{ recFields = fs, recInduction, recEtaEquality' = eta } -> do+  caseMaybeM (liftTCM $ isRecordType $ unArg b) notRecord+    \ (r, vs, RecordData{ _recFields = fs, _recInduction = ind, _recEtaEquality' = eta }) -> do       reportSDoc "tc.lhs.split" 20 $ sep-        [ text $ "we are of record type r  = " ++ prettyShow r-        , text   "applied to parameters vs = " <+> prettyTCM vs-        , text $ "and have fields       fs = " ++ prettyShow (map argFromDom fs)+        [ "we are of record type r  = " <> pure (P.pretty r)+        , "applied to parameters vs = " <> prettyTCM vs+        , "and have fields       fs = " <> pure (P.pretty $ map argFromDom fs)         ]-      let comatching = recInduction == Just CoInductive+      let comatching = ind == Just CoInductive                     || copatternMatchingAllowed eta       -- Try the projection candidates.       -- First, we try to find a disambiguation that doesn't produce@@ -1617,20 +1734,17 @@           -- If this fails, we try again with constraints, but we require           -- the solution to be unique.           tryDisambiguate True fs r vs comatching $ \case-            ([]   , []      ) -> __IMPOSSIBLE__-            (err:_, []      ) -> throwError err-            (_    , disambs@((d,a):_)) -> typeError . GenericDocError =<< vcat-              [ "Ambiguous projection " <> prettyTCM d <> "."-              , "It could refer to any of"-              , nest 2 $ vcat $ map (prettyDisambProj . fst) disambs-              ]-    _ -> __IMPOSSIBLE__-+            (err:_, [] ) -> throwError err+            ([]   , [] ) -> __IMPOSSIBLE__+            (_    , [_]) -> __IMPOSSIBLE__+            (_    , (d,_) : (d1,_) : disambs) ->+              typeError $ AmbiguousProjection d $ d1 :| map fst disambs   where     tryDisambiguate constraintsOk fs r vs comatching failure = do       -- Note that tryProj wraps TCM in an ExceptT, collecting errors       -- instead of throwing them to the user immediately.-      disambiguations <- mapM (runExceptT . tryProj constraintsOk fs r vs) ds+      disambiguations :: List1 (Either TCErr (QName, (Arg Type, ArgInfo, Maybe TCState)))+        <- mapM (runExceptT . tryProj constraintsOk fs r vs) ds       case List1.partitionEithers disambiguations of         (_ , (d, (a, ai, mst)) : disambs) | constraintsOk <= null disambs -> do           mapM_ putTC mst -- Activate state changes@@ -1646,20 +1760,8 @@      wrongProj :: (MonadTCM m, MonadError TCErr m, ReadTCState m) => QName -> m a     wrongProj d = softTypeError =<< do-      liftTCM $ GenericDocError <$> sep-        [ "Cannot eliminate type "-        , prettyTCM (unArg b)-        , " with projection "-        , if isAmbiguous ambD then-            text . prettyShow =<< dropTopLevelModule d-          else-            prettyTCM d-        ]--    wrongHiding :: (MonadTCM m, MonadError TCErr m, ReadTCState m) => QName -> m a-    wrongHiding d = softTypeError =<< do-      liftTCM $ GenericDocError <$> sep-        [ "Wrong hiding used for projection " , prettyTCM d ]+      liftTCM $ if isAmbiguous ambD then CannotEliminateWithProjection b True <$> dropTopLevelModule d+                else pure $ CannotEliminateWithProjection b False d      tryProj       :: Bool                 -- Are we allowed to create new constraints?@@ -1707,7 +1809,8 @@         -- Andreas, 2016-12-31, issue #2374:         -- We can also disambiguate by hiding info.         -- Andreas, 2018-10-18, issue #3289: postfix projections have no hiding info.-        unless (caseMaybe h True $ sameHiding $ projArgInfo proj) $ wrongHiding d+        unless (caseMaybe h True $ sameHiding $ projArgInfo proj) $+          softTypeError $ WrongHidingInProjection d          -- Andreas, 2016-12-31, issue #1976: Check parameters.         let chk = checkParameters qr r vs@@ -1748,11 +1851,8 @@         -- meaning that only the parameters may differ,         -- then throw more specific error.         (_    , [_]) -> typeError $ CantResolveOverloadedConstructorsTargetingSameDatatype d cs-        (_    , disambs@(((c,_,_):|_):_)) -> typeError . GenericDocError =<< vcat-          [ "Ambiguous constructor " <> pretty (qnameName c) <> "."-          , "It could refer to any of"-          , nest 2 $ vcat $ map (prettyDisambCons . conName . snd3) $ List1.concat disambs-          ]+        (_    , (d0@((c,_,_) :| _) : d1 : ds)) -> typeError $+          AmbiguousConstructor c $ fmap (conName . snd3) $ List2.concat21 $ List2 d0 d1 ds    where     tryDisambiguate@@ -1825,9 +1925,10 @@            -- its type, and maybe the state obtained after checking it            -- (which may contain new constraints/solutions).     tryCon constraintsOk cons d pars c = getConstInfo' c >>= \case-      Left (SigUnknown err) -> __IMPOSSIBLE__-      Left SigAbstract -> abstractConstructor c-      Right def -> do+      Left (SigUnknown err)     -> __IMPOSSIBLE__+      Left SigCubicalNotErasure -> __IMPOSSIBLE__+      Left SigAbstract          -> abstractConstructor c+      Right def                 -> do         let con = conSrcCon (theDef def) `withRangeOf` c         unless (conName con `elem` cons) $ wrongDatatype c d @@ -1893,19 +1994,6 @@           (Just{},  Just{})  -> return False       inState st m = localTCState $ do putTC st; m --prettyDisamb :: (QName -> Maybe (Range' SrcFile)) -> QName -> TCM Doc-prettyDisamb f x = do-  let d  = pretty =<< dropTopLevelModule x-  caseMaybe (f x) d $ \ r -> d <+> ("(introduced at " <> prettyTCM r <> ")")---- | For Ambiguous Projection errors, print the last range in 'qnameModule'.---   For Ambiguous Constructor errors, print the range in 'qnameName'. This fixes the bad---   error message in #4130.-prettyDisambProj, prettyDisambCons :: QName -> TCM Doc-prettyDisambProj = prettyDisamb $ lastMaybe . filter (noRange /=) . map nameBindingSite . mnameToList . qnameModule-prettyDisambCons = prettyDisamb $ Just . nameBindingSite . qnameName- -- | @checkConstructorParameters c d pars@ checks that the data/record type --   behind @c@ is has initial parameters (coming e.g. from a module instantiation) --   that coincide with an prefix of @pars@.@@ -1944,19 +2032,19 @@                         LensSort a, PrettyTCM a, LensSort ty, PrettyTCM ty)                     => DataOrRecord -> a -> Telescope -> Maybe ty -> m () checkSortOfSplitVar dr a tel mtarget = do-  liftTCM (reduce $ getSort a) >>= \case-    sa@Type{} -> whenM isTwoLevelEnabled checkFibrantSplit-    Prop{} -> checkPropSplit-    Inf IsFibrant _ -> whenM isTwoLevelEnabled checkFibrantSplit-    Inf IsStrict _ -> return ()-    SSet{} -> return ()-    sa      -> softTypeError =<< do+  let s = getSort a+  sa <- liftTCM $ reduce s+  case sortUniv sa of+    Just UType{} -> whenM isTwoLevelEnabled checkFibrantSplit+    Just UProp{} -> checkPropSplit+    Just USSet{} -> return ()+    Nothing      -> softTypeError =<< do       liftTCM $ SortOfSplitVarError <$> isBlocked sa <*> sep-        [ "Cannot split on datatype in sort" , prettyTCM (getSort a) ]+        [ "Cannot split on datatype in sort" , prettyTCM s]    where     checkPropSplit-      | IsRecord Nothing _ <- dr = return ()+      | IsRecord InductionAndEta { recordInduction=Nothing } <- dr = return ()       | Just target <- mtarget = do         reportSDoc "tc.sort.check" 20 $ "target prop:" <+> prettyTCM target         checkIsProp target@@ -1970,7 +2058,7 @@       Right True  -> return ()      checkFibrantSplit-      | IsRecord _ _ <- dr     = return ()+      | IsRecord _ <- dr       = return ()       | Just target <- mtarget = do           reportSDoc "tc.sort.check" 20 $ "target:" <+> prettyTCM target           checkIsFibrant target@@ -1983,26 +2071,18 @@      -- Cofibrant types are those that could be the domain of a fibrant     -- pi type. (Notion by C. Sattler).-    checkIsCoFibrant t = runBlocked (isCoFibrantSort t) >>= \case+    checkIsCoFibrant t = isCoFibrantSort t >>= \case       Left b      -> splitOnFibrantError' t $ Just b       Right False -> unlessM (isInterval t) $                        splitOnFibrantError' t $ Nothing       Right True  -> return () -    checkIsFibrant t = runBlocked (isFibrant t) >>= \case+    checkIsFibrant t = isFibrant' t >>= \case       Left b      -> splitOnFibrantError $ Just b       Right False -> splitOnFibrantError Nothing       Right True  -> return () -    splitOnPropError dr = softTypeError =<< do-      liftTCM $ GenericDocError <$>-        ("Cannot split on" <+> kindOfData dr <+> "in Prop unless target is in Prop")-      where-        kindOfData :: DataOrRecord -> TCM Doc-        kindOfData IsData                          = "datatype"-        kindOfData (IsRecord Nothing _)            = "record type"-        kindOfData (IsRecord (Just Inductive) _)   = "inductive record type"-        kindOfData (IsRecord (Just CoInductive) _) = "coinductive record type"+    splitOnPropError dr = softTypeError $ SplitInProp dr      splitOnFibrantError' t mb = softTypeError =<< do       liftTCM $ SortOfSplitVarError mb <$> fsep
src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs view
@@ -90,7 +90,8 @@       let ps0@(~(p1 : ps1)) = hs ++ ps       reduce a >>= piOrPath >>= \case         -- If @a@ is a function (or path) type, continue inserting after @p1@.-        Left (_, b) -> (p1 :) <$> insertImplicitPatternsT exh ps1 (absBody b)+        Left (dom, cod) -> underAbstraction dom cod $ \b ->+          (p1 :) <$> insertImplicitPatternsT exh ps1 b         -- Otherwise, we are done.         Right{}     -> return ps0   where
src/full/Agda/TypeChecking/Rules/LHS/Problem.hs view

file too large to diff

src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs view

file too large to diff

src/full/Agda/TypeChecking/Rules/LHS/Unify.hs view

file too large to diff

+ src/full/Agda/TypeChecking/Rules/LHS/Unify/LeftInverse.hs view

file too large to diff

+ src/full/Agda/TypeChecking/Rules/LHS/Unify/Types.hs view

file too large to diff

src/full/Agda/TypeChecking/Rules/Record.hs view

file too large to diff

src/full/Agda/TypeChecking/Rules/Term.hs view

file too large to diff

src/full/Agda/TypeChecking/Rules/Term.hs-boot view

file too large to diff

src/full/Agda/TypeChecking/Serialise.hs view

file too large to diff

src/full/Agda/TypeChecking/Serialise/Base.hs view

file too large to diff

src/full/Agda/TypeChecking/Serialise/Instances.hs view

file too large to diff

src/full/Agda/TypeChecking/Serialise/Instances/Abstract.hs view

file too large to diff

src/full/Agda/TypeChecking/Serialise/Instances/Common.hs view

file too large to diff

src/full/Agda/TypeChecking/Serialise/Instances/Compilers.hs view

file too large to diff

src/full/Agda/TypeChecking/Serialise/Instances/Errors.hs view

file too large to diff

src/full/Agda/TypeChecking/Serialise/Instances/Highlighting.hs view

file too large to diff

src/full/Agda/TypeChecking/Serialise/Instances/Internal.hs view

file too large to diff

src/full/Agda/TypeChecking/SizedTypes.hs view

file too large to diff

+ src/full/Agda/TypeChecking/SizedTypes/Pretty.hs view

file too large to diff

src/full/Agda/TypeChecking/SizedTypes/Solve.hs view

file too large to diff

src/full/Agda/TypeChecking/SizedTypes/Syntax.hs view

file too large to diff

src/full/Agda/TypeChecking/SizedTypes/Utils.hs view

file too large to diff

src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs view

file too large to diff

src/full/Agda/TypeChecking/Sort.hs view

file too large to diff

src/full/Agda/TypeChecking/Substitute.hs view

file too large to diff

src/full/Agda/TypeChecking/Substitute/Class.hs view

file too large to diff

src/full/Agda/TypeChecking/Substitute/DeBruijn.hs view

file too large to diff

src/full/Agda/TypeChecking/SyntacticEquality.hs view

file too large to diff

src/full/Agda/TypeChecking/Telescope.hs view

file too large to diff

src/full/Agda/TypeChecking/Telescope.hs-boot view

file too large to diff

src/full/Agda/TypeChecking/Telescope/Path.hs view

file too large to diff

src/full/Agda/TypeChecking/Unquote.hs view

file too large to diff

src/full/Agda/TypeChecking/Warnings.hs view

file too large to diff

src/full/Agda/TypeChecking/With.hs view

file too large to diff

src/full/Agda/Utils/AffineHole.hs view

file too large to diff

src/full/Agda/Utils/Applicative.hs view

file too large to diff

src/full/Agda/Utils/AssocList.hs view

file too large to diff

src/full/Agda/Utils/Bag.hs view

file too large to diff

src/full/Agda/Utils/Benchmark.hs view

file too large to diff

src/full/Agda/Utils/BiMap.hs view

file too large to diff

+ src/full/Agda/Utils/BoolSet.hs view

file too large to diff

+ src/full/Agda/Utils/Boolean.hs view

file too large to diff

src/full/Agda/Utils/CallStack.hs view

file too large to diff

src/full/Agda/Utils/CallStack/Base.hs view

file too large to diff

src/full/Agda/Utils/CallStack/Pretty.hs view

file too large to diff

src/full/Agda/Utils/Char.hs view

file too large to diff

src/full/Agda/Utils/Cluster.hs view

file too large to diff

src/full/Agda/Utils/Either.hs view

file too large to diff

src/full/Agda/Utils/Empty.hs view

file too large to diff

src/full/Agda/Utils/Environment.hs view

file too large to diff

src/full/Agda/Utils/Fail.hs view

file too large to diff

src/full/Agda/Utils/Favorites.hs view

file too large to diff

+ src/full/Agda/Utils/FileId.hs view

file too large to diff

src/full/Agda/Utils/FileName.hs view

file too large to diff

src/full/Agda/Utils/Float.hs view

file too large to diff

src/full/Agda/Utils/Function.hs view

file too large to diff

src/full/Agda/Utils/Functor.hs view

file too large to diff

+ src/full/Agda/Utils/GetOpt.hs view

file too large to diff

src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs view

file too large to diff

src/full/Agda/Utils/Graph/TopSort.hs view

file too large to diff

src/full/Agda/Utils/Hash.hs view

file too large to diff

+ src/full/Agda/Utils/HashTable.hs view

file too large to diff

src/full/Agda/Utils/Haskell/Syntax.hs view

file too large to diff

+ src/full/Agda/Utils/IArray.hs view

file too large to diff

src/full/Agda/Utils/IO.hs view

file too large to diff

src/full/Agda/Utils/IO/Binary.hs view

file too large to diff

src/full/Agda/Utils/IO/Directory.hs view

file too large to diff

src/full/Agda/Utils/IO/TempFile.hs view

file too large to diff

src/full/Agda/Utils/IO/UTF8.hs view

file too large to diff

src/full/Agda/Utils/IORef.hs view

file too large to diff

src/full/Agda/Utils/Impossible.hs view

file too large to diff

src/full/Agda/Utils/IndexedList.hs view

file too large to diff

src/full/Agda/Utils/IntSet/Infinite.hs view

file too large to diff

src/full/Agda/Utils/Lens.hs view

file too large to diff

src/full/Agda/Utils/Lens/Examples.hs view

file too large to diff

src/full/Agda/Utils/List.hs view

file too large to diff

src/full/Agda/Utils/List1.hs view

file too large to diff

src/full/Agda/Utils/List2.hs view

file too large to diff

src/full/Agda/Utils/ListT.hs view

file too large to diff

src/full/Agda/Utils/Map.hs view

file too large to diff

+ src/full/Agda/Utils/Map1.hs view

file too large to diff

src/full/Agda/Utils/Maybe.hs view

file too large to diff

src/full/Agda/Utils/Maybe/Strict.hs view

file too large to diff

src/full/Agda/Utils/Memo.hs view

file too large to diff

src/full/Agda/Utils/Monad.hs view

file too large to diff

src/full/Agda/Utils/Monoid.hs view

file too large to diff

src/full/Agda/Utils/Null.hs view

file too large to diff

src/full/Agda/Utils/POMonoid.hs view

file too large to diff

src/full/Agda/Utils/Parser/MemoisedCPS.hs view

file too large to diff

src/full/Agda/Utils/PartialOrd.hs view

file too large to diff

src/full/Agda/Utils/Permutation.hs view

file too large to diff

− src/full/Agda/Utils/Pointer.hs

file too large to diff

− src/full/Agda/Utils/Pretty.hs

file too large to diff

+ src/full/Agda/Utils/ProfileOptions.hs view

file too large to diff

src/full/Agda/Utils/SemiRing.hs view

file too large to diff

src/full/Agda/Utils/Semigroup.hs view

file too large to diff

+ src/full/Agda/Utils/Set1.hs view

file too large to diff

src/full/Agda/Utils/Singleton.hs view

file too large to diff

src/full/Agda/Utils/Size.hs view

file too large to diff

src/full/Agda/Utils/SmallSet.hs view

file too large to diff

src/full/Agda/Utils/String.hs view

file too large to diff

src/full/Agda/Utils/Suffix.hs view

file too large to diff

src/full/Agda/Utils/Three.hs view

file too large to diff

src/full/Agda/Utils/Time.hs view

file too large to diff

src/full/Agda/Utils/Trie.hs view

file too large to diff

src/full/Agda/Utils/Tuple.hs view

file too large to diff

src/full/Agda/Utils/TypeLevel.hs view

file too large to diff

src/full/Agda/Utils/TypeLits.hs view

file too large to diff

+ src/full/Agda/Utils/Unsafe.hs view

file too large to diff

src/full/Agda/Utils/Update.hs view

file too large to diff

src/full/Agda/Utils/VarSet.hs view

file too large to diff

− src/full/Agda/Utils/Warshall.hs

file too large to diff

src/full/Agda/Utils/WithDefault.hs view

file too large to diff

src/full/Agda/Utils/Zipper.hs view

file too large to diff

− src/full/Agda/Version.hs

file too large to diff

− src/full/Agda/VersionCommit.hs

file too large to diff

+ src/setup/Agda/Setup.hs view

file too large to diff

+ src/setup/Agda/Setup/DataFiles.hs view

file too large to diff

+ src/setup/Agda/Setup/EmacsMode.hs view

file too large to diff

+ src/setup/Agda/Version.hs view

file too large to diff

+ src/setup/Agda/VersionCommit.hs view

file too large to diff

− stack-8.0.2.yaml

file too large to diff

stack-8.10.7.yaml view

file too large to diff

− stack-8.2.2.yaml

file too large to diff

− stack-8.4.4.yaml

file too large to diff

− stack-8.6.5.yaml

file too large to diff

stack-8.8.4.yaml view

file too large to diff

− stack-9.0.1.yaml

file too large to diff

stack-9.0.2.yaml view

file too large to diff

+ stack-9.10.2.yaml view

file too large to diff

+ stack-9.12.2.yaml view

file too large to diff

− stack-9.2.1.yaml

file too large to diff

− stack-9.2.2.yaml

file too large to diff

+ stack-9.2.8.yaml view

file too large to diff

+ stack-9.4.8.yaml view

file too large to diff

+ stack-9.6.7.yaml view

file too large to diff

+ stack-9.8.4.yaml view

file too large to diff